]> Git — Sourcephile - majurity.git/blob - hjugement/Majority/Rank.hs
protocol: add decodeBigEndian
[majurity.git] / hjugement / Majority / Rank.hs
1 module Majority.Rank where
2
3 import Data.Bool
4 import Data.Eq (Eq(..))
5 import Data.Foldable (Foldable(..))
6 import Data.Function (($))
7 import Data.Functor ((<$>))
8 import Data.Ord (Ord(..))
9 import Data.Ratio
10 import Data.Semigroup (Semigroup(..))
11 import Prelude (Integer, Integral(..), Num(..), RealFrac(..), undefined)
12 import Text.Show (Show(..))
13 import qualified Data.List as List
14
15 import Majority.Merit hiding (merit)
16 import Majority.Value
17
18 -- * Convenient type aliases
19 -- | Number of judges.
20 type JS = Integer
21 -- | Number of grades.
22 type GS = Integer
23 -- | Rank of a 'MajorityValue'.
24 type Rank = Integer
25
26 -- ** Type 'Median'
27 -- | A median.
28 -- First 'G' (lower median) is lower or equal
29 -- to the second 'G' (higher median).
30 newtype Median = Median (G,G)
31 deriving (Eq, Show)
32
33 -- | 'Median' constructor enforcing its invariant.
34 median :: G -> G -> Median
35 median l h | l <= h = Median (l,h)
36 | otherwise = undefined
37
38 -- * Ranking and unranking 'MajorityValue's
39
40 -- | @('rankOfMajorityValue' gs mv)@ returns
41 -- the number of possible 'MajorityValue's lower than given 'mv'.
42 --
43 -- @
44 -- 'rankOfMajorityValue' gs . 'majorityValueOfRank' js gs
45 -- '<$>' [0..'lastRank' js gs] == [0..'lastRank' js gs]
46 -- @
47 rankOfMajorityValue :: GS -> MajorityValue (Ranked grade) -> Rank
48 rankOfMajorityValue gs mv =
49 go js 0 mvN
50 where
51 js = (2 *) $ sum $ middleShare <$> mvN
52 MajorityValue mvN = normalizeMajorityValue mv
53 go :: Rational -> G -> [Middle (Ranked grade)] -> Rank
54 go _n _previousHigh [] = 0
55 go n previousHigh (Middle s low high : ms)
56 -- Skip empty Middle.
57 | s <= 0 = go n previousHigh ms
58 -- Add the number of possible 'MajorityValue's
59 -- before the two middle judgments of the current 'Middle',
60 -- and recurse.
61 | otherwise =
62 countMediansBefore (numerator n) gs previousHigh (Median (rank low, rank high)) +
63 go (n - dn) (rank high) (Middle (s - dn * (1%2)) low high : ms)
64 where dn = if denominator s == 1 then 2 else 1
65
66 -- | The inverse of 'rankOfMajorityValue'.
67 --
68 -- @
69 -- 'majorityValueOfRank' js gs . 'rankOfMajorityValue' gs == 'id'
70 -- @
71 majorityValueOfRank :: JS -> GS -> Rank -> MajorityValue (Ranked ())
72 majorityValueOfRank js0 gs rk
73 | not (0<=rk && rk<=lastRank js0 gs) = undefined
74 -- error $ "rank="<>show rk<>" but lastRank "<>show js0<>" "<>show gs<>"="<>show (lastRank js0 gs)
75 | otherwise = MajorityValue $ go 0 js0 rk
76 where
77 go previousHigh js r
78 | js <= 0 = []
79 | otherwise =
80 let ms = listMediansBefore js gs previousHigh (Median (gs,gs)) in
81 let skip = List.takeWhile (<= r) $ List.scanl1 (+) $ countMedian js gs <$> ms in
82 let dr = if null skip then 0 else List.last skip in
83 let dj = if js`mod`2 == 0 then 2 else 1 in
84 let Median (l,h) = List.head $ List.drop (length skip) ms in
85 -- trace ("majorityValueOfRank: js="<>show js<>" r="<>show r<>" dr="<>show dr<>" "<>show (l,h)) $
86 case go h (js - dj) (r - dr) of
87 -- Merge the 'Middle's which have the same 'Median' grades,
88 -- by adding their 'Share'.
89 Middle s rl1@(Ranked (l1, ())) rh1@(Ranked (h1, ())) : mv
90 | l1 == l && h1 == h -> Middle (dj%2 + s) rl1 rh1 : mv
91 mv -> Middle (dj%2) (Ranked (l,())) (Ranked (h,())) : mv
92
93 positionOfMajorityValue :: GS -> MajorityValue (Ranked grade) -> Rational
94 positionOfMajorityValue gs mv =
95 rankOfMajorityValue gs mv %
96 countMerits (numerator js) gs
97 where
98 js = (2 *) $ sum $ middleShare <$> mvN
99 MajorityValue mvN = normalizeMajorityValue mv
100
101
102 -- ** Counting 'Merit's
103
104 -- | @('countMerits' js gs)@
105 -- returns the number of possible 'Merit's of size 'js' using grades 'gs'.
106 -- That is the number of ways to divide a segment of length 'js'
107 -- into at most 'gs' segments whose size is between '0' and 'js'.
108 --
109 -- The formula is: @(js+gs-1)·(js+gs-2)·…·(js+1)·js / (gs-1)·(gs-2)·…·2·1@
110 -- which is: @(js+gs-1)`nCk`(gs-1)@
111 countMerits :: JS -> GS -> Integer
112 countMerits js gs =
113 -- debug ("countMerits: js="<>show js<>" gs="<>show gs) $
114 (js+gs-1)`nCk`(gs-1)
115
116 -- | @('lastRank' js gs)@ returns the rank of the 'MajorityValue'
117 -- composed of 'js' times the highest grade of 'gs'.
118 --
119 -- @'lastRank' js gs == 'countMerits' js gs - 1@.
120 lastRank :: JS -> GS -> Rank
121 lastRank js gs = countMerits js gs - 1
122
123 -- ** Counting 'Median's
124
125 -- | @('countMedian' js gs ('Median' (l,h)))@
126 -- returns the number of possible 'Merit's of length 'js' using grades 'gs',
127 -- which have @(l,h)@ as lower and upper median grades.
128 -- This is done by multiplying together
129 -- the 'countMerits' to the left of 'l'
130 -- and the 'countMerits' to the right of 'h'.
131 countMedian :: JS -> GS -> Median -> Integer
132 countMedian js gs (Median (l,h)) =
133 -- debug ("countMedian: js="<>show js<>" gs="<>show gs<>" (l,h)="<>show (l,h)) $
134 countMerits js' (l+1) * -- NOTE: +1 because 'l' starts at 0
135 countMerits js' (gs-h)
136 where js' = floor $ (js-1)%2
137
138 -- | @('countMediansBefore' js gs previousHigh ('Median' (low,high)))@
139 -- returns the number of possible 'Merit's with 'js' judges and 'gs' grades,
140 -- whose @'Median' (l,h)@ is such that @((l,h) < (low, high))@
141 -- and @(previousHigh <= h)@.
142 countMediansBefore :: JS -> GS -> G -> Median -> Integer
143 countMediansBefore js gs previousHigh lh =
144 sum $ countMedian js gs <$> listMediansBefore js gs previousHigh lh
145
146 -- | @('listMediansBefore' js gs previousHigh ('Median' (low,high)))@
147 -- returns the 'Median's of possible 'Merit's with 'js' judges and 'gs' grades
148 -- with a 'Median' strictly lower than @(low,high)@.
149 listMediansBefore :: JS -> GS -> G -> Median -> [Median]
150 listMediansBefore js gs previousHigh (Median (l1,h1))
151 | js`mod`2 == 0 = evenBegin<>even<>evenEnd
152 | otherwise = odd
153 where
154 l0 = 0
155 -- | Walk from the low initial 'l0' upto the low target 'l1'.
156 odd = [ Median (l,l) | l<-[l0..l1-1] ]
157 -- | Walk from the low initial 'l0', upto:
158 -- - the highest (gs-1) if 'l0' is not the low target 'l1',
159 -- - or the high target (h1-1) otherwise.
160 evenBegin =
161 [ Median (l,h)
162 | l<-[l0]
163 , h<-[{-l`max`-}previousHigh..(if l0<l1 then gs-1 else h1-1)]
164 -- NOTE: useless (max l) since 'l' equals l0',
165 -- which is always lower than or equal to 'previousHigh'.
166 ]
167 -- | Walk from the grade after the low initial (l0+1) upto
168 -- the grade before the low target (l1-1)
169 -- while the high 'h' is walking
170 -- from the max of the minimal high and the current low,
171 -- to the highest (gs-1).
172 -- Beware that when recursing by removing a Middle,
173 -- the minimal high is not the low initial,
174 -- but the high of the lastly removed Middle.
175 even =
176 [ Median (l,h)
177 | l<-[l0+1..l1-1]
178 , h<-[l`max`previousHigh..gs-1]
179 ]
180 -- | Walk from the low target (if it hasn't been done yet)
181 -- to the high target instead of the highest grade.
182 evenEnd =
183 [ Median (l,h)
184 | l<-[l1 | l0 < l1]
185 , h<-[l`max`previousHigh..h1-1]
186 ]
187
188 -- | @('probaMedian' js gs)@ compute the probability
189 -- of each grade to be a 'MajorityGrade' given 'js' judges and 'gs' grades.
190 probaMedian :: JS -> GS -> [Rational]
191 probaMedian js gs =
192 [ countMedian js gs (Median (l,l)) % total
193 | l <- [0..gs-1]
194 ] where total = countMerits js gs
195
196 -- ** Utils
197 -- | @('nCk' n k)@ returns the binomial coefficient of 'n' and 'k',
198 -- that is number of combinations of size 'k' from a set of size 'n'.
199 --
200 -- Computed using the formula:
201 -- @'nCk' n (k+1) == 'nCk' n (k-1) * (n-k+1) / k@
202 nCk :: Integral i => i -> i -> i
203 n`nCk`k | n<0||k<0||n<k = undefined
204 | otherwise = go 1 1
205 where
206 go i acc = if k' < i then acc else go (i+1) (acc * (n-i+1) `div` i)
207 -- Use a symmetry to compute over smaller numbers,
208 -- which is more efficient and safer
209 k' = if n`div`2 < k then n-k else k
210 infix 7 `nCk`
211