Stable marriage problem: Difference between revisions

Content added Content deleted
(→‎{{header|UNIX Shell}}: Add implementation.)
(→‎{{header|Haskell}}: Changed to more idiomatic and clear solution)
Line 2,528: Line 2,528:


=={{header|Haskell}}==
=={{header|Haskell}}==
<lang haskell>import Data.List
import Control.Monad
import Control.Arrow
import Data.Maybe


=== The solution ===
mp = map ((head &&& tail). splitNames)
["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"]
fp = map ((head &&& tail). splitNames)
["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 Gale/Shapley algorithm is formulated via iterative changing of the state. In Haskell it is possible to implement this approach by pure function iterations.
splitNames = map (takeWhile(`notElem`",:")). words


The state here consists of the list of free guys and associative preferences lists for guys and girls correspondingly. In order to simplify the access to elements of the state we use lenses.
pref x y xs = fromJust (elemIndex x xs) < fromJust (elemIndex y xs)


<lang haskell>{-# LANGUAGE TemplateHaskell #-}
task ms fs = do
import Lens.Micro
let
import Lens.Micro.TH
jos = fst $ unzip ms
import Data.List (union, delete)
runGS es js ms = do
let (m:js') = js
(v:vm') = case lookup m ms of
Just xs -> xs
_ -> []
vv = fromJust $ lookup v fs
m2 = case lookup v es of
Just e -> e
_ -> ""
ms1 = insert (m,vm') $ delete (m,v:vm') ms


data State = State { _freeGuys :: [String]
if null js then do
, _guys :: [(String,[String])]
putStrLn ""
, _girls :: [(String,[String])]}
putStrLn "=== Couples ==="
return es
else if null m2 then
do putStrLn $ v ++ " with " ++ m
runGS ( insert (v,m) es ) js' ms1
else if pref m m2 vv then
do putStrLn $ v ++ " dumped " ++ m2 ++ " for " ++ m
runGS ( insert (v,m) $ delete (v,m2) es ) (if not $ null vm' then js'++[m2] else js') ms1


makeLenses ''State</lang>
else runGS es (if not $ null js' then js'++[m] else js') ms1


Lenses allow us to get access to each person in the state, and even to the associated preference list:
cs <- runGS [] jos ms
mapM_ (\(f,m) -> putStrLn $ f ++ " with " ++ m ) cs
putStrLn ""
checkStab cs
putStrLn ""
putStrLn "Introducing error: "
let [r1@(a,b), r2@(p,q)] = take 2 cs
r3 = (a,q)
r4 = (p,b)
errcs = insert r4. insert r3. delete r2 $ delete r1 cs
putStrLn $ "\tSwapping partners of " ++ a ++ " and " ++ p
putStrLn $ (\((a,b),(p,q)) -> "\t" ++ a ++ " is now with " ++ b ++ " and " ++ p ++ " with " ++ q) (r3,r4)
putStrLn ""
checkStab errcs


<lang Haskell>name n = lens get set
checkStab es = do
where get = head . dropWhile ((/= n).fst)
let
set assoc (_,v) = let (prev, _:post) = break ((== n).fst) assoc
fmt (a,b,c,d) = a ++ " and " ++ b ++ " like each other better than their current partners " ++ c ++ " and " ++ d
ies = uncurry(flip zip) $ unzip es -- es = [(fem,m)] & ies = [(m,fem)]
in prev ++ (n, v):post
slb = map (\(f,m)-> (f,m, map (id &&& fromJust. flip lookup ies). fst.break(==m). fromJust $ lookup f fp) ) es
hlb = map (\(f,m)-> (m,f, map (id &&& fromJust. flip lookup es ). fst.break(==f). fromJust $ lookup m mp) ) es
tslb = concatMap (filter snd. (\(f,m,ls) ->
map (\(m2,f2) ->
((f,m2,f2,m), pref f f2 $ fromJust $ lookup m2 mp)) ls)) slb
thlb = concatMap (filter snd. (\(m,f,ls) ->
map (\(f2,m2) ->
((m,f2,m2,f), pref m m2 $ fromJust $ lookup f2 fp)) ls)) hlb
res = tslb ++ thlb
if not $ null res then do
putStrLn "Marriages are unstable, e.g.:"
putStrLn.fmt.fst $ head res


fianceesOf n = guys.name n._2
else putStrLn "Marriages are stable"</lang>
fiancesOf n = girls.name n._2
{{out}}

<pre>*Main> task mp fp
theBestGirlFor name = fianceesOf name._head
abi with abe
theBestGuyFor name = fiancesOf name._head</lang>
cath with bob

hope with col
Here we see that the best choice for guys and for girls is expected to appear on the top of their preference lists. Note that in following we use lens operators:
ivy with dan

jan with ed
^. -- access to a field
bea with fred
%~ -- modification of a field
gay with gav
.~ -- setting a field the value
hope dumped col for ian

abi dumped abe for jon
Further we use a trick: guys list girls in a descending order of preference (the most liked is the first), while girls expect guys in opposite order -- the most liked is the last.
eve with hal

dee with col
With these tools and notes we are ready to implement the Gale/Shapley algorithm and the stability test as they are given in a textbook:
ivy dumped dan for abe

fay with dan
<lang Haskell>stableMatching = getPairs . iterateUntil (null._freeGuys) step
where
iterateUntil p f = head . dropWhile (not . p) . iterate f
getPairs s = map (_2 %~ head) $ s^.guys

step s = foldl propose s (s^.freeGuys)
where
propose s guy =
let girl = s^.theBestGirlFor guy
bestGuy : otherGuys = s^.fiancesOf girl
modify
| guy == bestGuy = freeGuys %~ delete guy
| guy `elem` otherGuys = (fiancesOf girl %~ dropWhile (/= guy)) .
(freeGuys %~ guy `replaceBy` bestGuy)
| otherwise = fianceesOf guy %~ tail
in modify s

replaceBy x y [] = []
replaceBy x y (h:t) | h == x = y:t
| otherwise = h:replaceBy x y t

unstablePairs s pairs =
[ ((m1, w1), (m2,w2)) | (m1, w1) <- pairs
, (m2,w2) <- pairs
, m1 /= m2
, let fm = s^.fianceesOf m1
, elemIndex w2 fm < elemIndex w1 fm
, let fw = s^.fiancesOf w2
, elemIndex m2 fw < elemIndex m1 fw ]</lang>
=== The task ===

Here are the given preferences:

<lang Haskell>guys0 =
[("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"])]
girls0 =
[("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"])]</lang>
The initial state:


<lang Haskell>s0 = State (fst <$> guys0) guys0 ((_2 %~ reverse) <$> girls0)</lang>
=== Couples ===
abi with jon
bea with fred
cath with bob
dee with col
eve with hal
fay with dan
gay with gav
hope with ian
ivy with abe
jan with ed


And the solution:
Marriages are stable
<pre>λ> let pairs = stableMatching s0
λ> mapM_ print pairs
("abe","ivy")
("bob","cath")
("col","dee")
("dan","fay")
("ed","jan")
("fred","bea")
("gav","gay")
("hal","eve")
("ian","hope")
("jon","abi")
λ> unstablePairs s0 pairs
[]</pre>


Lets' make some perturbations: swap fiancees of abe and bob:
Introducing error:
Swapping partners of abi and bea
abi is now with fred and bea with jon


<pre>λ> let fiance n = name n._2
Marriages are unstable, e.g.:
λ> let pairs' = pairs & (fiance "abe" .~ "cath") & (fiance "bob" .~ "ivy")
bea and fred like each other better than their current partners abi and jon</pre>
λ> mapM_ print $ unstablePairs s0 pairs'
(("bob","ivy"),("abe","cath"))
(("bob","ivy"),("dan","fay"))
(("bob","ivy"),("fred","bea"))
(("bob","ivy"),("ian","hope"))
(("bob","ivy"),("jon","abi"))</pre>


=={{header|Icon}} and {{header|Unicon}}==
=={{header|Icon}} and {{header|Unicon}}==
Retrieved from "https://rosettacode.org/wiki/Stable_marriage_problem"