Majority/Gauge.hs

   1 -- | WARNING: the 'MajorityGauge' is a simplified 'MajorityValue'
   2 -- which is sufficient to determine the 'MajorityRanking'
   3 -- when the number of judges is large.
   4 -- It is an approximation, it can perfectly lead to a wrong ranking
   5 -- wrt. the 'MajorityRanking' done by using 'majorityValue'.
   6 module Majority.Gauge where
   7
   8 import Data.Bool
   9 import Data.Eq (Eq(..))
  10 import Data.Function (($), (.))
  11 import Data.Functor ((<$>))
  12 import Data.Maybe (Maybe(..), listToMaybe)
  13 import Data.Ord (Ord(..), Ordering(..), Down(..))
  14 import Data.Tuple (snd)
  15 import Prelude (Num(..))
  16 import Text.Show (Show(..), showParen, shows)
  17 import qualified Data.HashMap.Strict as HM
  18 import qualified Data.List as List
  19 import qualified Data.Map.Strict as Map
  20
  21 import Majority.Merit
  22
  23 -- * Type 'MajorityGauge'
  24 -- | The 'MajorityGauge' is a simplification of the 'majorityValue'
  25 -- from which may be deduced the 'majorityRanking'
  26 -- among the propositions in many cases;
  27 -- in particular, when there are many judges.
  28 --
  29 -- However, when two propositions are tied with the same 'MajorityGauge',
  30 -- they are not necessarily tied according to their 'majorityValue's.
  31 data MajorityGauge g
  32  =   MajorityGauge
  33  {   mgHigher :: Share -- ^ Number of 'grade's given which are better than 'mgGrade'.
  34  ,   mgGrade  :: g     -- ^ 'majorityGrade'.
  35  ,   mgLower  :: Share -- ^ Number of 'grade's given which are worse than 'mgGrade'.
  36  } deriving (Eq)
  37 instance Show g => Show (MajorityGauge g) where
  38         showsPrec p (MajorityGauge b g w) = showParen (p >= 10) $ shows (b,g,w)
  39
  40 -- ** Type 'Sign'
  41 data Sign = Minus | Plus
  42  deriving (Eq, Show)
  43
  44 -- | If 'mgHigher' is higher than 'mgLower'
  45 -- then the 'majorityGrade' is completed by a 'Plus';
  46 -- otherwise the 'majorityGrade' is completed by a 'Minus'.
  47 mgSign :: MajorityGauge g -> Sign
  48 mgSign g = if mgHigher g > mgLower g then Plus else Minus
  49
  50 -- | The 'MajorityGauge'-ranking, first tries to rank
  51 -- according to the 'majorityGrade' 'mgGrade'.
  52 --
  53 -- If both 'MajorityGauge's have the same 'mgGrade',
  54 -- it tries to rank according to the 'mgSign' of both 'MajorityGauge's:
  55 -- a 'Plus' is ahead of a 'Minus'.
  56 --
  57 -- If both 'mgSign' are 'Plus',
  58 -- the one having the higher 'mgHigher' is ahead,
  59 -- or if both 'mgSign' are 'Minus',
  60 -- the one having the higher 'mgLower' is behind.
  61 --
  62 -- Otherwise, the 'MajorityGauge'-ranking is a tie.
  63 instance Ord g => Ord (MajorityGauge g) where
  64         x `compare` y =
  65                 case mgGrade x `compare` mgGrade y of
  66                  EQ ->
  67                         case (mgSign x, mgSign y) of
  68                          (Minus, Plus)  -> LT
  69                          (Plus , Minus) -> GT
  70                          (Plus , Plus)  -> mgHigher x `compare` mgHigher y
  71                          (Minus, Minus) -> mgLower  x `compare` mgLower  y
  72                  o -> o
  73
  74 majorityGauge :: Ord grade => Merit grade -> Maybe (MajorityGauge grade)
  75 majorityGauge = listToMaybe . majorityGauges
  76
  77 majorityGauges :: Ord grade => Merit grade -> [MajorityGauge grade]
  78 majorityGauges (Merit m) = go Map.empty m
  79         where
  80         go done gs = case snd (Map.foldlWithKey untilMajGrade (0,[]) gs) of
  81                       []  -> []
  82                       (mg,c):_ -> add mg done:go (Map.insert (mgGrade mg) c done) (Map.delete (mgGrade mg) gs)
  83                 where
  84                 add = Map.foldrWithKey $ \g c (MajorityGauge b mg w) ->
  85                         if g >= mg then MajorityGauge (b+c) mg w
  86                                    else MajorityGauge b mg (w+c)
  87                 total = List.sum gs
  88                 untilMajGrade (t,[]) g c | 2*tc >= total = (tc,[(MajorityGauge 0 g t,c)])
  89                                          | otherwise     = (tc,[])
  90                                          where tc = t+c
  91                 untilMajGrade (t,(mg,c):_) _g c' = (t,[(mg{mgHigher=mgHigher mg + c'},c)])
  92
  93 -- * Type 'MajorityGaugeRanking'
  94 type MajorityGaugeRanking choice grade = [(choice, [MajorityGauge grade])]
  95
  96 majorityGaugesByChoice :: Ord grade => MeritByChoice choice grade -> HM.HashMap choice [MajorityGauge grade]
  97 majorityGaugesByChoice (MeritByChoice ms) = majorityGauges <$> ms
  98
  99 majorityGaugeRanking :: Ord grade => MeritByChoice choice grade -> MajorityGaugeRanking choice grade
 100 majorityGaugeRanking = List.sortOn (Down . snd) . HM.toList . majorityGaugesByChoice