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