Majority/Rank.hs

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