From 1f62e6f242eb4e9c08793e33b80c64475b3917ec Mon Sep 17 00:00:00 2001 From: Jed Barber Date: Sat, 28 Jan 2017 15:06:23 +1100 Subject: Restructured vote counting/transfer (again) --- readme.txt | 1 + src/Counter.hs | 70 ++++++++++++++++++++++++++++++++++++++++++++++++--------- src/Criteria.hs | 6 +++++ src/Election.hs | 24 +++++++++----------- 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) -- cgit