summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/File.hs31
-rw-r--r--src/Miscellaneous.hs19
-rw-r--r--src/Preferences.hs117
-rw-r--r--src/Senate.hs143
-rw-r--r--src/Storage.hs30
-rw-r--r--src/main.hs6
6 files changed, 202 insertions, 144 deletions
diff --git a/src/File.hs b/src/File.hs
new file mode 100644
index 0000000..e1245e8
--- /dev/null
+++ b/src/File.hs
@@ -0,0 +1,31 @@
+module File(
+ countLines
+ ) where
+
+
+
+
+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
new file mode 100644
index 0000000..94e9672
--- /dev/null
+++ b/src/Miscellaneous.hs
@@ -0,0 +1,19 @@
+module Miscellaneous(
+ if'
+ (?)
+ ) where\
+
+
+
+
+if' :: Bool -> t -> t -> t
+if' a b c = if a then b else c
+
+
+
+
+infixr 1 ?
+(?) :: Bool -> t -> t -> t
+(?) = if'
+
+
diff --git a/src/Preferences.hs b/src/Preferences.hs
new file mode 100644
index 0000000..7a67e63
--- /dev/null
+++ b/src/Preferences.hs
@@ -0,0 +1,117 @@
+module Preferences(
+ Preference,
+ FullPreferences,
+
+ normalise,
+ parsePreferences
+ ) where
+
+
+
+
+import qualified SenateTypes 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/Senate.hs b/src/Senate.hs
index f10aa6a..bd048b5 100644
--- a/src/Senate.hs
+++ b/src/Senate.hs
@@ -1,5 +1,6 @@
module Senate(
SenateCounter,
+
createSenateCounter,
doCount
) where
@@ -8,21 +9,19 @@ module Senate(
import qualified SenateTypes 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 Text.ParserCombinators.Parsec as Parsec
-import qualified Data.Either as Either
+import qualified Data.Either.Unwrap as Either
import qualified Data.Maybe as Maybe
import qualified Data.List as List
-type Preferences = [(Typ.Position,Typ.Ranking)]
-type FullPreferences = (Preferences,Preferences)
-
data SenateCounter = SenateCounter { prefData :: Vec.Store
, ballotMap :: Typ.BelowLineBallot
, numBallots :: Int }
@@ -30,30 +29,24 @@ data SenateCounter = SenateCounter { prefData :: Vec.Store
-minAboveTheLine = 1
-minBelowTheLine = 6
-
-
-
-
createSenateCounter :: FilePath -> Typ.AboveLineBallot -> Typ.BelowLineBallot -> IO SenateCounter
createSenateCounter f a b = do
--
- numLines <- countLines f
+ numLines <- File.countLines f
arrayData <- Vec.createStore numLines (length b)
--
h <- IO.openFile f IO.ReadMode
- let readFunc n p h = if (n > numLines) then return p else do
+ let readFunc n p = if (n > numLines) then return p else do
t0 <- IO.hGetLine h
let t1 = CSV.parseRecord CSV.defaultSettings t0
- t2 = last (head (Either.rights [t1]))
- t3 = parsePreferences (length a) (length b) t2
- t4 = normalise a b (head (Either.rights [t3]))
+ t2 = last (Either.fromRight t1)
+ t3 = Pref.parsePreferences (length a) (length b) t2
+ t4 = Pref.normalise a b (Either.fromRight t3)
t5 = Maybe.fromJust t4
if (Either.isRight t1) && (Either.isRight t3) && (Maybe.isJust t4)
- then (mapM_ (uncurry (Vec.setPref arrayData n)) t5) >> (readFunc (n + 1) (p + 1) h)
- else readFunc (n + 1) p h
- p <- readFunc 1 0 h
+ then mapM_ (Vec.setPref arrayData n) t5 >> readFunc (n + 1) (p + 1)
+ else readFunc (n + 1) p
+ p <- readFunc 1 0
IO.hClose h
--
return (SenateCounter arrayData b p)
@@ -61,28 +54,15 @@ createSenateCounter f a b = do
-countLines :: FilePath -> IO Int
-countLines f = do
- let tailFunc x h = do
- t <- IO.hGetLine h
- e <- IO.hIsEOF h
- if e then (IO.hClose h >> return (x + 1)) else tailFunc (x + 1) h
- h <- IO.openFile f IO.ReadMode
- e <- IO.hIsEOF h
- if e then (IO.hClose h >> return 0) else tailFunc 0 h
-
-
-
-
doCount :: SenateCounter -> Typ.Criteria -> IO Int
-doCount sen crit = do
+doCount sen criteria = do
--
- let isValidCriteria = all (\(x,y) -> y `List.elem` (ballotMap sen)) crit
+ let isValidCriteria = all (\(x,y) -> y `List.elem` (ballotMap sen)) criteria
--
- let critToPref (r,c) = (Maybe.fromJust (List.elemIndex c (ballotMap sen)) + 1, r)
- neededPrefs = map critToPref crit
+ let critToPref (a,b) = (Maybe.fromJust (List.elemIndex b (ballotMap sen)) + 1, a)
+ neededPrefs = map critToPref criteria
checkFunc n r = if (n > (numBallots sen)) then return r else do
- t <- Con.liftM and (mapM (uncurry (Vec.checkPref (prefData sen) n)) neededPrefs)
+ t <- Con.liftM and (mapM (Vec.checkPref (prefData sen) n) neededPrefs)
if t then checkFunc (n + 1) (r + 1) else checkFunc (n + 1) r
--
if isValidCriteria
@@ -90,92 +70,3 @@ doCount sen crit = do
else return 0
-
-
--- converts a set of above+below-the-line preferences to just formal below-the-line
-normalise :: Typ.AboveLineBallot -> Typ.BelowLineBallot -> FullPreferences -> Maybe Preferences
-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 :: Preferences -> Preferences
-extractFormal p =
- let funcTail n r p =
- let (matches,rest) = List.partition ((== n) . snd) p
- in if (p == [] || (length matches) /= 1)
- then r
- else funcTail (n + 1) ((head matches):r) rest
- in funcTail 1 [] p
-
-
-
-
-isValidFormal :: Foldable t => Int -> t a -> Preferences -> Bool
-isValidFormal minLimit ballot pref =
- (length pref >= minLimit) || (length pref == length ballot)
-
-
-
-
-fromAboveToBelow :: Typ.AboveLineBallot -> Preferences -> Preferences
-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
index a97a5fc..75b452b 100644
--- a/src/Storage.hs
+++ b/src/Storage.hs
@@ -9,39 +9,39 @@ module Storage(
-import qualified Control.Monad.Primitive as Prim
+import Data.Int ( Int8 )
+import Preferences ( Preference )
import qualified Data.Vector.Unboxed.Mutable as Vec
-import qualified Data.Int as Ints
-data Store = Store { pointer :: Vec.MVector Prim.RealWorld Ints.Int8
- , sizeOfBallot :: Int}
+data Store = Store { getPointer :: Vec.IOVector Int8
+ , getBallotSize :: Int }
createStore :: Int -> Int -> IO Store
-createStore numberOfEntries ballotSize = do
- v <- Vec.new (numberOfEntries * ballotSize)
+createStore maxCapacity ballotSize = do
+ v <- Vec.new (maxCapacity * ballotSize)
return (Store v ballotSize)
-setPref :: Store -> Int -> Int -> Int -> IO ()
-setPref prefStore ballot position rank = do
- let place = (ballot - 1) * (sizeOfBallot prefStore) + (position - 1)
- Vec.write (pointer prefStore) place (fromIntegral rank)
+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)
-checkPref :: Store -> Int -> Int -> Int -> IO Bool
-checkPref prefStore ballot position rank = do
- let place = (ballot - 1) * (sizeOfBallot prefStore) + (position - 1)
- value <- Vec.read (pointer prefStore) place
- return (value == (fromIntegral rank))
+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
index c3db4ad..603151d 100644
--- a/src/main.hs
+++ b/src/main.hs
@@ -65,11 +65,11 @@ below2 = [ "Donnelly, Matt"
main = do
args <- Env.getArgs
- counter <- Sen.createSenateCounter (head args) above below
- let testTraces = (map (:[]) (zip [1,1..] below))
+ counter <- Sen.createSenateCounter (head args) above2 below2
+ let testTraces = (map (:[]) (zip [1,1..] below2))
results <- mapM (Sen.doCount counter) testTraces
let func (n,c) = putStrLn (c ++ " " ++ (show n))
- output = map func (zip results below)
+ output = map func (zip results below2)
sequence_ output
generated by cgit (git 2.30.0) at 2024-11-02 04:21:40 +0000