diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Counter.hs | 51 | ||||
| -rw-r--r-- | src/Criteria.hs | 3 | ||||
| -rw-r--r-- | src/Election.hs | 169 | ||||
| -rw-r--r-- | src/Miscellaneous.hs | 9 |
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 |