Data commit

Task/Stable-marriage-problem/Seed7/stable-marriage-problem.seed7

@@ -0,0 +1,150 @@
+$ 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;