diff options
| -rw-r--r-- | makefile | 8 | ||||
| -rw-r--r-- | notes.txt | 11 | ||||
| -rw-r--r-- | old/Criteria.hs | 93 | ||||
| -rw-r--r-- | old/Storage.hs | 73 | ||||
| -rw-r--r-- | old/preference_arrays.adb | 114 | ||||
| -rw-r--r-- | old/preference_arrays.ads | 38 | ||||
| -rw-r--r-- | old/testmain.hs | 21 | ||||
| -rw-r--r-- | readme.txt | 22 | ||||
| -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 |
17 files changed, 3 insertions, 1708 deletions
@@ -3,12 +3,6 @@ all: stv - stv: - ghc -O2 --make src/main.hs -isrc:build -odir build -outputdir build \ - -hidir build -stubdir build -dumpdir build -o bin/stv - - -ada: - gnatmake src/stv.adb -Isrc -D build -o bin/adastv + gnatmake src/stv.adb -Isrc -D build -o bin/stv @@ -11,20 +11,11 @@ add proper tiebreaker handling more counters/parsers/options to handle state elections, general stv data -more detailed logging for preference distribution? -tracking of exhausted/fractional-loss ballots? - -multithreaded operation to speed counting up, possibly using unsafePerformIO and/or forkIO - -group votes by uniqueness to reduce memory requirements, speed things up, and accommodate group tickets? +multithreaded operation? make the goddamn results correct are they correct now? it's a bit murky with how the AEC records transfers in DOP logs does the AEC use truncated values or exact ratios for transfer values? does the AEC check for candidates having quota when transfers are only partially done? -place candidate IDs and party designations into different fields in logfiles - -try and replace the constant recounting with unboxed vectors of ballot bundles that can be moved, split up, sorted, etc - diff --git a/old/Criteria.hs b/old/Criteria.hs deleted file mode 100644 index 8ca19c8..0000000 --- a/old/Criteria.hs +++ /dev/null @@ -1,93 +0,0 @@ -module Criteria( - Criteria, - CTest, - - evaluate, - matchID, - matchFromList, - many - ) where - - - - --- this is a preference criteria checking method modeled after parsec --- it looks nice, and it *does* work, but unfortunately it's far too slow - - - - -import qualified Control.Monad as Con -import qualified Data.List as List -import qualified Data.Either.Unwrap as Either -import qualified Candidate as Typ -import qualified Preferences as Pref - - - - -type Criteria = [CTest] -type CTest = CList -> Either CError CList -type CList = [Typ.CandidateID] -type CError = String - - - - -evaluate :: Typ.BelowLineBallot -> [Pref.Preference] -> Criteria -> Bool -evaluate ballot preferences criteria = - let clist = prefsToCList ballot preferences - parsed = Con.foldM (flip id) clist criteria - result = Either.isRight parsed - in if (isValidInput ballot preferences) - then result - else False - - - - -isValidInput :: Typ.BelowLineBallot -> [Pref.Preference] -> Bool -isValidInput ballot preferences = - all (\(x,y) -> x > 0 && x <= length ballot - && y > 0 && y <= length ballot) preferences - - - - -prefsToCList :: Typ.BelowLineBallot -> [Pref.Preference] -> CList -prefsToCList ballot preferences = - let t0 = map (\(x,y) -> (ballot !! (x - 1), y)) preferences - t1 = List.sortBy (\x y -> compare (snd x) (snd y)) t0 - in map fst t1 - - - - -matchID :: Typ.CandidateID -> CTest -matchID candID = (\x -> - let r = (head x == candID) - in if (length x == 0 || not r) - then Left "Couldn't match candidate" - else Right (tail x)) - - - - -matchFromList :: [Typ.CandidateID] -> CTest -matchFromList candList = (\x -> - let r = (head x) `elem` candList - in if (length x == 0 || not r) - then Left "Couldn't match candidate" - else Right (tail x)) - - - - -many :: CTest -> CTest -many ct = (\x -> - let r = ct x - in if (Either.isRight r) - then many ct (Either.fromRight r) - else Right x) - - diff --git a/old/Storage.hs b/old/Storage.hs deleted file mode 100644 index 2697c39..0000000 --- a/old/Storage.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} - -module Storage( - PrefStorage, - createStorage, - pokePref, - peekPref - ) where - - - - -import Foreign -import Foreign.C - - - - -foreign import ccall "create_pref_array" - c_createPrefArray :: CInt -> CInt -> IO (Ptr PrefArray) - -foreign import ccall "free_pref_array" - c_freePrefArray :: CInt -> CInt -> Ptr PrefArray -> IO () - -foreign import ccall "wrapper" - wrap :: (Ptr PrefArray -> IO ()) -> IO (FunPtr (Ptr PrefArray -> IO ())) - -foreign import ccall "poke_pref_array" - c_pokePrefArray :: CInt -> CInt -> Ptr PrefArray -> CInt -> CInt -> CInt -> IO () - -foreign import ccall "peek_pref_array" - c_peekPrefArray :: CInt -> CInt -> Ptr PrefArray -> CInt -> CInt -> CInt -> IO CInt - - - - -newtype PrefArray = PrefArray (Ptr PrefArray) - -data PrefStorage = PrefStorage { pointer :: ForeignPtr PrefArray - , numBallots :: Int - , sizeOfBallot :: Int } - - - - -createStorage :: Int -> Int -> IO PrefStorage -createStorage n s = do - x <- c_createPrefArray (fromIntegral n) (fromIntegral s) - f <- wrap (c_freePrefArray (fromIntegral n) (fromIntegral s)) - y <- newForeignPtr f x - return (PrefStorage y n s) - - - - -pokePref :: PrefStorage -> Int -> Int -> Int -> IO () -pokePref p n s r = do - let numBal = fromIntegral (numBallots p) - sizeBal = fromIntegral (sizeOfBallot p) - func a = c_pokePrefArray numBal sizeBal a (fromIntegral n) (fromIntegral s) (fromIntegral r) - withForeignPtr (pointer p) func - - - - -peekPref :: PrefStorage -> Int -> Int -> Int -> IO Bool -peekPref p n s r = do - let numBal = fromIntegral (numBallots p) - sizeBal = fromIntegral (sizeOfBallot p) - func a = c_peekPrefArray numBal sizeBal a (fromIntegral n) (fromIntegral s) (fromIntegral r) - result <- withForeignPtr (pointer p) func - return (result /= 0) - diff --git a/old/preference_arrays.adb b/old/preference_arrays.adb deleted file mode 100644 index 0b1218a..0000000 --- a/old/preference_arrays.adb +++ /dev/null @@ -1,114 +0,0 @@ - - -with Ada.Unchecked_Deallocation; -with System.Address_To_Access_Conversions; - - -package body Preference_Arrays is - - - type Ranking is range 1 .. 255; - - type Preference_Array is array (Positive range <>, Positive range <>) of Ranking; - pragma Pack (Preference_Array); - - - - - -- these following functions would be a lot smaller and neater - -- if the FFI could make use of fat pointers - - - - - function Create_Preference_Array - (Number_Of_Ballots, Size_Of_Ballot : in Interfaces.C.int) - return System.Address - is - subtype Constrained is Preference_Array - (1 .. Positive (Number_Of_Ballots), - 1 .. Positive (Size_Of_Ballot)); - - package Convert is new System.Address_To_Access_Conversions - (Object => Constrained); - - Pref_Array : Convert.Object_Pointer; - begin - Pref_Array := new Preference_Array - (1 .. Positive (Number_Of_Ballots), - 1 .. Positive (Size_Of_Ballot)); - return Convert.To_Address (Pref_Array); - end Create_Preference_Array; - - - - - procedure Free_Preference_Array - (Number_Of_Ballots, Size_Of_Ballot : in Interfaces.C.int; - Pref_Array_Address : in System.Address) - is - subtype Constrained is Preference_Array - (1 .. Positive (Number_Of_Ballots), - 1 .. Positive (Size_Of_Ballot)); - - package Convert is new System.Address_To_Access_Conversions - (Object => Constrained); - procedure Free_Pref_Array is new Ada.Unchecked_Deallocation - (Object => Constrained, Name => Convert.Object_Pointer); - - Pref_Array : Convert.Object_Pointer; - begin - Pref_Array := Convert.To_Pointer (Pref_Array_Address); - Free_Pref_Array (Pref_Array); - end Free_Preference_Array; - - - - - procedure Poke_Preference_Array - (Number_Of_Ballots, Size_Of_Ballot : in Interfaces.C.int; - Pref_Array_Address : in System.Address; - Ballot_Index, Box_Number, Rank : in Interfaces.C.int) - is - subtype Constrained is Preference_Array - (1 .. Positive (Number_Of_Ballots), - 1 .. Positive (Size_Of_Ballot)); - - package Convert is new System.Address_To_Access_Conversions - (Object => Constrained); - - Pref_Array : Convert.Object_Pointer; - begin - Pref_Array := Convert.To_Pointer (Pref_Array_Address); - Pref_Array (Positive (Ballot_Index), Positive (Box_Number)) := Ranking (Rank); - end Poke_Preference_Array; - - - - - function Peek_Preference_Array - (Number_Of_Ballots, Size_Of_Ballot : in Interfaces.C.int; - Pref_Array_Address : in System.Address; - Ballot_Index, Box_Number, Rank : in Interfaces.C.int) - return Interfaces.C.int - is - subtype Constrained is Preference_Array - (1 .. Positive (Number_Of_Ballots), - 1 .. Positive (Size_Of_Ballot)); - - package Convert is new System.Address_To_Access_Conversions - (Object => Constrained); - - Pref_Array : Convert.Object_Pointer; - begin - Pref_Array := Convert.To_Pointer (Pref_Array_Address); - if Pref_Array (Positive (Ballot_Index), Positive (Box_Number)) = Ranking (Rank) then - return 1; - else - return 0; - end if; - end Peek_Preference_Array; - - -end Preference_Arrays; - diff --git a/old/preference_arrays.ads b/old/preference_arrays.ads deleted file mode 100644 index c8245e0..0000000 --- a/old/preference_arrays.ads +++ /dev/null @@ -1,38 +0,0 @@ - - -with Interfaces.C; -with System; - - -package Preference_Arrays is - - - function Create_Preference_Array - (Number_Of_Ballots, Size_Of_Ballot : in Interfaces.C.int) - return System.Address; - pragma Export (C, Create_Preference_Array, "create_pref_array"); - - - procedure Free_Preference_Array - (Number_Of_Ballots, Size_Of_Ballot : in Interfaces.C.int; - Pref_Array_Address : in System.Address); - pragma Export (C, Free_Preference_Array, "free_pref_array"); - - - procedure Poke_Preference_Array - (Number_Of_Ballots, Size_Of_Ballot : in Interfaces.C.int; - Pref_Array_Address : in System.Address; - Ballot_Index, Box_Number, Rank : in Interfaces.C.int); - pragma Export (C, Poke_Preference_Array, "poke_pref_array"); - - - function Peek_Preference_Array - (Number_Of_Ballots, Size_Of_Ballot : in Interfaces.C.int; - Pref_Array_Address : in System.Address; - Ballot_Index, Box_Number, Rank : in Interfaces.C.int) - return Interfaces.C.int; - pragma Export (C, Peek_Preference_Array, "peek_pref_array"); - - -end Preference_Arrays; - diff --git a/old/testmain.hs b/old/testmain.hs deleted file mode 100644 index 3f340c2..0000000 --- a/old/testmain.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} - - - -import qualified Storage as Store - - - -foreign import ccall adainit :: IO Int -foreign import ccall adafinal :: IO Int - - - -main = do - adainit - s <- Store.createStorage 10 5 - Store.pokePref s 1 2 3 - r <- Store.peekPref s 1 2 3 - putStrLn (show r) - adafinal - @@ -7,7 +7,7 @@ algorithm on it to calculate election outcomes. To compile this program, the following dependencies are needed: - ghc (of course) + gnat (of course) gnu make Note however that make isn't strictly necessary if you have a look in the @@ -15,19 +15,6 @@ makefile to see the compilation commands required. -Aside from base, the cabal packages required to compile this program are: - - directory - either-unwrap - either - transformers - parsec - vector - array - time - - - Compilation is done by 'make all'. Further instruction on how to use this program can be obtained from the '--help' switch, once compiled. @@ -55,10 +42,3 @@ elect candidates. On the other hand, the AEC program is also a lot more verbose on the distribution of preferences, and doesn't do bulk exclusions. - -Finally, be aware that processing STV data takes a long time. It also takes a -lot of memory for the larger datasets. If you want to be sure that progress is -happening, either turn on the '--verbose' switch or monitor the output log -directory. - - 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) - - |