blob: 8ca19c8c3e724578dad54d52f7ac34932ea5e8aa (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
|
module Criteria(
Criteria,
CTest,
evaluate,
matchID,
matchFromList,
many
) where
-- this is a preference criteria checking method modeled after parsec
-- it looks nice, and it *does* work, but unfortunately it's far too slow
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)
|
