Stable marriage problem: Difference between revisions

=={{header|Tcl}}==

{{trans|Python}}

<lang 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]

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 "$she likes $guy better than $he and $he likes $she better than their current partner"

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 "$he likes $gal better than $she and $she likes $he better than their current partner"

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

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]]"</lang>

Sample output:

<pre>

Engagements:

abe and abi

bob and cath

col and hope

dan and ivy

ed and jan

fred and bea

gav and gay

hope dumped col for ian

abi dumped abe for jon

hal and eve

col and dee

ivy dumped dan for abe

dan and fay

Couples:

abi is engaged to jon,

bea is engaged to fred,

cath is engaged to bob,

dee is engaged to col,

eve is engaged to hal,

fay is engaged to dan,

gay is engaged to gav,

hope is engaged to ian,

ivy is engaged to abe,

jan is engaged to ed

Engagement stability check PASSED

Swapping two fiances to introduce an error

abi is now engaged to fred

bea is now engaged to jon

fred likes bea better than abi and abi likes fred better than their current partner

Engagement stability check FAILED

</pre>