150 lines
6.4 KiB
Text
150 lines
6.4 KiB
Text
$ 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;
|