summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorJed Barber <jjbarber@y7mail.com>2017-01-27 17:39:05 +1100
committerJed Barber <jjbarber@y7mail.com>2017-01-27 17:39:05 +1100
commitb282e055140ff65879296d4654ad269cc7ff8185 (patch)
treeefb85ed0d03f3b5323cb9c01f1fab9bfb09bab72 /src
parent57d88b07166911a13b37aea54c4247097dc2d0fa (diff)
Code a lot cleaner, algorithm theoretically improved, yet still slow as fuck probably due to criteria parsing
Diffstat (limited to 'src')
-rw-r--r--src/Counter.hs51
-rw-r--r--src/Criteria.hs3
-rw-r--r--src/Election.hs169
-rw-r--r--src/Miscellaneous.hs9
4 files changed, 84 insertions, 148 deletions
diff --git a/src/Counter.hs b/src/Counter.hs
index 37b36dc..855b266 100644
--- a/src/Counter.hs
+++ b/src/Counter.hs
@@ -1,5 +1,4 @@
module Counter(
- Criteria,
SenateCounter,
createSenateCounter,
@@ -13,6 +12,7 @@ module Counter(
import qualified Candidate as Typ
import qualified Preferences as Pref
+import qualified Criteria as Crit
import qualified CSV as CSV
import qualified Storage as Vec
import qualified System.IO as IO
@@ -25,10 +25,6 @@ import qualified Data.List as List
--- represents a criteria used for finding ballots that voted a specific
--- way, for example voted for candidate C as #1, candidate F as #2, etc
-type Criteria = [(Typ.Ranking,Typ.CandidateID)]
-
data SenateCounter = SenateCounter
{ prefData :: Vec.Store
, ballotMap :: Typ.BelowLineBallot
@@ -40,40 +36,45 @@ data SenateCounter = SenateCounter
createSenateCounter :: FilePath -> Typ.AboveLineBallot -> Typ.BelowLineBallot -> IO SenateCounter
createSenateCounter f a b = do
numLines <- File.countLines f
- arrayData <- Vec.createStore numLines (length b)
+ 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 t1 = CSV.parseRecord CSV.defaultSettings (t0 ++ "\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)
- t5 = Maybe.fromJust t4
- if (Either.isRight t1) && (Maybe.isJust t2) && (Either.isRight t3) && (Maybe.isJust t4)
- then mapM_ (Vec.setPref arrayData n) t5 >> readFunc (n + 1) (p + 1)
+ let prefs = parseRawLine a b t0
+ result = Maybe.fromJust prefs
+ if (Maybe.isJust prefs)
+ then Vec.setPrefs prefStore n result >> readFunc (n + 1) (p + 1)
else readFunc (n + 1) p
p <- readFunc 1 0
IO.hClose h
- return (SenateCounter arrayData b p)
+ return (SenateCounter prefStore b 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 isValidCriteria = all (\(x,y) -> y `List.elem` (ballotMap sen)) criteria
- 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 (Vec.checkPref (prefData sen) n) neededPrefs)
- if t then checkFunc (n + 1) (r + 1) else checkFunc (n + 1) r
- if isValidCriteria
- then checkFunc 1 0
- else return 0
+doCount :: SenateCounter -> Crit.Criteria -> IO Int
+doCount sen criteria =
+ let tailFunc n r = if (n > numBallots sen) then return r else do
+ prefs <- Vec.getPrefs (prefData sen) n
+ if (Crit.evaluate (ballotMap sen) prefs criteria)
+ then tailFunc (n + 1) (r + 1)
+ else tailFunc (n + 1) r
+ in tailFunc 1 0
diff --git a/src/Criteria.hs b/src/Criteria.hs
index 5df9cf1..7f46970 100644
--- a/src/Criteria.hs
+++ b/src/Criteria.hs
@@ -42,7 +42,8 @@ evaluate ballot preferences criteria =
isValidInput :: Typ.BelowLineBallot -> [Pref.Preference] -> Bool
isValidInput ballot preferences =
- all (\(x,y) -> x > 0 && x <= length ballot && y > 0 && y <= length ballot) preferences
+ all (\(x,y) -> x > 0 && x <= length ballot
+ && y > 0 && y <= length ballot) preferences
diff --git a/src/Election.hs b/src/Election.hs
index 39bcb22..0789fcf 100644
--- a/src/Election.hs
+++ b/src/Election.hs
@@ -12,13 +12,15 @@ import qualified System.IO as IO
import qualified Control.Monad as Con
import qualified Control.Monad.Trans.Either as ET
import qualified Control.Monad.IO.Class as MIO
-import qualified Data.Map.Strict as Map
+import Data.List ( (\\) )
import qualified Data.List as List
import qualified Data.Maybe as Maybe
import qualified Data.Either.Unwrap as Either
import qualified Counter as Sen
import qualified Candidate as Typ
+import qualified Criteria as Crit
import qualified CSV as CSV
+import Miscellaneous ( (.:) )
import qualified Miscellaneous as Misc
@@ -50,9 +52,15 @@ data Entry = Entry
deriving (Eq)
data Trace = Trace
- { getCriteria :: Sen.Criteria
+ { getCriteria :: Crit.Criteria
, getTransferVal :: Float }
- deriving (Eq)
+
+-- can't check for equality on functions, unfortunately,
+-- so this'll have to do
+instance Eq Trace where
+ a == b =
+ (length (getCriteria a) == length (getCriteria b))
+ && (getTransferVal a == getTransferVal b)
data Status = Running | Elected | Eliminated
deriving (Show, Eq)
@@ -60,28 +68,22 @@ data Status = Running | Elected | Eliminated
data Transfer = Transfer
{ getWhoFrom :: Typ.CandidateID
, getVoteAmount :: Int
+ , getNewValue :: Float
, getWhatToDist :: [Trace] }
--- the ints here are the raw count values of the ballots
--- that satisfy the criteria in each trace
-type TransferMap = Map.Map Typ.CandidateID [(Int,Trace)]
-
createElection :: FilePath -> Sen.SenateCounter -> Int -> Bool -> IO Election
createElection outDir counter numToElect verbosity = do
entries <- mapM (candToEntry counter) (Sen.getBallot counter)
- let mainLog = outDir ++ "/" ++ "log.txt"
- total = Sen.getTotal counter
- quota = droopQuota total numToElect
return (Election
{ getEntries = entries
, getCounter = counter
, getLogDir = outDir
- , getTotalPapers = total
- , getQuota = quota
- , getMainLog = mainLog
+ , getTotalPapers = Sen.getTotal counter
+ , getQuota = droopQuota (Sen.getTotal counter) numToElect
+ , getMainLog = outDir ++ "/" ++ "log.txt"
, getNextLogNum = 1
, getSeats = numToElect
, getVacancies = numToElect
@@ -100,9 +102,15 @@ droopQuota votes seats =
+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 = [(1,candidate)]
+ let criteria = [Crit.matchID candidate]
trace = Trace criteria 1
firstPrefs <- Sen.doCount counter criteria
return (Entry
@@ -206,13 +214,12 @@ doElectCandidate e = do
electedEntry = List.maximumBy compareVotes running
(beforeEntries, afterEntries) = Misc.partBeforeAfter electedEntry (getEntries e)
- newTransferValue = (fromIntegral (getTotalVotes electedEntry - getQuota e)) /
- (fromIntegral (getTotalVotes electedEntry))
- transferFunction x = x { getTransferVal = newTransferValue * getTransferVal x }
newTransfer = Transfer
{ getWhoFrom = getID electedEntry
, getVoteAmount = getTotalVotes electedEntry - getQuota e
- , getWhatToDist = map transferFunction (getCritTrace electedEntry) }
+ , getNewValue = (fromIntegral (getTotalVotes electedEntry - getQuota e)) /
+ (fromIntegral (getTotalVotes electedEntry))
+ , getWhatToDist = getCritTrace electedEntry }
revisedElectedEntry = electedEntry
{ getStatus = Elected
@@ -228,7 +235,7 @@ doElectCandidate e = do
ET.right (e
{ getEntries = allRevised
, getTransferQueue = (getTransferQueue e) ++ [newTransfer]
- , getNextToElect = 1 + getNextToElect e
+ , getNextToElect = getNextToElect e + 1
, getVacancies = getVacancies e - 1 })
else ET.left e
@@ -245,7 +252,7 @@ checkIfDone e =
--- redistributing votes in STV is surprisingly complex
+-- redistributing votes in STV is annoying as hell
transferVotes :: Election -> ET.EitherT Election IO Election
transferVotes e =
if (length (getTransferQueue e) > 0)
@@ -260,23 +267,29 @@ 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)
-
- mapKeys = map getID (beforeEntries ++ afterEntries)
- notRunningKeys = map getID (filter ((/= Running) . getStatus) (getEntries e))
- transferMap <- MIO.liftIO $ Con.foldM (addToTransferMap (getCounter e) mapKeys) Map.empty (getWhatToDist currentTransfer)
- revisedMap <- MIO.liftIO $ redistNotRunning (getCounter e) mapKeys notRunningKeys transferMap
-
- let reviseFunc entry =
- if (getStatus entry == Running)
- then transferToEntry revisedMap entry
- else entry
+ notRunningIDs = map getID (filter ((/= Running) . getStatus) (getEntries e))
+
+ reviseTrace candID trace = trace
+ { getCriteria = getCriteria trace ++
+ [Crit.many (Crit.matchFromList notRunningIDs), Crit.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 totalVoteChange = sum (zipWith (floor .: (*)) (map fromIntegral rawVoteChanges) (map getTransferVal newTraces))
+ return (entry
+ { getVoteChange = totalVoteChange
+ , getTotalVotes = getTotalVotes entry + totalVoteChange
+ , getCritTrace = getCritTrace entry ++ newTraces })
revisedFromEntry = fromEntry
{ getVoteChange = -(getVoteAmount currentTransfer)
, getTotalVotes = getTotalVotes fromEntry - (getVoteAmount currentTransfer)
- -- this last bit needs to be replaced with something more accurate
- , getCritTrace = [] }
- allRevised = (map reviseFunc beforeEntries) ++ [revisedFromEntry] ++ (map reviseFunc afterEntries)
+ , getCritTrace = (getCritTrace fromEntry) \\ (getWhatToDist currentTransfer) }
+ revisedBeforeEntries <- MIO.liftIO $ mapM reviseFunc beforeEntries
+ revisedAfterEntries <- MIO.liftIO $ mapM reviseFunc afterEntries
+ let allRevised = revisedBeforeEntries ++ [revisedFromEntry] ++ revisedAfterEntries
ET.left (e
{ getEntries = allRevised
@@ -285,88 +298,6 @@ doVoteTransfer e = do
-addToTransferMap :: Sen.SenateCounter -> [Typ.CandidateID] -> TransferMap -> Trace -> IO TransferMap
-addToTransferMap counter mapKeys transferMap traceToAdd = do
- let newTraces = map (addToTrace traceToAdd) mapKeys
- keyed = zip mapKeys newTraces
- noDupes = filter (not . criteriaHasDupe . getCriteria . snd) keyed
- counted <- mapM (\(k,t) -> Sen.doCount counter (getCriteria t) >>= (\x -> return (k,(x,t)))) noDupes
- let notZero (k,xt) = floor ((fromIntegral (fst xt)) * getTransferVal (snd xt)) > 0
- noZeroMap = filter notZero counted
- listed = map (\(k,xt) -> (k,xt:[])) noZeroMap
- return (Map.unionWith (++) transferMap (Map.fromList listed))
-
-
-
-
-redistNotRunning :: Sen.SenateCounter -> [Typ.CandidateID] -> [Typ.CandidateID] -> TransferMap -> IO TransferMap
-redistNotRunning counter mapKeys notRunningKeys transferMap =
- let lookupNotRunning k m =
- if (length k == 0)
- then Nothing
- else let x = Map.lookup (head k) m
- in if (Maybe.isJust x)
- then Just (head k, Maybe.fromJust x)
- else lookupNotRunning (tail k) m
- item = lookupNotRunning notRunningKeys transferMap
- in if (Maybe.isJust item)
- then do
- let (key,valList) = Maybe.fromJust item
- removedMap = Map.delete key transferMap
- revisedMap <- Con.foldM (addToTransferMap counter mapKeys) removedMap (map snd valList)
- redistNotRunning counter mapKeys notRunningKeys revisedMap
- else return transferMap
-
-
-
-
-transferToEntry :: TransferMap -> Entry -> Entry
-transferToEntry transferMap entry =
- let lookupVal = Map.lookup (getID entry) transferMap
- valList = Maybe.fromJust lookupVal
-
- voteChanges = map (\(x,y) -> floor ((fromIntegral x) * getTransferVal y)) valList
- addedTraces = map snd valList
- revisedEntry = entry
- { getVoteChange = sum voteChanges
- , getTotalVotes = getTotalVotes entry + sum voteChanges
- , getCritTrace = getCritTrace entry ++ addedTraces }
-
- in if (Maybe.isJust lookupVal)
- then revisedEntry
- else entry
-
-
-
-
-criteriaHasDupe :: Sen.Criteria -> Bool
-criteriaHasDupe crit =
- let test seen toCheck =
- if (length toCheck == 0)
- then False
- else if (elem (snd (head toCheck)) seen)
- then True
- else test ((snd (head toCheck)):seen) (tail toCheck)
- in test [] crit
-
-
-
-
-addToCriteria :: Typ.CandidateID -> Sen.Criteria -> Sen.Criteria
-addToCriteria candID crit =
- let maxRank = fst (List.maximumBy (\x y -> compare (fst x) (fst y)) crit)
- in (maxRank + 1, candID):crit
-
-
-
-
-addToTrace :: Trace -> Typ.CandidateID -> Trace
-addToTrace trace candID = trace
- { getCriteria = addToCriteria candID (getCriteria trace) }
-
-
-
-
-- needs to be modified to take into account ties
checkNoQuota :: Election -> ET.EitherT Election IO Election
checkNoQuota e = do
@@ -381,7 +312,6 @@ checkNoQuota e = do
if ((getStatus entry == Running) && (entry /= minimumEntry))
then makeElect entry
else entry
-
revisedMinEntry =
if (length running <= getVacancies e)
then makeElect minimumEntry
@@ -407,6 +337,7 @@ excludeSomeone e = do
newTransfer = Transfer
{ getWhoFrom = getID excludedEntry
, getVoteAmount = getTotalVotes excludedEntry
+ , getNewValue = 1
, getWhatToDist = getCritTrace excludedEntry }
revisedExcludedEntry = excludedEntry
@@ -421,9 +352,3 @@ excludeSomeone e = do
else ET.right e
-
-
-compareVotes :: Entry -> Entry -> Ordering
-compareVotes x y = compare (getTotalVotes x) (getTotalVotes y)
-
-
diff --git a/src/Miscellaneous.hs b/src/Miscellaneous.hs
index 5f018e6..ba9ca98 100644
--- a/src/Miscellaneous.hs
+++ b/src/Miscellaneous.hs
@@ -1,6 +1,7 @@
module Miscellaneous(
if',
(?),
+ (.:),
selectFrom,
readMaybe,
partBeforeAfter
@@ -29,6 +30,14 @@ infixr 1 ?
+-- 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