Skip to content

Instantly share code, notes, and snippets.

@altjsus altjsus/marriage.hs
Last active Jul 26, 2019

Embed
What would you like to do?
Stable marrige problem in Haskell. University task. Not optimized by complexity. Started learning haskell 2-3 month ago.
{- Author: Grigory Shepelev.; Github: @altjsus; E-mail: altjsus@gmail.com -}
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)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.