147 lines
5.6 KiB
FSharp
147 lines
5.6 KiB
FSharp
let menPrefs =
|
|
Map.ofList
|
|
["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 womenPrefs =
|
|
Map.ofList
|
|
["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"];
|
|
]
|
|
|
|
let men = menPrefs |> Map.toList |> List.map fst |> List.sort
|
|
let women = womenPrefs |> Map.toList |> List.map fst |> List.sort
|
|
|
|
|
|
type Configuration =
|
|
{
|
|
proposed: Map<string,string list>; // man -> list of women
|
|
wifeOf: Map<string, string>; // man -> woman
|
|
husbandOf: Map<string, string>; // woman -> man
|
|
}
|
|
|
|
|
|
// query functions
|
|
|
|
let isFreeMan config man = config.wifeOf.TryFind man = None
|
|
|
|
let isFreeWoman config woman = config.husbandOf.TryFind woman = None
|
|
|
|
let hasProposedTo config man woman =
|
|
defaultArg (config.proposed.TryFind(man)) []
|
|
|> List.exists ((=) woman)
|
|
|
|
// helper
|
|
let negate f = fun x -> not (f x)
|
|
|
|
// returns those 'women' who 'man' has not proposed to before
|
|
let notProposedBy config man women = List.filter (negate (hasProposedTo config man)) women
|
|
|
|
let prefers (prefs:Map<string,string list>) w m1 m2 =
|
|
let order = prefs.[w]
|
|
let m1i = List.findIndex ((=) m1) order
|
|
let m2i = List.findIndex ((=) m2) order
|
|
m1i < m2i
|
|
|
|
let womanPrefers = prefers womenPrefs
|
|
let manPrefers = prefers menPrefs
|
|
|
|
// returns the women that m likes better than his current fiancée
|
|
let preferredWomen config m =
|
|
let w = config.wifeOf.[m]
|
|
women
|
|
|> List.filter (fun w' -> manPrefers m w' w) // '
|
|
|
|
// whether there is a woman who m likes better than his current fiancée
|
|
// and who also likes him better than her current fiancé
|
|
let prefersAWomanWhoAlsoPrefersHim config m =
|
|
preferredWomen config m
|
|
|> List.exists (fun w -> womanPrefers w m config.husbandOf.[w])
|
|
|
|
let isStable config =
|
|
not (List.exists (prefersAWomanWhoAlsoPrefersHim config) men)
|
|
|
|
|
|
// modifiers (return new configurations)
|
|
|
|
let engage config man woman =
|
|
{ config with wifeOf = config.wifeOf.Add(man, woman);
|
|
husbandOf = config.husbandOf.Add(woman, man) }
|
|
|
|
let breakOff config man =
|
|
let woman = config.wifeOf.[man]
|
|
{ config with wifeOf = config.wifeOf.Remove(man);
|
|
husbandOf = config.husbandOf.Remove(woman) }
|
|
|
|
let propose config m w =
|
|
// remember the proposition
|
|
let proposedByM = defaultArg (config.proposed.TryFind m) []
|
|
let proposed' = config.proposed.Add(m, w::proposedByM) // '
|
|
let config = { config with proposed = proposed'} // '
|
|
// actually try to engage
|
|
if isFreeWoman config w then engage config m w
|
|
else
|
|
let m' = config.husbandOf.[w] // '
|
|
if womanPrefers w m m' then // '
|
|
let config = breakOff config m' // '
|
|
engage config m w
|
|
else
|
|
config
|
|
|
|
// do one step of the algorithm; returns None if no more steps are possible
|
|
let step config : Configuration option =
|
|
let freeMen = men |> List.filter (isFreeMan config)
|
|
let menWhoCanPropose =
|
|
freeMen |>
|
|
List.filter (fun man -> (notProposedBy config man women) <> [] )
|
|
match menWhoCanPropose with
|
|
| [] -> None
|
|
| m::_ -> let unproposedByM = menPrefs.[m] |> notProposedBy config m
|
|
// w is automatically the highest ranked because menPrefs.[m] is the source
|
|
let w = List.head unproposedByM
|
|
Some( propose config m w )
|
|
|
|
let rec loop config =
|
|
match step config with
|
|
| None -> config
|
|
| Some config' -> loop config' // '
|
|
|
|
|
|
// find solution and print it
|
|
let solution = loop { proposed = Map.empty<string, string list>;
|
|
wifeOf = Map.empty<string, string>;
|
|
husbandOf = Map.empty<string, string> }
|
|
|
|
for woman, man in Map.toList solution.husbandOf do
|
|
printfn "%s is engaged to %s" woman man
|
|
|
|
printfn "Solution is stable: %A" (isStable solution)
|
|
|
|
|
|
// create unstable configuration by perturbing the solution
|
|
let perturbed =
|
|
let gal0 = women.[0]
|
|
let gal1 = women.[1]
|
|
let guy0 = solution.husbandOf.[gal0]
|
|
let guy1 = solution.husbandOf.[gal1]
|
|
{ solution with wifeOf = solution.wifeOf.Add( guy0, gal1 ).Add( guy1, gal0 );
|
|
husbandOf = solution.husbandOf.Add( gal0, guy1 ).Add( gal1, guy0 ) }
|
|
|
|
printfn "Perturbed is stable: %A" (isStable perturbed)
|