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 -- 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
  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