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 woman ranks all the men in order of her preference.

A stable set of engagements for marriage is one where no man prefers a woman 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 Shapley 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.
 Another Gale-Shapley Algorithm Demonstration.
 Stable Marriage Problem - Numberphile (Video).
 Stable Marriage Problem (the math bit) (Video).
 The Stable Marriage Problem and School Choice. (Excellent exposition)


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)