Majority/Rank.hs

   1 module Majority.Rank where
   2 import Data.Bool
   3 import Data.Eq (Eq(..))
   4 import Data.Foldable (Foldable(..))
   5 import Data.Function (($))
   6 import Data.Functor ((<$>))
   7 import Data.Ord (Ord(..))
   8 import Data.Ratio
   9 import Data.Semigroup (Semigroup(..))
  10 import Prelude (Integer, Integral(..), Num(..), RealFrac(..), undefined)
  11
  12 import Majority.Merit hiding (merit)
  13 import Majority.Value
  14
  15 -- | Number of judges.
  16 type JS = Integer
  17 -- | Number of grades.
  18 type GS = Integer
  19 -- | Rank of grade.
  20 type G = Integer
  21
  22 -- | @'rankOfMajorityValue' gs mv@ returns
  23 -- the number of possible 'MajorityValue's lower than given 'mv'.
  24 rankOfMajorityValue :: GS -> MajorityValue (Ranked grade) -> Integer
  25 rankOfMajorityValue gs mv =
  26         go ((2 *) $ sum $ middleShare <$> mvN) (0,0) mvN
  27         where
  28         MajorityValue mvN = normalizeMajorityValue mv
  29         go :: Rational -> (G,G) -> [Middle (Ranked grade)] -> Integer
  30         go _n _0 [] = 0
  31         go n (l0,h0) (Middle s low high : ms)
  32          | s <= 0 = go n (l0,h0) ms
  33          | otherwise =
  34                 countMiddleFrom (numerator $ n) gs (l0,h0) (rank low, rank high) +
  35                 go (n - dn) (0, rank high) (Middle (s - dn * (1%2)) low high : ms)
  36                 where dn = if denominator s == 1 then 2 else 1
  37
  38 positionOfMajorityValue :: GS -> MajorityValue (Ranked grade) -> Rational
  39 positionOfMajorityValue gs mv =
  40         rankOfMajorityValue gs mv %
  41         countMerits (2 * numerator js) gs
  42         where js = sum $ middleShare <$> unMajorityValue mv
  43
  44 countMiddleFrom :: JS -> GS -> (G,G) -> (G,G) -> Integer
  45 countMiddleFrom js gs (l0,h0) (l1,h1) =
  46         sum $ countMiddle js gs <$>
  47                 if js`mod`2 == 0 then even else odd
  48         where
  49         even = even1 <> even2 <> even3
  50         odd = [ (l,l) | l<-[l0..l1-1] ]
  51         even1 =
  52          [ (l,h) | l<-[l0]
  53          , h<-[h0..(if l0<l1 then gs-1 else h1-1)]
  54          ]
  55         even2 =
  56          [ (l,h) | l<-[l0+1..l1-1]
  57          , h<-[max l h0..gs-1]
  58          ]
  59         even3 =
  60          [ (l,h) | l<-[l1 | l0 < l1]
  61          , h<-[max l h0..h1-1]
  62          ]
  63
  64 -- | @'countMiddle' js gs (l,h)@
  65 -- returns the number of 'MajorityValue's of length 'js' using grades 'gs',
  66 -- which have '(l,h)' as lower and upper majority grade.
  67 -- This is done by multiplying together
  68 -- the 'countMerits' to the left of 'l'
  69 -- and the 'countMerits' to the right of 'h'
  70 countMiddle :: JS -> GS -> (G,G) -> Integer
  71 countMiddle js gs (l,h) =
  72         -- debug ("countMiddle: js="<>show js<>" gs="<>show gs<>" (l,h)="<>show (l,h)) $
  73         countMerits side (l+1) * -- NOTE: +1 because 'l' starts at 0
  74         countMerits side (gs-h)
  75         where side = floor ((js-1)%2)
  76
  77 -- | @'probaMajorityGrades' js gs@ compute the probability
  78 -- of each grade to be a 'MajorityGrade' given 'js' judges and 'gs' grades.
  79 probaMajorityGrades :: JS -> GS -> [Rational]
  80 probaMajorityGrades js gs =
  81         [ countMiddle js gs (l,l) % d
  82         | l <- [0..gs-1]
  83         ] where d = countMerits js gs
  84
  85 -- | @'countMerits' js gs@
  86 -- returns the number of possible 'Merit's of size 'js' using grades 'gs'.
  87 -- That is the number of ways to divide a segment of length 'js'
  88 -- into at most 'gs' segments whose size is between '0' and 'js'.
  89 countMerits :: JS -> GS -> Integer
  90 countMerits js gs =
  91         -- debug ("countMerits: js="<>show js<>" gs="<>show gs) $
  92         (js+gs-1)`nCk`(gs-1)
  93
  94 lastRank :: JS -> GS -> Integer
  95 lastRank js gs = countMerits js gs - 1
  96
  97 -- | @'nCk' n k@ returns the number of combinations of size 'k' from a set of size 'n'.
  98 --
  99 -- Computed using the formula:
 100 -- @'nCk' n (k+1) == 'nCk' n (k-1) * (n-k+1) / k@
 101 nCk :: Integral i => i -> i -> i
 102 n`nCk`k | n<0||k<0||n<k = undefined
 103         | otherwise     = go 1 1
 104         where
 105         go i acc = if k' < i then acc else go (i+1) (acc * (n-i+1) `div` i)
 106         -- Use a symmetry to compute over smaller numbers,
 107         -- which is more efficient and safer
 108         k' = if n`div`2 < k then n-k else k
 109 infix 7 `nCk`