Hjugement/MJ.hs

   1 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   2 {-# LANGUAGE TypeFamilies #-}
   3 module Hjugement.MJ where
   4
   5 import Data.Bool
   6 import Data.Eq (Eq(..))
   7 import Data.Function (($), (.), on)
   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.Ratio (Rational)
  13 import Data.Ord (Ord(..), Ordering(..), Down(..))
  14 import Data.Semigroup (Semigroup(..))
  15 import Data.Set (Set)
  16 import Data.Tuple (fst, snd, curry)
  17 import Prelude (Bounded(..), Enum(..), Num(..), Integer, error)
  18 import GHC.Exts (IsList(..))
  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
  24
  25 -- * Type 'Choices'
  26 type Choices = HS.HashSet
  27
  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
  31
  32 -- * Type 'Grades'
  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.
  39 --
  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.
  46 type Grades = Set
  47
  48 grades :: [grade] -> Grades (Ranked grade)
  49 grades = Set.fromList . zipRank
  50
  51 -- * Type 'Ranked'
  52 -- | Helper type to rank data without a good 'Ord' instance.
  53 newtype Ranked a = Ranked (Integer, 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
  59
  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..]
  64
  65 rankKey :: [(k, a)] -> [(Ranked k, a)]
  66 rankKey = List.zipWith (\i (k,a) -> (Ranked (i,k),a)) [0..]
  67
  68 unRank :: Ranked a -> a
  69 unRank (Ranked (_i, x)) = x
  70
  71 -- | Return the 'Set' enumerating the alternatives
  72 -- of its type parameter. Useful on sum types.
  73 enum :: (Bounded a, Enum a, Ord a) => Set a
  74 enum = Set.fromList $ enumFrom minBound
  75
  76 -- * Type 'Judges'
  77 -- | Map each 'judge' to its default 'grade'
  78 -- (usually the same for all 'judge's but not necessarily).
  79 --
  80 -- For instance, when a 'judge' gives no 'grade' or has “no opinion”,
  81 -- this default grade could mean that the 'judge' chooses “To Reject” the 'choice':
  82 -- the rationale being that a 'judge' having “no opinion”
  83 -- concerning a 'choice' has not even taken the time to evaluate it
  84 -- and thus has implicitly rejected it.
  85 type Judges = HM.HashMap
  86
  87 judges ::
  88  Eq judge =>
  89  Hashable judge =>
  90  [judge] -> grade -> Judges judge grade
  91 judges js dg = HM.fromList $ (\j -> (j, dg)) <$> js
  92
  93 -- * Type 'Opinions'
  94 -- | Profile of opinions of some 'judge's about a single 'choice'.
  95 type Opinions judge grade = HM.HashMap judge (Distribution grade)
  96
  97 -- | '(ok, ko) = opinions js os' returns:
  98 --
  99 -- * in 'ok' the opinions of the 'judge's 'js' updated by those in 'os',
 100 -- * in 'ko' the opinions of 'judge's not in 'js'.
 101 opinions ::
 102  Eq judge =>
 103  Hashable judge =>
 104  Judges judge grade ->
 105  Opinions judge grade ->
 106  ( Opinions judge grade
 107  , HS.HashSet judge )
 108 opinions js os =
 109         ( HM.union os $ singleGrade <$> js
 110         , HS.fromMap $ (() <$) $ os`HM.difference`js )
 111
 112 -- ** Type 'Distribution'
 113 -- | Usually, a 'judge' gives a 'singleGrade' to a given 'choice'.
 114 -- However, when applying the Majority Judgment to a 'Tree' of 'Section's,
 115 -- what a 'judge' gives to a parent 'Section'
 116 -- is composed by the 'grade's he or she has given
 117 -- to the sub-'Section's, and those can be different.
 118 -- In that case, each 'grade' given to a sub-'Section' contributes to a 'Share'
 119 -- of the parent 'Section' which therefore is not necessarily a 'singleGrade',
 120 -- but more generally a 'Distribution' of 'grade's.
 121 -- And the sub-'Section's can actually themselves have sub-'Section's,
 122 -- hence not being given a 'grade', but a 'Distribution' of 'grade's too.
 123 type Distribution grade = Map grade Share
 124
 125 singleGrade :: grade -> Distribution grade
 126 singleGrade = (`Map.singleton` 1)
 127
 128 -- *** Type 'Share'
 129 -- | Usually a 'judge' attributes a 'singleGrade' to a given 'choice',
 130 -- and then the 'Share' of this 'grade' is 1.
 131 -- However, when introducing vote colleges (giving more power to some 'judge's),
 132 -- or when introducing 'Section's (decomposing a judgment into several sub-judgments),
 133 -- only a percent of 'grade' can be attributed by a 'judge' to a given 'choice'.
 134 -- This is what a 'Share' is used for.
 135 type Share = Rational
 136  -- FIXME: newtype checking >= 0
 137
 138 -- ** Type 'OpinionsByChoice'
 139 -- | Profile of opinions of some 'Judges' about some 'choice's.
 140 type OpinionsByChoice choice judge grade = HM.HashMap choice (Opinions judge grade)
 141
 142 opinionsByChoice ::
 143  Eq choice =>
 144  Hashable choice =>
 145  [(choice, Opinions judge grade)] ->
 146  OpinionsByChoice choice judge grade
 147 opinionsByChoice = HM.fromList
 148
 149 -- * Type 'Merit'
 150 -- | Profile of merit about a single 'choice'.
 151 newtype Merit grade = Merit (Map grade Share)
 152  deriving (Eq, Show)
 153 instance Ord grade => Semigroup (Merit grade) where
 154         Merit x <> Merit y = Merit (Map.unionWith (+) x y)
 155 instance Ord grade => Ord (Merit grade) where
 156         compare = compare `on` majorityValue
 157 instance (Ord grade, Show grade) => IsList (Merit grade) where
 158         type Item (Merit grade) = (grade, Share)
 159         fromList = Merit . Map.fromListWithKey
 160                  (\g _x _y -> error $ "duplicate grade in merit: " <> show g)
 161         toList (Merit cs) = toList cs
 162
 163 -- | @merit os@ returns the 'Merit' given by opinions 'os'
 164 merit ::
 165  Ord grade =>
 166  Opinions judge grade ->
 167  Merit grade
 168 merit = foldr insertOpinion $ Merit $ Map.empty
 169         -- TODO: maybe count by making g passes
 170         where
 171         insertOpinion dist (Merit m) =
 172                 Merit $
 173                 Map.foldlWithKey
 174                  (\acc g s -> Map.insertWith (+) g s acc)
 175                  m dist
 176
 177 -- ** Type 'MeritByChoice'
 178 -- | Profile of merit about some 'choice's.
 179 newtype MeritByChoice choice grade = MeritByChoice (HM.HashMap choice (Merit grade))
 180  deriving (Eq, Show)
 181 instance (Eq choice, Hashable choice, Ord grade) => Semigroup (MeritByChoice choice grade) where
 182         MeritByChoice x <> MeritByChoice y = MeritByChoice (HM.unionWith (<>) x y)
 183 instance (Eq choice, Hashable choice, Show choice) => IsList (MeritByChoice choice grade) where
 184         type Item (MeritByChoice choice grade) = (choice, Merit grade)
 185         fromList = MeritByChoice . HM.fromListWith
 186                  (\_x _y -> error $ "duplicate choice in merits")
 187         toList (MeritByChoice cs) = toList cs
 188
 189 -- | @meritByChoice gs cs os@ returns the 'Merit's
 190 -- given to 'choice's 'cs' by opinions 'os' from the 'Judges' 'js' on the 'Grades' 'gs'.
 191 meritByChoice ::
 192  (Ord grade, Eq choice, Hashable choice) =>
 193  OpinionsByChoice choice judge grade ->
 194  MeritByChoice choice grade
 195 meritByChoice os = MeritByChoice $ merit <$> os
 196
 197 -- * Type 'MajorityValue'
 198 -- | A 'MajorityValue' is a compressed list of 'grade's,
 199 -- where each 'grade' is associated with the 'Share'
 200 -- by which it would be replicated in situ if decompressed.
 201 newtype MajorityValue grade = MajorityValue [(grade,Share)]
 202  deriving (Eq, Show)
 203 -- | 'compare' lexicographically as if the 'MajorityValue's
 204 -- were decompressed.
 205 instance Ord grade => Ord (MajorityValue grade) where
 206         MajorityValue []`compare`MajorityValue [] = EQ
 207         MajorityValue []`compare`MajorityValue ys | all ((==0) . snd) ys = EQ
 208                                                   | otherwise            = LT
 209         MajorityValue xs`compare`MajorityValue [] | all ((==0) . snd) xs = EQ
 210                                                   | otherwise            = GT
 211         mx@(MajorityValue ((x,sx):xs)) `compare` my@(MajorityValue ((y,sy):ys)) =
 212                 case sx`compare`sy of
 213                  _ | sx == 0 && sy == 0 -> MajorityValue xs`compare`MajorityValue ys
 214                  _ | sx <= 0 -> MajorityValue xs`compare`my
 215                  _ | sy <= 0 -> mx`compare`MajorityValue ys
 216                  EQ -> x`compare`y <> MajorityValue xs`compare`MajorityValue ys
 217                  LT -> x`compare`y <> MajorityValue xs`compare`MajorityValue((y,sy-sx):ys)
 218                  GT -> x`compare`y <> MajorityValue((x,sx-sy):xs)`compare`MajorityValue ys
 219
 220 -- | The 'majorityValue' is the list of the 'majorityGrade's
 221 -- of a 'choice', each one replicated their associated 'Share' times,
 222 -- from the most consensual to the least,
 223 -- ie. by removing the 'grade' of the previous 'majorityGrade'
 224 -- to compute the next.
 225 majorityValue :: Ord grade => Merit grade -> MajorityValue grade
 226 majorityValue (Merit m) = MajorityValue (go m)
 227         where
 228         go :: Ord grade => Map grade Share -> [(grade, Share)]
 229         go gs = case snd (Map.foldlWithKey untilMajGrade (0,[]) gs) of
 230                  [] -> []
 231                  gw@(majGrade,_):_ -> gw:go (Map.delete majGrade gs)
 232                 where
 233                 tot = sum gs
 234                 untilMajGrade (t,[]) g s | 2*tc >= tot = (tc,[(g,s)])
 235                                          | otherwise   = (tc,[])
 236                                          where tc = t+s
 237                 untilMajGrade acc _g _s = acc
 238
 239 -- | The 'majorityGrade' is the lower middlemost
 240 -- (also known as median by experts) of the 'grade's
 241 -- given to a 'choice' by the 'Judges'.
 242 --
 243 -- It is the highest 'grade' approved by an absolute majority of the 'Judges':
 244 -- more than 50% of the 'Judges' give the 'choice' at least a 'grade' of 'majorityGrade',
 245 -- but every 'grade' lower than 'majorityGrade' is rejected by an absolute majority
 246 -- Thus the 'majorityGrade' of a 'choice'
 247 -- is the final 'grade' wished by the majority.
 248 --
 249 -- The 'majorityGrade' is necessarily a word that belongs to 'grades',
 250 -- and it has an absolute meaning.
 251 --
 252 -- When the number of 'Judges' is even, there is a middle-interval
 253 -- (which can, of course, be reduced to a single 'grade'
 254 -- if the two middle 'grade's are the same),
 255 -- then the 'majorityGrade' is the lowest 'grade' of the middle-interval
 256 -- (the “lower middlemost” when there are two in the middle),
 257 -- which is the only one which respects consensus:
 258 -- any other 'choice' whose grades are all within this middle-interval,
 259 -- has a 'majorityGrade' which is greater or equal to this lower middlemost.
 260 majorityGrade :: Ord grade => Merit grade -> grade
 261 majorityGrade m = fst (List.head gs) where MajorityValue gs = majorityValue m
 262
 263 -- * Type 'MajorityRanking'
 264 type MajorityRanking choice grade = [(choice, MajorityValue grade)]
 265
 266 majorityValueByChoice :: Ord grade => MeritByChoice choice grade -> HM.HashMap choice (MajorityValue grade)
 267 majorityValueByChoice (MeritByChoice ms) = majorityValue <$> ms
 268
 269 -- | The 'majorityRanking' ranks all the 'choice's on the basis of their 'grade's.
 270 --
 271 -- Choice A ranks higher than 'choice' B in the 'majorityRanking'
 272 -- if and only if A’s 'majorityValue' is lexicographically above B’s.
 273 -- There can be no tie unless two 'choice's have precisely the same 'majorityValue's.
 274 majorityRanking :: Ord grade => MeritByChoice choice grade -> MajorityRanking choice grade
 275 majorityRanking = List.sortOn (Down . snd) . HM.toList . majorityValueByChoice