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
---
src/Election.hs | 413 ++++++++++++++++++++++++++++++++++++++++++--------------
1 file changed, 309 insertions(+), 104 deletions(-)
(limited to 'src')
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