Solve the Stable marriage problem using the Gale/Shapley algorithm.


Problem description

Given an equal number of men and women to be paired for marriage, each man ranks all the women in order of his preference and each woman ranks all the men in order of her preference.

A stable set of engagements for marriage is one where no man prefers a woman over the one he is engaged to, where that other woman also prefers that man over the one she is engaged to. I.e. with consulting marriages, there would be no reason for the engagements between the people to change.

Gale and Shapley proved that there is a stable set of engagements for any set of preferences and the first link above gives their algorithm for finding a set of stable engagements.


Task Specifics

Given ten males:

   abe, bob, col, dan, ed, fred, gav, hal, ian, jon

And ten females:

   abi, bea, cath, dee, eve, fay, gay, hope, ivy, jan

And a complete list of ranked preferences, where the most liked is to the left:

  abe: abi, eve, cath, ivy, jan, dee, fay, bea, hope, gay
  bob: cath, hope, abi, dee, eve, fay, bea, jan, ivy, gay
  col: hope, eve, abi, dee, bea, fay, ivy, gay, cath, jan
  dan: ivy, fay, dee, gay, hope, eve, jan, bea, cath, abi
   ed: jan, dee, bea, cath, fay, eve, abi, ivy, hope, gay
 fred: bea, abi, dee, gay, eve, ivy, cath, jan, hope, fay
  gav: gay, eve, ivy, bea, cath, abi, dee, hope, jan, fay
  hal: abi, eve, hope, fay, ivy, cath, jan, bea, gay, dee
  ian: hope, cath, dee, gay, bea, abi, fay, ivy, jan, eve
  jon: abi, fay, jan, gay, eve, bea, dee, cath, ivy, hope
   
  abi: bob, fred, jon, gav, ian, abe, dan, ed, col, hal
  bea: bob, abe, col, fred, gav, dan, ian, ed, jon, hal
 cath: fred, bob, ed, gav, hal, col, ian, abe, dan, jon
  dee: fred, jon, col, abe, ian, hal, gav, dan, bob, ed
  eve: jon, hal, fred, dan, abe, gav, col, ed, ian, bob
  fay: bob, abe, ed, ian, jon, dan, fred, gav, col, hal
  gay: jon, gav, hal, fred, bob, abe, col, ed, dan, ian
 hope: gav, jon, bob, abe, ian, dan, hal, ed, col, fred
  ivy: ian, col, hal, gav, fred, bob, abe, ed, jon, dan
  jan: ed, hal, gav, abe, bob, jon, col, ian, fred, dan

 Use the Gale Shapley algorithm to find a stable set of engagements
 Perturb this set of engagements to form an unstable set of engagements then check this new set for stability.

References

 The Stable Marriage Problem. (Eloquent description and background information).
 Gale-Shapley Algorithm Demonstration.
 Another Gale-Shapley Algorithm Demonstration.
 Stable Marriage Problem - Numberphile (Video).
 Stable Marriage Problem (the math bit) (Video).
 The Stable Marriage Problem and School Choice. (Excellent exposition)


$ include "seed7_05.s7i";
 
const type: preferences is hash [string] array string;
const type: engaged is hash [string] string;
 
const func integer: pos (in array string: area, in string: searched) is func
  result
    var integer: pos is 1;
  begin
    while pos <= length(area) and area[pos] <> searched do
      incr(pos);
    end while;
    if pos > length(area) then
      pos := 0;
    end if;
  end func;
 
const func engaged: matchmaker (in preferences: guyPrefers, in preferences: girlPrefers) is func
  result
    var engaged: engagedTo is engaged.value;
  local
    var array string: freeGuys is 0 times "";
    var string: guy is "";
    var string: girl is "";
    var string: fiance is "";
    var array string: guyPreferencList is 0 times "";
    var array string: girlPreferenceList is 0 times "";
    var boolean: searching is TRUE;
  begin
    freeGuys := sort(keys(guyPrefers));
    while length(freeGuys) <> 0 do
      guy := freeGuys[1];
      freeGuys := freeGuys[2 ..];
      guyPreferencList := guyPrefers[guy];
      searching := TRUE;
      while searching and length(guyPreferencList) <> 0 do
        girl := guyPreferencList[1];
        guyPreferencList := guyPreferencList[2 ..];
        if girl not in engagedTo then
          engagedTo @:= [girl] guy;
          writeln("  " <& girl <& " and " <& guy);
          searching := FALSE;
        else
          fiance := engagedTo[girl];
          girlPreferenceList := girlPrefers[girl];
          if pos(girlPreferenceList, guy) < pos(girlPreferenceList, fiance) then
            # She prefers new guy
            engagedTo @:= [girl] guy;
            freeGuys &:= fiance;
            writeln("  " <& girl <& " dumped " <& fiance <& " for " <& guy);
            searching := FALSE;
          end if;
        end if;
      end while;
    end while;
  end func;
 
const func boolean: check (in engaged: engagedTo,
    in preferences: guyPrefers, in preferences: girlPrefers) is func
  result
    var boolean: stable is TRUE;
  local
    var string: he is "";
    var string: she is "";
    var string: guy is "";
    var string: girl is "";
    var engaged: inverseEngaged is engaged.value;
    var array string: sheLikes is 0 times "";
    var array string: sheLikesBetter is 0 times "";
    var array string: heLikes is 0 times "";
    var array string: heLikesBetter is 0 times "";
    var string: guysGirl is "";
    var array string: guyLikes is 0 times "";
    var string: girlsGuy is "";
    var array string: girlLikes is 0 times "";
  begin
    for he key she range engagedTo do
      inverseEngaged @:= [he] she;
    end for;
    for he key she range engagedTo do
      sheLikes := girlPrefers[she];
      sheLikesBetter := sheLikes[.. pred(pos(sheLikes, he))];
      heLikes := guyPrefers[he];
      heLikesBetter := heLikes[.. pred(pos(heLikes, she))];
      for guy range sheLikesBetter do
        guysGirl := inverseEngaged[guy];
        guyLikes := guyPrefers[guy];
        if pos(guyLikes, guysGirl) > pos(guyLikes, she) and stable then
          writeln(she <& " likes " <& guy <& " better than " <& he <& " and " <&
                  guy <& " likes " <& she <& " better than their current partner");
          stable := FALSE;
        end if;
      end for;
      for girl range heLikesBetter do
        girlsGuy := engagedTo[girl];
        girlLikes := girlPrefers[girl];
        if pos(girlLikes, girlsGuy) > pos(girlLikes, he) and stable then
          writeln(he <& " likes " <& girl <& " better than " <& she <& " and " <&
                  girl <& " likes " <& he <& " better than their current partner");
          stable := FALSE;
        end if;
      end for;
    end for;
  end func;
 
var preferences: guyPrefers is preferences.value;
var preferences: girlPrefers is preferences.value;
guyPrefers @:= ["abe"]  [] ("abi", "eve", "cath", "ivy", "jan", "dee", "fay", "bea", "hope", "gay");
guyPrefers @:= ["bob"]  [] ("cath", "hope", "abi", "dee", "eve", "fay", "bea", "jan", "ivy", "gay");
guyPrefers @:= ["col"]  [] ("hope", "eve", "abi", "dee", "bea", "fay", "ivy", "gay", "cath", "jan");
guyPrefers @:= ["dan"]  [] ("ivy", "fay", "dee", "gay", "hope", "eve", "jan", "bea", "cath", "abi");
guyPrefers @:= ["ed"]   [] ("jan", "dee", "bea", "cath", "fay", "eve", "abi", "ivy", "hope", "gay");
guyPrefers @:= ["fred"] [] ("bea", "abi", "dee", "gay", "eve", "ivy", "cath", "jan", "hope", "fay");
guyPrefers @:= ["gav"]  [] ("gay", "eve", "ivy", "bea", "cath", "abi", "dee", "hope", "jan", "fay");
guyPrefers @:= ["hal"]  [] ("abi", "eve", "hope", "fay", "ivy", "cath", "jan", "bea", "gay", "dee");
guyPrefers @:= ["ian"]  [] ("hope", "cath", "dee", "gay", "bea", "abi", "fay", "ivy", "jan", "eve");
guyPrefers @:= ["jon"]  [] ("abi", "fay", "jan", "gay", "eve", "bea", "dee", "cath", "ivy", "hope");
girlPrefers @:= ["abi"]  [] ("bob", "fred", "jon", "gav", "ian", "abe", "dan", "ed", "col", "hal");
girlPrefers @:= ["bea"]  [] ("bob", "abe", "col", "fred", "gav", "dan", "ian", "ed", "jon", "hal");
girlPrefers @:= ["cath"] [] ("fred", "bob", "ed", "gav", "hal", "col", "ian", "abe", "dan", "jon");
girlPrefers @:= ["dee"]  [] ("fred", "jon", "col", "abe", "ian", "hal", "gav", "dan", "bob", "ed");
girlPrefers @:= ["eve"]  [] ("jon", "hal", "fred", "dan", "abe", "gav", "col", "ed", "ian", "bob");
girlPrefers @:= ["fay"]  [] ("bob", "abe", "ed", "ian", "jon", "dan", "fred", "gav", "col", "hal");
girlPrefers @:= ["gay"]  [] ("jon", "gav", "hal", "fred", "bob", "abe", "col", "ed", "dan", "ian");
girlPrefers @:= ["hope"] [] ("gav", "jon", "bob", "abe", "ian", "dan", "hal", "ed", "col", "fred");
girlPrefers @:= ["ivy"]  [] ("ian", "col", "hal", "gav", "fred", "bob", "abe", "ed", "jon", "dan");
girlPrefers @:= ["jan"]  [] ("ed", "hal", "gav", "abe", "bob", "jon", "col", "ian", "fred", "dan");
 
const proc: main is func
  local
    var engaged: engagedTo is engaged.value;
    var string: girl is "";
  begin
    writeln("Matchmaking:");
    engagedTo := matchmaker(guyPrefers, girlPrefers);
    writeln;
    writeln("Engagements:");
    for girl range sort(keys(engagedTo)) do
      writeln("  " <& girl <& " and " <& engagedTo[girl]);
    end for;
    writeln;
    writeln("Marriages are " <& [] ("unstable", "stable") [succ(ord(check(engagedTo, guyPrefers, girlPrefers)))]);
    writeln;
    writeln("Perturb:");
    engagedTo @:= ["abi"] "fred";
    engagedTo @:= ["bea"] "jon";
    writeln("engage abi with fred and bea with jon");
    writeln;
    writeln("Marriages are " <& [] ("unstable", "stable") [succ(ord(check(engagedTo, guyPrefers, girlPrefers)))]);
  end func;