Instantly share code, notes, and snippets.

# fffej/StableMarriageProblem.hs Created Jul 14, 2014

Stable Marriage Problem
 import Data.List import Data.Maybe stableMatch :: (Eq m, Eq w) => [(m,[w])] -> [(w,[m])] -> [(m,w)] stableMatch ms ws = stableMatch' [] where stableMatch' ps = case unmarried ms ps of Just unmarriedMan -> stableMatch' (findMatch unmarriedMan ws ps) Nothing -> ps -- Outcome - m is always married to someone findMatch :: (Eq m,Eq w) => (m,[w]) -> [(w,[m])] -> [(m,w)] -> [(m,w)] findMatch (m,w:rest) ws ps = case isEngaged w ps of -- w is already engaged to m' - is there a better match? Just m' -> if prefers (getPrefs ws w) m m' then engage (breakup m' ps) m w else findMatch (m,rest) ws ps -- can match with first choice Nothing -> engage ps m w getPrefs :: Eq w => [(w,m)] -> w -> m getPrefs ws w = fromJust \$ lookup w ws isEngaged :: Eq w => w -> [(m,w)] -> Maybe m isEngaged w ps = fmap fst (find (\x -> snd x == w) ps) engage :: [(m,w)] -> m -> w -> [(m,w)] engage xs a b = (a,b) : xs breakup :: Eq m => m -> [(m,w)] -> [(m,w)] breakup m = filter (\x -> fst x /= m) -- Returns the first man in in ms not in ps unmarried :: Eq m => [(m,[w])] -> [(m,w)] -> Maybe (m,[w]) unmarried ms ps = find (\(m,_) -> m `notElem` engagedMen) ms where engagedMen = map fst ps -- Returns true if w prefers first over second prefers :: Eq m => [m] -> m -> m -> Bool prefers ms m1 m2 = go ms where go [] = error "no match" go (x:xs) | x == m1 = True | x == m2 = False | otherwise = go xs
to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.