31 lines
1.2 KiB
Haskell
31 lines
1.2 KiB
Haskell
stableMatching :: Eq a => State a -> [Couple a]
|
|
stableMatching = getPairs . until (null._freeGuys) step
|
|
where
|
|
getPairs s = map (_2 %~ head) $ s^.guys
|
|
|
|
step :: Eq a => State a -> State a
|
|
step s = foldl propose s (s^.freeGuys)
|
|
where
|
|
propose s guy =
|
|
let girl = s^.fianceesOf guy & head
|
|
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 :: Eq a => State a -> [Couple a] -> [(Couple a, Couple a)]
|
|
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 ]
|