1 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
2 {-# LANGUAGE TypeFamilies #-} -- NOTE: for IsList
3 module Majority.Merit where
5 import Data.Eq (Eq(..))
6 import Data.Foldable (Foldable, foldr)
7 import Data.Function (($), (.))
8 import Data.Functor (Functor, (<$>), (<$))
9 import Data.Hashable (Hashable)
10 import Data.List as List
11 import Data.Map.Strict (Map)
12 import Data.Ord (Ord(..))
13 import Data.Ratio ((%), Rational, denominator)
14 import Data.Semigroup (Semigroup(..))
16 import Data.Tuple (curry)
17 import GHC.Exts (IsList(..))
18 import Prelude (Bounded(..), Enum(..), Num(..), Integer, error, lcm)
19 import Text.Show (Show(..))
20 import qualified Data.HashMap.Strict as HM
21 import qualified Data.HashSet as HS
22 import qualified Data.Map.Strict as Map
23 import qualified Data.Set as Set
26 type Choices = HS.HashSet
28 -- | Return a set of 'Choices' by enumerating the alternatives of its type. Useful on sum types.
29 choices :: (Bounded choice , Enum choice , Eq choice, Hashable choice) => Choices choice
30 choices = HS.fromList $ enumFrom minBound
33 -- | How many 'grade's should be used?
34 -- A greater number of 'grade's permits a finer distinction but demands
35 -- a higher degree of expertise and discernment.
36 -- The optimal number is the highest number of 'grade's that constitutes a common language,
37 -- that is, that allows 'Judges' to make absolute judgments.
38 -- Too little 'grade's may lead too often to ties.
40 -- Note, however, that if the inputs or grades depend on the set of 'choice's,
41 -- i.e. if judges change their grades when 'choice's are added or dropped,
42 -- then the Arrow paradox cannot be avoided.
43 -- To avoid this the scale of grades must be fixed and absolute
44 -- so that more or fewer 'choice's does not change
45 -- the inputs or messages of other 'choice's.
48 grades :: [grade] -> Grades (Ranked grade)
49 grades = Set.fromList . zipRank
52 -- | Helper type to rank data without a good 'Ord' instance.
53 newtype Ranked a = Ranked (G, a)
54 deriving (Show,Functor)
55 instance Eq (Ranked a) where
56 Ranked (x,_) == Ranked (y,_) = x==y
57 instance Ord (Ranked a) where
58 Ranked (x,_) `compare` Ranked (y,_) = x`compare`y
60 -- | @'zipRank' xs@ returns a list with the items of 'xs' wrapped
61 -- so that they are 'compare'able according to their position into 'xs'.
62 zipRank :: [a] -> [Ranked a]
63 zipRank = List.zipWith (curry Ranked) [0..]
65 rankKey :: [(k, a)] -> [(Ranked k, a)]
66 rankKey = List.zipWith (\i (k,a) -> (Ranked (i,k),a)) [0..]
73 rank (Ranked (r, _x)) = r
75 unRank :: Ranked a -> a
76 unRank (Ranked (_r, x)) = x
78 -- | Return the 'Set' enumerating the alternatives
79 -- of its type parameter. Useful on sum types.
80 enum :: (Bounded a, Enum a, Ord a) => Set a
81 enum = Set.fromList $ enumFrom minBound
84 -- | Map each 'judge' to its default 'grade'
85 -- (usually the same for all 'judge's but not necessarily).
87 -- For instance, when a 'judge' gives no 'grade' or has “no opinion”,
88 -- this default grade could mean that the 'judge' chooses “To Reject” the 'choice':
89 -- the rationale being that a 'judge' having “no opinion”
90 -- concerning a 'choice' has not even taken the time to evaluate it
91 -- and thus has implicitly rejected it.
92 type Judges = HM.HashMap
97 [judge] -> grade -> Judges judge grade
98 judges js dg = HM.fromList $ (\j -> (j, dg)) <$> js
101 -- | Profile of opinions of some 'judge's about a single 'choice'.
102 type Opinions judge grade = HM.HashMap judge (Distribution grade)
104 -- | @(ok, ko) = 'opinions' js os@ returns:
106 -- * in 'ok' the opinions of the 'judge's 'js' updated by those in 'os',
107 -- * in 'ko' the opinions of 'judge's not in 'js'.
111 Judges judge grade ->
112 Opinions judge grade ->
113 ( Opinions judge grade
116 ( HM.union os $ singleGrade <$> js
117 , HS.fromMap $ (() <$) $ os`HM.difference`js )
119 -- ** Type 'Distribution'
120 -- | Usually, a 'judge' gives a 'singleGrade' to a given 'choice'.
121 -- However, when applying the Majority Judgment to a 'Tree' of 'Section's,
122 -- what a 'judge' gives to a parent 'Section'
123 -- is composed by the 'grade's he or she has given
124 -- to the sub-'Section's, and those can be different.
125 -- In that case, each 'grade' given to a sub-'Section' contributes to a 'Share'
126 -- of the parent 'Section' which therefore is not necessarily a 'singleGrade',
127 -- but more generally a 'Distribution' of 'grade's.
128 -- And the sub-'Section's can actually themselves have sub-'Section's,
129 -- hence not being given a 'grade', but a 'Distribution' of 'grade's too.
130 type Distribution grade = Map grade Share
132 singleGrade :: grade -> Distribution grade
133 singleGrade = (`Map.singleton` 1)
136 -- | Usually a 'judge' attributes a 'singleGrade' to a given 'choice',
137 -- and then the 'Share' of this 'grade' is 1.
138 -- However, when introducing vote colleges (giving more power to some 'judge's),
139 -- or when introducing 'Section's (decomposing a judgment into several sub-judgments),
140 -- it becomes possible that only a percentage of 'grade'
141 -- is attributed by a 'judge' to a given 'choice'.
142 -- This is what a 'Share' is used for.
143 type Share = Rational
144 -- FIXME: newtype checking >= 0
146 -- ** Type 'OpinionsByChoice'
147 -- | Profile of opinions of some 'Judges' about some 'choice's.
148 type OpinionsByChoice choice judge grade = HM.HashMap choice (Opinions judge grade)
153 [(choice, Opinions judge grade)] ->
154 OpinionsByChoice choice judge grade
155 opinionsByChoice = HM.fromList
158 -- | Profile of merit about a single 'choice'.
159 newtype Merit grade = Merit { unMerit :: Map grade Share }
161 instance Ord grade => Semigroup (Merit grade) where
162 Merit x <> Merit y = Merit (Map.unionWith (+) x y)
163 instance (Ord grade, Show grade) => IsList (Merit grade) where
164 type Item (Merit grade) = (grade, Share)
165 fromList = Merit . Map.fromListWithKey
166 (\g _x _y -> error $ "duplicate grade in merit: " <> show g)
167 toList (Merit cs) = toList cs
169 -- | @merit os@ returns the 'Merit' given by opinions 'os'
173 opinions (Distribution grade) ->
175 merit = foldr insertOpinion (Merit Map.empty)
176 -- TODO: maybe count by making g passes
178 insertOpinion dist (Merit m) =
181 (\acc g s -> Map.insertWith (+) g s acc)
190 meritFromList = merit . (singleGrade <$>)
192 -- | 'normalizeMerit m' multiply all 'Share's
193 -- by their least common denominator
194 -- to get integral 'Share's.
195 normalizeMerit :: Merit grade -> Merit grade
196 normalizeMerit (Merit ms) = Merit $ (lcm' *) <$> ms
197 where lcm' = foldr lcm 1 (denominator <$> ms) % 1
199 -- ** Type 'MeritByChoice'
200 -- | Profile of merit about some 'choice's.
201 newtype MeritByChoice choice grade
202 = MeritByChoice { unMeritByChoice :: HM.HashMap choice (Merit grade) }
204 instance (Eq choice, Hashable choice, Ord grade) => Semigroup (MeritByChoice choice grade) where
205 MeritByChoice x <> MeritByChoice y = MeritByChoice (HM.unionWith (<>) x y)
206 instance (Eq choice, Hashable choice, Show choice) => IsList (MeritByChoice choice grade) where
207 type Item (MeritByChoice choice grade) = (choice, Merit grade)
208 fromList = MeritByChoice . HM.fromListWith
209 (\_x _y -> error $ "duplicate choice in merits")
210 toList (MeritByChoice cs) = toList cs
212 -- | @meritByChoice gs cs os@ returns the 'Merit's
213 -- given to 'choice's 'cs' by opinions 'os' from the 'Judges' 'js' on the 'Grades' 'gs'.
215 (Ord grade, Eq choice, Hashable choice) =>
216 OpinionsByChoice choice judge grade ->
217 MeritByChoice choice grade
218 meritByChoice os = MeritByChoice $ merit <$> os