summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/CSV.hs112
-rw-r--r--src/Candidate.hs101
-rw-r--r--src/Counter.hs163
-rw-r--r--src/Election.hs404
-rw-r--r--src/File.hs42
-rw-r--r--src/Miscellaneous.hs87
-rw-r--r--src/Preferences.hs128
-rw-r--r--src/Storage.hs83
-rw-r--r--src/main.hs211
9 files changed, 0 insertions, 1331 deletions
diff --git a/src/CSV.hs b/src/CSV.hs
deleted file mode 100644
index b4850b4..0000000
--- a/src/CSV.hs
+++ /dev/null
@@ -1,112 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-
-module CSV(
- Settings(..),
-
- specialChars,
- defaultSettings,
- unParseRecord,
- parseRecord
- ) where
-
-
-
-
--- This source is licensed under Creative Commons CC0 v1.0.
-
--- To read the full text, see license.txt in the main directory of this repository
--- or go to https://creativecommons.org/publicdomain/zero/1.0/legalcode.txt
-
--- For a human readable summary, go to https://creativecommons.org/publicdomain/zero/1.0/
-
-
-
-
-import Text.ParserCombinators.Parsec ( (<|>), (<?>) )
-import qualified Text.ParserCombinators.Parsec as Parsec
-import qualified Data.Char as Char
-import qualified Data.List as List
-
-
-
-
-data Settings = Settings
- { separator :: Char
- , quote :: Char
- , escape :: Char }
-
-
-
-
-defaultSettings = Settings
- { separator = ','
- , quote = '\"'
- , escape = '\\' }
-
-
-
-
-specialChars :: Settings -> String
-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 =
- if ((escape settings) `elem` s || (quote settings) `elem` s || (separator settings) `elem` s)
- then ((quote settings) : (concatMap escFunc s)) ++ ((quote settings):[])
- else s
- in List.intercalate [separator settings] (map escapeField record)
-
-
-
-
-parseRecord :: Settings -> String -> Either Parsec.ParseError [String]
-parseRecord settings input =
- Parsec.parse (record settings) "error" input
-
-
-record s = do
- f <- (field s) `Parsec.sepBy` (Parsec.char (separator s))
- Parsec.optional eol
- Parsec.eof
- return f
-
-
-field s =
- Parsec.many (Parsec.try (quoted s) <|> Parsec.many1 (fieldChar s)) >>=
- return . foldl1 (++)
-
-
-quoted s =
- Parsec.between
- (Parsec.char (quote s))
- (Parsec.char (quote s))
- (Parsec.many (quotedChar s))
-
-
-fieldChar s = allExcept s (specialChars s)
-
-
-quotedChar s = allExcept s [quote s]
-
-
-allExcept s c =
- Parsec.try (escapeChar s) <|>
- Parsec.satisfy (\x -> (not (Char.isControl x)) && (x `notElem` c))
-
-
-escapeChar s = do
- Parsec.char (escape s)
- Parsec.oneOf (specialChars s)
-
-
-eol = Parsec.try (Parsec.string "\r\n")
- <|> Parsec.try (Parsec.string "\r")
- <|> Parsec.try (Parsec.string "\n")
- <?> "end of line"
-
-
diff --git a/src/Candidate.hs b/src/Candidate.hs
deleted file mode 100644
index e92fd05..0000000
--- a/src/Candidate.hs
+++ /dev/null
@@ -1,101 +0,0 @@
-module Candidate(
- Ranking,
- Position,
- CandidateID,
- AboveLineBallot,
- BelowLineBallot,
-
- readCandidates
- ) where
-
-
-
-
--- This source is licensed under Creative Commons CC0 v1.0.
-
--- To read the full text, see license.txt in the main directory of this repository
--- or go to https://creativecommons.org/publicdomain/zero/1.0/legalcode.txt
-
--- For a human readable summary, go to https://creativecommons.org/publicdomain/zero/1.0/
-
-
-
-
-import qualified CSV as CSV
-import qualified Miscellaneous as Misc
-import qualified System.IO as IO
-import qualified Data.List as List
-import qualified Data.Either.Unwrap as Either
-import qualified Data.Maybe as Maybe
-
-
-
-
-type Ranking = Int
-type Position = Int
-type CandidateID = String
-
--- positions in the uppermap list correspond to the boxes above the line,
--- and the lists of candidateIDs are the boxes below the line
-type AboveLineBallot = [[Position]]
-
--- a list of candidates in the order of how they were placed below the line
-type BelowLineBallot = [CandidateID]
-
-
-
-
-readCandidates :: FilePath -> String -> IO (AboveLineBallot, BelowLineBallot)
-readCandidates inputFile state = do
- h <- IO.openFile inputFile IO.ReadMode
- e <- IO.hIsEOF h
-
- let readFunc r c = if c then return r else do
- t0 <- IO.hGetLine h
- let t1 = CSV.parseRecord CSV.defaultSettings t0
- t2 = Misc.selectFrom [5,6,7,8,9] [(2,"S"),(3,state)] (Either.fromRight t1)
- t3 = Maybe.fromJust t2
- tx <- IO.hIsEOF h
- if (Either.isRight t1) && (Maybe.isJust t2)
- then readFunc (t3:r) tx
- else readFunc r tx
- raw <- readFunc [] e >>= return . (List.sortBy candRecComp)
-
- IO.hClose h
- return (makeAboveBallot raw, makeBelowBallot raw)
-
-
-
-
--- assumes there are at least two items in each list
--- see the above function for the things it gets applied on for why
-candRecComp :: [String] -> [String] -> Ordering
-candRecComp a b =
- let lenResult = compare (length (head a)) (length (head b))
- in if (lenResult == EQ)
- then compare (take 2 a) (take 2 b)
- else lenResult
-
-
-
-
--- very hacky, pls revise
-makeAboveBallot :: [[String]] -> AboveLineBallot
-makeAboveBallot input =
- let comp x y = (head x) == (head y)
- grouped = List.groupBy comp (filter ((/= "UG") . head) input)
- numFunc n r t =
- if (t == [])
- then r
- else numFunc (n + (length (head t))) (r ++ [(map fst (zip [n, n+1 ..] (head t)))]) (tail t)
- in numFunc (fromIntegral 1) [] grouped
-
-
-
-
-makeBelowBallot :: [[String]] -> BelowLineBallot
-makeBelowBallot input =
- let f (_:_:c:d:e:[]) = d ++ " " ++ c ++ ", " ++ e
- in map f input
-
-
diff --git a/src/Counter.hs b/src/Counter.hs
deleted file mode 100644
index bf2ee7e..0000000
--- a/src/Counter.hs
+++ /dev/null
@@ -1,163 +0,0 @@
-module Counter(
- SenateCounter,
- Criteria,
-
- createSenateCounter,
- doCount,
- getBallot,
- getTotal,
-
- matchID,
- matchList
- ) where
-
-
-
-
--- This source is licensed under Creative Commons CC0 v1.0.
-
--- To read the full text, see license.txt in the main directory of this repository
--- or go to https://creativecommons.org/publicdomain/zero/1.0/legalcode.txt
-
--- For a human readable summary, go to https://creativecommons.org/publicdomain/zero/1.0/
-
-
-
-
-import qualified Candidate as Typ
-import qualified Preferences as Pref
-import qualified CSV as CSV
-import qualified Storage as Vec
-import qualified System.IO as IO
-import qualified File as File
-import qualified Control.Monad as Con
-import qualified Data.Either.Unwrap as Either
-import qualified Data.Maybe as Maybe
-import qualified Data.List as List
-import Data.Array ( (!) )
-import qualified Data.Array as Arr
-
-
-
-
-data SenateCounter = SenateCounter
- { prefData :: Vec.Store
- , ballotMap :: Typ.BelowLineBallot
- , numBallots :: Int }
-
-
-
-
-type Criteria = [Either Typ.CandidateID [Typ.CandidateID]]
-
-
-
-
-createSenateCounter :: FilePath -> Typ.AboveLineBallot -> Typ.BelowLineBallot -> IO SenateCounter
-createSenateCounter f a b = do
- numLines <- File.countLines f
- prefStore <- Vec.createStore numLines (length b)
-
- h <- IO.openFile f IO.ReadMode
- let readFunc n p = if (n > numLines) then return p else do
- t0 <- IO.hGetLine h
- let prefs = parseRawLine a b t0
- result = Maybe.fromJust prefs
- if (Maybe.isJust prefs)
- then Vec.setPrefs prefStore (p + 1) result >> readFunc (n + 1) (p + 1)
- else readFunc (n + 1) p
- p <- readFunc 1 0
- IO.hClose h
-
- return (SenateCounter
- { prefData = prefStore
- , ballotMap = b
- , numBallots = p })
-
-
-
-
-parseRawLine :: Typ.AboveLineBallot -> Typ.BelowLineBallot -> String -> Maybe [Pref.Preference]
-parseRawLine a b input =
- let t1 = CSV.parseRecord CSV.defaultSettings (input ++ "\n")
- t2 = Maybe.listToMaybe . reverse . Either.fromRight $ t1
- t3 = Pref.parsePreferences (length a) (length b) (Maybe.fromJust t2)
- t4 = Pref.normalise a b (Either.fromRight t3)
- in if (Either.isRight t1 && Maybe.isJust t2 && Either.isRight t3)
- then t4
- else Nothing
-
-
-
-
-doCount :: SenateCounter -> Criteria -> IO Int
-doCount sen criteria = do
- let checkList = map (toInternal (ballotMap sen)) criteria
- upperBound = length checkList
- checkArray = Arr.listArray (1,upperBound) checkList
-
- testFunc bal check rank = if (check > upperBound) then return True else do
- case (checkArray ! check) of
- Left x -> do
- r <- Vec.checkPref (prefData sen) bal (x,rank)
- if r
- then testFunc bal (check + 1) (rank + 1)
- else return False
- Right xs -> do
- rs <- mapM (\p -> Vec.checkPref (prefData sen) bal (p,rank)) xs
- if (or rs)
- then testFunc bal check (rank + 1)
- else testFunc bal (check + 1) rank
-
- tailFunc n p = if (n > numBallots sen) then return p else do
- r <- testFunc n 1 1
- if r then tailFunc (n + 1) (p + 1) else tailFunc (n + 1) p
-
- if (all (isValid (ballotMap sen)) criteria)
- then tailFunc 1 0
- else return 0
-
-
-
-
-toInternal :: Typ.BelowLineBallot -> Either Typ.CandidateID [Typ.CandidateID] -> Either Typ.Position (Arr.Array Int Typ.Position)
-toInternal ballot (Left c) =
- let r = Maybe.fromJust (List.elemIndex c ballot)
- in Left (r + 1)
-toInternal ballot (Right cs) =
- let f x = Maybe.fromJust (List.elemIndex x ballot)
- r = map ((+ 1) . f) cs
- in Right (Arr.listArray (1,length r) r)
-
-
-
-
-isValid :: Typ.BelowLineBallot -> Either Typ.CandidateID [Typ.CandidateID] -> Bool
-isValid ballot (Left x) = x `elem` ballot
-isValid ballot (Right xs) = all (`elem` ballot) xs
-
-
-
-
-getBallot :: SenateCounter -> Typ.BelowLineBallot
-getBallot = ballotMap
-
-
-
-
-getTotal :: SenateCounter -> Int
-getTotal = numBallots
-
-
-
-
-matchID :: Typ.CandidateID -> Either Typ.CandidateID [Typ.CandidateID]
-matchID = Left
-
-
-
-
-matchList :: [Typ.CandidateID] -> Either Typ.CandidateID [Typ.CandidateID]
-matchList = Right
-
-
diff --git a/src/Election.hs b/src/Election.hs
deleted file mode 100644
index f3b504e..0000000
--- a/src/Election.hs
+++ /dev/null
@@ -1,404 +0,0 @@
-module Election(
- Election,
-
- createElection,
- doCount
- ) where
-
-
-
-
--- This source is licensed under Creative Commons CC0 v1.0.
-
--- To read the full text, see license.txt in the main directory of this repository
--- or go to https://creativecommons.org/publicdomain/zero/1.0/legalcode.txt
-
--- For a human readable summary, go to https://creativecommons.org/publicdomain/zero/1.0/
-
-
-
-
-import qualified System.IO as IO
-import qualified System.Exit as Ex
-import qualified Control.Monad as Con
-import qualified Control.Monad.Trans.Either as ET
-import qualified Control.Monad.IO.Class as MIO
-import Data.List ( (\\) )
-import qualified Data.List as List
-import qualified Data.Maybe as Maybe
-import qualified Data.Either.Unwrap as Either
-import Data.Ratio ( (%) )
-import qualified Counter as Sen
-import qualified Candidate as Typ
-import qualified CSV as CSV
-import Miscellaneous ( (?) )
-import qualified Miscellaneous as Misc
-
-
-
-
-data Election = Election
- { getEntries :: [Entry]
- , getCounter :: Sen.SenateCounter
- , getLogDir :: FilePath
- , getTotalPapers :: Int
- , getQuota :: Int
- , getMainLog :: String
- , getNextLogNum :: Int
- , getSeats :: Int
- , getVacancies :: Int
- , getTransferQueue :: [Transfer]
- , getNextToElect :: Int
- , isDone :: Bool
- , isVerbose :: 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 :: Rational }
- deriving (Eq)
-
-data Status = Running | Elected | Eliminated
- deriving (Show, Eq)
-
-data Transfer = Transfer
- { getWhoFrom :: Typ.CandidateID
- , getVoteAmount :: Int
- , getNewValue :: Rational
- , getWhatToDist :: [Trace] }
- deriving (Eq)
-
-
-
-
-createElection :: FilePath -> FilePath -> Sen.SenateCounter -> Int -> Bool -> IO Election
-createElection outDir mainLog counter numToElect verbosity = do
- entries <- mapM (candToEntry counter) (Sen.getBallot counter)
- return (Election
- { getEntries = entries
- , getCounter = counter
- , getLogDir = outDir
- , getTotalPapers = Sen.getTotal counter
- , getQuota = droopQuota (Sen.getTotal counter) numToElect
- , getMainLog = mainLog
- , getNextLogNum = 1
- , getSeats = numToElect
- , getVacancies = numToElect
- , getTransferQueue = []
- , getNextToElect = 1
- , isDone = False
- , isVerbose = verbosity })
-
-
-
-
-droopQuota :: Int -> Int -> Int
-droopQuota votes seats =
- 1 + floor ((fromIntegral votes) / (fromIntegral (seats + 1)))
-
-
-
-
-compareVotes :: Entry -> Entry -> Ordering
-compareVotes x y = compare (getTotalVotes x) (getTotalVotes y)
-
-
-
-
-candToEntry :: Sen.SenateCounter -> Typ.CandidateID -> IO Entry
-candToEntry counter candidate = do
- let criteria = [Sen.matchID 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 =
- Con.when (not (isDone e)) $ do
- writeLog e
- let e1 = e { getNextLogNum = 1 + getNextLogNum e }
- let e2 = e1 { getEntries = map clearChange (getEntries e1) }
-
- -- 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 $
- electCandidates e2 >>=
- checkIfDone >>=
- transferVotes >>=
- checkNoQuota >>=
- excludeCandidates
-
- -- this should never happen unless there's a bug somewhere
- Con.when (getEntries e2 == getEntries r && getTransferQueue e2 == getTransferQueue r && not (isDone r)) $
- Ex.die "Infinite loop detected in election counting"
-
- doCount r
-
-
-
-
-writeLog :: Election -> IO ()
-writeLog e = do
- let logName = (getLogDir e) ++ "/" ++ (show (getNextLogNum e)) ++ ".csv"
-
- header =
- [ "Seats"
- , "Vacancies"
- , "Total Papers"
- , "Quota"
- , "Candidate"
- , "Votes"
- , "Transfer"
- , "Status"
- , "Changed"
- , "Order Elected" ]
- static =
- [ show (getSeats e)
- , 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
-
-
-
-
-clearChange :: Entry -> Entry
-clearChange entry = entry
- { getChanged = False
- , getVoteChange = 0 }
-
-
-
-
-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
--- may be prudent to put this just in the IO monad instead of EitherT
-doElectCandidate :: Election -> ET.EitherT Election IO Election
-doElectCandidate e = do
- let running = filter ((== Running) . getStatus) (getEntries e)
- electedEntry = List.maximumBy compareVotes running
- (beforeEntries, afterEntries) = Misc.partBeforeAfter electedEntry (getEntries e)
-
- newTransfer = Transfer
- { getWhoFrom = getID electedEntry
- , getVoteAmount = getTotalVotes electedEntry - getQuota e
- , getNewValue = (fromIntegral (getTotalVotes electedEntry - getQuota e)) %
- (fromIntegral (getTotalVotes electedEntry))
- , getWhatToDist = getCritTrace electedEntry }
-
- revisedElectedEntry = electedEntry
- { getStatus = Elected
- , getChanged = True
- , getOrderElected = Just (getNextToElect e) }
- allRevised = beforeEntries ++ [revisedElectedEntry] ++ afterEntries
-
- if (getTotalVotes electedEntry >= getQuota e)
- then do
- let logmsg = show (getID electedEntry) ++ " elected at logfile #" ++ show (getNextLogNum e)
- MIO.liftIO $ IO.appendFile (getMainLog e) (logmsg ++ "\n")
- MIO.liftIO $ Con.when (isVerbose e) (IO.hPutStrLn IO.stderr logmsg)
- ET.right (e
- { getEntries = allRevised
- , getTransferQueue = (getTransferQueue e) ++ [newTransfer]
- , getNextToElect = getNextToElect e + 1
- , 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 annoying as hell
-transferVotes :: Election -> ET.EitherT Election IO Election
-transferVotes e =
- if (length (getTransferQueue e) > 0)
- then (MIO.liftIO $ doVoteTransfer e) >>= ET.left
- else ET.right e
-
-
-
-
-doVoteTransfer :: Election -> IO Election
-doVoteTransfer e = do
- let (currentTransfer:remainingTransfers) = getTransferQueue e
- fromEntry = Maybe.fromJust (List.find ((== getWhoFrom currentTransfer) . getID) (getEntries e))
- (beforeEntries, afterEntries) = Misc.partBeforeAfter fromEntry (getEntries e)
- notRunningIDs = map getID (filter ((/= Running) . getStatus) (getEntries e))
-
- reviseTrace candID trace = trace
- { getCriteria = getCriteria trace ++ [Sen.matchList notRunningIDs, Sen.matchID candID]
- , getTransferVal = getTransferVal trace * getNewValue currentTransfer }
-
- reviseFunc entry = do
- let newTraces = map (reviseTrace (getID entry)) (getWhatToDist currentTransfer)
- rawVoteChanges <- mapM (Sen.doCount (getCounter e)) (map getCriteria newTraces)
- let tracesAndChanges = zip (map fromIntegral rawVoteChanges) newTraces
- adjustedChanges = map (\(r,t) -> (floor (r * getTransferVal t), t)) tracesAndChanges
- filteredChanges = filter ((/= 0) . fst) adjustedChanges
- totalVoteChange = sum (map fst filteredChanges)
- addedTraces = map snd filteredChanges
- return (entry
- { getVoteChange = totalVoteChange
- , getTotalVotes = getTotalVotes entry + totalVoteChange
- , getCritTrace = getCritTrace entry ++ addedTraces })
-
- revisedFromEntry = fromEntry
- { getVoteChange = -(getVoteAmount currentTransfer)
- , getTotalVotes = getTotalVotes fromEntry - getVoteAmount currentTransfer
- , getCritTrace = getCritTrace fromEntry \\ getWhatToDist currentTransfer }
- revisedBeforeEntries <- mapM reviseFunc beforeEntries
- revisedAfterEntries <- mapM reviseFunc afterEntries
- let allRevised = revisedBeforeEntries ++ [revisedFromEntry] ++ revisedAfterEntries
-
- return (e
- { getEntries = allRevised
- , getTransferQueue = remainingTransfers })
-
-
-
-
--- needs to be modified to take into account ties
-checkNoQuota :: Election -> ET.EitherT Election IO Election
-checkNoQuota e = do
- let running = filter ((== Running) . getStatus) (getEntries e)
- sorted = reverse (List.sortBy compareVotes running)
-
- if (length running <= getVacancies e + 1)
- then do
- let makeElect entry n = do
- let logmsg = show (getID entry) ++ " elected at logfile #" ++ show (getNextLogNum e)
- IO.appendFile (getMainLog e) (logmsg ++ "\n")
- Con.when (isVerbose e) (IO.hPutStrLn IO.stderr logmsg)
- return (entry
- { getStatus = Elected
- , getChanged = True
- , getOrderElected = Just n })
-
- reviseFunc input output toChange n =
- if (length input == 0)
- then return (reverse output)
- else if ((head input) `elem` toChange)
- then do
- r <- makeElect (head input) n
- reviseFunc (tail input) (r:output) toChange (n + 1)
- else reviseFunc (tail input) ((head input):output) toChange n
-
- toChange = if (length running <= getVacancies e) then sorted else init sorted
-
- allRevised <- MIO.liftIO $ reviseFunc (getEntries e) [] toChange (getNextToElect e)
-
- ET.left (e
- { getEntries = allRevised
- , getVacancies = 0
- , getNextToElect = getNextToElect e + length toChange })
- else ET.right e
-
-
-
-
-excludeCandidates :: Election -> ET.EitherT Election IO Election
-excludeCandidates e = do
- let running = filter ((== Running) . getStatus) (getEntries e)
- sorted = reverse (List.sortBy compareVotes running)
- appliedBreakpoint = getQuota e - getTotalVotes (head sorted)
-
- excludeLoop n v e = do
- (i,r) <- MIO.liftIO $ excludeSomeone e
- let v1 = v + i
- n1 = n + 1
- if (v1 > appliedBreakpoint)
- then if (n > 0)
- then do
- MIO.liftIO $ Con.when (n > 1) $ do
- let logmsg = "Bulk exclusion of " ++ show n ++
- " candidates at logfile #" ++ show (getNextLogNum e)
- IO.appendFile (getMainLog e) (logmsg ++ "\n")
- Con.when (isVerbose e) (IO.hPutStrLn IO.stderr logmsg)
- ET.left e
- else ET.left r
- else excludeLoop n1 v1 r
-
- if (length running > 0 && all (< getQuota e) (map getTotalVotes running))
- then excludeLoop 0 0 e
- else ET.right e
-
-
-
-
--- needs to be modified to take into account ties
--- this function is still in the IO monad in case I want to log something in verbose mode later
-excludeSomeone :: Election -> IO (Int, Election)
-excludeSomeone e = do
- let running = filter ((== Running) . getStatus) (getEntries e)
- excludedEntry = List.minimumBy compareVotes running
- (beforeEntries, afterEntries) = Misc.partBeforeAfter excludedEntry (getEntries e)
-
- newTransfer = Transfer
- { getWhoFrom = getID excludedEntry
- , getVoteAmount = getTotalVotes excludedEntry
- , getNewValue = 1
- , getWhatToDist = getCritTrace excludedEntry }
-
- revisedExcludedEntry = excludedEntry
- { getStatus = Eliminated
- , getChanged = True }
- allRevised = beforeEntries ++ [revisedExcludedEntry] ++ afterEntries
-
- return (getTotalVotes excludedEntry, e
- { getEntries = allRevised
- , getTransferQueue = (getTransferQueue e) ++ [newTransfer] })
-
-
diff --git a/src/File.hs b/src/File.hs
deleted file mode 100644
index 5e4dce8..0000000
--- a/src/File.hs
+++ /dev/null
@@ -1,42 +0,0 @@
-module File(
- countLines
- ) where
-
-
-
-
--- This source is licensed under Creative Commons CC0 v1.0.
-
--- To read the full text, see license.txt in the main directory of this repository
--- or go to https://creativecommons.org/publicdomain/zero/1.0/legalcode.txt
-
--- For a human readable summary, go to https://creativecommons.org/publicdomain/zero/1.0/
-
-
-
-
-import qualified System.IO as IO
-
-
-
-
-countLines :: FilePath -> IO Int
-countLines f = do
- h <- IO.openFile f IO.ReadMode
- e <- IO.hIsEOF h
- if e
- then IO.hClose h >> return 0
- else countLinesTail h 0
-
-
-
-
-countLinesTail :: IO.Handle -> Int -> IO Int
-countLinesTail h n = do
- t <- IO.hGetLine h
- e <- IO.hIsEOF h
- if e
- then IO.hClose h >> return (n + 1)
- else countLinesTail h (n + 1)
-
-
diff --git a/src/Miscellaneous.hs b/src/Miscellaneous.hs
deleted file mode 100644
index 8081c93..0000000
--- a/src/Miscellaneous.hs
+++ /dev/null
@@ -1,87 +0,0 @@
-module Miscellaneous(
- if',
- (?),
- (.:),
- selectFrom,
- readMaybe,
- partBeforeAfter
- ) where
-
-
-
-
--- This source is licensed under Creative Commons CC0 v1.0.
-
--- To read the full text, see license.txt in the main directory of this repository
--- or go to https://creativecommons.org/publicdomain/zero/1.0/legalcode.txt
-
--- For a human readable summary, go to https://creativecommons.org/publicdomain/zero/1.0/
-
-
-
-
-import qualified Control.Monad as Con
-import qualified Data.List as List
-import qualified Data.Maybe as Maybe
-
-
-
-
-if' :: Bool -> t -> t -> t
-if' a b c = if a then b else c
-
-
-
-
-infixr 1 ?
-(?) :: Bool -> t -> t -> t
-(?) = if'
-
-
-
-
--- with this, I have truly gone dotty
-infixr 9 .:
-(.:) :: (a -> b) -> (c -> d -> a) -> c -> d -> b
-(.:) = (.).(.)
-
-
-
-
--- kinda functions like poor man's sql
--- first argument is the indices of the items you want in the results
--- second argument is index-item pairs to dictate what records are acceptable to select from
--- third argument is the list of items that makes up the record under consideration
--- then if the record was deemed acceptable you get the bits you wanted
--- (note that all indices start from 1)
-selectFrom :: (Num t, Eq t, Eq a, Enum t) => [t] -> [(t,a)] -> [a] -> Maybe [a]
-selectFrom pick has from =
- let foldFunc r i =
- let check = List.lookup (fst i) has
- in if (Maybe.isNothing check || Maybe.fromJust check == snd i)
- then if (List.elem (fst i) pick)
- then Just (r ++ [snd i])
- else Just r
- else Nothing
- in Con.foldM foldFunc [] (zip [1,2..] from)
-
-
-
-
-readMaybe :: Read a => String -> Maybe a
-readMaybe s =
- case reads s of
- [(val, "")] -> Just val
- _ -> Nothing
-
-
-
-
-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)
-
-
diff --git a/src/Preferences.hs b/src/Preferences.hs
deleted file mode 100644
index abdd89d..0000000
--- a/src/Preferences.hs
+++ /dev/null
@@ -1,128 +0,0 @@
-module Preferences(
- Preference,
- FullPreferences,
-
- normalise,
- parsePreferences
- ) where
-
-
-
-
--- This source is licensed under Creative Commons CC0 v1.0.
-
--- To read the full text, see license.txt in the main directory of this repository
--- or go to https://creativecommons.org/publicdomain/zero/1.0/legalcode.txt
-
--- For a human readable summary, go to https://creativecommons.org/publicdomain/zero/1.0/
-
-
-
-
-import qualified Candidate as Typ
-import qualified Text.ParserCombinators.Parsec as Parsec
-import qualified Data.List as List
-
-
-
-
-type Preference = (Typ.Position,Typ.Ranking)
-type FullPreferences = ([Preference],[Preference])
-
-
-
-
-minAboveTheLine = 1
-minBelowTheLine = 6
-
-
-
-
--- converts a set of above+below-the-line preferences to just formal below-the-line
-normalise :: Typ.AboveLineBallot -> Typ.BelowLineBallot -> FullPreferences -> Maybe [Preference]
-normalise a b f =
- let na = extractFormal (fst f)
- nb = extractFormal (snd f)
- in if (isValidFormal minBelowTheLine b nb)
- then Just nb
- else if (isValidFormal minAboveTheLine a na)
- then Just (fromAboveToBelow a na)
- else Nothing
-
-
-
-
-extractFormal :: [Preference] -> [Preference]
-extractFormal pref =
- let formTail n r p =
- let (matches,rest) = List.partition ((== n) . snd) p
- in if (p == [] || (length matches) /= 1)
- then r
- else formTail (n + 1) ((head matches):r) rest
- in formTail 1 [] pref
-
-
-
-
-isValidFormal :: Foldable t => Int -> t a -> [Preference] -> Bool
-isValidFormal minLimit ballot pref =
- (length pref >= minLimit) || (length pref == length ballot)
-
-
-
-
--- inefficient?
-fromAboveToBelow :: Typ.AboveLineBallot -> [Preference] -> [Preference]
-fromAboveToBelow a p =
- let sortedByRanking = List.sortBy (\x y -> compare (snd x) (snd y)) p
- tailFunc n bp ap =
- if (ap == [])
- then bp
- else let place = fst (head ap)
- newPrefs = zip (a !! (place - 1)) [n, n+1 ..]
- in tailFunc (n + length newPrefs) (bp ++ newPrefs) (tail ap)
- in tailFunc 1 [] sortedByRanking
-
-
-
-
--- the two int arguments are the number of boxes above the line and the number
--- of boxes below the line respectively
-parsePreferences :: Int -> Int -> String -> Either Parsec.ParseError FullPreferences
-parsePreferences aboveBoxes belowBoxes input =
- Parsec.parse (preference aboveBoxes belowBoxes) "error" input
-
-
-preference a b = do
- x <- Parsec.count a rank
- y <- Parsec.count b rank
- Parsec.eof
- let xr = map (read :: String -> Typ.Ranking) x
- yr = map (read :: String -> Typ.Ranking) y
- xp = (filter ((> 0) . snd) (zip [1,2..] xr))
- yp = (filter ((> 0) . snd) (zip [1,2..] yr))
- return (xp,yp)
-
-
-rank = do
- n <- Parsec.choice [normalRank, weirdRank, nullRank]
- Parsec.choice [Parsec.char ',' >> return (), Parsec.eof]
- return n
-
-
-normalRank = do
- n <- Parsec.oneOf "123456789"
- ns <- Parsec.many Parsec.digit
- return (n:ns)
-
-
--- these symbols are taken to mean '1' according to AEC guidelines
-weirdRank = do
- Parsec.choice [Parsec.char '/', Parsec.char '*']
- return "1"
-
-
--- these ranks are standins that will be filtered out
-nullRank = return "0"
-
-
diff --git a/src/Storage.hs b/src/Storage.hs
deleted file mode 100644
index 2c0504d..0000000
--- a/src/Storage.hs
+++ /dev/null
@@ -1,83 +0,0 @@
-module Storage(
- Store,
-
- createStore,
- setPref,
- setPrefs,
- getPrefs,
- checkPref
- ) where
-
-
-
-
--- This source is licensed under Creative Commons CC0 v1.0.
-
--- To read the full text, see license.txt in the main directory of this repository
--- or go to https://creativecommons.org/publicdomain/zero/1.0/legalcode.txt
-
--- For a human readable summary, go to https://creativecommons.org/publicdomain/zero/1.0/
-
-
-
-
-import Data.Int ( Int8 )
-import Preferences ( Preference )
-import qualified Data.Vector.Unboxed.Mutable as Vec
-
-
-
-
-data Store = Store
- { getPointer :: Vec.IOVector Int8
- , getBallotSize :: Int }
-
-
-
-
-createStore :: Int -> Int -> IO Store
-createStore maxCapacity ballotSize = do
- v <- Vec.replicate (maxCapacity * ballotSize) 0
- return (Store
- { getPointer = v
- , getBallotSize = ballotSize })
-
-
-
-
-setPref :: Store -> Int -> Preference -> IO ()
-setPref prefStore ballot (position,rank) = do
- let place = (ballot - 1) * (getBallotSize prefStore) + (position - 1)
- Vec.write (getPointer prefStore) place (fromIntegral rank)
-
-
-
-
-setPrefs :: Store -> Int -> [Preference] -> IO ()
-setPrefs prefStore ballot prefList = do
- let blank = take (getBallotSize prefStore) (zip [1..] (cycle [0]))
- mapM_ (setPref prefStore ballot) blank
- mapM_ (setPref prefStore ballot) prefList
-
-
-
-
-getPrefs :: Store -> Int -> IO [Preference]
-getPrefs prefStore ballot = do
- let startPlace = (ballot - 1) * (getBallotSize prefStore)
- endPlace = startPlace + (getBallotSize prefStore) - 1
- base = [startPlace .. endPlace]
- r0 <- mapM (Vec.read (getPointer prefStore)) base
- let r1 = zip [1..] (map fromIntegral r0)
- return (filter ((/= 0) . snd) r1)
-
-
-
-
-checkPref :: Store -> Int -> Preference -> IO Bool
-checkPref prefStore ballot (position,rank) = do
- let place = (ballot - 1) * (getBallotSize prefStore) + (position - 1)
- value <- Vec.read (getPointer prefStore) place
- return (value == fromIntegral rank)
-
-
diff --git a/src/main.hs b/src/main.hs
deleted file mode 100644
index c66dc6e..0000000
--- a/src/main.hs
+++ /dev/null
@@ -1,211 +0,0 @@
-
-
-
-
--- This source is licensed under Creative Commons CC0 v1.0.
-
--- To read the full text, see license.txt in the main directory of this repository
--- or go to https://creativecommons.org/publicdomain/zero/1.0/legalcode.txt
-
--- For a human readable summary, go to https://creativecommons.org/publicdomain/zero/1.0/
-
-
-
-
-import qualified System.Environment as Env
-import qualified System.Console.GetOpt as Opt
-import qualified System.Exit as Ex
-import qualified System.Directory as Dir
-import qualified System.IO as IO
-import qualified Control.Monad as Con
-import qualified Data.Time.Clock as Time
-import qualified Data.Maybe as Maybe
-import qualified Counter as Sen
-import qualified Candidate as Cand
-import qualified Election as Elt
-import qualified Miscellaneous as Misc
-
-
-
-
-data Options = Options
- { isVerbose :: Bool
- , isVersion :: Bool
- , isHelp :: Bool
- , getCandFile :: Maybe FilePath
- , getPrefFile :: Maybe FilePath
- , getOutDir :: Maybe FilePath
- , getNumToElect :: Maybe Int
- , getState :: Maybe String }
- deriving Show
-
-
-
-
-defaultOptions = Options
- { isVerbose = False
- , isVersion = False
- , isHelp = False
- , getCandFile = Nothing
- , getPrefFile = Nothing
- , getOutDir = Nothing
- , getNumToElect = Nothing
- , getState = Nothing }
-
-
-
-
-electOpt :: String -> (Options -> Options)
-electOpt str =
- let r = Misc.readMaybe str :: Maybe Int
- jr = if (Maybe.isJust r && Maybe.fromJust r > 0) then r else Nothing
- in (\opts -> opts { getNumToElect = jr })
-
-
-
-
-stateOpt :: String -> (Options -> Options)
-stateOpt str =
- let validStates = ["NSW", "VIC", "TAS", "QLD", "SA", "WA", "NT", "ACT"]
- sr = if (str `elem` validStates) then Just str else Nothing
- in (\opts -> opts { getState = sr } )
-
-
-
-
-optionHeader =
- "Usage: stv [OPTION...]\n\n" ++
- "Note that the -c, -p, -o, -e, -s options are all\n" ++
- "required for normal operation.\n"
-
-furtherHelp =
- "Please be sure to provide all required options to run the election counter.\n" ++
- "For further information consult '--help'.\n"
-
-optionData :: [Opt.OptDescr (Options -> Options)]
-optionData =
- [ Opt.Option ['v'] ["verbose"]
- (Opt.NoArg (\opts -> opts { isVerbose = True}) )
- "chatty output on stderr"
-
- , Opt.Option ['V'] ["version"]
- (Opt.NoArg (\opts -> opts { isVersion = True}) )
- "show version number"
-
- , Opt.Option ['h'] ["help"]
- (Opt.NoArg (\opts -> opts { isHelp = True }) )
- "show this help information"
-
- , Opt.Option ['c'] ["candidates"]
- (Opt.ReqArg (\c opts -> opts { getCandFile = Just c }) "FILE")
- ".csv file containing AEC candidate data"
-
- , Opt.Option ['p'] ["preferences"]
- (Opt.ReqArg (\p opts -> opts { getPrefFile = Just p}) "FILE")
- ".csv file containing AEC formal preferences"
-
- , Opt.Option ['o'] ["outdir"]
- (Opt.ReqArg (\d opts -> opts { getOutDir = Just d}) "DIR")
- "new directory to output count logging"
-
- , Opt.Option ['e'] ["elect"]
- (Opt.ReqArg electOpt "INT")
- "number of candidates to elect"
-
- , Opt.Option ['s'] ["state"]
- (Opt.ReqArg stateOpt "STATE")
- "state or territory the data corresponds to" ]
-
-
-
-
-getOpts :: [String] -> IO (Options, [String])
-getOpts argv =
- case Opt.getOpt Opt.Permute optionData argv of
- (o,n, [] ) -> return (foldl (flip id) defaultOptions o, n)
- (_,_,errs) -> ioError (userError (concat errs ++ Opt.usageInfo optionHeader optionData))
-
-
-
-
-main = do
- rawArgs <- Env.getArgs
- (options, arguments) <- getOpts rawArgs
-
-
- -- options that abort the main program
- Con.when (isHelp options) $ do
- putStrLn (Opt.usageInfo optionHeader optionData)
- Ex.exitFailure
-
- Con.when (isVersion options) $ do
- putStrLn "Australian STV Counter v0.1"
- Ex.exitFailure
-
-
- -- check that all necessary parameters are
- -- both present and valid
- let candidateFile = Maybe.fromJust (getCandFile options)
- Con.when (Maybe.isNothing (getCandFile options)) $
- Ex.die ("Candidate data file not provided.\n\n" ++ furtherHelp)
- doesExist <- Dir.doesFileExist candidateFile
- Con.when (not doesExist) $
- Ex.die ("Candidate data file does not exist.\n\n" ++ furtherHelp)
-
- let preferenceFile = Maybe.fromJust (getPrefFile options)
- Con.when (Maybe.isNothing (getPrefFile options)) $
- Ex.die ("Formal preference data file not provided.\n\n" ++ furtherHelp)
- doesExist <- Dir.doesFileExist preferenceFile
- Con.when (not doesExist) $
- Ex.die ("Formal preference data file does not exist.\n\n" ++ furtherHelp)
-
- let outputDir = Maybe.fromJust (getOutDir options)
- Con.when (Maybe.isNothing (getOutDir options)) $
- Ex.die ("Output logging directory not provided.\n\n" ++ furtherHelp)
- doesExist <- Dir.doesDirectoryExist outputDir
- Con.when doesExist $
- Ex.die ("Output directory already exists.\n\n" ++ furtherHelp)
-
- let numToElect = Maybe.fromJust (getNumToElect options)
- Con.when (Maybe.isNothing (getNumToElect options)) $
- Ex.die ("Invalid number of candidates to elect or number not provided.\n\n" ++ furtherHelp)
-
- let state = Maybe.fromJust (getState options)
- Con.when (Maybe.isNothing (getState options)) $
- Ex.die ("Invalid state/territory or state/territory not provided.\n\n" ++ furtherHelp)
-
-
- -- set up logging
- Dir.createDirectory outputDir
- startTime <- Time.getCurrentTime
- let mainLog = outputDir ++ "/" ++ "log.txt"
- startmsg = "Started election count at " ++ show startTime ++ "\n"
- IO.appendFile mainLog startmsg
- Con.when (isVerbose options) $ IO.hPutStrLn IO.stderr startmsg
-
-
- -- set up the election processing
- Con.when (isVerbose options) $ IO.hPutStrLn IO.stderr "Reading candidate data..."
- (aboveBallot, belowBallot) <- Cand.readCandidates candidateFile state
- Con.when (isVerbose options) $ IO.hPutStrLn IO.stderr "Reading preference data..."
- counter <- Sen.createSenateCounter preferenceFile aboveBallot belowBallot
- Con.when (isVerbose options) $ IO.hPutStrLn IO.stderr "Done.\n"
- Con.when (isVerbose options) $ IO.hPutStrLn IO.stderr "Setting up election..."
- election <- Elt.createElection outputDir mainLog counter numToElect (isVerbose options)
- Con.when (isVerbose options) $ IO.hPutStrLn IO.stderr "Done.\n"
-
-
- -- run the show
- Con.when (isVerbose options) $ IO.hPutStrLn IO.stderr "Running...\n"
- Elt.doCount election
- Con.when (isVerbose options) $ IO.hPutStr IO.stderr "\n"
-
-
- -- finish up logging
- endTime <- Time.getCurrentTime
- let endmsg = "Finished election count at " ++ show endTime ++ "\n"
- elapsedmsg = show (Time.diffUTCTime endTime startTime) ++ " elapsed\n"
- IO.appendFile mainLog (endmsg ++ elapsedmsg)
- Con.when (isVerbose options) $ IO.hPutStrLn IO.stderr (endmsg ++ elapsedmsg)
-
-