diff options
| -rw-r--r-- | notes.txt | 2 | ||||
| -rw-r--r-- | src/Election.hs | 78 |
2 files changed, 41 insertions, 39 deletions
@@ -37,7 +37,7 @@ more counters/parsers/options to handle state elections, general stv data more detailed logging for preference distribution? tracking of exhausted/fractional-loss ballots? -multithreaded operation to speed counting up, possibly using unsafePerformIO +multithreaded operation to speed counting up, possibly using unsafePerformIO and/or forkIO group votes by uniqueness to reduce memory requirements, speed things up, and accommodate group tickets? diff --git a/src/Election.hs b/src/Election.hs index 6d946cd..582b29e 100644 --- a/src/Election.hs +++ b/src/Election.hs @@ -21,6 +21,7 @@ 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 @@ -208,7 +209,7 @@ electCandidates e = do -- 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, notRunning) = List.partition ((== Running) . getStatus) (getEntries e) + let running = filter ((== Running) . getStatus) (getEntries e) electedEntry = List.maximumBy compareVotes running (beforeEntries, afterEntries) = Misc.partBeforeAfter electedEntry (getEntries e) @@ -254,14 +255,13 @@ checkIfDone e = transferVotes :: Election -> ET.EitherT Election IO Election transferVotes e = if (length (getTransferQueue e) > 0) - then doVoteTransfer e + then (MIO.liftIO $ doVoteTransfer e) >>= ET.left else ET.right e --- may be prudent to put this just in the IO monad instead of EitherT -doVoteTransfer :: Election -> ET.EitherT Election IO Election +doVoteTransfer :: Election -> IO Election doVoteTransfer e = do let (currentTransfer:remainingTransfers) = getTransferQueue e fromEntry = Maybe.fromJust (List.find ((== getWhoFrom currentTransfer) . getID) (getEntries e)) @@ -287,50 +287,54 @@ doVoteTransfer e = do revisedFromEntry = fromEntry { getVoteChange = -(getVoteAmount currentTransfer) - , getTotalVotes = getTotalVotes fromEntry - (getVoteAmount currentTransfer) - , getCritTrace = (getCritTrace fromEntry) \\ (getWhatToDist currentTransfer) } - revisedBeforeEntries <- MIO.liftIO $ mapM reviseFunc beforeEntries - revisedAfterEntries <- MIO.liftIO $ mapM reviseFunc afterEntries + , getTotalVotes = getTotalVotes fromEntry - getVoteAmount currentTransfer + , getCritTrace = getCritTrace fromEntry \\ getWhatToDist currentTransfer } + revisedBeforeEntries <- mapM reviseFunc beforeEntries + revisedAfterEntries <- mapM reviseFunc afterEntries let allRevised = revisedBeforeEntries ++ [revisedFromEntry] ++ revisedAfterEntries - ET.left (e + return (e { getEntries = allRevised , getTransferQueue = remainingTransfers }) +-- needs to properly mark the order that the last candidates were elected -- needs to be modified to take into account ties checkNoQuota :: Election -> ET.EitherT Election IO Election checkNoQuota e = do - let (running, notRunning) = List.partition ((== Running) . getStatus) (getEntries e) - minimumEntry = List.minimumBy compareVotes running - (beforeEntries, afterEntries) = Misc.partBeforeAfter minimumEntry (getEntries e) - - makeElect entry = do - let logmsg = show (getID entry) ++ " 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) - return (entry - { getStatus = Elected - , getChanged = True }) - reviseFunc entry = - if ((getStatus entry == Running) && (entry /= minimumEntry)) - then makeElect entry - else return entry - - revisedMinEntry <- - if (length running <= getVacancies e) - then makeElect minimumEntry - else return minimumEntry - revisedBeforeEntries <- mapM reviseFunc beforeEntries - revisedAfterEntries <- mapM reviseFunc afterEntries - let allRevised = revisedBeforeEntries ++ [revisedMinEntry] ++ revisedAfterEntries + let running = filter ((== Running) . getStatus) (getEntries e) + sorted = reverse (List.sortBy compareVotes running) if (length running <= getVacancies e + 1) - then ET.left (e - { getEntries = allRevised - , getVacancies = 0 }) + 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 @@ -347,9 +351,7 @@ excludeCandidates e = do let v1 = v + i n1 = n + 1 if (v1 > appliedBreakpoint) - then if (n > 0) - then ET.left e - else ET.left r + then n > 0 ? ET.left e $ ET.left r else excludeLoop n1 v1 r if (length running > 0 && all (< getQuota e) (map getTotalVotes running)) |