Anonymous user
Stable marriage problem: Difference between revisions
→{{header|Haskell}}: Changed to more idiomatic and clear solution
(→{{header|UNIX Shell}}: Add implementation.) |
(→{{header|Haskell}}: Changed to more idiomatic and clear solution) |
||
Line 2,528:
=={{header|Haskell}}==
=== The solution ===
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.
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.
<lang haskell>{-# LANGUAGE TemplateHaskell #-}
import Lens.Micro
import Lens.Micro.TH
import Data.List (union, delete)
data State = State { _freeGuys :: [String]
, _guys :: [(String,[String])]
, _girls :: [(String,[String])]}
makeLenses ''State</lang>
Lenses allow us to get access to each person in the state, and even to the associated preference list:
<lang Haskell>name n = lens get set
where get = head . dropWhile ((/= n).fst)
set assoc (_,v) = let (prev, _:post) = break ((== n).fst) assoc
fianceesOf n = guys.name n._2
fiancesOf n = girls.name n._2
theBestGirlFor name = fianceesOf name._head
theBestGuyFor name = fiancesOf name._head</lang>
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:
^. -- access to a field
%~ -- modification of a field
.~ -- setting a field the value
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.
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:
<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>
And the solution:
<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:
<pre>λ> let fiance n = name n._2
λ> let pairs' = pairs & (fiance "abe" .~ "cath") & (fiance "bob" .~ "ivy")
λ> 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}}==
|