4
\$\begingroup\$

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.

\$\endgroup\$
  • \$\begingroup\$ I'm sorry for mistake: marrige = marriage. I'm not native in English. \$\endgroup\$ – Grigory Shepelev Mar 31 at 14:12
2
\$\begingroup\$
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}
\$\endgroup\$
  • \$\begingroup\$ Thank you. Do I have to mark your answer. I'd like to know if marriage could be more syntax-sweet. \$\endgroup\$ – Grigory Shepelev Mar 31 at 14:13
  • \$\begingroup\$ 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. \$\endgroup\$ – Gurkenglas Apr 3 at 2:03

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.