1 module Majority.Rank where
4 import Data.Eq (Eq(..))
5 import Data.Foldable (Foldable(..))
6 import Data.Function (($))
7 import Data.Functor ((<$>))
8 import Data.Ord (Ord(..))
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
15 import Majority.Merit hiding (merit)
18 -- * Convenient type aliases
19 -- | Number of judges.
20 type JS = Integer -- TODO: use Natural
21 -- | Number of grades.
22 type GS = Integer -- TODO: use Natural
23 -- | Rank of a 'MajorityValue'.
24 type Rank = Integer -- TODO: use Natural
28 -- First 'G' (lower median) is lower or equal
29 -- to the second 'G' (higher median).
30 newtype Median = Median (G,G)
33 -- | 'Median' constructor enforcing its invariant.
34 median :: G -> G -> Median
35 median l h | l <= h = Median (l,h)
36 | otherwise = undefined
38 -- * Ranking and unranking 'MajorityValue's
40 -- | @('rankOfMajorityValue' gs mv)@ returns
41 -- the number of possible 'MajorityValue's lower than given 'mv'.
44 -- 'rankOfMajorityValue' gs . 'majorityValueOfRank' js gs
45 -- '<$>' [0..'lastRank' js gs] == [0..'lastRank' js gs]
47 rankOfMajorityValue :: GS -> MajorityValue (Ranked grade) -> Rank
48 rankOfMajorityValue gs mv =
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)
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',
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
66 -- | The inverse of 'rankOfMajorityValue'.
69 -- 'majorityValueOfRank' js gs . 'rankOfMajorityValue' gs == 'id'
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
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) = ms List.!! length skip 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
93 positionOfMajorityValue :: GS -> MajorityValue (Ranked grade) -> Rational
94 positionOfMajorityValue gs mv =
95 rankOfMajorityValue gs mv %
96 countMerits (numerator js) gs
98 js = (2 *) $ sum $ middleShare <$> mvN
99 MajorityValue mvN = normalizeMajorityValue mv
102 -- ** Counting 'Merit's
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'.
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
113 -- debug ("countMerits: js="<>show js<>" gs="<>show gs) $
116 -- | @('lastRank' js gs)@ returns the rank of the 'MajorityValue'
117 -- composed of 'js' times the highest grade of 'gs'.
119 -- @'lastRank' js gs == 'countMerits' js gs - 1@.
120 lastRank :: JS -> GS -> Rank
121 lastRank js gs = countMerits js gs - 1
123 -- ** Counting 'Median's
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
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
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
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.
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'.
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.
178 , h<-[l`max`previousHigh..gs-1]
180 -- | Walk from the low target (if it hasn't been done yet)
181 -- to the high target instead of the highest grade.
185 , h<-[l`max`previousHigh..h1-1]
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]
192 [ countMedian js gs (Median (l,l)) % total
194 ] where total = countMerits js gs
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'.
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
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