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
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
|
module Senate(
SenateCounter,
createSenateCounter,
doCount
) where
import qualified SenateTypes as Typ
import qualified CSV as CSV
import qualified Text.ParserCombinators.Parsec as Parsec
import qualified Data.Either as Either
import qualified Data.Maybe as Maybe
import qualified Data.List as List
data SenateCounter = SenateCounter { inputData :: FilePath
, upperMap :: Typ.UpperMap
, lowerMap :: Typ.LowerMap }
headerLines = 2
fieldsInRecord = 6
minAboveTheLine = 1
minBelowTheLine = 6
createSenateCounter :: FilePath -> Typ.UpperMap -> Typ.LowerMap -> IO (Maybe SenateCounter)
createSenateCounter f a b = do
raw <- readFile f
let recs = drop headerLines (lines raw)
if (and (map isValidRecord recs))
then return (Just (SenateCounter f a b))
else return Nothing
-- preference data may contain odd symbols like '/' or '*' so
-- testing for that stuff is relegated to when actual counts are
-- performed, while this routine only checks that the CSV format
-- is valid and that the required number of fields are present
isValidRecord :: String -> Bool
isValidRecord record =
case (CSV.parseRecord CSV.defaultSettings record) of
Left _ -> False
Right x -> length x == fieldsInRecord
doCount :: SenateCounter -> Typ.Trace -> IO Int
doCount sen tr = do
raw <- readFile (inputData sen)
let recs = drop headerLines (lines raw)
parsedRecs = Either.rights (map (CSV.parseRecord CSV.defaultSettings) recs)
prefs = Either.rights
(filter Either.isRight
(map ((parsePreferences
(length (upperMap sen))
(length (lowerMap sen))) . last)
parsedRecs))
fits = filter (tester (lowerMap sen) tr) (map (normalise (upperMap sen) (lowerMap sen)) prefs)
return (length fits)
-- tests to see if a given set of preferences matches a specified trace criteria
tester :: Typ.LowerMap -> Typ.Trace -> Typ.BelowPreferences -> Bool
tester _ [] _ = True
tester m tr p =
let result = do
index <- List.elemIndex (snd (head tr)) m
hasRank <- List.lookup (index + 1) p
if (hasRank == (fst (head tr)))
then Just True
else Nothing
in if (Maybe.isJust result)
then tester m (tail tr) p
else False
-- converts a set of above+below-the-line preferences to just below-the-line
normalise :: Typ.UpperMap -> Typ.LowerMap -> Typ.FullPreferences -> Typ.BelowPreferences
normalise a b f =
let na = normaliseAbove (fst f)
nb = normaliseBelow (snd f)
in if (isValidBelowPreference b nb)
then nb
else if (isValidAbovePreference a na)
then (fromAboveToBelow a na)
else [] -- empty preference if both above/below are invalid
-- this needs to be merged with normaliseBelow
normaliseAbove :: Typ.AbovePreferences -> Typ.AbovePreferences
normaliseAbove p =
let funcTail n r p =
let (matches,rest) = List.partition ((== n) . snd) p
in if (p == [] || (length matches) /= 1)
then r
else funcTail (n + 1) ((head matches):r) rest
in funcTail 1 [] p
-- this needs to be merged with normaliseAbove
normaliseBelow :: Typ.BelowPreferences -> Typ.BelowPreferences
normaliseBelow p =
let funcTail n r p =
let (matches,rest) = List.partition ((== n) . snd) p
in if (p == [] || (length matches) /= 1)
then r
else funcTail (n + 1) ((head matches):r) rest
in funcTail 1 [] p
isValidAbovePreference :: Typ.UpperMap -> Typ.AbovePreferences -> Bool
isValidAbovePreference a p =
(((length a) < minAboveTheLine) && ((length a) == (length p))) || ((length p) >= minAboveTheLine)
isValidBelowPreference :: Typ.LowerMap -> Typ.BelowPreferences -> Bool
isValidBelowPreference b p =
(((length b) < minBelowTheLine) && ((length b) == (length p))) || ((length p) >= minBelowTheLine)
fromAboveToBelow :: Typ.UpperMap -> Typ.AbovePreferences -> Typ.BelowPreferences
fromAboveToBelow a p =
let sortedByRanking = List.sortBy (\x y -> compare (snd x) (snd y)) p
tailFunc n bp ap =
if (ap == [])
then bp
else let place = fst (head ap)
newPrefs = zip (a !! (place - 1)) [n, n+1 ..]
in tailFunc (n + length newPrefs) (bp ++ newPrefs) (tail ap)
in tailFunc 1 [] sortedByRanking
-- the two int arguments are the number of boxes above the line and the number
-- of boxes below the line respectively
parsePreferences :: Int -> Int -> String -> Either Parsec.ParseError Typ.FullPreferences
parsePreferences aboveBoxes belowBoxes input =
Parsec.parse (preference aboveBoxes belowBoxes) "error" input
preference a b = do
x <- Parsec.count a rank
y <- Parsec.count b rank
Parsec.eof
let xr = map (read :: String -> Typ.Ranking) x
yr = map (read :: String -> Typ.Ranking) y
xp = (filter ((> 0) . snd) (zip [1,2..] xr)) :: Typ.AbovePreferences
yp = (filter ((> 0) . snd) (zip [1,2..] yr)) :: Typ.BelowPreferences
return (xp,yp)
rank = do
n <- Parsec.choice [normalRank, weirdRank, nullRank]
Parsec.choice [Parsec.char ',' >> return (), Parsec.eof]
return n
normalRank = do
n <- Parsec.oneOf "123456789"
ns <- Parsec.many Parsec.digit
return (n:ns)
-- these symbols are taken to mean '1' according to AEC guidelines
weirdRank = do
Parsec.choice [Parsec.char '/', Parsec.char '*']
return "1"
-- these ranks are standins that will be filtered out
nullRank = return "-1"
|
