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 ((2 *) $ sum $ middleShare <$> mvN) 0 mvN
  50         where
  51         MajorityValue mvN = normalizeMajorityValue mv
  52         go :: Rational -> G -> [Middle (Ranked grade)] -> Rank
  53         go _n _previousHigh [] = 0
  54         go n previousHigh (Middle s low high : ms)
  55          -- Skip empty Middle.
  56          | s <= 0 = go n previousHigh ms
  57          -- Add the number of possible 'MajorityValue's
  58          -- before the two middle judgments of the current 'Middle',
  59          -- and recurse.
  60          | otherwise =
  61                 countMediansBefore (numerator n) gs previousHigh (Median (rank low, rank high)) +
  62                 go (n - dn) (rank high) (Middle (s - dn * (1%2)) low high : ms)
  63                 where dn = if denominator s == 1 then 2 else 1
  64
  65 -- | The inverse of 'rankOfMajorityValue'.
  66 --
  67 -- @
  68 -- 'majorityValueOfRank' js gs . 'rankOfMajorityValue' gs == 'id'
  69 -- @
  70 majorityValueOfRank :: JS -> GS -> Rank -> MajorityValue (Ranked ())
  71 majorityValueOfRank js0 gs rk
  72  | not (0<=rk && rk<=lastRank js0 gs) = undefined
  73         -- error $ "rank="<>show rk<>" but lastRank "<>show js0<>" "<>show gs<>"="<>show (lastRank js0 gs)
  74  | otherwise = MajorityValue $ go 0 js0 rk
  75         where
  76         go previousHigh js r
  77          | js <= 0 = []
  78          | otherwise =
  79                 let ms   = listMediansBefore js gs previousHigh (Median (gs,gs)) in
  80                 let skip = List.takeWhile (<= r) $ List.scanl1 (+) $ countMedian js gs <$> ms in
  81                 let dr   = if null skip then 0 else List.last skip in
  82                 let dj   = if js`mod`2 == 0 then 2 else 1 in
  83                 let Median (l,h) = List.head $ List.drop (length skip) ms in
  84                 -- trace ("majorityValueOfRank: js="<>show js<>" r="<>show r<>" dr="<>show dr<>" "<>show (l,h)) $
  85                 case go h (js - dj) (r - dr) of
  86                  -- Merge the 'Middle's which have the same 'Median' grades,
  87                  -- by adding their 'Share'.
  88                  Middle s rl1@(Ranked (l1, ())) rh1@(Ranked (h1, ())) : mv
  89                   | l1 == l && h1 == h -> Middle (dj%2 + s) rl1 rh1 : mv
  90                  mv -> Middle (dj%2) (Ranked (l,())) (Ranked (h,())) : mv
  91
  92 positionOfMajorityValue :: GS -> MajorityValue (Ranked grade) -> Rational
  93 positionOfMajorityValue gs mv =
  94         rankOfMajorityValue gs mv %
  95         countMerits (numerator js) gs
  96         where js = (2 *) $ sum $ middleShare <$> unMajorityValue mv
  97
  98
  99 -- ** Counting 'Merit's
 100
 101 -- | @('countMerits' js gs)@
 102 -- returns the number of possible 'Merit's of size 'js' using grades 'gs'.
 103 -- That is the number of ways to divide a segment of length 'js'
 104 -- into at most 'gs' segments whose size is between '0' and 'js'.
 105 --
 106 -- The formula is: @(js+gs-1)·(js+gs-2)·…·(js+1)·js / (gs-1)·(gs-2)·…·2·1@
 107 -- which is: @(js+gs-1)`nCk`(gs-1)@
 108 countMerits :: JS -> GS -> Integer
 109 countMerits js gs =
 110         -- debug ("countMerits: js="<>show js<>" gs="<>show gs) $
 111         (js+gs-1)`nCk`(gs-1)
 112
 113 -- | @('lastRank' js gs)@ returns the rank of the 'MajorityValue'
 114 -- composed of 'js' times the highest grade of 'gs'.
 115 --
 116 -- @'lastRank' js gs == 'countMerits' js gs - 1@.
 117 lastRank :: JS -> GS -> Rank
 118 lastRank js gs = countMerits js gs - 1
 119
 120 -- ** Counting 'Median's
 121
 122 -- | @('countMedian' js gs ('Median' (l,h)))@
 123 -- returns the number of possible 'Merit's of length 'js' using grades 'gs',
 124 -- which have @(l,h)@ as lower and upper median grades.
 125 -- This is done by multiplying together
 126 -- the 'countMerits' to the left of 'l'
 127 -- and the 'countMerits' to the right of 'h'.
 128 countMedian :: JS -> GS -> Median -> Integer
 129 countMedian js gs (Median (l,h)) =
 130         -- debug ("countMedian: js="<>show js<>" gs="<>show gs<>" (l,h)="<>show (l,h)) $
 131         countMerits side (l+1) * -- NOTE: +1 because 'l' starts at 0
 132         countMerits side (gs-h)
 133         where side = floor ((js-1)%2)
 134
 135 -- | @('countMediansBefore' js gs previousHigh ('Median' (low,high)))@
 136 -- returns the number of possible 'Merit's with 'js' judges and 'gs' grades,
 137 -- whose @'Median' (l,h)@ is such that @((l,h) < (low, high))@
 138 -- and @(previousHigh <= h)@.
 139 countMediansBefore :: JS -> GS -> G -> Median -> Integer
 140 countMediansBefore js gs previousHigh lh =
 141         sum $ countMedian js gs <$> listMediansBefore js gs previousHigh lh
 142
 143 -- | @('listMediansBefore' js gs previousHigh ('Median' (low,high)))@
 144 -- returns the 'Median's of possible 'Merit's with 'js' judges and 'gs' grades
 145 -- with a 'Median' strictly lower than @(low,high)@.
 146 listMediansBefore :: JS -> GS -> G -> Median -> [Median]
 147 listMediansBefore js gs previousHigh (Median (l1,h1))
 148  | js`mod`2 == 0 = evenBegin<>even<>evenEnd
 149  | otherwise = odd
 150         where
 151         l0 = 0
 152         -- | Walk from the low initial 'l0' upto the low target 'l1'.
 153         odd = [ Median (l,l) | l<-[l0..l1-1] ]
 154         -- | Walk from the low initial 'l0', upto:
 155         -- - the highest (gs-1) if 'l0' is not the low target 'l1',
 156         -- - or the high target (h1-1) otherwise.
 157         evenBegin =
 158          [ Median (l,h)
 159          | l<-[l0]
 160          , h<-[{-l`max`-}previousHigh..(if l0<l1 then gs-1 else h1-1)]
 161           -- NOTE: useless (max l) since 'l' equals l0',
 162           -- which is always lower than or equal to 'previousHigh'.
 163          ]
 164         -- | Walk from the grade after the low initial (l0+1) upto
 165         -- the grade before the low target (l1-1)
 166         -- while the high 'h' is walking
 167         -- from the max of the minimal high and the current low,
 168         -- to the highest (gs-1).
 169         -- Beware that when recursing by removing a Middle,
 170         -- the minimal high is not the low initial,
 171         -- but the high of the lastly removed Middle.
 172         even =
 173          [ Median (l,h)
 174          | l<-[l0+1..l1-1]
 175          , h<-[l`max`previousHigh..gs-1]
 176          ]
 177         -- | Walk from the low target (if it hasn't been done yet)
 178         -- to the high target instead of the highest grade.
 179         evenEnd =
 180          [ Median (l,h)
 181          | l<-[l1 | l0 < l1]
 182          , h<-[l`max`previousHigh..h1-1]
 183          ]
 184
 185 -- | @('probaMedian' js gs)@ compute the probability
 186 -- of each grade to be a 'MajorityGrade' given 'js' judges and 'gs' grades.
 187 probaMedian :: JS -> GS -> [Rational]
 188 probaMedian js gs =
 189         [ countMedian js gs (Median (l,l)) % d
 190         | l <- [0..gs-1]
 191         ] where d = countMerits js gs
 192
 193 -- ** Utils
 194 -- | @('nCk' n k)@ returns the binomial coefficient of 'n' and 'k',
 195 -- that is number of combinations of size 'k' from a set of size 'n'.
 196 --
 197 -- Computed using the formula:
 198 -- @'nCk' n (k+1) == 'nCk' n (k-1) * (n-k+1) / k@
 199 nCk :: Integral i => i -> i -> i
 200 n`nCk`k | n<0||k<0||n<k = undefined
 201         | otherwise     = go 1 1
 202         where
 203         go i acc = if k' < i then acc else go (i+1) (acc * (n-i+1) `div` i)
 204         -- Use a symmetry to compute over smaller numbers,
 205         -- which is more efficient and safer
 206         k' = if n`div`2 < k then n-k else k
 207 infix 7 `nCk`
 208