Code reworked, now 16x faster, but uses 18.5x more memory

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