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.Function (($), (.))
   7 import Data.Functor (Functor, (<$>), (<$))
   8 import Data.Hashable (Hashable)
   9 import Data.List as List
  10 import Data.Map.Strict (Map)
  11 import Data.Ord (Ord(..))
  12 import Data.Ratio (Rational)
  13 import Data.Semigroup (Semigroup(..))
  14 import Data.Set (Set)
  15 import Data.Tuple (curry)
  16 import GHC.Exts (IsList(..))
  17 import Prelude (Bounded(..), Enum(..), Num(..), Integer, error)
  18 import Text.Show (Show(..))
  19 import qualified Data.HashMap.Strict as HM
  20 import qualified Data.HashSet as HS
  21 import qualified Data.Map.Strict as Map
  22 import qualified Data.Set as Set
  23
  24 -- * Type 'Choices'
  25 type Choices = HS.HashSet
  26
  27 -- | Return a set of 'Choices' by enumerating the alternatives of its type. Useful on sum types.
  28 choices :: (Bounded choice , Enum choice , Eq choice, Hashable choice) => Choices choice
  29 choices = HS.fromList $ enumFrom minBound
  30
  31 -- * Type 'Grades'
  32 -- | How many 'grade's should be used?
  33 -- A greater number of 'grade's permits a finer distinction but demands
  34 -- a higher degree of expertise and discernment.
  35 -- The optimal number is the highest number of 'grade's that constitutes a common language,
  36 -- that is, that allows 'Judges' to make absolute judgments.
  37 -- Too little 'grade's may lead too often to ties.
  38 --
  39 -- Note, however, that if the inputs or grades depend on the set of 'choice's,
  40 -- i.e. if judges change their grades when 'choice's are added or dropped,
  41 -- then the Arrow paradox cannot be avoided.
  42 -- To avoid this the scale of grades must be fixed and absolute
  43 -- so that more or fewer 'choice's does not change
  44 -- the inputs or messages of other 'choice's.
  45 type Grades = Set
  46
  47 grades :: [grade] -> Grades (Ranked grade)
  48 grades = Set.fromList . zipRank
  49
  50 -- * Type 'Ranked'
  51 -- | Helper type to rank data without a good 'Ord' instance.
  52 newtype Ranked a = Ranked (Integer, a)
  53  deriving (Show,Functor)
  54 instance Eq (Ranked a) where
  55         Ranked (x,_) == Ranked (y,_) = x==y
  56 instance Ord (Ranked a) where
  57         Ranked (x,_) `compare` Ranked (y,_) = x`compare`y
  58
  59 -- | @'zipRank' xs@ returns a list with the items of 'xs' wrapped
  60 -- so that they are 'compare'able according to their position into 'xs'.
  61 zipRank :: [a] -> [Ranked a]
  62 zipRank = List.zipWith (curry Ranked) [0..]
  63
  64 rankKey :: [(k, a)] -> [(Ranked k, a)]
  65 rankKey = List.zipWith (\i (k,a) -> (Ranked (i,k),a)) [0..]
  66
  67 unRank :: Ranked a -> a
  68 unRank (Ranked (_i, x)) = x
  69
  70 -- | Return the 'Set' enumerating the alternatives
  71 -- of its type parameter. Useful on sum types.
  72 enum :: (Bounded a, Enum a, Ord a) => Set a
  73 enum = Set.fromList $ enumFrom minBound
  74
  75 -- * Type 'Judges'
  76 -- | Map each 'judge' to its default 'grade'
  77 -- (usually the same for all 'judge's but not necessarily).
  78 --
  79 -- For instance, when a 'judge' gives no 'grade' or has “no opinion”,
  80 -- this default grade could mean that the 'judge' chooses “To Reject” the 'choice':
  81 -- the rationale being that a 'judge' having “no opinion”
  82 -- concerning a 'choice' has not even taken the time to evaluate it
  83 -- and thus has implicitly rejected it.
  84 type Judges = HM.HashMap
  85
  86 judges ::
  87  Eq judge =>
  88  Hashable judge =>
  89  [judge] -> grade -> Judges judge grade
  90 judges js dg = HM.fromList $ (\j -> (j, dg)) <$> js
  91
  92 -- * Type 'Opinions'
  93 -- | Profile of opinions of some 'judge's about a single 'choice'.
  94 type Opinions judge grade = HM.HashMap judge (Distribution grade)
  95
  96 -- | @(ok, ko) = 'opinions' js os@ returns:
  97 --
  98 -- * in 'ok' the opinions of the 'judge's 'js' updated by those in 'os',
  99 -- * in 'ko' the opinions of 'judge's not in 'js'.
 100 opinions ::
 101  Eq judge =>
 102  Hashable judge =>
 103  Judges judge grade ->
 104  Opinions judge grade ->
 105  ( Opinions judge grade
 106  , HS.HashSet judge )
 107 opinions js os =
 108         ( HM.union os $ singleGrade <$> js
 109         , HS.fromMap $ (() <$) $ os`HM.difference`js )
 110
 111 -- ** Type 'Distribution'
 112 -- | Usually, a 'judge' gives a 'singleGrade' to a given 'choice'.
 113 -- However, when applying the Majority Judgment to a 'Tree' of 'Section's,
 114 -- what a 'judge' gives to a parent 'Section'
 115 -- is composed by the 'grade's he or she has given
 116 -- to the sub-'Section's, and those can be different.
 117 -- In that case, each 'grade' given to a sub-'Section' contributes to a 'Share'
 118 -- of the parent 'Section' which therefore is not necessarily a 'singleGrade',
 119 -- but more generally a 'Distribution' of 'grade's.
 120 -- And the sub-'Section's can actually themselves have sub-'Section's,
 121 -- hence not being given a 'grade', but a 'Distribution' of 'grade's too.
 122 type Distribution grade = Map grade Share
 123
 124 singleGrade :: grade -> Distribution grade
 125 singleGrade = (`Map.singleton` 1)
 126
 127 -- *** Type 'Share'
 128 -- | Usually a 'judge' attributes a 'singleGrade' to a given 'choice',
 129 -- and then the 'Share' of this 'grade' is 1.
 130 -- However, when introducing vote colleges (giving more power to some 'judge's),
 131 -- or when introducing 'Section's (decomposing a judgment into several sub-judgments),
 132 -- it becomes possible that only a percentage of 'grade'
 133 -- is 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 { unMerit :: 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, Show grade) => IsList (Merit grade) where
 156         type Item (Merit grade) = (grade, Share)
 157         fromList = Merit . Map.fromListWithKey
 158                  (\g _x _y -> error $ "duplicate grade in merit: " <> show g)
 159         toList (Merit cs) = toList cs
 160
 161 -- | @merit os@ returns the 'Merit' given by opinions 'os'
 162 merit ::
 163  Ord grade =>
 164  Opinions judge grade ->
 165  Merit grade
 166 merit = foldr insertOpinion $ Merit $ Map.empty
 167         -- TODO: maybe count by making g passes
 168         where
 169         insertOpinion dist (Merit m) =
 170                 Merit $
 171                 Map.foldlWithKey
 172                  (\acc g s -> Map.insertWith (+) g s acc)
 173                  m dist
 174
 175 -- ** Type 'MeritByChoice'
 176 -- | Profile of merit about some 'choice's.
 177 newtype MeritByChoice choice grade
 178  =      MeritByChoice { unMeritByChoice :: HM.HashMap choice (Merit grade) }
 179  deriving (Eq, Show)
 180 instance (Eq choice, Hashable choice, Ord grade) => Semigroup (MeritByChoice choice grade) where
 181         MeritByChoice x <> MeritByChoice y = MeritByChoice (HM.unionWith (<>) x y)
 182 instance (Eq choice, Hashable choice, Show choice) => IsList (MeritByChoice choice grade) where
 183         type Item (MeritByChoice choice grade) = (choice, Merit grade)
 184         fromList = MeritByChoice . HM.fromListWith
 185                  (\_x _y -> error $ "duplicate choice in merits")
 186         toList (MeritByChoice cs) = toList cs
 187
 188 -- | @meritByChoice gs cs os@ returns the 'Merit's
 189 -- given to 'choice's 'cs' by opinions 'os' from the 'Judges' 'js' on the 'Grades' 'gs'.
 190 meritByChoice ::
 191  (Ord grade, Eq choice, Hashable choice) =>
 192  OpinionsByChoice choice judge grade ->
 193  MeritByChoice choice grade
 194 meritByChoice os = MeritByChoice $ merit <$> os