summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorJed Barber <jjbarber@y7mail.com>2017-01-06 18:54:42 +1100
committerJed Barber <jjbarber@y7mail.com>2017-01-06 18:54:42 +1100
commit9c88780375c5fd42f305746156484257c02245c7 (patch)
tree6eaf9ea4451357812b56229951dffa68e04c975b /src
parent93a9b586e82b5d113d9140ceac95acabc7d51917 (diff)
Code reworked, now 16x faster, but uses 18.5x more memory
Diffstat (limited to 'src')
-rw-r--r--src/Senate.hs98
-rw-r--r--src/SenateTypes.hs22
-rw-r--r--src/main.hs29
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