I implemented a stable marriage problem in Haskell few month ago. It's not optimized at all and I'd like to know how to make it better from performance and readability perspective.

data Sex = Male | Female deriving (Eq, Show)
data Virtue = Intelligence | Appearence | Kindness deriving (Eq, Show, Enum)

data Parameter = Parameter{
virtue :: Virtue,
value :: Int
} deriving (Eq, Show)

data Person = Person{
name :: String,
sex :: Sex,
preferences :: [Virtue],
parameters :: [Parameter],
partner :: Maybe Person
} deriving (Eq, Show)


Results list of women sorted by preferences of one man by defaultRateFunction :: Person -> Person -> Int. In my implementation it depends on judges preferences and rated person parameters. I won't put it there for brevity. You can find full program in a link to Gist at the bottom of post. Imagine that function to be anything you want.

personalRating :: Person -> [Person] -> [Person]
personalRating x ys = sortBy (comparing (\y -> defaultRateFunction x y)) ys


Man makes an engagement proposal for the woman and if she don't have partner — she replies positively (True) and if she does, if new partner's rating > than the old one's — "returns" True and if it does not — False

proposal :: Person -> Person -> Bool
proposal male female
| isNothing (partner female) = True
| defaultRateFunction female male > defaultRateFunction female (fromJust $partner female) = True | otherwise = False  Man makes a proposal for each woman in females untill he'll find the one who'll reply positively. Assumed that there are at least one of this type in the array findTheBride :: Person -> [Person] -> Person findTheBride male females | proposal male (head females) == True = head females | otherwise = findTheBride male (tail females)  The ugliest part is marrige algorhitm itself. As I call it recursively I have to clean person from array of corresponded sexes every time it finds partner and also check if woman has an ex-partner, and deal with thier "breakup" also. marrige :: [Person] -> [Person] -> [Person] marrige males females | sm == [] = females | isNothing ex = marrige (fsmWithNewPartner:(delete fsm males)) (fsmPartnerWithFsm:(delete fsmPartner females)) | otherwise = marrige (fsmWithNewPartner:((fromJust ex) {partner = Nothing}):(delete fsm$ delete (fromJust ex) males))
(fsmPartnerWithFsm:(delete fsmPartner females))
where
sm = filter (\x -> partner x == Nothing) males -- Single males
fsm = head sm -- Fist single male
fsmPartner = findTheBride fsm (personalRating fsm females) -- Fist single male's partner
ex = partner fsmPartner -- Partner's ex (Maybe)
fsmWithNewPartner = fsm {partner = Just fsmPartner}
fsmPartnerWithFsm = fsmPartner {partner = Just fsm}


Full version of program (where random Person data are generated) avialible on Gist.

• I'm sorry for mistake: marrige = marriage. I'm not native in English. – Grigory Shepelev Mar 31 at 14:12

import Safe (findJust)
import Data.Foldable (null, all)

personalRating = sortBy . comparing . defaultRateFunction

proposal m f = all (on (>) (defaultRateFunction f) m) $partner f remarry p x = (x {partner = p} :) . delete x marrige :: [Person] -> [Person] -> [Person] marrige ms fs = case find (null . partner) ms of Nothing -> fs Just m -> marrige (remarry (Just f} m$ maybe id (remarry Nothing) (partner f) ms)
(remarry (Just m) f fs)
where f = findJust (proposal m) $personalRating m fs  You never actually use ms that have a partner. Why keep track of them? I'll assume that all start out without partners, otherwise filter once at the start. In particular, I'll assume the invariant that partnership is symmetric. marrige :: [Person] -> [Person] -> [Person] marrige [] fs = fs marriage (m:ms) fs = marrige (maybe id (\ex -> (ex {partner = Nothing} :)) (partner f) ms) (f {partner = Just m} : delete f fs) where f = findJust (proposal m)$ personalRating m fs


For performance, you could use Data.Map instead of []'s delete.

Edit: Here's one where the explicit recursion is less global. Unsetting ex's partner may be superfluous.

import Control.Monad.State

marrige = execState . traverse_ go where go m = do
f <- gets $findJust (proposal m) . personalRating m modify$ (f {partner = Just m} :) . delete f
for_ (partner f) $\ex -> go$ ex {partner = Nothing}

• Thank you. Do I have to mark your answer. I'd like to know if marriage could be more syntax-sweet. – Grigory Shepelev Mar 31 at 14:13
• If you're not satisfied, we needn't be done! Specify what metric you'd like to improve. For example, with another data structure and using the lens library, the penultimate line could be at f ?= m. – Gurkenglas Apr 3 at 2:03