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)


package require Tcl 8.5
 
# Functions as aliases to standard commands
interp alias {} tcl::mathfunc::pos {} ::lsearch -exact
interp alias {} tcl::mathfunc::nonempty {} ::llength
 
# The stability check
proc check engaged {
    global preferences
    set inverse [lreverse $engaged]
    set errmsg "%s and %s like each other better than their present partners,\
	    %s and %s respectively"
    dict for {she he} $engaged {
	set shelikes [dict get $preferences $she]
	set shelikesbetter [lrange $shelikes 0 [expr {pos($shelikes,$he)}]]
	set helikes [dict get $preferences $he]
	set helikesbetter [lrange $helikes 0 [expr {pos($helikes,$she)}]]
	foreach guy $shelikesbetter {
	    set guysgirl [dict get $inverse $guy]
	    set guylikes [dict get $preferences $guy]
	    if {pos($guylikes,$guysgirl) > pos($guylikes,$she)} {
		puts [format $errmsg $she $guy $he $guysgirl]
		return 0
	    }
	}
	foreach gal $helikesbetter {
	    set galsguy [dict get $engaged $gal]
	    set gallikes [dict get $preferences $gal]
	    if {pos($gallikes,$galsguy) > pos($gallikes,$he)} {
		puts [format $errmsg $he $gal $she $galsguy]
		return 0
	    }
	}
    }
    return 1
}
 
# The match-making algorithm
proc matchmaker {} {
    global guys gals preferences
    set guysfree $guys
    set engaged {}
    array set p $preferences
    while {nonempty($guysfree)} {
	set guysfree [lassign $guysfree guy]
	set p($guy) [set guyslist [lassign $p($guy) gal]]
	if {![dict exists $engaged $gal]} {
	    # She's free
	    dict set engaged $gal $guy
	    puts "  $guy and $gal"
	    continue
	}
	# The bounder proposes to an engaged lass!
	set fiance [dict get $engaged $gal]
	if {pos($p($gal), $fiance) > pos($p($gal), $guy)} {
	    # She prefers the new guy
	    dict set engaged $gal $guy
	    puts "  $gal dumped $fiance for $guy"
	    set guy $fiance
	}
	if {nonempty($p($guy))} {
	    lappend guysfree $guy
	}
    }
    return $engaged
}
 
# Problem dataset; preferences unified since all names distinct
set guys {abe bob col  dan ed  fred gav hal  ian jon}
set gals {abi bea cath dee eve fay  gay hope ivy jan}
set preferences {
    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}
}
 
# The demonstration code
puts "Engagements:"
set engaged [matchmaker]
 
puts "\nCouples:"
set pfx ""
foreach gal $gals {
    puts -nonewline "$pfx  $gal is engaged to [dict get $engaged $gal]"
    set pfx ",\n"
}
puts "\n"
puts "Engagement stability check [lindex {FAILED PASSED} [check $engaged]]"
 
puts "\n\nSwapping two fiances to introduce an error"
set tmp [dict get $engaged [lindex $gals 0]]
dict set engaged [lindex $gals 0] [dict get $engaged [lindex $gals 1]]
dict set engaged [lindex $gals 1] $tmp
foreach gal [lrange $gals 0 1] {
    puts "  $gal is now engaged to [dict get $engaged $gal]"
}
puts ""
puts "Engagement stability check [lindex {FAILED PASSED} [check $engaged]]"