1 files changed, 159 insertions, 0 deletions
diff --git a/src/Senate.hs b/src/Senate.hs
new file mode 100644
index 0000000..21c8f4b
--- /dev/null
+++ b/src/Senate.hs
@@ -0,0 +1,159 @@
+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
+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 =
+    if (isValidBelowPreference b (snd f))
+        then (snd f)
+        else (fromAboveToBelow a (fst f))
+
+
+
+
+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 a b input = Parsec.parse (preference a b) "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.char ','
+    return n
+
+
+normalRank = do
+    n <- Parsec.oneOf "123456789"
+    ns <- Parsec.many Parsec.digit
+    return (n:ns)
+
+
+--  currently assuming that these symbols always mean '1'
+weirdRank = do
+    Parsec.choice [Parsec.char '/', Parsec.char '*']
+    return "1"
+
+
+nullRank = return "-1"
+