diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Senate.hs | 98 | ||||
| -rw-r--r-- | src/SenateTypes.hs | 22 | ||||
| -rw-r--r-- | src/main.hs | 29 |
3 files changed, 66 insertions, 83 deletions
diff --git a/src/Senate.hs b/src/Senate.hs index b3aad8c..ef2ed9b 100644 --- a/src/Senate.hs +++ b/src/Senate.hs @@ -17,9 +17,12 @@ import qualified Data.List as List -data SenateCounter = SenateCounter { inputData :: FilePath - , upperMap :: Typ.UpperMap - , lowerMap :: Typ.LowerMap } +type Preferences = [(Typ.Position,Typ.Ranking)] +type FullPreferences = (Preferences,Preferences) + +data SenateCounter = SenateCounter { prefData :: [Preferences] + , aboveMap :: Typ.AboveLineBallot + , belowMap :: Typ.BelowLineBallot } @@ -32,49 +35,28 @@ minBelowTheLine = 6 -createSenateCounter :: FilePath -> Typ.UpperMap -> Typ.LowerMap -> IO (Maybe SenateCounter) +createSenateCounter :: FilePath -> Typ.AboveLineBallot -> Typ.BelowLineBallot -> IO 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 - - - + let rawRecs = drop headerLines (lines raw) + parsedRecs = Either.rights (filter Either.isRight (map (CSV.parseRecord CSV.defaultSettings) rawRecs)) + rawPrefs = Either.rights (filter Either.isRight (map ((parsePreferences (length a) (length b)) . last) parsedRecs)) + normedPrefs = map Maybe.fromJust (filter Maybe.isJust (map (normalise a b) rawPrefs)) + return (SenateCounter normedPrefs a b) --- 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.Criteria -> Int +doCount sen tr = + let fits = filter (tester (belowMap sen) tr) (prefData sen) + in length fits -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 +-- tests to see if a given set of preferences matches a specified criteria +tester :: Typ.BelowLineBallot -> Typ.Criteria -> Preferences -> Bool tester _ [] _ = True tester m tr p = let result = do @@ -90,36 +72,22 @@ tester m tr p = --- converts a set of above+below-the-line preferences to just below-the-line -normalise :: Typ.UpperMap -> Typ.LowerMap -> Typ.FullPreferences -> Typ.BelowPreferences +-- converts a set of above+below-the-line preferences to just formal below-the-line +normalise :: Typ.AboveLineBallot -> Typ.BelowLineBallot -> FullPreferences -> Maybe Preferences normalise a b f = - let na = normaliseAbove (fst f) - nb = normaliseBelow (snd f) + let na = extractFormal (fst f) + nb = extractFormal (snd f) in if (isValidBelowPreference b nb) - then nb + then Just 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 + then Just (fromAboveToBelow a na) + else Nothing --- this needs to be merged with normaliseAbove -normaliseBelow :: Typ.BelowPreferences -> Typ.BelowPreferences -normaliseBelow p = +extractFormal :: Preferences -> Preferences +extractFormal p = let funcTail n r p = let (matches,rest) = List.partition ((== n) . snd) p in if (p == [] || (length matches) /= 1) @@ -130,21 +98,21 @@ normaliseBelow p = -isValidAbovePreference :: Typ.UpperMap -> Typ.AbovePreferences -> Bool +isValidAbovePreference :: Typ.AboveLineBallot -> Preferences -> Bool isValidAbovePreference a p = (((length a) < minAboveTheLine) && ((length a) == (length p))) || ((length p) >= minAboveTheLine) -isValidBelowPreference :: Typ.LowerMap -> Typ.BelowPreferences -> Bool +isValidBelowPreference :: Typ.BelowLineBallot -> Preferences -> Bool isValidBelowPreference b p = (((length b) < minBelowTheLine) && ((length b) == (length p))) || ((length p) >= minBelowTheLine) -fromAboveToBelow :: Typ.UpperMap -> Typ.AbovePreferences -> Typ.BelowPreferences +fromAboveToBelow :: Typ.AboveLineBallot -> Preferences -> Preferences fromAboveToBelow a p = let sortedByRanking = List.sortBy (\x y -> compare (snd x) (snd y)) p tailFunc n bp ap = @@ -160,7 +128,7 @@ fromAboveToBelow a p = -- 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 :: Int -> Int -> String -> Either Parsec.ParseError FullPreferences parsePreferences aboveBoxes belowBoxes input = Parsec.parse (preference aboveBoxes belowBoxes) "error" input @@ -171,8 +139,8 @@ preference a b = do 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 + xp = (filter ((> 0) . snd) (zip [1,2..] xr)) + yp = (filter ((> 0) . snd) (zip [1,2..] yr)) return (xp,yp) diff --git a/src/SenateTypes.hs b/src/SenateTypes.hs index 764e733..3691034 100644 --- a/src/SenateTypes.hs +++ b/src/SenateTypes.hs @@ -2,16 +2,14 @@ module SenateTypes( Ranking, Position, CandidateID, - AbovePreferences, - BelowPreferences, - FullPreferences, - UpperMap, - LowerMap, - Trace + AboveLineBallot, + BelowLineBallot, + Criteria ) where + -- fairly obvious, rankings, positions and candidateIDs are all numbers type Ranking = Int type Position = Int @@ -19,24 +17,18 @@ 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]] +type AboveLineBallot = [[Position]] -- a list of candidates in the order of how they were placed below the line -type LowerMap = [CandidateID] +type BelowLineBallot = [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)] +type Criteria = [(Ranking,CandidateID)] diff --git a/src/main.hs b/src/main.hs index 99a6681..6e95f2a 100644 --- a/src/main.hs +++ b/src/main.hs @@ -37,14 +37,37 @@ below = [ "Pile, Jan" , "Strettles, Greg" ] +above2 = [[1,2],[3,4],[5,6],[7,8],[9,10],[11,12],[13,14],[15,16],[17,18],[19,20]] +below2 = [ "Donnelly, Matt" + , "Hennings, Cawley" + , "Edwards, David" + , "Mihaljevic, Denis" + , "Gallagher, Katy" + , "Smith, David" + , "O'Connor, Sandie" + , "Wyatt, Jess" + , "Haydon, John" + , "Tye, Martin" + , "Seselja, Zed" + , "Hiatt, Jane" + , "Field, Deborah" + , "Montagne, Jessica" + , "Hobbs, Christina" + , "Wareham, Sue" + , "Kim, David William" + , "Tadros, Elizabeth" + , "Bailey, Steven" + , "Swan, Robbie" + , "Hay, Michael Gerard" + , "Hanson, Anthony" ] + 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 + let testTraces = (map (:[]) (zip [1,1..] below)) + results = map (\x -> putStrLn . (((snd . head $ x) ++ " ") ++) . show . (Sen.doCount counter) $ x) testTraces sequence_ results |