hjugement/Majority/Merit.hs

   1 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   2 {-# LANGUAGE TypeFamilies #-} -- NOTE: for IsList
   3 module Majority.Merit where
   4
   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(..))
  15 import Data.Set (Set)
  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
  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 (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
  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 -- ** Type 'G'
  69 -- | Rank of a grade.
  70 type G = Integer
  71
  72 rank :: Ranked a -> G
  73 rank (Ranked (r, _x)) = r
  74
  75 unRank :: Ranked a -> a
  76 unRank (Ranked (_r, x)) = x
  77
  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
  82
  83 -- * Type 'Judges'
  84 -- | Map each 'judge' to its default 'grade'
  85 -- (usually the same for all 'judge's but not necessarily).
  86 --
  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
  93
  94 judges ::
  95  Eq judge =>
  96  Hashable judge =>
  97  [judge] -> grade -> Judges judge grade
  98 judges js dg = HM.fromList $ (\j -> (j, dg)) <$> js
  99
 100 -- * Type 'Opinions'
 101 -- | Profile of opinions of some 'judge's about a single 'choice'.
 102 type Opinions judge grade = HM.HashMap judge (Distribution grade)
 103
 104 -- | @(ok, ko) = 'opinions' js os@ returns:
 105 --
 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'.
 108 opinions ::
 109  Eq judge =>
 110  Hashable judge =>
 111  Judges judge grade ->
 112  Opinions judge grade ->
 113  ( Opinions judge grade
 114  , HS.HashSet judge )
 115 opinions js os =
 116         ( HM.union os $ singleGrade <$> js
 117         , HS.fromMap $ (() <$) $ os`HM.difference`js )
 118
 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
 131
 132 singleGrade :: grade -> Distribution grade
 133 singleGrade = (`Map.singleton` 1)
 134
 135 -- *** Type 'Share'
 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
 145
 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)
 149
 150 opinionsByChoice ::
 151  Eq choice =>
 152  Hashable choice =>
 153  [(choice, Opinions judge grade)] ->
 154  OpinionsByChoice choice judge grade
 155 opinionsByChoice = HM.fromList
 156
 157 -- * Type 'Merit'
 158 -- | Profile of merit about a single 'choice'.
 159 newtype Merit grade = Merit { unMerit :: Map grade Share }
 160  deriving (Eq, Show)
 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
 168
 169 -- | @merit os@ returns the 'Merit' given by opinions 'os'
 170 merit ::
 171  Ord grade =>
 172  Foldable opinions =>
 173  opinions (Distribution grade) ->
 174  Merit grade
 175 merit = foldr insertOpinion (Merit Map.empty)
 176         -- TODO: maybe count by making g passes
 177         where
 178         insertOpinion dist (Merit m) =
 179                 Merit $
 180                 Map.foldlWithKey
 181                  (\acc g s -> Map.insertWith (+) g s acc)
 182                  m dist
 183
 184 meritFromList ::
 185  Ord grade =>
 186  Foldable opinions =>
 187  Functor opinions =>
 188  opinions grade ->
 189  Merit grade
 190 meritFromList = merit . (singleGrade <$>)
 191
 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
 198
 199 -- ** Type 'MeritByChoice'
 200 -- | Profile of merit about some 'choice's.
 201 newtype MeritByChoice choice grade
 202  =      MeritByChoice { unMeritByChoice :: HM.HashMap choice (Merit grade) }
 203  deriving (Eq, Show)
 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
 211
 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'.
 214 meritByChoice ::
 215  (Ord grade, Eq choice, Hashable choice) =>
 216  OpinionsByChoice choice judge grade ->
 217  MeritByChoice choice grade
 218 meritByChoice os = MeritByChoice $ merit <$> os