Stable marriage problem: Difference between revisions

Line 2,540:

import Data.List (union, delete)

type Preferences a = (a, [a])

⚫

data State = State { _freeGuys :: [~~String~~]

type Couple a = (a,a)

⚫

, _guys :: [~~(String,[String])~~]

⚫

data State a = State { _freeGuys :: [a]

⚫

, _girls :: [~~(String,[String])~~]}

⚫

, _guys :: [Preferences a]

⚫

, _girls :: [Preferences a]}

makeLenses ''State</lang>

Line 2,554:

Line 2,556:

fianceesOf n = guys.name n._2

fiancesOf n = girls.name n._2

fiancesOf n = girls.name n._2</lang>

Note that in following we use lens operators:

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

Line 2,565:

Line 2,564:

.~ -- 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.

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. In any case, we assume that the current best choice for guys and for girls is expected to appear on the top of their preference lists.

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~~

<lang Haskell>stableMatching :: Eq a => State a -> [Couple a]

stableMatching = getPairs . iterateUntil (null._freeGuys) step

where

iterateUntil p f = head . dropWhile (not . p) . iterate f

getPairs s = map (_2 %~ head) $ s^.guys

step :: Eq a => State a -> State a

step s = foldl propose s (s^.freeGuys)

where

Line 2,590:

Line 2,591:

| 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

Line 2,598:

Line 2,600:

, let fw = s^.fiancesOf w2

, elemIndex m2 fw < elemIndex m1 fw ]</lang>

This solution works not only for strings, but for any equable data.

=== The task ===