summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorJed Barber <jjbarber@y7mail.com>2017-01-27 00:43:19 +1100
committerJed Barber <jjbarber@y7mail.com>2017-01-27 00:43:19 +1100
commit57d88b07166911a13b37aea54c4247097dc2d0fa (patch)
tree922f9467ef148ccf887268b72c27a6463c856250 /src
parente7dbb4348d17f44c0f9162bea68738f3e2dc72f8 (diff)
Groundwork for new Criteria setup
Diffstat (limited to 'src')
-rw-r--r--src/Criteria.hs86
-rw-r--r--src/Storage.hs23
2 files changed, 108 insertions, 1 deletions
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)