diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/CSV.hs | 112 | ||||
| -rw-r--r-- | src/Candidate.hs | 101 | ||||
| -rw-r--r-- | src/Counter.hs | 163 | ||||
| -rw-r--r-- | src/Election.hs | 404 | ||||
| -rw-r--r-- | src/File.hs | 42 | ||||
| -rw-r--r-- | src/Miscellaneous.hs | 87 | ||||
| -rw-r--r-- | src/Preferences.hs | 128 | ||||
| -rw-r--r-- | src/Storage.hs | 83 | ||||
| -rw-r--r-- | src/main.hs | 211 |
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) - - |