Groundwork for new Criteria setup

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)