diff options
Diffstat (limited to 'src/Election.hs')
| -rw-r--r-- | src/Election.hs | 169 |
1 files changed, 47 insertions, 122 deletions
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) - - |