Stable marriage in Haskell

Question

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.

• shegeley: I'm sorry for mistake: marrige = marriage. I'm not native in English.

Answer 1

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}

• shegeley: Thank you. Do I have to mark your answer. I'd like to know if marriage could be more syntax-sweet.
• Gurkenglas: 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.