Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- {- 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
- data Sex = Male | Female deriving (Eq, Show) -- Yep, that's true
- data Virtue = Intelligence | Appearence | Kindness deriving (Eq, Show, Enum)
- type Preferences = [Virtue]
- data Parameter = Parameter{
- virtue :: Virtue,
- value :: Int
- } deriving (Eq, Show)
- type Parameters = [Parameter]
- data Person = Person{
- name :: String,
- sex :: Sex,
- preferences :: Preferences,
- parameters :: Parameters,
- 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))
- {-| Sorts parameters by preferences and results values of given parameters -}
- parametersByPreferencesVector :: Parameters -> Preferences -> [Int]
- parametersByPreferencesVector parameters preferences = map ( \x -> value $ parameters !! ( fromJust $ elemIndex x $ map virtue parameters ) ) preferences
- {-| 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)
- {-| 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
- {-| 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 allVirtues
- parametersValues <- sequence $ replicate (length allVirtues) $ randomRIO (1 :: Int , 10 :: Int)
- return $ Just $ Person name sex preferences (parametersFromValues parametersValues) Nothing
- where
- allVirtues = [Intelligence ..]
- parametersFromValues parametersValues = map (\x -> Parameter (fst x) (snd x) ) $ zip allVirtues parametersValues
- {-| 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 x ys = sortBy (comparing (\y -> defaultRateFunction x y)) ys
- {-| 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)
Add Comment
Please, Sign In to add comment