From ed35d03fbdafce4d6d41d8731318304a8eb7ff61 Mon Sep 17 00:00:00 2001 From: Jed Barber Date: Fri, 6 Jan 2017 00:11:00 +1100 Subject: Ballot counting working, but results differ slightly from AEC counts --- src/CSV.hs | 59 ++++++++++++++++++ src/Senate.hs | 159 +++++++++++++++++++++++++++++++++++++++++++++++++ src/SenateTypes.hs | 42 +++++++++++++ src/csv.hs | 57 ------------------ src/current_output.txt | 19 ++++++ src/main.hs | 44 ++++++++++++++ src/senate.hs | 28 --------- src/senatetypes.hs | 28 --------- 8 files changed, 323 insertions(+), 113 deletions(-) create mode 100644 src/CSV.hs create mode 100644 src/Senate.hs create mode 100644 src/SenateTypes.hs delete mode 100644 src/csv.hs create mode 100644 src/current_output.txt create mode 100644 src/main.hs delete mode 100644 src/senate.hs delete mode 100644 src/senatetypes.hs (limited to 'src') diff --git a/src/CSV.hs b/src/CSV.hs new file mode 100644 index 0000000..ae2bbea --- /dev/null +++ b/src/CSV.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE FlexibleContexts #-} + +module CSV( + Settings(..), + specialChars, + defaultSettings, + parseRecord + ) where + + + + +import Text.ParserCombinators.Parsec +import Data.Char + + + + +data Settings = Settings { separator :: Char + , quote :: Char + , escape :: Char } + + +specialChars :: Settings -> String +specialChars s = (separator s):(quote s):(escape s):[] + + +defaultSettings = Settings { separator = ',', quote = '\"', escape = '\\' } + + + + +parseRecord :: Settings -> String -> Either ParseError [String] +parseRecord settings input = + parse (record settings) "error" input + + + + +record s = do + f <- (field s) `sepBy` (char (separator s)) + optional eol + eof + return f + + +field s = many (try (quoted s) <|> many1 (fieldChar s)) >>= return . foldl1 (++) +quoted s = between (char (quote s)) (char (quote s)) (many (quotedChar s)) +fieldChar s = allExcept s (specialChars s) +quotedChar s = allExcept s [quote s] +allExcept s c = try (escapeChar s) <|> satisfy (\x -> (not (isControl x)) && (x `notElem` c)) +escapeChar s = char (escape s) >> oneOf (specialChars s) + + +eol = try (string "\r\n") + <|> try (string "\r") + <|> try (string "\n") + "end of line" + 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" + diff --git a/src/SenateTypes.hs b/src/SenateTypes.hs new file mode 100644 index 0000000..764e733 --- /dev/null +++ b/src/SenateTypes.hs @@ -0,0 +1,42 @@ +module SenateTypes( + Ranking, + Position, + CandidateID, + AbovePreferences, + BelowPreferences, + FullPreferences, + UpperMap, + LowerMap, + Trace + ) where + + + +-- fairly obvious, rankings, positions and candidateIDs are all numbers +type Ranking = Int +type Position = Int +type CandidateID = String + + + +type AbovePreferences = [(Position,Ranking)] +type BelowPreferences = [(Position,Ranking)] +type FullPreferences = (AbovePreferences,BelowPreferences) + + + +-- positions in the uppermap list correspond to the boxes above the line, +-- and the lists of candidateIDs are the boxes below the line +type UpperMap = [[Position]] + + + +-- a list of candidates in the order of how they were placed below the line +type LowerMap = [CandidateID] + + + +-- represents a criteria used for finding ballots that voted a specific +-- way, for example voted for candidate C as #1, candidate F as #2, etc +type Trace = [(Ranking,CandidateID)] + diff --git a/src/csv.hs b/src/csv.hs deleted file mode 100644 index ddef1d2..0000000 --- a/src/csv.hs +++ /dev/null @@ -1,57 +0,0 @@ -module CSV( - Settings(..), - specialChars, - defaultSettings, - parseRecord - ) where - - - - -import Text.ParserCombinators.Parsec -import Data.Char - - - - -data Settings = Settings { separator :: Char - , quote :: Char - , escape :: Char } - - -specialChars :: Settings -> String -specialChars s = (separator s):(quote s):(escape s):[] - - -defaultSettings = Settings { separator = ',', quote = '\"', escape = '\\' } - - - - -parseRecord :: Settings -> String -> Either ParseError [String] -parseRecord settings input = - parse (record settings) "error" input - - - - -record s = do - f <- (field s) `sepBy` (char (separator s)) - optional eol - eof - return f - - -field s = many (try (quoted s) <|> many1 (fieldChar s)) >>= return . foldl1 (++) -quoted s = between (char (quote s)) (char (quote s)) (many (quotedChar s)) -fieldChar s = allExcept s (specialChars s) -quotedChar s = allExcept s [quote s] -allExcept s c = try (escapeChar s) <|> satisfy (\x -> (not (isControl x)) && (x `notElem` c)) -escapeChar s = char (escape s) >> oneOf (specialChars s) - - -eol = try (string "\r\n") - <|> try (string "\r") - <|> try (string "\n") - "end of line" - diff --git a/src/current_output.txt b/src/current_output.txt new file mode 100644 index 0000000..0a99977 --- /dev/null +++ b/src/current_output.txt @@ -0,0 +1,19 @@ +Pile, Jan 6585 +Gimini, Jimmy 205 +Kavasilas, Andrew 4802 +Jones, Timothy 190 +Campbell, Trudy 1239 +Barry, Ian 73 +Connard, Michael 10649 +Bannister, Kathy 402 +Scullion, Nigel 36895 +Lillis, Jenni 309 +McCarthy, Malarndirri 37811 +Honan, Pat 392 +Ordish, Carol 1648 +Ordish, John 70 +Lee, TS 312 +Marshall, Tristan 187 +Ryan, Maurie Japarta 185 +MacDonald, Marney 122 +Strettles, Greg 376 diff --git a/src/main.hs b/src/main.hs new file mode 100644 index 0000000..ecfec97 --- /dev/null +++ b/src/main.hs @@ -0,0 +1,44 @@ + + +import qualified System.Environment as Env +import qualified Senate as Sen +import qualified SenateTypes as Typ +import qualified Data.Maybe as Maybe + + + + +-- maps for NT Senate data +-- will be removed when candidate info parsing complete +above = [[1,2],[3,4],[5,6],[7,8],[9,10],[11,12],[13,14]] +below = [ "Pile, Jan" + , "Gimini, Jimmy" + , "Kavasilas, Andrew" + , "Jones, Timothy" + , "Campbell, Trudy" + , "Barry, Ian" + , "Connard, Michael" + , "Bannister, Kathy" + , "Scullion, Nigel" + , "Lillis, Jenni" + , "McCarthy, Malarndirri" + , "Honan, Pat" + , "Ordish, Carol" + , "Ordish, John" + , "Lee, TS" + , "Marshall, Tristan" + , "Ryan, Maurie Japarta" + , "MacDonald, Marney" + , "Strettles, Greg" ] + + + + +main = do + args <- Env.getArgs + counter <- Sen.createSenateCounter (head args) above below + let testTraces = map (:[]) (zip [1,1..] below) + theCounter = Maybe.fromJust counter + results = map (\x -> (Sen.doCount theCounter x) >>= (putStrLn . (((snd . head $ x) ++ " ") ++) . show)) testTraces + sequence_ results + diff --git a/src/senate.hs b/src/senate.hs deleted file mode 100644 index 8f24d88..0000000 --- a/src/senate.hs +++ /dev/null @@ -1,28 +0,0 @@ -module Senate( - SenateCounter, - createSenateCounter, - doCount - ) where - - - -import qualified System.IO as IO -import qualified SenateTypes as STY -import qualified CSV as CSV - - - -data SenateCounter = SenateCounter { inputData : IO.FilePath - , upperMap : STY.UpperMap - , lowerMap : STY.LowerMap } - - - -createSenateCounter :: IO.FilePath -> STY.UpperMap -> STY.LowerMap -> SenateCounter -createSenateCounter = SenateCounter --- use this function to errorcheck the input data - - - -doCount :: SenateCounter -> STY.Trace -> Int - diff --git a/src/senatetypes.hs b/src/senatetypes.hs deleted file mode 100644 index 23ef738..0000000 --- a/src/senatetypes.hs +++ /dev/null @@ -1,28 +0,0 @@ -module SenateTypes( - CandidateID, - UpperLowerMap - ) where - - - --- fairly obvious, rankings and candidateIDs are both numbers -type Ranking = Int -type CandidateID = Int - - - --- positions in the uppermap list correspond to the boxes above the line, --- and the lists of candidateIDs are the boxes below the line -type UpperMap = [[CandidateID]] - - - --- merely a list in the order of how candidates were placed below the line -type LowerMap = [CandidateID] - - - --- represents a criteria used for finding ballots that voted a specific --- way, for example voted for candidate C as #1, candidate F as #2, etc -type Trace = [(Ranking,CandidateID)] - -- cgit