Anonymous user
Stable marriage problem: Difference between revisions
→Icon and Unicon
Line 842:
Marriages are unstable, e.g.:
bea and fred like each other better than their current partners abi and jon</pre>
=={{header|Icon}} and {{header|Unicon}}==
<lang Icon>link printf
procedure main()
smd := IsStable(ShowEngaged(StableMatching(setup())))
IsStable(ShowEngaged(Swap(\smd,smd.women[1],smd.women[2])))
end
procedure index(L,x) #: return index of value or fail
return ( L[i := 1 to *L] === x, i)
end
procedure ShowEngaged(smd) #: Show who's hooked up
printf("\nEngagements:\n")
every w := !smd.women do
printf("%s is engaged to %s\n",w,smd.engaged[w])
return smd
end
procedure Swap(smd,x0,x1) #: swap two couples by m or w
printf("\nSwapping %s and %s\n",x0,x1)
e := smd.engaged
e[x0] :=: e[x1] # swap partners
e[e[x0]] := e[e[x1]]
return smd
end
procedure IsStable(smd) #: validate stability
stable := 1 # assumption
printf("\n")
every mp := smd.prefs[m := !smd.men] & # man & pref
w := mp[index(mp,smd.engaged[m])-1 to 1 by -1] do { # better choices
wp := smd.prefs[w] # her choices
if index(wp,smd.engaged[w]) > index(wp,m) then {
printf("Engagement of %s to %s is unstable.\n",w,m)
stable := &null # broken
}
}
if \stable then {
printf("Engagments are all stable.\n")
return smd
}
end
procedure StableMatching(smd) #: match making
freemen := copy(smd.men) # Initialize all m memberof M
freewomen := set(smd.women) # ... and w memberof W to free
every (prefmen := table())[m := !freemen] := copy(smd.prefs[m])
smd.engaged := engaged := table()
printf("\nMatching:\n")
while m := get(freemen) do { # next freeman
while w := get(prefmen[m]) do { # . with prpoposals left
if member(freewomen,w) then { # . . is she free?
engaged[m] := w # . . . (m, w)
engaged[w] := m
delete(freewomen,w)
printf("%s accepted %s's proposal\n",w,m)
break
}
else { # . . no, she's engaged
m0 := engaged[w] # to m0
if index(smd.prefs[w],m) < index(smd.prefs[w],m0) then {
engaged[m] := w # (m, w) become engaged
engaged[w] := m
delete(freewomen,w)
engaged[m0] := &null # m' becomes free
put(freemen,m0)
printf("%s chose %s over %s\n",w,m,m0)
break
}
else next # she's happier as is
}
}
}
return smd
end
record sm_data(men,women,prefs,engaged) #: everyones data
procedure setup() #: setup everyones data
X := sm_data()
X.men := ["abe","bob","col","dan","ed","fred","gav","hal","ian","jon"]
X.women := ["abi","bea","cath","dee","eve","fay","gay","hope","ivy","jan"]
if *X.men ~= *(M := set(X.men)) then runerr(500,X.men) # duplicate?
if *X.women ~= *(W := set(X.women)) then runerr(500,X.women) # duplicate?
if *(B := M**W) ~= 0 then runerr(500,B) # intersect?
X.prefs := p := table()
p["abe"] := ["abi","eve","cath","ivy","jan","dee","fay","bea","hope","gay"]
p["bob"] := ["cath","hope","abi","dee","eve","fay","bea","jan","ivy","gay"]
p["col"] := ["hope","eve","abi","dee","bea","fay","ivy","gay","cath","jan"]
p["dan"] := ["ivy","fay","dee","gay","hope","eve","jan","bea","cath","abi"]
p["ed"] := ["jan","dee","bea","cath","fay","eve","abi","ivy","hope","gay"]
p["fred"] := ["bea","abi","dee","gay","eve","ivy","cath","jan","hope","fay"]
p["gav"] := ["gay","eve","ivy","bea","cath","abi","dee","hope","jan","fay"]
p["hal"] := ["abi","eve","hope","fay","ivy","cath","jan","bea","gay","dee"]
p["ian"] := ["hope","cath","dee","gay","bea","abi","fay","ivy","jan","eve"]
p["jon"] := ["abi","fay","jan","gay","eve","bea","dee","cath","ivy","hope"]
p["abi"] := ["bob","fred","jon","gav","ian","abe","dan","ed","col","hal"]
p["bea"] := ["bob","abe","col","fred","gav","dan","ian","ed","jon","hal"]
p["cath"] := ["fred","bob","ed","gav","hal","col","ian","abe","dan","jon"]
p["dee"] := ["fred","jon","col","abe","ian","hal","gav","dan","bob","ed"]
p["eve"] := ["jon","hal","fred","dan","abe","gav","col","ed","ian","bob"]
p["fay"] := ["bob","abe","ed","ian","jon","dan","fred","gav","col","hal"]
p["gay"] := ["jon","gav","hal","fred","bob","abe","col","ed","dan","ian"]
p["hope"] := ["gav","jon","bob","abe","ian","dan","hal","ed","col","fred"]
p["ivy"] := ["ian","col","hal","gav","fred","bob","abe","ed","jon","dan"]
p["jan"] := ["ed","hal","gav","abe","bob","jon","col","ian","fred","dan"]
return X
end</lang>
{{libheader|Icon Programming Library}}
[http://www.cs.arizona.edu/icon/library/src/procs/printf.icn printf.icn provides formatting]
Output:<pre>
Matching:
abi accepted abe's proposal
cath accepted bob's proposal
hope accepted col's proposal
ivy accepted dan's proposal
jan accepted ed's proposal
bea accepted fred's proposal
gay accepted gav's proposal
eve accepted hal's proposal
hope chose ian over col
abi chose jon over abe
dee accepted col's proposal
ivy chose abe over dan
fay accepted dan's proposal
Engagements:
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
Engagments are all stable.
Swapping abi and bea
Engagements:
abi is engaged to fred
bea is engaged to jon
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 of bea to fred is unstable.</pre>
=={{header|J}}==
| |||