53 lines
2.7 KiB
Plaintext
53 lines
2.7 KiB
Plaintext
<<Combinatorica`;
|
|
ClearAll[CheckStability]
|
|
CheckStabilityHelp[male_, female_, ml_List, fl_List, pairing_List] := Module[{prefs, currentmale},
|
|
prefs = fl[[female]];
|
|
currentmale = Sort[Reverse /@ pairing][[female, 2]];
|
|
FirstPosition[prefs, currentmale][[1]] < FirstPosition[prefs, male][[1]]
|
|
]
|
|
CheckStabilityHelp[male_, ml_List, fl_List, pairing_List] := Module[{prefs, m, f, p, otherf, reversepair, pos, othermen},
|
|
prefs = ml[[male]];
|
|
{m, f} = pairing[[male]];
|
|
p = FirstPosition[prefs, f][[1]];
|
|
otherf = Take[prefs, p - 1];
|
|
AllTrue[otherf, CheckStabilityHelp[male, #, ml, fl, pairing] &]
|
|
]
|
|
CheckStability[ml_List, fl_List, pairing_List] := AllTrue[pairing[[All, 1]], CheckStabilityHelp[#, ml, fl, pairing] &]
|
|
males = {"abe", "bob", "col", "dan", "ed", "fred", "gav", "hal",
|
|
"ian", "jon"};
|
|
females = {"abi", "bea", "cath", "dee", "eve", "fay", "gay", "hope",
|
|
"ivy", "jan"};
|
|
ml = {{"abi", "eve", "cath", "ivy", "jan", "dee", "fay", "bea",
|
|
"hope", "gay"}, {"cath", "hope", "abi", "dee", "eve", "fay",
|
|
"bea", "jan", "ivy", "gay"}, {"hope", "eve", "abi", "dee", "bea",
|
|
"fay", "ivy", "gay", "cath", "jan"}, {"ivy", "fay", "dee", "gay",
|
|
"hope", "eve", "jan", "bea", "cath", "abi"}, {"jan", "dee", "bea",
|
|
"cath", "fay", "eve", "abi", "ivy", "hope", "gay"}, {"bea",
|
|
"abi", "dee", "gay", "eve", "ivy", "cath", "jan", "hope",
|
|
"fay"}, {"gay", "eve", "ivy", "bea", "cath", "abi", "dee", "hope",
|
|
"jan", "fay"}, {"abi", "eve", "hope", "fay", "ivy", "cath",
|
|
"jan", "bea", "gay", "dee"}, {"hope", "cath", "dee", "gay", "bea",
|
|
"abi", "fay", "ivy", "jan", "eve"}, {"abi", "fay", "jan", "gay",
|
|
"eve", "bea", "dee", "cath", "ivy", "hope"}};
|
|
fl = {{"bob", "fred", "jon", "gav", "ian", "abe", "dan", "ed", "col",
|
|
"hal"}, {"bob", "abe", "col", "fred", "gav", "dan", "ian", "ed",
|
|
"jon", "hal"}, {"fred", "bob", "ed", "gav", "hal", "col", "ian",
|
|
"abe", "dan", "jon"}, {"fred", "jon", "col", "abe", "ian", "hal",
|
|
"gav", "dan", "bob", "ed"}, {"jon", "hal", "fred", "dan", "abe",
|
|
"gav", "col", "ed", "ian", "bob"}, {"bob", "abe", "ed", "ian",
|
|
"jon", "dan", "fred", "gav", "col", "hal"}, {"jon", "gav", "hal",
|
|
"fred", "bob", "abe", "col", "ed", "dan", "ian"}, {"gav", "jon",
|
|
"bob", "abe", "ian", "dan", "hal", "ed", "col", "fred"}, {"ian",
|
|
"col", "hal", "gav", "fred", "bob", "abe", "ed", "jon",
|
|
"dan"}, {"ed", "hal", "gav", "abe", "bob", "jon", "col", "ian",
|
|
"fred", "dan"}};
|
|
ml = ml /. Thread[females -> Range[Length[males]]];
|
|
fl = fl /. Thread[males -> Range[Length[females]]];
|
|
pairing = StableMarriage[ml, fl];
|
|
pairing = {Range[Length[pairing]], pairing} // Transpose;
|
|
pairing
|
|
CheckStability[ml, fl, pairing]
|
|
pairing[[{2, 7}, 2]] //= Reverse;
|
|
pairing
|
|
CheckStability[ml, fl, pairing]
|