module Election( Election, createElection, doCount ) where 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 import qualified CSV as CSV data Election = Election { 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 , getOrderElected :: Maybe Int } deriving (Eq) data Trace = Trace { getCriteria :: Sen.Criteria , getTransferVal :: Float } deriving (Eq) 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)] 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 = 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))) candToEntry :: Sen.SenateCounter -> Typ.CandidateID -> IO Entry candToEntry counter candidate = do let criteria = [(1,candidate)] trace = Trace criteria 1 firstPrefs <- Sen.doCount counter criteria return (Entry { getID = candidate , getVoteChange = firstPrefs , getTotalVotes = firstPrefs , getCritTrace = [trace] , getStatus = Running , getChanged = False , getOrderElected = Nothing }) doCount :: Election -> IO () doCount e = do 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 doCount r 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) }) 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 -- 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 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 , getOrderElected = Just (getNextToElect e) } allRevised = beforeEntries ++ [revisedElectedEntry] ++ afterEntries if (getTotalVotes electedEntry >= getQuota e) 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 -- 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 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 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 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) minimumEntry = List.minimumBy compareVotes running (beforeEntries, afterEntries) = partBeforeAfter minimumEntry (getEntries e) makeElect x = x { getStatus = Elected , 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 = allRevised , getVacancies = 0 }) else ET.right 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)