diff options
Diffstat (limited to 'src/Election.hs')
| -rw-r--r-- | src/Election.hs | 404 |
1 files changed, 0 insertions, 404 deletions
diff --git a/src/Election.hs b/src/Election.hs deleted file mode 100644 index f3b504e..0000000 --- a/src/Election.hs +++ /dev/null @@ -1,404 +0,0 @@ -module Election( - Election, - - createElection, - doCount - ) where - - - - --- This source is licensed under Creative Commons CC0 v1.0. - --- To read the full text, see license.txt in the main directory of this repository --- or go to https://creativecommons.org/publicdomain/zero/1.0/legalcode.txt - --- For a human readable summary, go to https://creativecommons.org/publicdomain/zero/1.0/ - - - - -import qualified System.IO as IO -import qualified System.Exit as Ex -import qualified Control.Monad as Con -import qualified Control.Monad.Trans.Either as ET -import qualified Control.Monad.IO.Class as MIO -import Data.List ( (\\) ) -import qualified Data.List as List -import qualified Data.Maybe as Maybe -import qualified Data.Either.Unwrap as Either -import Data.Ratio ( (%) ) -import qualified Counter as Sen -import qualified Candidate as Typ -import qualified CSV as CSV -import Miscellaneous ( (?) ) -import qualified Miscellaneous as Misc - - - - -data Election = Election - { getEntries :: [Entry] - , getCounter :: Sen.SenateCounter - , getLogDir :: FilePath - , getTotalPapers :: Int - , getQuota :: Int - , getMainLog :: String - , getNextLogNum :: Int - , getSeats :: Int - , getVacancies :: Int - , getTransferQueue :: [Transfer] - , getNextToElect :: Int - , isDone :: Bool - , isVerbose :: Bool } - -data Entry = Entry - { getID :: Typ.CandidateID - , getVoteChange :: Int - , getTotalVotes :: Int - , getCritTrace :: [Trace] - , getStatus :: Status - , getChanged :: Bool - , getOrderElected :: Maybe Int } - deriving (Eq) - -data Trace = Trace - { getCriteria :: Sen.Criteria - , getTransferVal :: Rational } - deriving (Eq) - -data Status = Running | Elected | Eliminated - deriving (Show, Eq) - -data Transfer = Transfer - { getWhoFrom :: Typ.CandidateID - , getVoteAmount :: Int - , getNewValue :: Rational - , getWhatToDist :: [Trace] } - deriving (Eq) - - - - -createElection :: FilePath -> FilePath -> Sen.SenateCounter -> Int -> Bool -> IO Election -createElection outDir mainLog counter numToElect verbosity = do - entries <- mapM (candToEntry counter) (Sen.getBallot counter) - return (Election - { getEntries = entries - , getCounter = counter - , getLogDir = outDir - , getTotalPapers = Sen.getTotal counter - , getQuota = droopQuota (Sen.getTotal counter) numToElect - , getMainLog = mainLog - , getNextLogNum = 1 - , getSeats = numToElect - , getVacancies = numToElect - , getTransferQueue = [] - , getNextToElect = 1 - , isDone = False - , isVerbose = verbosity }) - - - - -droopQuota :: Int -> Int -> Int -droopQuota votes seats = - 1 + floor ((fromIntegral votes) / (fromIntegral (seats + 1))) - - - - -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 = [Sen.matchID candidate] - trace = Trace criteria 1 - firstPrefs <- Sen.doCount counter criteria - return (Entry - { getID = candidate - , getVoteChange = firstPrefs - , getTotalVotes = firstPrefs - , getCritTrace = [trace] - , getStatus = Running - , getChanged = False - , getOrderElected = Nothing }) - - - - -doCount :: Election -> IO () -doCount e = - Con.when (not (isDone e)) $ do - writeLog e - let e1 = e { getNextLogNum = 1 + getNextLogNum e } - let e2 = e1 { getEntries = map clearChange (getEntries e1) } - - -- these following calculations probably aren't the - -- intended use of Either monads, but the pattern fits - -- and it's certainly a lot better than a bunch of - -- if-then-else constructs in haskell - r <- ET.eitherT return return $ - electCandidates e2 >>= - checkIfDone >>= - transferVotes >>= - checkNoQuota >>= - excludeCandidates - - -- this should never happen unless there's a bug somewhere - Con.when (getEntries e2 == getEntries r && getTransferQueue e2 == getTransferQueue r && not (isDone r)) $ - Ex.die "Infinite loop detected in election counting" - - doCount r - - - - -writeLog :: Election -> IO () -writeLog e = do - let logName = (getLogDir e) ++ "/" ++ (show (getNextLogNum e)) ++ ".csv" - - header = - [ "Seats" - , "Vacancies" - , "Total Papers" - , "Quota" - , "Candidate" - , "Votes" - , "Transfer" - , "Status" - , "Changed" - , "Order Elected" ] - static = - [ show (getSeats e) - , show (getVacancies e) - , show (getTotalPapers e) - , show (getQuota e)] - dynFunc c = - [ getID c - , show (getTotalVotes c) - , show (getVoteChange c) - , show (getStatus c) - , if (getChanged c) then show (getChanged c) else "" - , if (Maybe.isJust (getOrderElected c)) then show (Maybe.fromJust (getOrderElected c)) else "" ] - - records = map (\x -> static ++ dynFunc x) (getEntries e) - headerLine = CSV.unParseRecord CSV.defaultSettings header - recordLines = map (CSV.unParseRecord CSV.defaultSettings) records - output = unlines (headerLine:recordLines) - IO.writeFile logName output - - - - -clearChange :: Entry -> Entry -clearChange entry = entry - { getChanged = False - , getVoteChange = 0 } - - - - -electCandidates :: Election -> ET.EitherT Election IO Election -electCandidates e = do - let oldToElectNum = getNextToElect e - electLoop x = ET.eitherT return electLoop $ doElectCandidate x - r <- MIO.liftIO $ electLoop e - if (getNextToElect r > oldToElectNum) - then ET.left r - else ET.right r - - - - --- needs to be modified to take into account ties --- may be prudent to put this just in the IO monad instead of EitherT -doElectCandidate :: Election -> ET.EitherT Election IO Election -doElectCandidate e = do - let running = filter ((== Running) . getStatus) (getEntries e) - electedEntry = List.maximumBy compareVotes running - (beforeEntries, afterEntries) = Misc.partBeforeAfter electedEntry (getEntries e) - - newTransfer = Transfer - { getWhoFrom = getID electedEntry - , getVoteAmount = getTotalVotes electedEntry - getQuota e - , getNewValue = (fromIntegral (getTotalVotes electedEntry - getQuota e)) % - (fromIntegral (getTotalVotes electedEntry)) - , getWhatToDist = getCritTrace electedEntry } - - revisedElectedEntry = electedEntry - { getStatus = Elected - , getChanged = True - , getOrderElected = Just (getNextToElect e) } - allRevised = beforeEntries ++ [revisedElectedEntry] ++ afterEntries - - if (getTotalVotes electedEntry >= getQuota e) - then do - let logmsg = show (getID electedEntry) ++ " elected at logfile #" ++ show (getNextLogNum e) - MIO.liftIO $ IO.appendFile (getMainLog e) (logmsg ++ "\n") - MIO.liftIO $ Con.when (isVerbose e) (IO.hPutStrLn IO.stderr logmsg) - ET.right (e - { getEntries = allRevised - , getTransferQueue = (getTransferQueue e) ++ [newTransfer] - , getNextToElect = getNextToElect e + 1 - , getVacancies = getVacancies e - 1 }) - else ET.left e - - - - -checkIfDone :: Election -> ET.EitherT Election IO Election -checkIfDone e = - let stillRunning = filter ((== Running) . getStatus) (getEntries e) - in if (getVacancies e == 0 || length stillRunning == 0) - then ET.left (e { isDone = True }) - else ET.right e - - - - --- redistributing votes in STV is annoying as hell -transferVotes :: Election -> ET.EitherT Election IO Election -transferVotes e = - if (length (getTransferQueue e) > 0) - then (MIO.liftIO $ doVoteTransfer e) >>= ET.left - else ET.right e - - - - -doVoteTransfer :: Election -> IO Election -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) - notRunningIDs = map getID (filter ((/= Running) . getStatus) (getEntries e)) - - reviseTrace candID trace = trace - { 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 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 ++ addedTraces }) - - revisedFromEntry = fromEntry - { getVoteChange = -(getVoteAmount currentTransfer) - , getTotalVotes = getTotalVotes fromEntry - getVoteAmount currentTransfer - , getCritTrace = getCritTrace fromEntry \\ getWhatToDist currentTransfer } - revisedBeforeEntries <- mapM reviseFunc beforeEntries - revisedAfterEntries <- mapM reviseFunc afterEntries - let allRevised = revisedBeforeEntries ++ [revisedFromEntry] ++ revisedAfterEntries - - return (e - { getEntries = allRevised - , getTransferQueue = remainingTransfers }) - - - - --- needs to be modified to take into account ties -checkNoQuota :: Election -> ET.EitherT Election IO Election -checkNoQuota e = do - let running = filter ((== Running) . getStatus) (getEntries e) - sorted = reverse (List.sortBy compareVotes running) - - if (length running <= getVacancies e + 1) - then do - let makeElect entry n = do - let logmsg = show (getID entry) ++ " elected at logfile #" ++ show (getNextLogNum e) - IO.appendFile (getMainLog e) (logmsg ++ "\n") - Con.when (isVerbose e) (IO.hPutStrLn IO.stderr logmsg) - return (entry - { getStatus = Elected - , getChanged = True - , getOrderElected = Just n }) - - reviseFunc input output toChange n = - if (length input == 0) - then return (reverse output) - else if ((head input) `elem` toChange) - then do - r <- makeElect (head input) n - reviseFunc (tail input) (r:output) toChange (n + 1) - else reviseFunc (tail input) ((head input):output) toChange n - - toChange = if (length running <= getVacancies e) then sorted else init sorted - - allRevised <- MIO.liftIO $ reviseFunc (getEntries e) [] toChange (getNextToElect e) - - ET.left (e - { getEntries = allRevised - , getVacancies = 0 - , getNextToElect = getNextToElect e + length toChange }) - else ET.right e - - - - -excludeCandidates :: Election -> ET.EitherT Election IO Election -excludeCandidates e = do - let running = filter ((== Running) . getStatus) (getEntries e) - sorted = reverse (List.sortBy compareVotes running) - appliedBreakpoint = getQuota e - getTotalVotes (head sorted) - - excludeLoop n v e = do - (i,r) <- MIO.liftIO $ excludeSomeone e - let v1 = v + i - n1 = n + 1 - if (v1 > appliedBreakpoint) - then if (n > 0) - then do - MIO.liftIO $ Con.when (n > 1) $ do - let logmsg = "Bulk exclusion of " ++ show n ++ - " candidates at logfile #" ++ show (getNextLogNum e) - IO.appendFile (getMainLog e) (logmsg ++ "\n") - Con.when (isVerbose e) (IO.hPutStrLn IO.stderr logmsg) - ET.left e - else ET.left r - else excludeLoop n1 v1 r - - if (length running > 0 && all (< getQuota e) (map getTotalVotes running)) - then excludeLoop 0 0 e - else ET.right e - - - - --- needs to be modified to take into account ties --- this function is still in the IO monad in case I want to log something in verbose mode later -excludeSomeone :: Election -> IO (Int, Election) -excludeSomeone e = do - let running = filter ((== Running) . getStatus) (getEntries e) - excludedEntry = List.minimumBy compareVotes running - (beforeEntries, afterEntries) = Misc.partBeforeAfter excludedEntry (getEntries e) - - newTransfer = Transfer - { getWhoFrom = getID excludedEntry - , getVoteAmount = getTotalVotes excludedEntry - , getNewValue = 1 - , getWhatToDist = getCritTrace excludedEntry } - - revisedExcludedEntry = excludedEntry - { getStatus = Eliminated - , getChanged = True } - allRevised = beforeEntries ++ [revisedExcludedEntry] ++ afterEntries - - return (getTotalVotes excludedEntry, e - { getEntries = allRevised - , getTransferQueue = (getTransferQueue e) ++ [newTransfer] }) - - |