Hjugement/Majority.hs

   1 {-# LANGUAGE TypeFamilies #-}
   2 module Hjugement.Majority where
   3
   4 import Data.Function (on)
   5 import Data.List
   6 import Data.Map.Strict (Map)
   7 import Data.Maybe (fromMaybe)
   8 import Data.Ord (Down(..))
   9 import Data.Semigroup (Semigroup(..))
  10 import Data.Set (Set)
  11 import GHC.Exts (IsList(..))
  12 import qualified Data.Map.Strict as Map
  13 import qualified Data.Set as Set
  14
  15 -- * Type 'Choices'
  16 type Choices prop = Set prop
  17
  18 -- | Return a set of 'Choices' by enumerating the alternatives of its type. Useful on sum types.
  19 choices :: (Bounded prop , Enum prop , Ord prop) => Choices prop
  20 choices = Set.fromList (enumFrom minBound)
  21
  22 -- * Type 'Scale'
  23 data Scale grade
  24  =   Scale
  25  {   scaleGrades :: Set grade
  26      -- ^ How many 'grade's should be used?
  27      -- A greater number of 'grade's permits a finer distinction but demands
  28      -- a higher degree of expertise and discernment.
  29      -- The optimal number is the highest number of 'grade's that constitutes a common language,
  30      -- that is, that allows 'judge's to make absolute judgments.
  31      -- Too little 'grade's may lead too often to ties.
  32      --
  33      -- Note, however, that if the inputs or grades depend on the set of choices,
  34      -- i.e. if judges change their grades when choices are added or dropped,
  35      -- then the Arrow paradox cannot be avoided.
  36      -- To avoid this the scale must be fixed and absolute
  37      -- so that more or fewer choices does not change
  38      -- the inputs or messages of other choices.
  39  ,   scaleDefault :: grade
  40      -- ^ For instance, when a 'judge' gives no 'grade' or has “no opinion”,
  41      -- 'scaleDefault' could mean that the 'judge' chooses “To Reject” the choice:
  42      -- the rationale being that a 'judge' having “no opinion”
  43      -- concerning a choice has not even taken the time to evaluate it
  44      -- and thus has implicitly rejected it.
  45  } deriving (Eq, Show)
  46
  47 -- | Return a 'Scale' by enumerating the alternatives of its type. Useful on sum types.
  48 scale :: (Bounded grade, Enum grade, Ord grade) => Scale grade
  49 scale = Scale { scaleGrades  = Set.fromList (enumFrom minBound)
  50               , scaleDefault = toEnum 0
  51               }
  52
  53 -- | Return a 'Scale' from a list of 'grade's and a default 'grade'.
  54 -- Useful with 'grade's whose type has no 'Ord' instance
  55 -- or a different one than the one wanted.
  56 scaleOfList :: Eq a => [a] -> a -> Scale Int
  57 scaleOfList gs dg = Scale is di
  58         where
  59         is = fromList $ findIndices (const True) gs
  60         di = fromMaybe (error "default grade not in the scale") $ dg`elemIndex`gs
  61
  62 gradeOfScale :: [a] -> Int -> a
  63 gradeOfScale = (!!)
  64
  65 -- * Type 'Jury'
  66 type Jury judge = Set judge
  67
  68 -- | Return a 'Jury' by enumerating the alternatives of its type. Useful on sum types.
  69 jury :: (Bounded judge , Enum judge , Ord judge) => Jury judge
  70 jury = Set.fromList (enumFrom minBound)
  71
  72 -- * Type 'Opinion'
  73 -- | Profile of opinions of one single 'judge' about some 'prop'ositions.
  74 type Opinion prop grade = Map prop grade
  75
  76 -- | Construct the 'Opinion' of a 'judge' about some 'prop'ositions implicit from their type.
  77 opinion :: (Enum prop, Bounded prop, Ord prop) =>
  78            judge -> [grade] ->
  79            (judge, Opinion prop grade)
  80 opinion j gs = (j, Map.fromList (zip (enumFrom minBound) gs))
  81
  82 -- ** Type 'Opinions'
  83 -- | Profile of opinions of some 'judge's about some 'prop'ositions.
  84 newtype Opinions prop grade judge = Opinions (Map judge (Opinion prop grade))
  85  deriving (Eq, Show)
  86 instance (Ord judge, Show judge) => IsList (Opinions prop grade judge) where
  87         type Item (Opinions prop grade judge) = (judge, Opinion prop grade)
  88         fromList = Opinions . Map.fromListWithKey
  89                  (\k _x _y -> error $ "duplicate opinion for judge: " <> show k)
  90         toList (Opinions os) = toList os
  91
  92 -- * Type 'Merit'
  93 -- | Profile of merits about a choice.
  94 newtype Merit grade = Merit (Map grade Count)
  95  deriving (Eq, Show)
  96 type Count = Int
  97
  98 instance Ord grade => Semigroup (Merit grade) where
  99         Merit x <> Merit y = Merit (Map.unionWith (+) x y)
 100 instance Ord grade => Ord (Merit grade) where
 101         compare = compare `on` majorityValue
 102 instance (Ord grade, Show grade) => IsList (Merit grade) where
 103         type Item (Merit grade) = (grade, Count)
 104         fromList = Merit . Map.fromListWithKey
 105                  (\g _x _y -> error $ "duplicate grade in merit: " <> show g)
 106         toList (Merit cs) = toList cs
 107
 108 -- | @merit grad@ returns the 'Merit'
 109 -- of a single 'choice' by some 'judge's.
 110 merit :: (Ord grade, Ord prop) =>
 111          Scale grade -> prop -> Opinions prop grade judge ->
 112          Merit grade
 113 merit scal prop (Opinions os) = foldr insertOpinion defaultMerit os
 114         where
 115         insertOpinion op (Merit m) = Merit (Map.insertWith (+) g 1 m)
 116                 where g = Map.findWithDefault (scaleDefault scal) prop op
 117         defaultMerit = Merit (const 0 `Map.fromSet` scaleGrades scal)
 118
 119 -- ** Type 'Merits'
 120 -- | Profile of merits about some choices.
 121 newtype Merits prop grade = Merits (Map prop (Merit grade))
 122  deriving (Eq, Show)
 123 instance (Ord grade, Ord prop) => Semigroup (Merits prop grade) where
 124         Merits x <> Merits y = Merits (Map.unionWith (<>) x y)
 125 instance (Ord prop, Show prop) => IsList (Merits prop grade) where
 126         type Item (Merits prop grade) = (prop, Merit grade)
 127         fromList = Merits . Map.fromListWithKey
 128                  (\p _x _y -> error $ "duplicate choice in merits: " <> show p)
 129         toList (Merits cs) = toList cs
 130
 131 -- | @merit scal props opins@ returns the 'Merits'
 132 -- of the 'Choices' 'props'
 133 -- as judged by the 'Opinions' 'opins'
 134 -- on the 'Scale' 'scal'.
 135 merits :: (Ord grade, Ord prop) =>
 136           Scale grade -> Choices prop -> Opinions prop grade judge ->
 137           Merits prop grade
 138 merits scal props (Opinions os) = foldr ((<>) . meritsFromOpinion) defaultMerits os
 139         where
 140         meritsFromOpinion = Merits . (Merit . (`Map.singleton` 1) <$>) . (<> defaultOpinion)
 141         defaultOpinion    = const (scaleDefault scal) `Map.fromSet` props
 142         defaultMerits     = Merits (const defaultMerit `Map.fromSet` props)
 143         defaultMerit      = Merit (const 0 `Map.fromSet` scaleGrades scal)
 144
 145 -- * Type 'Value'
 146 -- | A 'Value' is a compressed list of 'grade's,
 147 -- where each 'grade' is associated with the 'Count'
 148 -- by which it would be replicated in situ if decompressed.
 149 newtype Value grade = Value [(grade,Count)]
 150  deriving (Eq, Show)
 151 -- | 'compare' lexicographically as if the 'Value's
 152 -- were decompressed.
 153 instance Ord grade => Ord (Value grade) where
 154         Value []`compare`Value [] = EQ
 155         Value []`compare`Value ys | all ((==0) . snd) ys = EQ
 156                                   | otherwise            = LT
 157         Value xs`compare`Value [] | all ((==0) . snd) xs = EQ
 158                                   | otherwise            = GT
 159         sx@(Value ((x,cx):xs)) `compare` sy@(Value ((y,cy):ys)) =
 160                 case cx`compare`cy of
 161                  _ | cx == 0 && cy == 0 -> Value xs`compare`Value ys
 162                  _ | cx <= 0 -> Value xs`compare`sy
 163                  _ | cy <= 0 -> sx`compare`Value ys
 164                  EQ -> x`compare`y <> Value xs`compare`Value ys
 165                  LT -> x`compare`y <> Value xs`compare`Value((y,cy-cx):ys)
 166                  GT -> x`compare`y <> Value((x,cx-cy):xs)`compare`Value ys
 167
 168 -- | The 'majorityValue' is the list of the 'majorityGrade's
 169 -- of a choice, each one replicated their associated 'Count' times,
 170 -- from the most consensual to the least,
 171 -- ie. by removing the 'grade' of the previous 'majorityGrade'
 172 -- to compute the next.
 173 majorityValue :: Ord grade => Merit grade -> Value grade
 174 majorityValue (Merit m) = Value (go m)
 175         where
 176         go gs = case snd (Map.foldlWithKey untilMajGrade (0,[]) gs) of
 177                  [] -> []
 178                  gw@(g,_):_ -> gw:go (Map.delete g gs)
 179                 where
 180                 tot = sum gs
 181                 untilMajGrade (t,[]) g c | 2*tc >= tot = (tc,[(g,c)])
 182                                          | otherwise   = (tc,[])
 183                                          where tc = t+c
 184                 untilMajGrade acc _g _c = acc
 185
 186 -- | The 'majorityGrade' is the lower middlemost
 187 -- (also known as median by experts) of the 'grade's
 188 -- given to a choice by the 'judge's.
 189 --
 190 -- It is the highest 'grade' approved by an absolute majority of the 'judge's:
 191 -- more than 50% of the 'judge's give the choice at least a 'grade' of 'majorityGrade',
 192 -- but every 'grade' lower than 'majorityGrade' is rejected by an absolute majority
 193 -- Thus the 'majorityGrade' of a choice
 194 -- is the final 'grade' wished by the majority.
 195 --
 196 -- The 'majorityGrade' is necessarily a word that belongs to 'grades',
 197 -- and it has an absolute meaning.
 198 --
 199 -- When the number of 'judge's is even, there is a middle-interval
 200 -- (which can, of course, be reduced to a single 'grade'
 201 -- if the two middle 'grade's are the same),
 202 -- then the 'majorityGrade' is the lowest 'grade' of the middle-interval
 203 -- (the “lower middlemost” when there are two in the middle),
 204 -- which is the only one which respects consensus:
 205 -- any other choice whose grades are all within this middle-interval,
 206 -- has a 'majorityGrade' which is greater or equal to this lower middlemost.
 207 majorityGrade :: Ord grade => Merit grade -> grade
 208 majorityGrade m = fst (head gs) where Value gs = majorityValue m
 209
 210 -- * Type 'Ranking'
 211
 212 type Ranking prop = [prop]
 213
 214 -- | The 'majorityRanking' ranks all the choices on the basis of their 'grade's.
 215 --
 216 -- Choice A ranks higher than choice B in the 'majorityRanking'
 217 -- if and only if A’s 'majorityValue' is lexicographically above B’s.
 218 -- There can be no tie unless two choices have precisely the same 'majorityValue's.
 219 majorityRanking :: Ord grade => Merits prop grade -> Ranking prop
 220 majorityRanking = map fst . sortBy (compare `on` Down . snd) . majorityValueByChoice
 221
 222 majorityValueByChoice :: Ord grade => Merits prop grade -> [(prop, Value grade)]
 223 majorityValueByChoice (Merits ms) = Map.toAscList (majorityValue <$> ms)