module Majority.Rank where import Data.Bool import Data.Eq (Eq(..)) import Data.Foldable (Foldable(..)) import Data.Function (($)) import Data.Functor ((<$>)) import Data.Ord (Ord(..)) import Data.Ratio import Data.Semigroup (Semigroup(..)) import Prelude (Integer, Integral(..), Num(..), RealFrac(..), undefined) import Text.Show (Show(..)) import qualified Data.List as List import Majority.Merit hiding (merit) import Majority.Value -- * Convenient type aliases -- | Number of judges. type JS = Integer -- TODO: use Natural -- | Number of grades. type GS = Integer -- TODO: use Natural -- | Rank of a 'MajorityValue'. type Rank = Integer -- TODO: use Natural -- ** Type 'Median' -- | A median. -- First 'G' (lower median) is lower or equal -- to the second 'G' (higher median). newtype Median = Median (G,G) deriving (Eq, Show) -- | 'Median' constructor enforcing its invariant. median :: G -> G -> Median median l h | l <= h = Median (l,h) | otherwise = undefined -- * Ranking and unranking 'MajorityValue's -- | @('rankOfMajorityValue' gs mv)@ returns -- the number of possible 'MajorityValue's lower than given 'mv'. -- -- @ -- 'rankOfMajorityValue' gs . 'majorityValueOfRank' js gs -- '<$>' [0..'lastRank' js gs] == [0..'lastRank' js gs] -- @ rankOfMajorityValue :: GS -> MajorityValue (Ranked grade) -> Rank rankOfMajorityValue gs mv = go js 0 mvN where js = (2 *) $ sum $ middleShare <$> mvN MajorityValue mvN = normalizeMajorityValue mv go :: Rational -> G -> [Middle (Ranked grade)] -> Rank go _n _previousHigh [] = 0 go n previousHigh (Middle s low high : ms) -- Skip empty Middle. | s <= 0 = go n previousHigh ms -- Add the number of possible 'MajorityValue's -- before the two middle judgments of the current 'Middle', -- and recurse. | otherwise = countMediansBefore (numerator n) gs previousHigh (Median (rank low, rank high)) + go (n - dn) (rank high) (Middle (s - dn * (1%2)) low high : ms) where dn = if denominator s == 1 then 2 else 1 -- | The inverse of 'rankOfMajorityValue'. -- -- @ -- 'majorityValueOfRank' js gs . 'rankOfMajorityValue' gs == 'id' -- @ majorityValueOfRank :: JS -> GS -> Rank -> MajorityValue (Ranked ()) majorityValueOfRank js0 gs rk | not (0<=rk && rk<=lastRank js0 gs) = undefined -- error $ "rank="<>show rk<>" but lastRank "<>show js0<>" "<>show gs<>"="<>show (lastRank js0 gs) | otherwise = MajorityValue $ go 0 js0 rk where go previousHigh js r | js <= 0 = [] | otherwise = let ms = listMediansBefore js gs previousHigh (Median (gs,gs)) in let skip = List.takeWhile (<= r) $ List.scanl1 (+) $ countMedian js gs <$> ms in let dr = if null skip then 0 else List.last skip in let dj = if js`mod`2 == 0 then 2 else 1 in let Median (l,h) = ms List.!! length skip in -- trace ("majorityValueOfRank: js="<>show js<>" r="<>show r<>" dr="<>show dr<>" "<>show (l,h)) $ case go h (js - dj) (r - dr) of -- Merge the 'Middle's which have the same 'Median' grades, -- by adding their 'Share'. Middle s rl1@(Ranked (l1, ())) rh1@(Ranked (h1, ())) : mv | l1 == l && h1 == h -> Middle (dj%2 + s) rl1 rh1 : mv mv -> Middle (dj%2) (Ranked (l,())) (Ranked (h,())) : mv positionOfMajorityValue :: GS -> MajorityValue (Ranked grade) -> Rational positionOfMajorityValue gs mv = rankOfMajorityValue gs mv % countMerits (numerator js) gs where js = (2 *) $ sum $ middleShare <$> mvN MajorityValue mvN = normalizeMajorityValue mv -- ** Counting 'Merit's -- | @('countMerits' js gs)@ -- returns the number of possible 'Merit's of size 'js' using grades 'gs'. -- That is the number of ways to divide a segment of length 'js' -- into at most 'gs' segments whose size is between '0' and 'js'. -- -- The formula is: @(js+gs-1)·(js+gs-2)·…·(js+1)·js / (gs-1)·(gs-2)·…·2·1@ -- which is: @(js+gs-1)`nCk`(gs-1)@ countMerits :: JS -> GS -> Integer countMerits js gs = -- debug ("countMerits: js="<>show js<>" gs="<>show gs) $ (js+gs-1)`nCk`(gs-1) -- | @('lastRank' js gs)@ returns the rank of the 'MajorityValue' -- composed of 'js' times the highest grade of 'gs'. -- -- @'lastRank' js gs == 'countMerits' js gs - 1@. lastRank :: JS -> GS -> Rank lastRank js gs = countMerits js gs - 1 -- ** Counting 'Median's -- | @('countMedian' js gs ('Median' (l,h)))@ -- returns the number of possible 'Merit's of length 'js' using grades 'gs', -- which have @(l,h)@ as lower and upper median grades. -- This is done by multiplying together -- the 'countMerits' to the left of 'l' -- and the 'countMerits' to the right of 'h'. countMedian :: JS -> GS -> Median -> Integer countMedian js gs (Median (l,h)) = -- debug ("countMedian: js="<>show js<>" gs="<>show gs<>" (l,h)="<>show (l,h)) $ countMerits js' (l+1) * -- NOTE: +1 because 'l' starts at 0 countMerits js' (gs-h) where js' = floor $ (js-1)%2 -- | @('countMediansBefore' js gs previousHigh ('Median' (low,high)))@ -- returns the number of possible 'Merit's with 'js' judges and 'gs' grades, -- whose @'Median' (l,h)@ is such that @((l,h) < (low, high))@ -- and @(previousHigh <= h)@. countMediansBefore :: JS -> GS -> G -> Median -> Integer countMediansBefore js gs previousHigh lh = sum $ countMedian js gs <$> listMediansBefore js gs previousHigh lh -- | @('listMediansBefore' js gs previousHigh ('Median' (low,high)))@ -- returns the 'Median's of possible 'Merit's with 'js' judges and 'gs' grades -- with a 'Median' strictly lower than @(low,high)@. listMediansBefore :: JS -> GS -> G -> Median -> [Median] listMediansBefore js gs previousHigh (Median (l1,h1)) | js`mod`2 == 0 = evenBegin<>even<>evenEnd | otherwise = odd where l0 = 0 -- | Walk from the low initial 'l0' upto the low target 'l1'. odd = [ Median (l,l) | l<-[l0..l1-1] ] -- | Walk from the low initial 'l0', upto: -- - the highest (gs-1) if 'l0' is not the low target 'l1', -- - or the high target (h1-1) otherwise. evenBegin = [ Median (l,h) | l<-[l0] , h<-[{-l`max`-}previousHigh..(if l0 GS -> [Rational] probaMedian js gs = [ countMedian js gs (Median (l,l)) % total | l <- [0..gs-1] ] where total = countMerits js gs -- ** Utils -- | @('nCk' n k)@ returns the binomial coefficient of 'n' and 'k', -- that is number of combinations of size 'k' from a set of size 'n'. -- -- Computed using the formula: -- @'nCk' n (k+1) == 'nCk' n (k-1) * (n-k+1) / k@ nCk :: Integral i => i -> i -> i n`nCk`k | n<0||k<0||n