From a56fb56bbea4acb9698a32cb284a827c0d00fe9f Mon Sep 17 00:00:00 2001 From: Jed Barber Date: Fri, 20 Jan 2017 20:00:12 +1100 Subject: Some bugs fixed, vote transfer upon exclusion still not working properly --- src/Election.hs | 99 ++++++++++++++++++++++++++++++++------------------------- 1 file changed, 56 insertions(+), 43 deletions(-) (limited to 'src/Election.hs') diff --git a/src/Election.hs b/src/Election.hs index ce2f574..7f8628c 100644 --- a/src/Election.hs +++ b/src/Election.hs @@ -38,10 +38,12 @@ data Entry = Entry , getCritTrace :: [Trace] , getStatus :: Status , getChanged :: Bool } + deriving (Eq) data Trace = Trace { getCriteria :: Sen.Criteria , getTransferVal :: Float } + deriving (Eq) data Status = Running | Elected | Eliminated deriving (Show, Eq) @@ -71,31 +73,23 @@ candToEntry counter candidate = do doCount :: Election -> IO () doCount e = do - writeLog e + e' <- writeLog e -- 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-them-else constructs in haskell r <- ET.eitherT return return $ - incrementLog e >>= - checkNoneLeft >>= + checkDone e' >>= electSomeone >>= - excludeSomeone >>= - checkNoQuota + checkNoQuota >>= + excludeSomeone Con.when (not (isDone r)) $ doCount r -incrementLog :: Election -> ET.EitherT Election IO Election -incrementLog e = - ET.right (e { getNextLogNum = 1 + (getNextLogNum e) }) - - - - -checkNoneLeft :: Election -> ET.EitherT Election IO Election -checkNoneLeft e = do +checkDone :: Election -> ET.EitherT Election IO Election +checkDone e = do let running = filter ((== Running) . getStatus) (getEntries e) if (getVacancies e == 0 || length running == 0) then ET.left (e { isDone = True }) @@ -104,25 +98,36 @@ checkNoneLeft e = do +partBeforeAfter :: (Eq a) => a -> [a] -> ([a],[a]) +partBeforeAfter item list = + let (x,y) = List.break (== item) list + in if (length y <= 1) + then (x,[]) + else (x,tail y) + + + + electSomeone :: Election -> ET.EitherT Election IO Election electSomeone e = do let (running, notRunning) = List.partition ((== Running) . getStatus) (getEntries e) - (reachedQuota, notReached) = List.partition ((>= getQuota e) . getTotalVotes) running - sortedReached = List.sortBy (\x y -> compare (getTotalVotes y) (getTotalVotes x)) reachedQuota - (electedEntry, otherEntries) = (head sortedReached, (tail sortedReached) ++ notReached ++ notRunning) + electedEntry = List.maximumBy (\x y -> compare (getTotalVotes x) (getTotalVotes y)) running + (beforeEntries, afterEntries) = partBeforeAfter electedEntry (getEntries e) - newTransferValue = (fromIntegral (getTotalVotes electedEntry)) / (fromIntegral (getQuota e)) + newTransferValue = (fromIntegral (getTotalVotes electedEntry - getQuota e)) / + (fromIntegral (getTotalVotes electedEntry)) revisedElectedEntry = electedEntry { getStatus = Elected , getChanged = True , getTotalVotes = (getQuota e) , getVoteChange = (getQuota e) - (getTotalVotes electedEntry) } - revisedOtherEntries <- MIO.liftIO $ transferVotes (getCounter e) newTransferValue electedEntry otherEntries - let revisedEntries = revisedElectedEntry:revisedOtherEntries - - if (length reachedQuota > 0) - then ET.left (e { getEntries = revisedEntries, getVacancies = (getVacancies e) - 1 }) + if (getTotalVotes electedEntry >= getQuota e) + then do + revisedBeforeEntries <- MIO.liftIO $ transferVotes (getCounter e) newTransferValue electedEntry beforeEntries + revisedAfterEntries <- MIO.liftIO $ transferVotes (getCounter e) newTransferValue electedEntry afterEntries + let revisedEntries = revisedBeforeEntries ++ [revisedElectedEntry] ++ revisedAfterEntries + ET.left (e { getEntries = revisedEntries, getVacancies = (getVacancies e) - 1 }) else ET.right e @@ -131,21 +136,21 @@ electSomeone e = do excludeSomeone :: Election -> ET.EitherT Election IO Election excludeSomeone e = do let (running, notRunning) = List.partition ((== Running) . getStatus) (getEntries e) - (reachedQuota, notReached) = List.partition ((>= getQuota e) . getTotalVotes) running - sortedNotReached = List.sortBy (\x y -> compare (getTotalVotes x) (getTotalVotes y)) notReached - (excludedEntry, otherEntries) = (head sortedNotReached, (tail sortedNotReached) ++ reachedQuota ++ notRunning) + excludedEntry = List.minimumBy (\x y -> compare (getTotalVotes x) (getTotalVotes y)) running + (beforeEntries, afterEntries) = partBeforeAfter excludedEntry (getEntries e) revisedExcludedEntry = excludedEntry { getStatus = Eliminated , getChanged = True , getTotalVotes = 0 - , getVoteChange = getTotalVotes excludedEntry } - revisedOtherEntries <- MIO.liftIO $ transferVotes (getCounter e) 1 excludedEntry otherEntries - - let revisedEntries = revisedExcludedEntry:revisedOtherEntries - - if (length notReached > 0) - then ET.left (e { getEntries = revisedEntries }) + , getVoteChange = -(getTotalVotes excludedEntry) } + + if (getTotalVotes excludedEntry < getQuota e) + then do + revisedBeforeEntries <- MIO.liftIO $ transferVotes (getCounter e) 1 excludedEntry beforeEntries + revisedAfterEntries <- MIO.liftIO $ transferVotes (getCounter e) 1 excludedEntry afterEntries + let revisedEntries = revisedBeforeEntries ++ [revisedExcludedEntry] ++ revisedAfterEntries + ET.left (e { getEntries = revisedEntries }) else ET.right e @@ -164,10 +169,10 @@ transferVotes counter value from to = do let newTraces = map (addToTrace (getID entryTo)) (getCritTrace entryFrom) voteList <- Con.mapM (Sen.doCount counter) (map getCriteria newTraces) let changeList = zipWith (*) (map getTransferVal newTraces) (map fromIntegral voteList) - totalVoteChange = List.foldl' (+) 0 changeList + totalVoteChange = List.foldl' (+) 0 (map floor changeList) return (entryTo - { getVoteChange = round totalVoteChange - , getTotalVotes = (getTotalVotes entryTo) + (round totalVoteChange) + { getVoteChange = totalVoteChange + , getTotalVotes = (getTotalVotes entryTo) + totalVoteChange , getCritTrace = newTraces , getChanged = True }) @@ -179,18 +184,25 @@ transferVotes counter value from to = do checkNoQuota :: Election -> ET.EitherT Election IO Election checkNoQuota e = do let (running, notRunning) = List.partition ((== Running) . getStatus) (getEntries e) - sortedRunning = List.sortBy (\x y -> compare (getTotalVotes y) (getTotalVotes x)) running - (topRunning, rest) = List.splitAt (getVacancies e) sortedRunning - changed = map (\x -> x { getStatus = Elected, getChanged = True }) topRunning - revisedEntries = map (\x -> x { getVoteChange = 0 }) (changed ++ rest ++ notRunning) - if (getVacancies e == 1 || getVacancies e == length running) - then ET.left (e { getEntries = revisedEntries, getVacancies = 0 }) + electedEntry = List.maximumBy (\x y -> compare (getTotalVotes x) (getTotalVotes y)) running + (beforeEntries, afterEntries) = partBeforeAfter electedEntry (getEntries e) + + revisedElectedEntry = electedEntry + { getStatus = Elected + , getChanged = True + , getVoteChange = 0 } + revisedBeforeEntries = map (\x -> x { getVoteChange = 0, getChanged = False }) beforeEntries + revisedAfterEntries = map (\x -> x { getVoteChange = 0, getChanged = False }) afterEntries + revisedEntries = revisedBeforeEntries ++ [revisedElectedEntry] ++ revisedAfterEntries + + if (length running <= getVacancies e + 1) + then ET.left (e { getEntries = revisedEntries, getVacancies = getVacancies e - 1 }) else ET.right e -writeLog :: Election -> IO () +writeLog :: Election -> IO Election writeLog e = do let logName = (getLogDir e) ++ "/" ++ (show (getNextLogNum e)) ++ ".csv" header = ["Vacancies", "Total Papers", "Quota", "Candidate", "Votes", "Transfer", "Status", "Changed"] @@ -201,5 +213,6 @@ writeLog e = do recordLines = map (CSV.unParseRecord CSV.defaultSettings) records output = unlines (headerLine:recordLines) IO.writeFile logName output + return (e { getNextLogNum = 1 + getNextLogNum e }) -- cgit