From 57d88b07166911a13b37aea54c4247097dc2d0fa Mon Sep 17 00:00:00 2001 From: Jed Barber Date: Fri, 27 Jan 2017 00:43:19 +1100 Subject: Groundwork for new Criteria setup --- src/Criteria.hs | 86 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ src/Storage.hs | 23 ++++++++++++++- 2 files changed, 108 insertions(+), 1 deletion(-) create mode 100644 src/Criteria.hs (limited to 'src') diff --git a/src/Criteria.hs b/src/Criteria.hs new file mode 100644 index 0000000..5df9cf1 --- /dev/null +++ b/src/Criteria.hs @@ -0,0 +1,86 @@ +module Criteria( + Criteria, + CTest, + + evaluate, + matchID, + matchFromList, + many + ) where + + + + +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/src/Storage.hs b/src/Storage.hs index 2f0ed1c..295273b 100644 --- a/src/Storage.hs +++ b/src/Storage.hs @@ -3,6 +3,8 @@ module Storage( createStore, setPref, + setPrefs, + getPrefs, checkPref ) where @@ -25,7 +27,7 @@ data Store = Store createStore :: Int -> Int -> IO Store createStore maxCapacity ballotSize = do - v <- Vec.new (maxCapacity * ballotSize) + v <- Vec.replicate (maxCapacity * ballotSize) 0 return (Store v ballotSize) @@ -39,6 +41,25 @@ setPref prefStore ballot (position,rank) = do +setPrefs :: Store -> Int -> [Preference] -> IO () +setPrefs prefStore ballot prefList = + 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) -- cgit