From 8001d0fda7de000530d2c71fe8d507006036eccd Mon Sep 17 00:00:00 2001
From: Jed Barber <jjbarber@y7mail.com>
Date: Mon, 23 Jan 2017 17:11:32 +1100
Subject: Vote transferral fixed

---
 readme.txt      |   1 +
 src/Election.hs | 413 ++++++++++++++++++++++++++++++++++++++++++--------------
 2 files changed, 310 insertions(+), 104 deletions(-)

diff --git a/readme.txt b/readme.txt
index bcfec83..c3aff22 100644
--- a/readme.txt
+++ b/readme.txt
@@ -19,5 +19,6 @@ Aside from base, the cabal packages required to compile this program are:
     transformers
     parsec
     vector
+    containers
 
 
diff --git a/src/Election.hs b/src/Election.hs
index 7f8628c..d7c8bee 100644
--- a/src/Election.hs
+++ b/src/Election.hs
@@ -12,7 +12,9 @@ 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 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
@@ -22,22 +24,25 @@ import qualified CSV as CSV
 
 
 data Election = Election
-    { getEntries     :: [Entry]
-    , getCounter     :: Sen.SenateCounter
-    , getLogDir      :: FilePath
-    , getTotalPapers :: Int
-    , getQuota       :: Int
-    , getNextLogNum  :: Int
-    , getVacancies   :: Int
-    , isDone         :: Bool }
+    { getEntries       :: [Entry]
+    , getCounter       :: Sen.SenateCounter
+    , getLogDir        :: FilePath
+    , getTotalPapers   :: Int
+    , getQuota         :: Int
+    , getNextLogNum    :: Int
+    , getVacancies     :: Int
+    , getTransferQueue :: [Transfer]
+    , getNextToElect   :: Int
+    , isDone           :: Bool }
 
 data Entry = Entry
-    { getID         :: Typ.CandidateID
-    , getVoteChange :: Int
-    , getTotalVotes :: Int
-    , getCritTrace  :: [Trace]
-    , getStatus     :: Status
-    , getChanged    :: Bool }
+    { getID           :: Typ.CandidateID
+    , getVoteChange   :: Int
+    , getTotalVotes   :: Int
+    , getCritTrace    :: [Trace]
+    , getStatus       :: Status
+    , getChanged      :: Bool
+    , getOrderElected :: Maybe Int }
     deriving (Eq)
 
 data Trace = Trace
@@ -48,6 +53,15 @@ data Trace = Trace
 data Status = Running | Elected | Eliminated
     deriving (Show, Eq)
 
+data Transfer = Transfer
+    { getWhoFrom    :: Typ.CandidateID
+    , getVoteAmount :: Int
+    , 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)]
+
 
 
 
@@ -55,8 +69,25 @@ createElection :: FilePath -> Sen.SenateCounter -> Int -> IO Election
 createElection outDir counter numToElect = do
     entries <- mapM (candToEntry counter) (Sen.getBallot counter)
     let total = Sen.getTotal counter
-        quota = 1 + floor ((fromIntegral total) / (fromIntegral (numToElect + 1)))
-    return (Election entries counter outDir total quota 1 numToElect False)
+        quota = droopQuota total numToElect
+    return (Election
+        { getEntries       = entries
+        , getCounter       = counter
+        , getLogDir        = outDir
+        , getTotalPapers   = total
+        , getQuota         = quota
+        , getNextLogNum    = 1
+        , getVacancies     = numToElect
+        , getTransferQueue = []
+        , getNextToElect   = 1
+        , isDone           = False })
+
+
+
+
+droopQuota :: Int -> Int -> Int
+droopQuota votes seats =
+    1 + floor ((fromIntegral votes) / (fromIntegral (seats + 1)))
 
 
 
@@ -66,153 +97,327 @@ candToEntry counter candidate = do
     let criteria = [(1,candidate)]
         trace = Trace criteria 1
     firstPrefs <- Sen.doCount counter criteria
-    return (Entry candidate firstPrefs firstPrefs [trace] Running False)
+    return (Entry
+        { getID           = candidate
+        , getVoteChange   = firstPrefs
+        , getTotalVotes   = firstPrefs
+        , getCritTrace    = [trace]
+        , getStatus       = Running
+        , getChanged      = False
+        , getOrderElected = Nothing })
 
 
 
 
 doCount :: Election -> IO ()
 doCount e = do
-    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 $
-            checkDone e' >>=
-            electSomeone >>=
+    writeLog e
+    let e1 = e { getNextLogNum = 1 + getNextLogNum e }
+
+    Con.when (not (isDone e1)) $ do
+
+        --  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 $
+            clearChanges e1 >>=
+            electCandidates >>=
+            checkIfDone >>=
+            transferVotes >>=
             checkNoQuota >>=
             excludeSomeone
-    Con.when (not (isDone r)) $ doCount r
 
+        doCount r
 
 
 
-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 })
-        else ET.right e
 
+writeLog :: Election -> IO ()
+writeLog e = do
+    let logName = (getLogDir e) ++ "/" ++ (show (getNextLogNum e)) ++ ".csv"
 
+        header =
+            [ "Vacancies"
+            , "Total Papers"
+            , "Quota"
+            , "Candidate"
+            , "Votes"
+            , "Transfer"
+            , "Status"
+            , "Changed"
+            , "Order Elected" ]
+        static =
+            [ 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
+
+
+
+
+clearChanges :: Election -> ET.EitherT Election IO Election
+clearChanges e = do
+    let clear entry = entry
+            { getChanged = False
+            , getVoteChange = 0 }
+    ET.right (e { getEntries = map clear (getEntries e) })
 
 
-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)
 
 
+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
 
 
-electSomeone :: Election -> ET.EitherT Election IO Election
-electSomeone e = do
+
+
+--  needs to be modified to take into account ties
+doElectCandidate :: Election -> ET.EitherT Election IO Election
+doElectCandidate e = do
     let (running, notRunning) = List.partition ((== Running) . getStatus) (getEntries e)
-        electedEntry = List.maximumBy (\x y -> compare (getTotalVotes x) (getTotalVotes y)) running
+        electedEntry = List.maximumBy compareVotes running
         (beforeEntries, afterEntries) = 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) }
+
         revisedElectedEntry = electedEntry
             { getStatus = Elected
             , getChanged = True
-            , getTotalVotes = (getQuota e)
-            , getVoteChange = (getQuota e) - (getTotalVotes electedEntry) }
+            , getOrderElected = Just (getNextToElect e) }
+        allRevised = beforeEntries ++ [revisedElectedEntry] ++ afterEntries
 
     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 })
+        then ET.right (e
+            { getEntries = allRevised
+            , getTransferQueue = (getTransferQueue e) ++ [newTransfer]
+            , getNextToElect = 1 + getNextToElect e
+            , 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
 
 
 
 
-excludeSomeone :: Election -> ET.EitherT Election IO Election
-excludeSomeone e = do
-    let (running, notRunning) = List.partition ((== Running) . getStatus) (getEntries e)
-        excludedEntry = List.minimumBy (\x y -> compare (getTotalVotes x) (getTotalVotes y)) running
-        (beforeEntries, afterEntries) = partBeforeAfter excludedEntry (getEntries e)
+--  redistributing votes in STV is surprisingly complex
+transferVotes :: Election -> ET.EitherT Election IO Election
+transferVotes e =
+    if (length (getTransferQueue e) > 0)
+        then doVoteTransfer e
+        else ET.right e
 
-        revisedExcludedEntry = excludedEntry
-            { getStatus = Eliminated
-            , getChanged = True
-            , getTotalVotes = 0
-            , getVoteChange = -(getTotalVotes excludedEntry) }
 
-    if (getTotalVotes excludedEntry < getQuota e)
+
+
+doVoteTransfer :: Election -> ET.EitherT Election IO Election
+doVoteTransfer e = do
+    let (currentTransfer:remainingTransfers) = getTransferQueue e
+        fromEntry = Maybe.fromJust (List.find ((== getWhoFrom currentTransfer) . getID) (getEntries e))
+        (beforeEntries, afterEntries) = 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
+
+        revisedFromEntry = fromEntry
+            { getVoteChange = -(getVoteAmount currentTransfer)
+            , getTotalVotes = getTotalVotes fromEntry - (getVoteAmount currentTransfer)
+            , getCritTrace = [] }
+        allRevised = (map reviseFunc beforeEntries) ++ [revisedFromEntry] ++ (map reviseFunc afterEntries)
+
+    ET.left (e
+        { getEntries = allRevised
+        , getTransferQueue = remainingTransfers })
+
+
+
+
+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 noZeros = filter ((/= 0) . fst . head . snd) counted
+    return (Map.unionWith (++) transferMap (Map.fromList noZeros))
+
+
+
+
+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
-            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
+            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
 
 
-transferVotes :: Sen.SenateCounter -> Float -> Entry -> [Entry] -> IO [Entry]
-transferVotes counter value from to = do
-    let addToCriteria candID crit =
-            let maxRank = fst (List.maximumBy (\x y -> compare (fst x) (fst y)) crit)
-            in (maxRank + 1, candID):crit
-        addToTrace candID trace = trace
-            { getCriteria = addToCriteria candID (getCriteria trace)
-            , getTransferVal = value * (getTransferVal trace) }
 
-        transferFunc entryFrom entryTo = 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 (map floor changeList)
-            return (entryTo
-                { getVoteChange = totalVoteChange
-                , getTotalVotes = (getTotalVotes entryTo) + totalVoteChange
-                , getCritTrace = newTraces
-                , getChanged = True })
 
-    Con.mapM (transferFunc from) to
+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
     let (running, notRunning) = List.partition ((== Running) . getStatus) (getEntries e)
-        electedEntry = List.maximumBy (\x y -> compare (getTotalVotes x) (getTotalVotes y)) running
-        (beforeEntries, afterEntries) = partBeforeAfter electedEntry (getEntries e)
+        minimumEntry = List.minimumBy compareVotes running
+        (beforeEntries, afterEntries) = partBeforeAfter minimumEntry (getEntries e)
 
-        revisedElectedEntry = electedEntry
+        makeElect x = x
             { 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
+            , getChanged = True }
+        reviseFunc entry =
+            if ((getStatus entry == Running) && (entry /= minimumEntry))
+                then makeElect entry
+                else entry
+
+        revisedMinEntry =
+            if (length running <= getVacancies e)
+                then makeElect minimumEntry
+                else minimumEntry
+        allRevised = (map reviseFunc beforeEntries) ++ [revisedMinEntry] ++ (map reviseFunc afterEntries)
 
     if (length running <= getVacancies e + 1)
-        then ET.left (e { getEntries = revisedEntries, getVacancies = getVacancies e - 1 })
+        then ET.left (e
+            { getEntries = allRevised
+            , getVacancies = 0 })
         else ET.right e
 
 
 
 
-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"]
-        static = [show (getVacancies e), show (getTotalPapers e), show (getQuota e)]
-        dynFunc c = [getID c, show (getTotalVotes c), show (getVoteChange c), show (getStatus c), show (getChanged c)]
-        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
-    return (e { getNextLogNum = 1 + getNextLogNum e })
+--  needs to be modified to take into account ties
+excludeSomeone :: Election -> ET.EitherT Election IO Election
+excludeSomeone e = do
+    let (running, notRunning) = List.partition ((== Running) . getStatus) (getEntries e)
+        excludedEntry = List.minimumBy compareVotes running
+        (beforeEntries, afterEntries) = partBeforeAfter excludedEntry (getEntries e)
+
+        newTransfer = Transfer
+            { getWhoFrom = getID excludedEntry
+            , getVoteAmount = getTotalVotes excludedEntry
+            , getWhatToDist = getCritTrace excludedEntry }
+
+        revisedExcludedEntry = excludedEntry
+            { getStatus = Eliminated
+            , getChanged = True }
+        allRevised = beforeEntries ++ [revisedExcludedEntry] ++ afterEntries
+
+    if (getTotalVotes excludedEntry < getQuota e)
+        then ET.left (e
+            { getEntries = allRevised
+            , getTransferQueue = (getTransferQueue e) ++ [newTransfer] })
+        else ET.right e
+
+
+
+
+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)
+
+
+
+
+compareVotes :: Entry -> Entry -> Ordering
+compareVotes x y = compare (getTotalVotes x) (getTotalVotes y)
 
 
-- 
cgit