Stable marrige problem in Haskell. University task. Not optimized by complexity. Started learning haskell 2-3 month ago.

marriage.hs

{- Author: Grigory Shepelev.; Github: @altjsus; E-mail: [email protected] -}
import Data.List
import Data.Ord
import Data.Maybe

import Control.Monad
import System.Random

import Fake hiding (shuffle)
import Fake.Provider.Person.EN_US

import qualified Data.Text as T

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)

{-| Shuffles given array -}
shuffle :: [a] -> IO [a]
shuffle [] = return []
shuffle xs = do 
    randomPosition <- getStdRandom (randomR (0, length xs - 1))
    let (left, (a:right)) = splitAt randomPosition xs
    fmap (a:) (shuffle (left ++ right))
    
{-| Generates random name (module Fake), based on sex -}
generateNameBasedOnSex :: Sex -> Maybe (IO String)
generateNameBasedOnSex sex
        | sex == Male = Just $ nameGen maleName
        | sex == Female = Just $ nameGen femaleName
        | otherwise = Nothing
    where nameGen x = fmap T.unpack $ generate x

{-| Sorts parameters by preferences and results values of given parameters -}
parametersByPreferencesVector :: [Parameter] -> [Virtue] -> [Int]
parametersByPreferencesVector parameters preferences = map (\x -> value $ parameters !! (fromJust $ elemIndex x $ map virtue parameters))  preferences

{-| Creates instance of Person structure with given sex but random name, parameters and preferences -}
generateRandomPerson :: Sex -> IO (Maybe Person)
generateRandomPerson sex =
    case generateNameBasedOnSex sex of
        Nothing -> return Nothing
        Just value -> do
            name <- value
            preferences <- shuffle [Intelligence ..]
            parametersValues <- sequence $ replicate (length [Intelligence ..]) $ randomRIO (1 :: Int , 10 :: Int)
            return $ Just $ Person name sex preferences (parametersFromValues parametersValues) Nothing
    where 
        parametersFromValues parametersValues = map (\x -> Parameter (fst x) (snd x) ) $ zip [Intelligence ..] parametersValues

{-| Creates rating by given parameters array. In given case return sum of products elements of the parameters vector on their index. Example: [6, 2, 1] -> 18 + 4 + 1 -> 23 -}
rate :: [Int] -> Int
rate array = sum $ map (\x -> (length array - x) * array!!x) [0..length array - 1]

{-| Combines parametersByPreferencesVector and rate. Given an instance of Person (judge) and the one who'll be rated (person) calculates rating of person based on judge's preferences and person parameters -}
defaultRateFunction :: Person -> Person -> Int
defaultRateFunction judge person = rate $ parametersByPreferencesVector (parameters person) (preferences judge)

{-| 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 is larger than the old one's — returns True and if it does not — returns 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)

{-| Results list of women sorted by preferences of man by defaultRateFunction -}
personalRating :: Person -> [Person] -> [Person]
personalRating = sortBy . comparing . defaultRateFunction

{-| Takes an array of array of femalse and retruns a list of females, each of whom has a partner. Pairings satisfy stability rule. -}
marrige :: [Person] -> [Person] -> [Person]
marrige males females
        | sm == [] = females
        | isNothing ex =
            marrige
            ([fsm {partner = Just fsmPartner}] ++ delete fsm males)
            ([fsmPartner {partner = Just fsm}] ++ delete fsmPartner females)
        | otherwise =
            marrige 
            ([fsm {partner = Just fsmPartner}] ++ [(fromJust ex) {partner = Nothing}] ++ delete fsm (delete (fromJust ex) males))
            ([fsmPartner {partner = Just fsm}] ++ 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)

main :: IO()
main = do
    let n = 5
    males <- sequence $ replicate n $ generateRandomPerson Male -- creates an array of n'th random Males
    females <- sequence $ replicate n $ generateRandomPerson Female -- creates an array of n'th random Females
    print $ marrige (catMaybes males) (catMaybes females)