diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Election.hs | 413 |
1 files changed, 309 insertions, 104 deletions
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) |