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 (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 rank :: Ranked a -> Integer
  69 rank (Ranked (r, _x)) = r
  70
  71 unRank :: Ranked a -> a
  72 unRank (Ranked (_r, x)) = x
  73
  74 -- | Return the 'Set' enumerating the alternatives
  75 -- of its type parameter. Useful on sum types.
  76 enum :: (Bounded a, Enum a, Ord a) => Set a
  77 enum = Set.fromList $ enumFrom minBound
  78
  79 -- * Type 'Judges'
  80 -- | Map each 'judge' to its default 'grade'
  81 -- (usually the same for all 'judge's but not necessarily).
  82 --
  83 -- For instance, when a 'judge' gives no 'grade' or has “no opinion”,
  84 -- this default grade could mean that the 'judge' chooses “To Reject” the 'choice':
  85 -- the rationale being that a 'judge' having “no opinion”
  86 -- concerning a 'choice' has not even taken the time to evaluate it
  87 -- and thus has implicitly rejected it.
  88 type Judges = HM.HashMap
  89
  90 judges ::
  91  Eq judge =>
  92  Hashable judge =>
  93  [judge] -> grade -> Judges judge grade
  94 judges js dg = HM.fromList $ (\j -> (j, dg)) <$> js
  95
  96 -- * Type 'Opinions'
  97 -- | Profile of opinions of some 'judge's about a single 'choice'.
  98 type Opinions judge grade = HM.HashMap judge (Distribution grade)
  99
 100 -- | @(ok, ko) = 'opinions' js os@ returns:
 101 --
 102 -- * in 'ok' the opinions of the 'judge's 'js' updated by those in 'os',
 103 -- * in 'ko' the opinions of 'judge's not in 'js'.
 104 opinions ::
 105  Eq judge =>
 106  Hashable judge =>
 107  Judges judge grade ->
 108  Opinions judge grade ->
 109  ( Opinions judge grade
 110  , HS.HashSet judge )
 111 opinions js os =
 112         ( HM.union os $ singleGrade <$> js
 113         , HS.fromMap $ (() <$) $ os`HM.difference`js )
 114
 115 -- ** Type 'Distribution'
 116 -- | Usually, a 'judge' gives a 'singleGrade' to a given 'choice'.
 117 -- However, when applying the Majority Judgment to a 'Tree' of 'Section's,
 118 -- what a 'judge' gives to a parent 'Section'
 119 -- is composed by the 'grade's he or she has given
 120 -- to the sub-'Section's, and those can be different.
 121 -- In that case, each 'grade' given to a sub-'Section' contributes to a 'Share'
 122 -- of the parent 'Section' which therefore is not necessarily a 'singleGrade',
 123 -- but more generally a 'Distribution' of 'grade's.
 124 -- And the sub-'Section's can actually themselves have sub-'Section's,
 125 -- hence not being given a 'grade', but a 'Distribution' of 'grade's too.
 126 type Distribution grade = Map grade Share
 127
 128 singleGrade :: grade -> Distribution grade
 129 singleGrade = (`Map.singleton` 1)
 130
 131 -- *** Type 'Share'
 132 -- | Usually a 'judge' attributes a 'singleGrade' to a given 'choice',
 133 -- and then the 'Share' of this 'grade' is 1.
 134 -- However, when introducing vote colleges (giving more power to some 'judge's),
 135 -- or when introducing 'Section's (decomposing a judgment into several sub-judgments),
 136 -- it becomes possible that only a percentage of 'grade'
 137 -- is attributed by a 'judge' to a given 'choice'.
 138 -- This is what a 'Share' is used for.
 139 type Share = Rational
 140  -- FIXME: newtype checking >= 0
 141
 142 -- ** Type 'OpinionsByChoice'
 143 -- | Profile of opinions of some 'Judges' about some 'choice's.
 144 type OpinionsByChoice choice judge grade = HM.HashMap choice (Opinions judge grade)
 145
 146 opinionsByChoice ::
 147  Eq choice =>
 148  Hashable choice =>
 149  [(choice, Opinions judge grade)] ->
 150  OpinionsByChoice choice judge grade
 151 opinionsByChoice = HM.fromList
 152
 153 -- * Type 'Merit'
 154 -- | Profile of merit about a single 'choice'.
 155 newtype Merit grade = Merit { unMerit :: Map grade Share }
 156  deriving (Eq, Show)
 157 instance Ord grade => Semigroup (Merit grade) where
 158         Merit x <> Merit y = Merit (Map.unionWith (+) x y)
 159 instance (Ord grade, Show grade) => IsList (Merit grade) where
 160         type Item (Merit grade) = (grade, Share)
 161         fromList = Merit . Map.fromListWithKey
 162                  (\g _x _y -> error $ "duplicate grade in merit: " <> show g)
 163         toList (Merit cs) = toList cs
 164
 165 -- | @merit os@ returns the 'Merit' given by opinions 'os'
 166 merit ::
 167  Ord grade =>
 168  Foldable opinions =>
 169  opinions (Distribution grade) ->
 170  Merit grade
 171 merit = foldr insertOpinion (Merit Map.empty)
 172         -- TODO: maybe count by making g passes
 173         where
 174         insertOpinion dist (Merit m) =
 175                 Merit $
 176                 Map.foldlWithKey
 177                  (\acc g s -> Map.insertWith (+) g s acc)
 178                  m dist
 179
 180 meritFromList ::
 181  Ord grade =>
 182  Foldable opinions =>
 183  Functor opinions =>
 184  opinions grade ->
 185  Merit grade
 186 meritFromList = merit . (singleGrade <$>)
 187
 188 -- | 'normalizeMerit m' multiply all 'Share's
 189 -- by their least common denominator
 190 -- to get integral 'Share's.
 191 normalizeMerit :: Merit grade -> Merit grade
 192 normalizeMerit (Merit ms) = Merit $ (lcm' *) <$> ms
 193         where lcm' = foldr lcm 1 (denominator <$> ms) % 1
 194
 195 -- ** Type 'MeritByChoice'
 196 -- | Profile of merit about some 'choice's.
 197 newtype MeritByChoice choice grade
 198  =      MeritByChoice { unMeritByChoice :: HM.HashMap choice (Merit grade) }
 199  deriving (Eq, Show)
 200 instance (Eq choice, Hashable choice, Ord grade) => Semigroup (MeritByChoice choice grade) where
 201         MeritByChoice x <> MeritByChoice y = MeritByChoice (HM.unionWith (<>) x y)
 202 instance (Eq choice, Hashable choice, Show choice) => IsList (MeritByChoice choice grade) where
 203         type Item (MeritByChoice choice grade) = (choice, Merit grade)
 204         fromList = MeritByChoice . HM.fromListWith
 205                  (\_x _y -> error $ "duplicate choice in merits")
 206         toList (MeritByChoice cs) = toList cs
 207
 208 -- | @meritByChoice gs cs os@ returns the 'Merit's
 209 -- given to 'choice's 'cs' by opinions 'os' from the 'Judges' 'js' on the 'Grades' 'gs'.
 210 meritByChoice ::
 211  (Ord grade, Eq choice, Hashable choice) =>
 212  OpinionsByChoice choice judge grade ->
 213  MeritByChoice choice grade
 214 meritByChoice os = MeritByChoice $ merit <$> os