Restructured vote counting/transfer (again)

4 files changed, 77 insertions, 24 deletions

diff --git a/readme.txt b/readme.txt
index dd3f968..aa28cc2 100644
--- a/readme.txt
+++ b/readme.txt
@@ -18,6 +18,7 @@ Aside from base, the cabal packages required to compile this program are:
     transformers
     parsec
     vector
+    array
 
 
 
diff --git a/src/Counter.hs b/src/Counter.hs
index 855b266..0f3e0d9 100644
--- a/src/Counter.hs
+++ b/src/Counter.hs
@@ -1,10 +1,14 @@
 module Counter(
     SenateCounter,
+    Criteria,
 
     createSenateCounter,
     doCount,
     getBallot,
-    getTotal
+    getTotal,
+
+    matchID,
+    matchList
     ) where
 
 
@@ -12,7 +16,6 @@ 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
@@ -21,6 +24,8 @@ import qualified Control.Monad as Con
 import qualified Data.Either.Unwrap as Either
 import qualified Data.Maybe as Maybe
 import qualified Data.List as List
+import Data.Array ( (!) )
+import qualified Data.Array as Arr
 
 
 
@@ -33,6 +38,11 @@ data SenateCounter = SenateCounter
 
 
 
+type Criteria = [Either Typ.CandidateID [Typ.CandidateID]]
+
+
+
+
 createSenateCounter :: FilePath -> Typ.AboveLineBallot -> Typ.BelowLineBallot -> IO SenateCounter
 createSenateCounter f a b = do
     numLines <- File.countLines f
@@ -67,14 +77,42 @@ parseRawLine a b input =
 
 
 
-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
+doCount :: SenateCounter -> Criteria -> IO Int
+doCount sen criteria = do
+    let checkList = map (toInternal (ballotMap sen)) criteria
+        upperBound = length checkList
+        checkArray = Arr.listArray (1,upperBound) checkList
+
+        testFunc bal check rank = if (check > upperBound) then return True else do
+            case (checkArray ! check) of
+                Left x -> do
+                    r <- Vec.checkPref (prefData sen) bal (x,rank)
+                    if r
+                        then testFunc bal (check + 1) (rank + 1)
+                        else return False
+                Right xs -> do
+                    rs <- mapM (\p -> Vec.checkPref (prefData sen) bal (p,rank)) xs
+                    if (or rs)
+                        then testFunc bal check (rank + 1)
+                        else testFunc bal (check + 1) rank
+
+        tailFunc n p = if (n > numBallots sen) then return p else do
+            r <- testFunc n 1 1
+            if r then tailFunc (n + 1) (p + 1) else tailFunc (n + 1) p
+
+    tailFunc 1 0
+
+
+
+
+toInternal :: Typ.BelowLineBallot -> Either Typ.CandidateID [Typ.CandidateID] -> Either Typ.Position (Arr.Array Int Typ.Position)
+toInternal ballot (Left c) =
+    let r = Maybe.fromJust (List.elemIndex c ballot)
+    in Left (r + 1)
+toInternal ballot (Right cs) =
+    let f x = Maybe.fromJust (List.elemIndex x ballot)
+        r = map ((+ 1) . f) cs
+    in Right (Arr.listArray (1,length r) r)
 
 
 
@@ -89,3 +127,15 @@ getTotal :: SenateCounter -> Int
 getTotal = numBallots
 
 
+
+
+matchID :: Typ.CandidateID -> Either Typ.CandidateID [Typ.CandidateID]
+matchID = Left
+
+
+
+
+matchList :: [Typ.CandidateID] -> Either Typ.CandidateID [Typ.CandidateID]
+matchList = Right
+
+
diff --git a/src/Criteria.hs b/src/Criteria.hs
index 7f46970..8ca19c8 100644
--- a/src/Criteria.hs
+++ b/src/Criteria.hs
@@ -11,6 +11,12 @@ module Criteria(
 
 
 
+--  this is a preference criteria checking method modeled after parsec
+--  it looks nice, and it *does* work, but unfortunately it's far too slow
+
+
+
+
 import qualified Control.Monad as Con
 import qualified Data.List as List
 import qualified Data.Either.Unwrap as Either
diff --git a/src/Election.hs b/src/Election.hs
index 0789fcf..5ffba0d 100644
--- a/src/Election.hs
+++ b/src/Election.hs
@@ -18,7 +18,6 @@ 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
@@ -52,15 +51,9 @@ data Entry = Entry
     deriving (Eq)
 
 data Trace = Trace
-    { getCriteria    :: Crit.Criteria
+    { getCriteria    :: Sen.Criteria
     , getTransferVal :: Float }
-
---  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)
+    deriving (Eq)
 
 data Status = Running | Elected | Eliminated
     deriving (Show, Eq)
@@ -110,7 +103,7 @@ compareVotes x y = compare (getTotalVotes x) (getTotalVotes y)
 
 candToEntry :: Sen.SenateCounter -> Typ.CandidateID -> IO Entry
 candToEntry counter candidate = do
-    let criteria = [Crit.matchID candidate]
+    let criteria = [Sen.matchID candidate]
         trace = Trace criteria 1
     firstPrefs <- Sen.doCount counter criteria
     return (Entry
@@ -270,18 +263,21 @@ doVoteTransfer e = do
         notRunningIDs = map getID (filter ((/= Running) . getStatus) (getEntries e))
 
         reviseTrace candID trace = trace
-            { getCriteria = getCriteria trace ++
-                    [Crit.many (Crit.matchFromList notRunningIDs), Crit.matchID candID]
+            { getCriteria = getCriteria trace ++ [Sen.matchList notRunningIDs, Sen.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))
+            let tracesAndChanges = zip (map fromIntegral rawVoteChanges) newTraces
+                adjustedChanges = map (\(r,t) -> (floor (r * getTransferVal t), t)) tracesAndChanges
+                filteredChanges = filter ((/= 0) . fst) adjustedChanges
+                totalVoteChange = sum (map fst filteredChanges)
+                addedTraces = map snd filteredChanges
             return (entry
                 { getVoteChange = totalVoteChange
                 , getTotalVotes = getTotalVotes entry + totalVoteChange
-                , getCritTrace = getCritTrace entry ++ newTraces })
+                , getCritTrace = getCritTrace entry ++ addedTraces })
 
         revisedFromEntry = fromEntry
             { getVoteChange = -(getVoteAmount currentTransfer)