Data commit

Task/Stable-marriage-problem/F-Sharp/stable-marriage-problem.fs

@@ -0,0 +1,147 @@
+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)