Stable marriage problem: Difference between revisions
m (J: eliminated a one use variable which had a not-very-informative name) |
(→{{header|J}}: Marked incorrect. Can't work out that stability is violated with the results as given.) |
||
Line 336: | Line 336: | ||
=={{header|J}}== |
=={{header|J}}== |
||
{{incorrect|J|Difficult to work out that stability is violated with the results of the check as given.}} |
|||
<lang j>mraw=:;:;._2]noun define-.':,' |
<lang j>mraw=:;:;._2]noun define-.':,' |
||
abe: abi, eve, cath, ivy, jan, dee, fay, bea, hope, gay |
abe: abi, eve, cath, ivy, jan, dee, fay, bea, hope, gay |
Revision as of 07:00, 3 September 2010
You are encouraged to solve this task according to the task description, using any language you may know.
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 women ranks all the men in order of her preference.
A stable set of engagements for marriage is one where no man prefers a women 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 Shipley 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.
D
D v.2, adapted from the Python and Java versions. <lang d>import std.stdio: writeln, writefln; import std.array: popFront; import std.algorithm: indexOf, swap; import std.string: split, splitlines;
string[string] matchmaker(const string[][string] guyPrefers,
const string[][string] girlPrefers) { string[string] engagedTo; string[] freeGuys = guyPrefers.keys;
while (freeGuys.length) { const auto string thisGuy = freeGuys[0]; freeGuys.popFront(); const auto thisGuyPrefers = guyPrefers[thisGuy]; foreach (girl; thisGuyPrefers) { if (girl !in engagedTo) { // girl is free engagedTo[girl] = thisGuy; break; } else { string otherGuy = engagedTo[girl]; const string[] thisGirlPrefers = girlPrefers[girl]; if (thisGirlPrefers.indexOf(thisGuy) < thisGirlPrefers.indexOf(otherGuy)) { // this girl prefers this guy to the guy she's engagedTo to engagedTo[girl] = thisGuy; freeGuys ~= otherGuy; break; } // else no change, keep looking for this guy } } }
return engagedTo;
}
bool check(bool doPrint=false)(const string[string] engagedTo,
const string[][string] guyPrefers, const string[][string] galPrefers) { enum MSG = "%s likes %s better than %s and %s likes %s better than their current partner"; string[string] inverseEngaged; foreach (k, v; engagedTo) inverseEngaged[v] = k;
foreach (she, he; engagedTo) { const auto sheLikes = galPrefers[she]; const auto sheLikesBetter = sheLikes[0 .. sheLikes.indexOf(he)]; const auto heLikes = guyPrefers[he]; const auto heLikesBetter = heLikes[0 .. heLikes.indexOf(she)]; foreach (guy; sheLikesBetter) { const auto guysGirl = inverseEngaged[guy]; const auto guyLikes = guyPrefers[guy];
if (guyLikes.indexOf(guysGirl) > guyLikes.indexOf(she)) { static if (doPrint) writefln(MSG, she, guy, he, guy, she); return false; } }
foreach (gal; heLikesBetter) { const auto girlsGuy = engagedTo[gal]; const auto galLikes = galPrefers[gal];
if (galLikes.indexOf(girlsGuy) > galLikes.indexOf(he)) { static if (doPrint) writefln(MSG, he, gal, she, gal, he); return false; } } }
return true;
}
void main() {
auto guyData = "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";
auto galData = "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";
string[][string] guyPrefers, galPrefers; foreach (line; guyData.splitlines()) guyPrefers[split(line)[0]] = split(line)[1..$]; foreach (line; galData.splitlines()) galPrefers[split(line)[0]] = split(line)[1..$];
writeln("Engagements:"); auto engagedTo = matchmaker(guyPrefers, galPrefers);
writeln("\nCouples:"); string[] parts; foreach (k; engagedTo.keys.sort) writefln("%s is engagedTo to %s", k, engagedTo[k]); writeln();
bool c = check!(true)(engagedTo, guyPrefers, galPrefers); writeln("Marriages are ", c ? "stable" : "unstable");
writeln("\n\nSwapping two fiances to introduce an error"); auto gals = galPrefers.keys.sort; swap(engagedTo[gals[0]], engagedTo[gals[1]]); foreach (gal; gals[0 .. 2]) writefln(" %s is now engagedTo to %s", gal, engagedTo[gal]); writeln();
c = check!(true)(engagedTo, guyPrefers, galPrefers); writeln("Marriages are ", c ? "stable" : "unstable");
}</lang> Output:
Engagements: Couples: abi is engagedTo to jon bea is engagedTo to fred cath is engagedTo to bob dee is engagedTo to col eve is engagedTo to hal fay is engagedTo to dan gay is engagedTo to gav hope is engagedTo to ian ivy is engagedTo to abe jan is engagedTo to ed Marriages are stable Swapping two fiances to introduce an error abi is now engagedTo to fred bea is now engagedTo to jon fred likes bea better than abi and bea likes fred better than their current partner Marriages are unstable
Haskell
<lang haskell>import Data.List import Control.Monad import Control.Arrow import Data.Maybe
mp = map ((head &&& tail). splitNames)
["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"]
fp = map ((head &&& tail). splitNames)
["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"]
splitNames = map (takeWhile(`notElem`",:")). words
pref x y xs = fromJust (elemIndex x xs) < fromJust (elemIndex y xs)
task ms fs = do
let jos = fst $ unzip ms runGS es js ms = do let (m:js') = js
(v:vm') = case lookup m ms of Just xs -> xs _ -> [] vv = fromJust $ lookup v fs m2 = case lookup v es of Just e -> e _ -> "" ms1 = insert (m,vm') $ delete (m,v:vm') ms
if null js then do
putStrLn "" putStrLn "=== Couples ===" return es
else if null m2 then
do putStrLn $ v ++ " with " ++ m runGS ( insert (v,m) es ) js' ms1
else if pref m m2 vv then
do putStrLn $ v ++ " dumped " ++ m2 ++ " for " ++ m runGS ( insert (v,m) $ delete (v,m2) es ) (if not $ null vm' then js'++[m2] else js') ms1
else runGS es (if not $ null js' then js'++[m] else js') ms1
cs <- runGS [] jos ms mapM_ (\(f,m) -> putStrLn $ f ++ " with " ++ m ) cs putStrLn "" checkStab cs putStrLn "" putStrLn "Introducing error: " let [r1@(a,b), r2@(p,q)] = take 2 cs r3 = (a,q) r4 = (p,b) errcs = insert r4. insert r3. delete r2 $ delete r1 cs putStrLn $ "\tSwapping partners of " ++ a ++ " and " ++ p putStrLn $ (\((a,b),(p,q)) -> "\t" ++ a ++ " is now with " ++ b ++ " and " ++ p ++ " with " ++ q) (r3,r4) putStrLn "" checkStab errcs
checkStab es = do
let fmt (a,b,c,d) = a ++ " and " ++ b ++ " like each other better than their current partners " ++ c ++ " and " ++ d ies = uncurry(flip zip) $ unzip es -- es = [(fem,m)] & ies = [(m,fem)] slb = map (\(f,m)-> (f,m, map (id &&& fromJust. flip lookup ies). fst.break(==m). fromJust $ lookup f fp) ) es hlb = map (\(f,m)-> (m,f, map (id &&& fromJust. flip lookup es ). fst.break(==f). fromJust $ lookup m mp) ) es tslb = concatMap (filter snd. (\(f,m,ls) ->
map (\(m2,f2) -> ((f,m2,f2,m), pref f f2 $ fromJust $ lookup m2 mp)) ls)) slb
thlb = concatMap (filter snd. (\(m,f,ls) ->
map (\(f2,m2) -> ((m,f2,m2,f), pref m m2 $ fromJust $ lookup f2 fp)) ls)) hlb
res = tslb ++ thlb if not $ null res then do putStrLn "Marriages are unstable, e.g.:" putStrLn.fmt.fst $ head res
else putStrLn "Marriages are stable"</lang>
Task: <lang haskell>*Main> task mp fp abi with abe cath with bob hope with col ivy with dan jan with ed bea with fred gay with gav hope dumped col for ian abi dumped abe for jon eve with hal dee with col ivy dumped dan for abe fay with dan
Couples
abi with jon bea with fred cath with bob dee with col eve with hal fay with dan gay with gav hope with ian ivy with abe jan with ed
Marriages are stable
Introducing error:
Swapping partners of abi and bea abi is now with fred and bea with jon
Marriages are unstable, e.g.: bea and fred like each other better than their current partners abi and jon</lang>
J
<lang j>mraw=:;:;._2]noun define-.':,'
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
)
fraw=:;:;._2]noun define-.':,'
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
)
guyNames=: {."1 mraw galNames=: {."1 fraw
mprefs=: galNames i. }."1 mraw fprefs=: guyNames i. }."1 fraw
propose=: dyad define
engaged=. x 'guy gal'=. y if. gal e. engaged do. fiance=. engaged i. gal if. guy <&((gal{fprefs)&i.) fiance do. engaged=. gal guy} _ fiance} engaged end. else. engaged=. gal guy} engaged end. engaged
)
matchMake=: monad define
engaged=. _"0 guyNames NB. initially no one is engaged fallback=. 0"0 engaged NB. and each guy will first propose to his favorite whilst. _ e. engaged do. for_guy. I. _ = engaged do. next=. guy{fallback gal=. (<guy,next){mprefs engaged=. engaged propose guy,gal fallback=. (next+1) guy} fallback end. end. guyNames,:engaged{galNames
)
checkStable=: monad define
'guys gals'=. (guyNames,:galNames) i."1 y satisfied=. ] >: (<0 1) |: ] guysHappy=. satisfied (guys{mprefs) i."1 0/ gals galsHappy=. satisfied (gals{fprefs) i."1 0/ guys stable=. guysHappy +. |:galsHappy if. bad=. 0 e. ,stable do. smoutput 'Better matches:' smoutput y {~"1 0"2 1 ($stable) #: I.,-.stable end. assert-.bad
)</lang>
For most of this, males and females are both represented by indices. Rows of mprefs
are indexed by a male index and list female indices in priority order. Rows of fprefs
are indexed by a female index and list male indices in priority order. The same indices select the corresponding names from guyNames
and galNames
.
In matchMake (and propose), engaged
identifies the gal each guy is engaged to (or _ if that guy is not engaged). And, fallback
identifies the column which has the next gal, in mprefs, for that guy to propose to.
Example use:
<lang> matchMake ┌───┬────┬───┬───┬───┬────┬───┬───┬────┬───┐ │abe│bob │col│dan│ed │fred│gav│hal│ian │jon│ ├───┼────┼───┼───┼───┼────┼───┼───┼────┼───┤ │ivy│cath│dee│fay│jan│bea │gay│eve│hope│abi│ └───┴────┴───┴───┴───┴────┴───┴───┴────┴───┘</lang>
Stability check:
<lang j> 1 2 A."_1 matchMake init NB. perturbed matches ┌───┬────┬───┬───┬───┬────┬───┬────┬───┬───┐ │abe│bob │col│dan│ed │fred│gav│hal │jon│ian│ ├───┼────┼───┼───┼───┼────┼───┼────┼───┼───┤ │ivy│cath│dee│fay│jan│bea │gay│hope│eve│abi│ └───┴────┴───┴───┴───┴────┴───┴────┴───┴───┘
checkStable 1 2 A."_1 matchMake init
Better matches: ┌───┬────┐ │jon│fay │ ├───┼────┤ │jon│gay │ ├───┼────┤ │jon│abi │ ├───┼────┤ │ian│hope│ └───┴────┘ |assertion failure: assert | assert-.bad</lang>
As an aside, note that the guys fared much better than the gals here, with over half of the guys getting their first preference and only one gal getting her first preference. The worst match for any guy was fourth preference where the worst for any gal was seventh preference.
Java
This is not a direct translation of Python, but it's fairly close (especially the stability check). <lang java5>import java.util.*;
public class Stable {
static List<String> guys = Arrays.asList( new String[]{ "abe", "bob", "col", "dan", "ed", "fred", "gav", "hal", "ian", "jon"}); static List<String> girls = Arrays.asList( new String[]{ "abi", "bea", "cath", "dee", "eve", "fay", "gay", "hope", "ivy", "jan"}); static Map<String, List<String>> guyPrefers = new HashMap<String, List<String>>(){{ put("abe", Arrays.asList("abi", "eve", "cath", "ivy", "jan", "dee", "fay", "bea", "hope", "gay")); put("bob", Arrays.asList("cath", "hope", "abi", "dee", "eve", "fay", "bea", "jan", "ivy", "gay")); put("col", Arrays.asList("hope", "eve", "abi", "dee", "bea", "fay", "ivy", "gay", "cath", "jan")); put("dan", Arrays.asList("ivy", "fay", "dee", "gay", "hope", "eve", "jan", "bea", "cath", "abi")); put("ed", Arrays.asList("jan", "dee", "bea", "cath", "fay", "eve", "abi", "ivy", "hope", "gay")); put("fred", Arrays.asList("bea", "abi", "dee", "gay", "eve", "ivy", "cath", "jan", "hope", "fay")); put("gav", Arrays.asList("gay", "eve", "ivy", "bea", "cath", "abi", "dee", "hope", "jan", "fay")); put("hal", Arrays.asList("abi", "eve", "hope", "fay", "ivy", "cath", "jan", "bea", "gay", "dee")); put("ian", Arrays.asList("hope", "cath", "dee", "gay", "bea", "abi", "fay", "ivy", "jan", "eve")); put("jon", Arrays.asList("abi", "fay", "jan", "gay", "eve", "bea", "dee", "cath", "ivy", "hope")); }}; static Map<String, List<String>> girlPrefers = new HashMap<String, List<String>>(){{ put("abi", Arrays.asList("bob", "fred", "jon", "gav", "ian", "abe", "dan", "ed", "col", "hal")); put("bea", Arrays.asList("bob", "abe", "col", "fred", "gav", "dan", "ian", "ed", "jon", "hal")); put("cath", Arrays.asList("fred", "bob", "ed", "gav", "hal", "col", "ian", "abe", "dan", "jon")); put("dee", Arrays.asList("fred", "jon", "col", "abe", "ian", "hal", "gav", "dan", "bob", "ed")); put("eve", Arrays.asList("jon", "hal", "fred", "dan", "abe", "gav", "col", "ed", "ian", "bob")); put("fay", Arrays.asList("bob", "abe", "ed", "ian", "jon", "dan", "fred", "gav", "col", "hal")); put("gay", Arrays.asList("jon", "gav", "hal", "fred", "bob", "abe", "col", "ed", "dan", "ian")); put("hope", Arrays.asList("gav", "jon", "bob", "abe", "ian", "dan", "hal", "ed", "col", "fred")); put("ivy", Arrays.asList("ian", "col", "hal", "gav", "fred", "bob", "abe", "ed", "jon", "dan")); put("jan", Arrays.asList("ed", "hal", "gav", "abe", "bob", "jon", "col", "ian", "fred", "dan")); }}; public static void main(String[] args){ Map<String, String> matches = match(guys, guyPrefers, girlPrefers); for(Map.Entry<String, String> couple:matches.entrySet()){ System.out.println( couple.getKey() + " is engaged to " + couple.getValue()); } if(checkMatches(guys, girls, matches, guyPrefers, girlPrefers)){ System.out.println("Marriages are stable"); }else{ System.out.println("Marriages are unstable"); } String tmp = matches.get(girls.get(0)); matches.put(girls.get(0), matches.get(girls.get(1))); matches.put(girls.get(1), tmp); System.out.println( girls.get(0) +" and " + girls.get(1) + " have switched partners"); if(checkMatches(guys, girls, matches, guyPrefers, girlPrefers)){ System.out.println("Marriages are stable"); }else{ System.out.println("Marriages are unstable"); } }
private static Map<String, String> match(List<String> guys, Map<String, List<String>> guyPrefers, Map<String, List<String>> girlPrefers){ Map<String, String> engagedTo = new TreeMap<String, String>(); List<String> freeGuys = new LinkedList<String>(); freeGuys.addAll(guys); while(!freeGuys.isEmpty()){ String thisGuy = freeGuys.remove(0); //get a load of THIS guy List<String> thisGuyPrefers = guyPrefers.get(thisGuy); for(String girl:thisGuyPrefers){ if(engagedTo.get(girl) == null){//girl is free engagedTo.put(girl, thisGuy); //awww break; }else{ String otherGuy = engagedTo.get(girl); List<String> thisGirlPrefers = girlPrefers.get(girl); if(thisGirlPrefers.indexOf(thisGuy) < thisGirlPrefers.indexOf(otherGuy)){ //this girl prefers this guy to the guy she's engaged to engagedTo.put(girl, thisGuy); freeGuys.add(otherGuy); break; }//else no change...keep looking for this guy } } } return engagedTo; }
private static boolean checkMatches(List<String> guys, List<String> girls, Map<String, String> matches, Map<String, List<String>> guyPrefers, Map<String, List<String>> girlPrefers) { if(!matches.keySet().containsAll(girls)){ return false; }
if(!matches.values().containsAll(guys)){ return false; }
Map<String, String> invertedMatches = new TreeMap<String, String>(); for(Map.Entry<String, String> couple:matches.entrySet()){ invertedMatches.put(couple.getValue(), couple.getKey()); }
for(Map.Entry<String, String> couple:matches.entrySet()){ List<String> shePrefers = girlPrefers.get(couple.getKey()); List<String> sheLikesBetter = new LinkedList<String>(); for(int i = 0; i < shePrefers.indexOf(couple.getValue());i++){ sheLikesBetter.add(shePrefers.get(i)); } List<String> hePrefers = guyPrefers.get(couple.getValue()); List<String> heLikesBetter = new LinkedList<String>(); for(int i = 0; i < hePrefers.indexOf(couple.getKey());i++){ heLikesBetter.add(hePrefers.get(i)); }
for(String guy : sheLikesBetter){ String guysFinace = invertedMatches.get(guy); List<String> thisGuyPrefers = guyPrefers.get(guy); if(thisGuyPrefers.indexOf(guysFinace) > thisGuyPrefers.indexOf(couple.getKey())){ System.out.printf("%s likes %s better than %s and %s" + " likes %s better than their current partner\n", couple.getKey(), guy, couple.getValue(), guy, couple.getKey()); return false; } }
for(String girl : heLikesBetter){ String girlsFinace = matches.get(girl); List<String> thisGirlPrefers = girlPrefers.get(girl); if(thisGirlPrefers.indexOf(girlsFinace) > thisGirlPrefers.indexOf(couple.getValue())){ System.out.printf("%s likes %s better than %s and %s" + " likes %s better than their current partner\n", couple.getValue(), girl, couple.getKey(), girl, couple.getValue()); return false; } } } return true; }
}</lang> Output:
abi is engaged to jon bea is engaged to fred cath is engaged to bob dee is engaged to col eve is engaged to hal fay is engaged to dan gay is engaged to gav hope is engaged to ian ivy is engaged to abe jan is engaged to ed Marriages are stable abi and bea have switched partners fred likes bea better than abi and bea likes fred better than their current partner Marriages are unstable
OCaml
<lang ocaml>let men = [
"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"];
]
let women = [
"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"];
]
type woman_name = string type man_name = string
type man =
{ m_name: man_name; free: bool; women_rank: woman_name list; has_proposed: woman_name list }
type woman =
{ w_name: woman_name; men_rank: man_name list; engaged: man_name option }
let free_men men =
List.filter (fun m -> m.free) men
let replace m ms =
let rec aux acc = function | _m::ms -> if _m.m_name = m.m_name then List.rev_append acc (m::ms) else aux (_m::acc) ms | [] -> invalid_arg "replace" in aux [] ms
let becomes_free m_name ms =
let m = List.find (fun m -> m.m_name = m_name) ms in let m = { m with free = true } in replace m ms
let rank_of w m =
let rec aux i = function | _m::ms -> if _m = m then i else aux (succ i) ms | [] -> invalid_arg "rank_of" in aux 0 w.men_rank
let get_highest_ranked m =
(* highest ranked woman who the man has not proposed to yet *) let rec aux = function | w::ws -> if List.mem w m.has_proposed then aux ws else (w) | [] -> invalid_arg "get_highest_ranked" in aux m.women_rank
let more_ranked_than name rank =
let rec aux acc = function | x::xs -> if x = name then (List.rev acc) else aux (x::acc) xs | [] -> (List.rev acc) in aux [] rank
let build_structs ~men ~women =
List.map (fun (name, rank) -> { m_name = name; women_rank = rank; free = true; has_proposed = [] } ) men, List.map (fun (name, rank) -> { w_name = name; men_rank = rank; engaged = None } ) women
let _stable_matching ms ws =
let rec aux ms ws = match free_men ms with (*TODO free men who still has some w to propose to *) | [] -> (ms, ws) | m::_ -> let w = get_highest_ranked m in let m = { m with has_proposed = w :: m.has_proposed } in let w, ws = List.partition (fun _w -> _w.w_name = w) ws in let w = List.hd w in match w.engaged with | None -> (* w is free *) (* (m, w) become engaged *) let w = { w with engaged = Some m.m_name } and m = { m with free = false } in aux (replace m ms) (w::ws) | Some m' -> (* some pair (m', w) already exists *) if (rank_of w m.m_name) > (rank_of w m') then aux (replace m ms) (w::ws) (* (m', w) remain engaged *) else begin (* w prefers m to m' *) let w = { w with engaged = Some m.m_name } and m = { m with free = false } in aux (replace m (becomes_free m' ms)) (w::ws) end in aux ms ws
let stable_matching ~men ~women =
let ms, ws = build_structs ~men ~women in let _, ws = _stable_matching ms ws in let some = function Some v -> v | None -> "" in let engagements = List.map (fun w -> w.w_name, some w.engaged) ws in (engagements)
let is_stable ~men ~women eng =
let ms, ws = build_structs ~men ~women in try List.iter (fun (wn, mn) -> let m = List.find (fun m -> m.m_name = mn) ms in let prefered_women = more_ranked_than wn m.women_rank in List.iter (fun pref_w -> let w = List.find (fun w -> w.w_name = pref_w) ws in let eng_m = List.assoc pref_w eng in let prefered_men = more_ranked_than eng_m w.men_rank in if List.mem m.m_name prefered_men then raise Exit (* one unstable engagement found *) ) prefered_women ) eng; (true) with Exit -> (false)
let perturb_engagements eng =
Random.self_init(); let eng = Array.of_list eng in let len = Array.length eng in for n = 1 to 3 do let i = Random.int len and j = Random.int len in let w1, m1 = eng.(i) and w2, m2 = eng.(j) in eng.(i) <- (w1, m2); eng.(j) <- (w2, m1); done; Array.to_list eng
let print engs =
List.iter (fun (w,m) -> Printf.printf " %4s is engaged with %s\n" w m) engs; Printf.printf "# Engagements %s stable\n" (if is_stable ~men ~women engs then "are" else "are not")
let () =
let engagements = stable_matching ~men ~women in print engagements; print_endline "========================"; let engagements = perturb_engagements engagements in print engagements;
- </lang>
PicoLisp
<lang PicoLisp>(setq
*Boys (list (de abe abi eve cath ivy jan dee fay bea hope gay) (de bob cath hope abi dee eve fay bea jan ivy gay) (de col hope eve abi dee bea fay ivy gay cath jan) (de dan ivy fay dee gay hope eve jan bea cath abi) (de ed jan dee bea cath fay eve abi ivy hope gay) (de fred bea abi dee gay eve ivy cath jan hope fay) (de gav gay eve ivy bea cath abi dee hope jan fay) (de hal abi eve hope fay ivy cath jan bea gay dee) (de ian hope cath dee gay bea abi fay ivy jan eve) (de jon abi fay jan gay eve bea dee cath ivy hope) ) *Girls (list (de bi bob fred jon gav ian abe dan ed col hal) (de bea bob abe col fred gav dan ian ed jon hal) (de cath fred bob ed gav hal col ian abe dan jon) (de dee fred jon col abe ian hal gav dan bob ed) (de eve jon hal fred dan abe gav col ed ian bob) (de fay bob abe ed ian jon dan fred gav col hal) (de gay jon gav hal fred bob abe col ed dan ian) (de hope gav jon bob abe ian dan hal ed col fred) (de ivy ian col hal gav fred bob abe ed jon dan) (de jan ed hal gav abe bob jon col ian fred dan) ) *Couples NIL )
(bind *Boys
(while (find '((Boy) (and (val Boy) (not (asoq Boy *Couples)))) *Boys ) (let (Boy @ Girl (pop Boy) Pair (find '((P) (== Girl (cdr P))) *Couples)) (nond (Pair (push '*Couples (cons Boy Girl))) # Girl is free ((memq Boy (memq (car Pair) (val Girl))) # Girl prefers Boy (set Pair Boy) ) ) ) ) )
(for Pair *Couples
(prinl (cdr Pair) " is engaged to " (car Pair)) )
(de checkCouples ()
(unless (filter '((Pair) (let (Boy (car Pair) Girl (cdr Pair)) (find '((B) (and (memq Boy (cdr (memq B (val Girl)))) # Girl prefers B (memq (cdr (asoq B *Couples)) # and B prefers Girl (cdr (memq Girl (val B))) ) (prinl Girl " likes " B " better than " Boy " and " B " likes " Girl " better than " (cdr (asoq B *Couples)) ) ) ) (val Girl) ) ) ) *Couples ) (prinl "All marriages are stable") ) )
(checkCouples) (prinl) (prinl "Engage fred with abi and jon with bea") (con (asoq 'fred *Couples) 'abi) (con (asoq 'jon *Couples) 'bea) (checkCouples)</lang> Output:
dee is engaged to col fay is engaged to dan eve is engaged to hal gay is engaged to gav bea is engaged to fred jan is engaged to ed ivy is engaged to abe hope is engaged to ian cath is engaged to bob abi is engaged to jon All marriages are stable Engage fred with abi and jon with bea fay likes jon better than dan and jon likes fay better than bea eve likes jon better than hal and jon likes eve better than bea gay likes jon better than gav and jon likes gay better than bea bea likes fred better than jon and fred likes bea better than abi
Python
<lang python>import copy
guyprefers = {
'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']}
galprefers = {
'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']}
guys = sorted(guyprefers.keys()) gals = sorted(galprefers.keys())
def check(engaged):
inverseengaged = dict((v,k) for k,v in engaged.items()) for she, he in engaged.items(): shelikes = galprefers[she] shelikesbetter = shelikes[:shelikes.index(he)] helikes = guyprefers[he] helikesbetter = helikes[:helikes.index(she)] for guy in shelikesbetter: guysgirl = inverseengaged[guy] guylikes = guyprefers[guy] if guylikes.index(guysgirl) > guylikes.index(she): print("%s and %s like each other better than " "their present partners: %s and %s, respectively" % (she, guy, he, guysgirl)) return False for gal in helikesbetter: girlsguy = engaged[gal] gallikes = galprefers[gal] if gallikes.index(girlsguy) > gallikes.index(he): print("%s and %s like each other better than " "their present partners: %s and %s, respectively" % (he, gal, she, girlsguy)) return False return True
def matchmaker():
guysfree = guys[:] engaged = {} guyprefers2 = copy.deepcopy(guyprefers) galprefers2 = copy.deepcopy(galprefers) while guysfree: guy = guysfree.pop(0) guyslist = guyprefers2[guy] gal = guyslist.pop(0) fiance = engaged.get(gal) if not fiance: # She's free engaged[gal] = guy print(" %s and %s" % (guy, gal)) else: # The bounder proposes to an engaged lass! galslist = galprefers2[gal] if galslist.index(fiance) > galslist.index(guy): # She prefers new guy engaged[gal] = guy print(" %s dumped %s for %s" % (gal, fiance, guy)) if guyprefers2[fiance]: # Ex has more girls to try guysfree.append(fiance) else: # She is faithful to old fiance if guyslist: # Look again guysfree.append(guy) return engaged
print('\nEngagements:')
engaged = matchmaker()
print('\nCouples:') print(' ' + ',\n '.join('%s is engaged to %s' % couple
for couple in sorted(engaged.items())))
print() print('Engagement stability check PASSED'
if check(engaged) else 'Engagement stability check FAILED')
print('\n\nSwapping two fiances to introduce an error') engaged[gals[0]], engaged[gals[1]] = engaged[gals[1]], engaged[gals[0]] for gal in gals[:2]:
print(' %s is now engaged to %s' % (gal, engaged[gal]))
print() print('Engagement stability check PASSED'
if check(engaged) else 'Engagement stability check FAILED')</lang>
Sample Output
Engagements: abe and abi bob and cath col and hope dan and ivy ed and jan fred and bea gav and gay hope dumped col for ian abi dumped abe for jon hal and eve col and dee ivy dumped dan for abe dan and fay Couples: abi is engaged to jon, bea is engaged to fred, cath is engaged to bob, dee is engaged to col, eve is engaged to hal, fay is engaged to dan, gay is engaged to gav, hope is engaged to ian, ivy is engaged to abe, jan is engaged to ed Engagement stability check PASSED Swapping two fiances to introduce an error abi is now engaged to fred bea is now engaged to jon fay and jon like each other better than their present partners: dan and bea, respectively Engagement stability check FAILED
Tcl
<lang tcl>package require Tcl 8.5
- Functions as aliases to standard commands
interp alias {} tcl::mathfunc::pos {} ::lsearch -exact interp alias {} tcl::mathfunc::nonempty {} ::llength
- The stability check
proc check engaged {
global preferences set inverse [lreverse $engaged] dict for {she he} $engaged {
set shelikes [dict get $preferences $she] set shelikesbetter [lrange $shelikes 0 [expr {pos($shelikes,$he)}]] set helikes [dict get $preferences $he] set helikesbetter [lrange $helikes 0 [expr {pos($helikes,$she)}]] foreach guy $shelikesbetter { set guysgirl [dict get $inverse $guy] set guylikes [dict get $preferences $guy] if {pos($guylikes,$guysgirl) > pos($guylikes,$she)} { puts "$she likes $guy better than $he and $he likes $she better\ than their current partner" return 0 } } foreach gal $helikesbetter { set galsguy [dict get $engaged $gal] set gallikes [dict get $preferences $gal] if {pos($gallikes,$galsguy) > pos($gallikes,$he)} { puts "$he likes $gal better than $she and $she likes $he better\ than their current partner" return 0 } }
} return 1
}
- The match-making algorithm
proc matchmaker {} {
global guys gals preferences set guysfree $guys set engaged {} array set p $preferences while {nonempty($guysfree)} {
set guysfree [lassign $guysfree guy] set p($guy) [set guyslist [lassign $p($guy) gal]] if {![dict exists $engaged $gal]} { # She's free dict set engaged $gal $guy puts " $guy and $gal" continue } # The bounder proposes to an engaged lass! set fiance [dict get $engaged $gal] if {pos($p($gal), $fiance) > pos($p($gal), $guy)} { # She prefers the new guy dict set engaged $gal $guy puts " $gal dumped $fiance for $guy" set guy $fiance } if {nonempty($p($guy))} { lappend guysfree $guy }
} return $engaged
}
- Problem dataset; preferences unified since all names distinct
set guys {abe bob col dan ed fred gav hal ian jon} set gals {abi bea cath dee eve fay gay hope ivy jan} set preferences {
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}
}
- The demonstration code
puts "Engagements:" set engaged [matchmaker]
puts "\nCouples:" set pfx "" foreach gal $gals {
puts -nonewline "$pfx $gal is engaged to [dict get $engaged $gal]" set pfx ",\n"
} puts "\n" puts "Engagement stability check [lindex {FAILED PASSED} [check $engaged]]"
puts "\n\nSwapping two fiances to introduce an error" set tmp [dict get $engaged [lindex $gals 0]] dict set engaged [lindex $gals 0] [dict get $engaged [lindex $gals 1]] dict set engaged [lindex $gals 1] $tmp foreach gal [lrange $gals 0 1] {
puts " $gal is now engaged to [dict get $engaged $gal]"
} puts "" puts "Engagement stability check [lindex {FAILED PASSED} [check $engaged]]"</lang> Sample output:
Engagements: abe and abi bob and cath col and hope dan and ivy ed and jan fred and bea gav and gay hope dumped col for ian abi dumped abe for jon hal and eve col and dee ivy dumped dan for abe dan and fay Couples: abi is engaged to jon, bea is engaged to fred, cath is engaged to bob, dee is engaged to col, eve is engaged to hal, fay is engaged to dan, gay is engaged to gav, hope is engaged to ian, ivy is engaged to abe, jan is engaged to ed Engagement stability check PASSED Swapping two fiances to introduce an error abi is now engaged to fred bea is now engaged to jon fred likes bea better than abi and abi likes fred better than their current partner Engagement stability check FAILED