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)


link printf
 
procedure main()
   smd := IsStable(ShowEngaged(StableMatching(setup())))   
   IsStable(ShowEngaged(Swap(\smd,smd.women[1],smd.women[2]))) 
end
 
procedure index(L,x)                         #: return index of value or fail
   return ( L[i := 1 to *L] === x, i)
end
 
procedure ShowEngaged(smd)                   #: Show who's hooked up
   printf("\nEngagements:\n")
   every w := !smd.women do
      printf("%s is engaged to %s\n",w,smd.engaged[w])
   return smd
end
 
procedure Swap(smd,x0,x1)                    #: swap two couples by m or w   
   printf("\nSwapping %s and %s\n",x0,x1)
   e := smd.engaged
   e[x0] :=: e[x1]                           # swap partners
   e[e[x0]] := e[e[x1]]
   return smd
end   
 
procedure IsStable(smd)                      #: validate stability
   stable := 1                                               # assumption
   printf("\n")
   every mp := smd.prefs[m := !smd.men] &                    # man & pref
         w := mp[index(mp,smd.engaged[m])-1 to 1 by -1] do { # better choices 
      wp := smd.prefs[w]                                     # her choices
      if index(wp,smd.engaged[w]) > index(wp,m) then {
         printf("Engagement of %s to %s is unstable.\n",w,m)
         stable := &null                                     # broken
         }
      }
   if \stable then {
      printf("Engagments are all stable.\n")
      return smd
      }
end
 
procedure StableMatching(smd)                #: match making 
   freemen   := copy(smd.men)                # Initialize all m memberof M 
   freewomen := set(smd.women)               # ... and w memberof W to free
   every (prefmen := table())[m := !freemen] := copy(smd.prefs[m])
   smd.engaged := engaged := table()
   printf("\nMatching:\n")   
   while m := get(freemen) do {                 # next freeman
      while w := get(prefmen[m]) do  {          # . with prpoposals left
         if member(freewomen,w) then {          # . . is she free?
            engaged[m] := w                     # . . . (m, w) 
            engaged[w] := m
            delete(freewomen,w)
            printf("%s accepted %s's proposal\n",w,m)
            break
            }
         else {                                 # . . no, she's engaged         
            m0 := engaged[w]                    #     to m0                  
            if index(smd.prefs[w],m) < index(smd.prefs[w],m0) then {  
               engaged[m] := w                  # (m, w) become engaged
               engaged[w] := m
               delete(freewomen,w)
               engaged[m0] := &null             # m' becomes free
               put(freemen,m0)   
               printf("%s chose %s over %s\n",w,m,m0)
               break
               }
            else next                          # she's happier as is 
         }
      }
   }
   return smd
end
 
record sm_data(men,women,prefs,engaged)  #: everyones data
 
procedure setup()                        #: setup everyones data
   X := sm_data()
   X.men   := ["abe","bob","col","dan","ed","fred","gav","hal","ian","jon"]
   X.women := ["abi","bea","cath","dee","eve","fay","gay","hope","ivy","jan"]
 
   if *X.men ~= *(M := set(X.men)) then runerr(500,X.men)       # duplicate? 
   if *X.women ~= *(W := set(X.women)) then runerr(500,X.women) # duplicate?
   if *(B := M**W) ~= 0 then runerr(500,B)                      # intersect?
 
   X.prefs := p := table()
 
   p["abe"]  := ["abi","eve","cath","ivy","jan","dee","fay","bea","hope","gay"]
   p["bob"]  := ["cath","hope","abi","dee","eve","fay","bea","jan","ivy","gay"]
   p["col"]  := ["hope","eve","abi","dee","bea","fay","ivy","gay","cath","jan"]
   p["dan"]  := ["ivy","fay","dee","gay","hope","eve","jan","bea","cath","abi"]
   p["ed"]   := ["jan","dee","bea","cath","fay","eve","abi","ivy","hope","gay"]
   p["fred"] := ["bea","abi","dee","gay","eve","ivy","cath","jan","hope","fay"]
   p["gav"]  := ["gay","eve","ivy","bea","cath","abi","dee","hope","jan","fay"]
   p["hal"]  := ["abi","eve","hope","fay","ivy","cath","jan","bea","gay","dee"]
   p["ian"]  := ["hope","cath","dee","gay","bea","abi","fay","ivy","jan","eve"]
   p["jon"]  := ["abi","fay","jan","gay","eve","bea","dee","cath","ivy","hope"]
 
   p["abi"]  := ["bob","fred","jon","gav","ian","abe","dan","ed","col","hal"]
   p["bea"]  := ["bob","abe","col","fred","gav","dan","ian","ed","jon","hal"]
   p["cath"] := ["fred","bob","ed","gav","hal","col","ian","abe","dan","jon"]
   p["dee"]  := ["fred","jon","col","abe","ian","hal","gav","dan","bob","ed"]
   p["eve"]  := ["jon","hal","fred","dan","abe","gav","col","ed","ian","bob"]
   p["fay"]  := ["bob","abe","ed","ian","jon","dan","fred","gav","col","hal"]
   p["gay"]  := ["jon","gav","hal","fred","bob","abe","col","ed","dan","ian"]
   p["hope"] := ["gav","jon","bob","abe","ian","dan","hal","ed","col","fred"]
   p["ivy"]  := ["ian","col","hal","gav","fred","bob","abe","ed","jon","dan"]
   p["jan"]  := ["ed","hal","gav","abe","bob","jon","col","ian","fred","dan"]
 
   return X
end