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)


#coupleCount = 10
 
DataSection
  ;guys
  Data.s "abe: abi, eve, cath, ivy, jan, dee, fay, bea, hope, gay"
  Data.s "bob: cath, hope, abi, dee, eve, fay, bea, jan, ivy, gay"
  Data.s "col: hope, eve, abi, dee, bea, fay, ivy, gay, cath, jan"
  Data.s "dan: ivy, fay, dee, gay, hope, eve, jan, bea, cath, abi"
  Data.s "ed: jan, dee, bea, cath, fay, eve, abi, ivy, hope, gay"
  Data.s "fred: bea, abi, dee, gay, eve, ivy, cath, jan, hope, fay"
  Data.s "gav: gay, eve, ivy, bea, cath, abi, dee, hope, jan, fay"
  Data.s "hal: abi, eve, hope, fay, ivy, cath, jan, bea, gay, dee"
  Data.s "ian: hope, cath, dee, gay, bea, abi, fay, ivy, jan, eve"
  Data.s "jon: abi, fay, jan, gay, eve, bea, dee, cath, ivy, hope"
  ;gals
  Data.s "abi: bob, fred, jon, gav, ian, abe, dan, ed, col, hal"
  Data.s "bea: bob, abe, col, fred, gav, dan, ian, ed, jon, hal"
  Data.s "cath: fred, bob, ed, gav, hal, col, ian, abe, dan, jon"
  Data.s "dee: fred, jon, col, abe, ian, hal, gav, dan, bob, ed"
  Data.s "eve: jon, hal, fred, dan, abe, gav, col, ed, ian, bob"
  Data.s "fay: bob, abe, ed, ian, jon, dan, fred, gav, col, hal"
  Data.s "gay: jon, gav, hal, fred, bob, abe, col, ed, dan, ian"
  Data.s "hope: gav, jon, bob, abe, ian, dan, hal, ed, col, fred"
  Data.s "ivy: ian, col, hal, gav, fred, bob, abe, ed, jon, dan"
  Data.s "jan: ed, hal, gav, abe, bob, jon, col, ian, fred, dan"
EndDataSection
 
Structure message
  source.s ;person that message is from
  dest.s   ;person that message is for
  action.s ;{'P', 'A', 'D', 'B'} for proposal, accept, decline, break-up
EndStructure
 
Structure person
  name.s
  isEngagedTo.s
  List prefs.s()
EndStructure
 
Global NewList messages.message()
 
Procedure setupPersons(List persons.person(), count) 
  Protected i, j, start, pref$
  For i = 1 To count
    Read.s pref$
    pref$ = LCase(pref$)
    start = FindString(pref$, ":", 1)
    AddElement(persons())
    persons()\name = Left(pref$, start - 1)
    pref$ = Trim(Right(pref$, Len(pref$) - start))
    For j = 1 To count
      AddElement(persons()\prefs())
      persons()\prefs() = Trim(StringField(pref$, j, ","))
    Next
  Next
EndProcedure
 
Procedure sendMessage(source.s, dest.s, action.s) 
  LastElement(messages())
  AddElement(messages())
  With messages()
    \source = source
    \dest = dest
    \action = action
  EndWith
  ResetList(messages())
EndProcedure
 
Procedure selectPerson(name.s, List persons.person())
  ForEach persons()
    If persons()\name = name
      Break
    EndIf 
  Next 
EndProcedure
 
Procedure rankPerson(name.s, List prefs.s())
  ForEach prefs()
    If prefs() = name
      ProcedureReturn #coupleCount - ListIndex(prefs()) ;higher is better
    EndIf 
  Next 
  ProcedureReturn -1 ;no rank, shouldn't occur
EndProcedure
 
Procedure stabilityCheck(List guys.person(), List gals.person())
  Protected isStable = #True
  ForEach guys()
    rankPerson(guys()\isEngagedTo, guys()\prefs())
    While PreviousElement(guys()\prefs())
      selectPerson(guys()\prefs(), gals())
      If rankPerson(guys()\name, gals()\prefs()) > rankPerson(gals()\isEngagedTo, gals()\prefs())
        Print("  " + gals()\name + " loves " + guys()\name + " more than " + gals()\isEngagedTo + ",")
        PrintN(" And " + guys()\name + " loves " + gals()\name + " more than " + guys()\isEngagedTo + ".")
        isStable = #False
      EndIf
    Wend 
  Next
  If isStable
    PrintN(#CRLF$ + "Marriage stability check PASSED.")
  Else 
    PrintN(#CRLF$ + "Marriage stability check FAILED.")
  EndIf
EndProcedure
 
NewList guys.person()
NewList gals.person()
setupPersons(guys(), #coupleCount)
setupPersons(gals(), #coupleCount)
 
;make initial round of proposals
ForEach guys()
  FirstElement(guys()\prefs())
  sendMessage(guys()\name, guys()\prefs(), "P")
Next
 
;dispatch messages
Define source.s, dest.s, action.s
ForEach messages()
  source = messages()\source
  dest = messages()\dest
  action = messages()\action
 
  DeleteElement(messages())
  Select action
    Case "P" ;propose ;only message received by gals
      selectPerson(dest, gals())
      selectPerson(source, guys())
      If rankPerson(guys()\name, gals()\prefs()) < rankPerson(gals()\isEngagedTo, gals()\prefs())
        sendMessage(dest, source, "D") ;decline proposal
      ElseIf rankPerson(guys()\name, gals()\prefs()) > rankPerson(gals()\isEngagedTo, gals()\prefs())
        If gals()\isEngagedTo
          sendMessage(dest, gals()\isEngagedTo, "B")  ;break-up engagement
        EndIf 
        gals()\isEngagedTo = source
        sendMessage(dest, source, "A") ;accept proposal
      EndIf 
    Case "A", "D", "B" ;messages received by guys
      selectPerson(dest, guys())
      If action = "A" ;proposal accepted
        guys()\isEngagedTo = source 
      Else
        If action = "B" ;broke-up
          guys()\isEngagedTo = ""
        EndIf 
        NextElement(guys()\prefs())
        sendMessage(dest, guys()\prefs(),"P") ;propose to next pref
      EndIf  
  EndSelect
Next 
 
If OpenConsole()
  PrintN("Marriages:")
  ForEach guys()
    PrintN("  " + guys()\name + " And " + guys()\isEngagedTo + ".")
  Next
  stabilityCheck(guys(), gals())
 
  Define *person_1.person, *person_2.person
  PrintN(#CRLF$ + "Introducing an error by swapping partners of abi and bea.")
  selectPerson("abi", gals()): *person_1 = @gals()
  selectPerson("bea", gals()): *person_2 = @gals()
  Swap *person_1\isEngagedTo, *person_2\isEngagedTo
  selectPerson(*person_1\isEngagedTo, guys()): *person_1 = @guys()
  selectPerson(*person_1\isEngagedTo, guys()): *person_2 = @guys()
  Swap *person_1\isEngagedTo, *person_2\isEngagedTo
  PrintN("  " + *person_1\name + " is now with " + *person_1\isEngagedTo + ".")
  PrintN("  " + *person_2\name + " is now with " + *person_2\isEngagedTo + ".")
  PrintN("")
  stabilityCheck(guys(), gals())
 
  Print(#CRLF$ + #CRLF$ + "Press ENTER to exit"): Input()
  CloseConsole()
EndIf