summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/CSV.hs11
-rw-r--r--src/Counter.hs16
-rw-r--r--src/Election.hs186
-rw-r--r--src/main.hs4
4 files changed, 208 insertions, 9 deletions
diff --git a/src/CSV.hs b/src/CSV.hs
index d25a669..05fb472 100644
--- a/src/CSV.hs
+++ b/src/CSV.hs
@@ -5,6 +5,7 @@ module CSV(
specialChars,
defaultSettings,
+ unParseRecord,
parseRecord
) where
@@ -14,6 +15,7 @@ module CSV(
import Text.ParserCombinators.Parsec ( (<|>), (<?>) )
import qualified Text.ParserCombinators.Parsec as Parsec
import qualified Data.Char as Char
+import qualified Data.List as List
@@ -40,6 +42,15 @@ specialChars s = (separator s):(quote s):(escape s):[]
+unParseRecord :: Settings -> [String] -> String
+unParseRecord settings record =
+ let escFunc c = if (c == escape settings || c == quote settings) then (escape settings):c:[] else c:[]
+ escapeField s = ((quote settings) : (concatMap escFunc s)) ++ ((quote settings):[])
+ in List.intercalate [separator settings] (map escapeField record)
+
+
+
+
parseRecord :: Settings -> String -> Either Parsec.ParseError [String]
parseRecord settings input =
Parsec.parse (record settings) "error" input
diff --git a/src/Counter.hs b/src/Counter.hs
index 021ac45..317f96a 100644
--- a/src/Counter.hs
+++ b/src/Counter.hs
@@ -3,7 +3,9 @@ module Counter(
SenateCounter,
createSenateCounter,
- doCount
+ doCount,
+ getBallot,
+ getTotal
) where
@@ -74,3 +76,15 @@ doCount sen criteria = do
else return 0
+
+
+getBallot :: SenateCounter -> Typ.BelowLineBallot
+getBallot = ballotMap
+
+
+
+
+getTotal :: SenateCounter -> Int
+getTotal = numBallots
+
+
diff --git a/src/Election.hs b/src/Election.hs
index 082ee4c..ce2f574 100644
--- a/src/Election.hs
+++ b/src/Election.hs
@@ -8,24 +8,198 @@ module Election(
+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.List as List
+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 String
+data Election = Election
+ { getEntries :: [Entry]
+ , getCounter :: Sen.SenateCounter
+ , getLogDir :: FilePath
+ , getTotalPapers :: Int
+ , getQuota :: Int
+ , getNextLogNum :: Int
+ , getVacancies :: Int
+ , isDone :: Bool }
+data Entry = Entry
+ { getID :: Typ.CandidateID
+ , getVoteChange :: Int
+ , getTotalVotes :: Int
+ , getCritTrace :: [Trace]
+ , getStatus :: Status
+ , getChanged :: Bool }
+data Trace = Trace
+ { getCriteria :: Sen.Criteria
+ , getTransferVal :: Float }
+data Status = Running | Elected | Eliminated
+ deriving (Show, Eq)
-createElection :: FilePath -> Sen.SenateCounter -> IO Election
-createElection outDir counter = return (Election "testcode")
+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)
-doCount :: Election -> Int -> IO ()
-doCount election numToElect =
- putStrLn "run election here"
+
+
+
+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 candidate firstPrefs firstPrefs [trace] Running False)
+
+
+
+
+doCount :: Election -> IO ()
+doCount e = do
+ 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 >>=
+ electSomeone >>=
+ excludeSomeone >>=
+ checkNoQuota
+ 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
+ let running = filter ((== Running) . getStatus) (getEntries e)
+ if (getVacancies e == 0 || length running == 0)
+ then ET.left (e { isDone = True })
+ else ET.right e
+
+
+
+
+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)
+
+ newTransferValue = (fromIntegral (getTotalVotes electedEntry)) / (fromIntegral (getQuota e))
+ 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 })
+ else ET.right e
+
+
+
+
+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)
+
+ 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 })
+ else ET.right e
+
+
+
+
+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 changeList
+ return (entryTo
+ { getVoteChange = round totalVoteChange
+ , getTotalVotes = (getTotalVotes entryTo) + (round totalVoteChange)
+ , getCritTrace = newTraces
+ , getChanged = True })
+
+ Con.mapM (transferFunc from) to
+
+
+
+
+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 })
+ 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"]
+ 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
diff --git a/src/main.hs b/src/main.hs
index 6e68489..7b08e64 100644
--- a/src/main.hs
+++ b/src/main.hs
@@ -166,10 +166,10 @@ main = do
(aboveBallot, belowBallot) <- Cand.readCandidates candidateFile state
counter <- Sen.createSenateCounter preferenceFile aboveBallot belowBallot
Dir.createDirectory outputDir
- election <- Elt.createElection outputDir counter
+ election <- Elt.createElection outputDir counter numToElect
-- run the show
- Elt.doCount election numToElect
+ Elt.doCount election