Skip to content

Instantly share code, notes, and snippets.

# altjsus/marraige.hs Last active Apr 2, 2019

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)
to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.