Code a lot cleaner, algorithm theoretically improved, yet still slow as fuck probably due to criteria parsing

4 files changed, 84 insertions, 148 deletions

diff --git a/src/Counter.hs b/src/Counter.hs
index 37b36dc..855b266 100644
--- a/src/Counter.hs
+++ b/src/Counter.hs
@@ -1,5 +1,4 @@
 module Counter(
-    Criteria,
     SenateCounter,
 
     createSenateCounter,
@@ -13,6 +12,7 @@ module Counter(
 
 import qualified Candidate as Typ
 import qualified Preferences as Pref
+import qualified Criteria as Crit
 import qualified CSV as CSV
 import qualified Storage as Vec
 import qualified System.IO as IO
@@ -25,10 +25,6 @@ import qualified Data.List as List
 
 
 
---  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 Criteria = [(Typ.Ranking,Typ.CandidateID)]
-
 data SenateCounter = SenateCounter
     { prefData   :: Vec.Store
     , ballotMap  :: Typ.BelowLineBallot
@@ -40,40 +36,45 @@ data SenateCounter = SenateCounter
 createSenateCounter :: FilePath -> Typ.AboveLineBallot -> Typ.BelowLineBallot -> IO SenateCounter
 createSenateCounter f a b = do
     numLines <- File.countLines f
-    arrayData <- Vec.createStore numLines (length b)
+    prefStore <- Vec.createStore numLines (length b)
 
     h <- IO.openFile f IO.ReadMode
     let readFunc n p = if (n > numLines) then return p else do
             t0 <- IO.hGetLine h
-            let t1 = CSV.parseRecord CSV.defaultSettings (t0 ++ "\n")
-                t2 = Maybe.listToMaybe . reverse . Either.fromRight $ t1
-                t3 = Pref.parsePreferences (length a) (length b) (Maybe.fromJust t2)
-                t4 = Pref.normalise a b (Either.fromRight t3)
-                t5 = Maybe.fromJust t4
-            if (Either.isRight t1) && (Maybe.isJust t2) && (Either.isRight t3) && (Maybe.isJust t4)
-                then mapM_ (Vec.setPref arrayData n) t5 >> readFunc (n + 1) (p + 1)
+            let prefs = parseRawLine a b t0
+                result = Maybe.fromJust prefs
+            if (Maybe.isJust prefs)
+                then Vec.setPrefs prefStore n result >> readFunc (n + 1) (p + 1)
                 else readFunc (n + 1) p
     p <- readFunc 1 0
     IO.hClose h
 
-    return (SenateCounter arrayData b p)
+    return (SenateCounter prefStore b p)
+
+
 
 
+parseRawLine :: Typ.AboveLineBallot -> Typ.BelowLineBallot -> String -> Maybe [Pref.Preference]
+parseRawLine a b input =
+    let t1 = CSV.parseRecord CSV.defaultSettings (input ++ "\n")
+        t2 = Maybe.listToMaybe . reverse . Either.fromRight $ t1
+        t3 = Pref.parsePreferences (length a) (length b) (Maybe.fromJust t2)
+        t4 = Pref.normalise a b (Either.fromRight t3)
+    in if (Either.isRight t1 && Maybe.isJust t2 && Either.isRight t3)
+        then t4
+        else Nothing
 
 
-doCount :: SenateCounter -> Criteria -> IO Int
-doCount sen criteria = do
-    let isValidCriteria = all (\(x,y) -> y `List.elem` (ballotMap sen)) criteria
 
-    let critToPref (a,b) = (Maybe.fromJust (List.elemIndex b (ballotMap sen)) + 1, a)
-        neededPrefs = map critToPref criteria
-        checkFunc n r = if (n > numBallots sen) then return r else do
-            t <- Con.liftM and (mapM (Vec.checkPref (prefData sen) n) neededPrefs)
-            if t then checkFunc (n + 1) (r + 1) else checkFunc (n + 1) r
 
-    if isValidCriteria
-        then checkFunc 1 0
-        else return 0
+doCount :: SenateCounter -> Crit.Criteria -> IO Int
+doCount sen criteria =
+    let tailFunc n r = if (n > numBallots sen) then return r else do
+            prefs <- Vec.getPrefs (prefData sen) n
+            if (Crit.evaluate (ballotMap sen) prefs criteria)
+                then tailFunc (n + 1) (r + 1)
+                else tailFunc (n + 1) r
+    in tailFunc 1 0
 
 
 
diff --git a/src/Criteria.hs b/src/Criteria.hs
index 5df9cf1..7f46970 100644
--- a/src/Criteria.hs
+++ b/src/Criteria.hs
@@ -42,7 +42,8 @@ evaluate ballot preferences criteria =
 
 isValidInput :: Typ.BelowLineBallot -> [Pref.Preference] -> Bool
 isValidInput ballot preferences =
-    all (\(x,y) -> x > 0 && x <= length ballot && y > 0 && y <= length ballot) preferences
+    all (\(x,y) -> x > 0 && x <= length ballot
+                && y > 0 && y <= length ballot) preferences
 
 
 
diff --git a/src/Election.hs b/src/Election.hs
index 39bcb22..0789fcf 100644
--- a/src/Election.hs
+++ b/src/Election.hs
@@ -12,13 +12,15 @@ import qualified System.IO as IO
 import qualified Control.Monad as Con
 import qualified Control.Monad.Trans.Either as ET
 import qualified Control.Monad.IO.Class as MIO
-import qualified Data.Map.Strict as Map
+import Data.List ( (\\) )
 import qualified Data.List as List
 import qualified Data.Maybe as Maybe
 import qualified Data.Either.Unwrap as Either
 import qualified Counter as Sen
 import qualified Candidate as Typ
+import qualified Criteria as Crit
 import qualified CSV as CSV
+import Miscellaneous ( (.:) )
 import qualified Miscellaneous as Misc
 
 
@@ -50,9 +52,15 @@ data Entry = Entry
     deriving (Eq)
 
 data Trace = Trace
-    { getCriteria    :: Sen.Criteria
+    { getCriteria    :: Crit.Criteria
     , getTransferVal :: Float }
-    deriving (Eq)
+
+--  can't check for equality on functions, unfortunately,
+--  so this'll have to do
+instance Eq Trace where
+    a == b =
+        (length (getCriteria a) == length (getCriteria b))
+        && (getTransferVal a == getTransferVal b)
 
 data Status = Running | Elected | Eliminated
     deriving (Show, Eq)
@@ -60,28 +68,22 @@ data Status = Running | Elected | Eliminated
 data Transfer = Transfer
     { getWhoFrom    :: Typ.CandidateID
     , getVoteAmount :: Int
+    , getNewValue   :: Float
     , getWhatToDist :: [Trace] }
 
---  the ints here are the raw count values of the ballots
---  that satisfy the criteria in each trace
-type TransferMap = Map.Map Typ.CandidateID [(Int,Trace)]
-
 
 
 
 createElection :: FilePath -> Sen.SenateCounter -> Int -> Bool -> IO Election
 createElection outDir counter numToElect verbosity = do
     entries <- mapM (candToEntry counter) (Sen.getBallot counter)
-    let mainLog = outDir ++ "/" ++ "log.txt"
-        total = Sen.getTotal counter
-        quota = droopQuota total numToElect
     return (Election
         { getEntries       = entries
         , getCounter       = counter
         , getLogDir        = outDir
-        , getTotalPapers   = total
-        , getQuota         = quota
-        , getMainLog       = mainLog
+        , getTotalPapers   = Sen.getTotal counter
+        , getQuota         = droopQuota (Sen.getTotal counter) numToElect
+        , getMainLog       = outDir ++ "/" ++ "log.txt"
         , getNextLogNum    = 1
         , getSeats         = numToElect
         , getVacancies     = numToElect
@@ -100,9 +102,15 @@ droopQuota votes seats =
 
 
 
+compareVotes :: Entry -> Entry -> Ordering
+compareVotes x y = compare (getTotalVotes x) (getTotalVotes y)
+
+
+
+
 candToEntry :: Sen.SenateCounter -> Typ.CandidateID -> IO Entry
 candToEntry counter candidate = do
-    let criteria = [(1,candidate)]
+    let criteria = [Crit.matchID candidate]
         trace = Trace criteria 1
     firstPrefs <- Sen.doCount counter criteria
     return (Entry
@@ -206,13 +214,12 @@ doElectCandidate e = do
         electedEntry = List.maximumBy compareVotes running
         (beforeEntries, afterEntries) = Misc.partBeforeAfter electedEntry (getEntries e)
 
-        newTransferValue = (fromIntegral (getTotalVotes electedEntry - getQuota e)) /
-                                (fromIntegral (getTotalVotes electedEntry))
-        transferFunction x = x { getTransferVal = newTransferValue * getTransferVal x }
         newTransfer = Transfer
             { getWhoFrom = getID electedEntry
             , getVoteAmount = getTotalVotes electedEntry - getQuota e
-            , getWhatToDist = map transferFunction (getCritTrace electedEntry) }
+            , getNewValue = (fromIntegral (getTotalVotes electedEntry - getQuota e)) /
+                                (fromIntegral (getTotalVotes electedEntry))
+            , getWhatToDist = getCritTrace electedEntry }
 
         revisedElectedEntry = electedEntry
             { getStatus = Elected
@@ -228,7 +235,7 @@ doElectCandidate e = do
             ET.right (e
                 { getEntries = allRevised
                 , getTransferQueue = (getTransferQueue e) ++ [newTransfer]
-                , getNextToElect = 1 + getNextToElect e
+                , getNextToElect = getNextToElect e + 1
                 , getVacancies = getVacancies e - 1 })
         else ET.left e
 
@@ -245,7 +252,7 @@ checkIfDone e =
 
 
 
---  redistributing votes in STV is surprisingly complex
+--  redistributing votes in STV is annoying as hell
 transferVotes :: Election -> ET.EitherT Election IO Election
 transferVotes e =
     if (length (getTransferQueue e) > 0)
@@ -260,23 +267,29 @@ doVoteTransfer e = do
     let (currentTransfer:remainingTransfers) = getTransferQueue e
         fromEntry = Maybe.fromJust (List.find ((== getWhoFrom currentTransfer) . getID) (getEntries e))
         (beforeEntries, afterEntries) = Misc.partBeforeAfter fromEntry (getEntries e)
-
-        mapKeys = map getID (beforeEntries ++ afterEntries)
-        notRunningKeys = map getID (filter ((/= Running) . getStatus) (getEntries e))
-    transferMap <- MIO.liftIO $ Con.foldM (addToTransferMap (getCounter e) mapKeys) Map.empty (getWhatToDist currentTransfer)
-    revisedMap <- MIO.liftIO $ redistNotRunning (getCounter e) mapKeys notRunningKeys transferMap
-
-    let reviseFunc entry =
-            if (getStatus entry == Running)
-                then transferToEntry revisedMap entry
-                else entry
+        notRunningIDs = map getID (filter ((/= Running) . getStatus) (getEntries e))
+
+        reviseTrace candID trace = trace
+            { getCriteria = getCriteria trace ++
+                    [Crit.many (Crit.matchFromList notRunningIDs), Crit.matchID candID]
+            , getTransferVal = getTransferVal trace * getNewValue currentTransfer }
+
+        reviseFunc entry = do
+            let newTraces = map (reviseTrace (getID entry)) (getWhatToDist currentTransfer)
+            rawVoteChanges <- mapM (Sen.doCount (getCounter e)) (map getCriteria newTraces)
+            let totalVoteChange = sum (zipWith (floor .: (*)) (map fromIntegral rawVoteChanges) (map getTransferVal newTraces))
+            return (entry
+                { getVoteChange = totalVoteChange
+                , getTotalVotes = getTotalVotes entry + totalVoteChange
+                , getCritTrace = getCritTrace entry ++ newTraces })
 
         revisedFromEntry = fromEntry
             { getVoteChange = -(getVoteAmount currentTransfer)
             , getTotalVotes = getTotalVotes fromEntry - (getVoteAmount currentTransfer)
-            --  this last bit needs to be replaced with something more accurate
-            , getCritTrace = [] }
-        allRevised = (map reviseFunc beforeEntries) ++ [revisedFromEntry] ++ (map reviseFunc afterEntries)
+            , getCritTrace = (getCritTrace fromEntry) \\ (getWhatToDist currentTransfer) }
+    revisedBeforeEntries <- MIO.liftIO $ mapM reviseFunc beforeEntries
+    revisedAfterEntries <- MIO.liftIO $ mapM reviseFunc afterEntries
+    let allRevised = revisedBeforeEntries ++ [revisedFromEntry] ++ revisedAfterEntries
 
     ET.left (e
         { getEntries = allRevised
@@ -285,88 +298,6 @@ doVoteTransfer e = do
 
 
 
-addToTransferMap :: Sen.SenateCounter -> [Typ.CandidateID] -> TransferMap -> Trace -> IO TransferMap
-addToTransferMap counter mapKeys transferMap traceToAdd = do
-    let newTraces = map (addToTrace traceToAdd) mapKeys
-        keyed = zip mapKeys newTraces
-        noDupes = filter (not . criteriaHasDupe . getCriteria . snd) keyed
-    counted <- mapM (\(k,t) -> Sen.doCount counter (getCriteria t) >>= (\x -> return (k,(x,t)))) noDupes
-    let notZero (k,xt) = floor ((fromIntegral (fst xt)) * getTransferVal (snd xt)) > 0
-        noZeroMap = filter notZero counted
-        listed = map (\(k,xt) -> (k,xt:[])) noZeroMap
-    return (Map.unionWith (++) transferMap (Map.fromList listed))
-
-
-
-
-redistNotRunning :: Sen.SenateCounter -> [Typ.CandidateID] -> [Typ.CandidateID] -> TransferMap -> IO TransferMap
-redistNotRunning counter mapKeys notRunningKeys transferMap =
-    let lookupNotRunning k m =
-            if (length k == 0)
-                then Nothing
-                else let x = Map.lookup (head k) m
-                     in if (Maybe.isJust x)
-                         then Just (head k, Maybe.fromJust x)
-                         else lookupNotRunning (tail k) m
-        item = lookupNotRunning notRunningKeys transferMap
-    in if (Maybe.isJust item)
-        then do
-            let (key,valList) = Maybe.fromJust item
-                removedMap = Map.delete key transferMap
-            revisedMap <- Con.foldM (addToTransferMap counter mapKeys) removedMap (map snd valList)
-            redistNotRunning counter mapKeys notRunningKeys revisedMap
-        else return transferMap
-
-
-
-
-transferToEntry :: TransferMap -> Entry -> Entry
-transferToEntry transferMap entry =
-    let lookupVal = Map.lookup (getID entry) transferMap
-        valList = Maybe.fromJust lookupVal
-
-        voteChanges = map (\(x,y) -> floor ((fromIntegral x) * getTransferVal y)) valList
-        addedTraces = map snd valList
-        revisedEntry = entry
-            { getVoteChange = sum voteChanges
-            , getTotalVotes = getTotalVotes entry + sum voteChanges
-            , getCritTrace = getCritTrace entry ++ addedTraces }
-
-    in if (Maybe.isJust lookupVal)
-        then revisedEntry
-        else entry
-
-
-
-
-criteriaHasDupe :: Sen.Criteria -> Bool
-criteriaHasDupe crit =
-    let test seen toCheck =
-            if (length toCheck == 0)
-                then False
-                else if (elem (snd (head toCheck)) seen)
-                        then True
-                        else test ((snd (head toCheck)):seen) (tail toCheck)
-    in test [] crit
-
-
-
-
-addToCriteria :: Typ.CandidateID -> Sen.Criteria -> Sen.Criteria
-addToCriteria candID crit =
-    let maxRank = fst (List.maximumBy (\x y -> compare (fst x) (fst y)) crit)
-    in (maxRank + 1, candID):crit
-
-
-
-
-addToTrace :: Trace -> Typ.CandidateID -> Trace
-addToTrace trace candID = trace
-    { getCriteria = addToCriteria candID (getCriteria trace) }
-
-
-
-
 --  needs to be modified to take into account ties
 checkNoQuota :: Election -> ET.EitherT Election IO Election
 checkNoQuota e = do
@@ -381,7 +312,6 @@ checkNoQuota e = do
             if ((getStatus entry == Running) && (entry /= minimumEntry))
                 then makeElect entry
                 else entry
-
         revisedMinEntry =
             if (length running <= getVacancies e)
                 then makeElect minimumEntry
@@ -407,6 +337,7 @@ excludeSomeone e = do
         newTransfer = Transfer
             { getWhoFrom = getID excludedEntry
             , getVoteAmount = getTotalVotes excludedEntry
+            , getNewValue = 1
             , getWhatToDist = getCritTrace excludedEntry }
 
         revisedExcludedEntry = excludedEntry
@@ -421,9 +352,3 @@ excludeSomeone e = do
         else ET.right e
 
 
-
-
-compareVotes :: Entry -> Entry -> Ordering
-compareVotes x y = compare (getTotalVotes x) (getTotalVotes y)
-
-
diff --git a/src/Miscellaneous.hs b/src/Miscellaneous.hs
index 5f018e6..ba9ca98 100644
--- a/src/Miscellaneous.hs
+++ b/src/Miscellaneous.hs
@@ -1,6 +1,7 @@
 module Miscellaneous(
     if',
     (?),
+    (.:),
     selectFrom,
     readMaybe,
     partBeforeAfter
@@ -29,6 +30,14 @@ infixr 1 ?
 
 
 
+--  with this, I have truly gone dotty
+infixr 9 .:
+(.:) :: (a -> b) -> (c -> d -> a) -> c -> d -> b
+(.:) = (.).(.)
+
+
+
+
 --  kinda functions like poor man's sql
 --  first argument is the indices of the items you want in the results
 --  second argument is index-item pairs to dictate what records are acceptable to select from