Stable marriage problem: Difference between revisions

=={{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>