Data commit

Task/Stable-marriage-problem/Tcl/stable-marriage-problem.tcl

@@ -0,0 +1,116 @@
+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]]"