116 lines
3.9 KiB
Tcl
116 lines
3.9 KiB
Tcl
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]]"
|