1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
|
module Main where
import Data.Map (Map)
import qualified Data.Map as Map
import Data.List (unfoldr, foldl', sortBy, nub, (\\), nubBy, find)
import Data.Maybe (fromMaybe)
import Control.Applicative ((<$>))
import System.IO
import Text.PrettyPrint.HughesPJ
import Debug.Trace
data Gender = Male | Female deriving (Show, Eq, Ord)
data Orientation = Straight | Bi | Gay deriving (Show, Eq, Ord)
data Person = Person Orientation Gender Int deriving (Show, Eq, Ord)
likes :: Person -> [Gender]
likes (Person Bi _ _) = [Male, Female]
likes (Person Gay gender _) = [gender]
likes (Person Straight Male _) = [Female]
likes (Person Straight Female _) = [Male]
compatible :: Person -> Person -> Bool
p1@(Person orientation1 gender1 _) `compatible` p2@(Person orientation2 gender2 _)
= gender2 `elem` likes p1 && gender1 `elem` likes p2
pairings :: [Person] -> [(Person, Person)]
pairings people = [(p1, p2) | p1 <- people, p2 <- people, p1 < p2, p1 `compatible` p2]
people :: [(Person, Person)] -> [Person]
people ps = nub $ map fst ps ++ map snd ps
rounds :: Maybe Int -> [(Person, Person)] -> [[(Person, Person)]]
rounds maxTables pairs = unfoldr makeRound (initDisenfranchiseMap, pairs)
where
initDisenfranchiseMap = foldl' (\acc val -> Map.insert val 0 acc) Map.empty (people pairs)
makeRound (disenfranchised, pairs) = case pairs of
[] -> Nothing
_ -> Just (finishedRound, (newDisenfranchise, sortByDisenfranchise newDisenfranchise remainingPairs))
where
finishedUncheckedRound = nubBy (\(a, b) (c, d) -> length (nub [a,b,c,d]) < 4) pairs
finishedRound = maybe finishedUncheckedRound (\maxTables' -> take maxTables' finishedUncheckedRound) maxTables
peopleInRound = people finishedRound
newDisenfranchise :: Map Person Int
newDisenfranchise = foldl' (\acc val -> Map.adjust
(if val `elem` peopleInRound then (const 0) else (+1))
val
acc
)
disenfranchised
(people remainingPairs ++ peopleInRound)
remainingPairs = pairs \\ finishedRound
sortByDisenfranchise :: Map Person Int -> [(Person, Person)] -> [(Person, Person)]
sortByDisenfranchise disenfranchiseMap = sortBy (flip comparer)
where
comparer p1@(p1a, p1b) p2@(p2a, p2b) = case max p1a'r p1b'r `compare` max p2a'r p2b'r of
EQ -> case (p1a'r + p1b'r) `compare` (p2a'r + p2b'r) of
EQ -> p1 `compare` p2
x -> x
x -> x
where
p1a'r = rounds p1a
p1b'r = rounds p1b
p2a'r = rounds p2a
p2b'r = rounds p2b
rounds person = fromMaybe (error "Person not found in disenfranchisement map") $ Map.lookup person disenfranchiseMap
mapTables :: [[(Person, Person)]] -> Map Person [Maybe Int]
mapTables rounds = foldl' go (Map.fromList (map (,[]) (people (concat rounds)))) rounds
where
go acc round = Map.mapWithKey adjustPerson acc
where
adjustPerson person personsTables = personsTables ++ [(maybeTable person)]
maybeTable person = fst <$> find (\(table, (p1, p2)) -> person == p1 || person == p2) (zip [1..] round)
prompt :: String -> IO Int
prompt string = putStr string >> hFlush stdout >> (getLine >>= readIO)
makePeople :: (Int -> Person) -> Int -> [Person]
makePeople personMaker num = map personMaker [1..num]
main :: IO ()
main = do
maxTables <- (\n -> if n == 0 then Nothing else Just n) <$> prompt "How many tables maximum (0 for unbounded)? "
sm <- prompt "How many straight males? "
sf <- prompt "How many straight females? "
bm <- prompt "How many bi males? "
bf <- prompt "How many bi females? "
gm <- prompt "How many gay males? "
gf <- prompt "How many gay females? "
let people = makePeople (Person Straight Male) sm ++
makePeople (Person Straight Female) sf ++
makePeople (Person Bi Male) bm ++
makePeople (Person Bi Female) bf ++
makePeople (Person Gay Male) gm ++
makePeople (Person Gay Female) gf
let answer = mapTables . rounds maxTables . pairings $ people
print answer |
