Some bugs fixed, vote transfer upon exclusion still not working properly

1 files changed, 56 insertions, 43 deletions

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 })