module Majurity.Judgment.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 Majurity.Judgment.Merit hiding (merit)
import Majurity.Judgment.Value

-- * Convenient type aliases
-- | Number of judges.
type JS = Integer
-- | Number of grades.
type GS = Integer
-- | Rank of a 'MajorityValue'.
type Rank = Integer

-- ** Type 'Median'
-- | A median.
-- First 'G' (lower median) is lower or equal
-- to the second 'G' (higher median).
newtype Median = Median (G,G)
 deriving (Median -> Median -> Bool
(Median -> Median -> Bool)
-> (Median -> Median -> Bool) -> Eq Median
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Median -> Median -> Bool
$c/= :: Median -> Median -> Bool
== :: Median -> Median -> Bool
$c== :: Median -> Median -> Bool
Eq, Int -> Median -> ShowS
[Median] -> ShowS
Median -> String
(Int -> Median -> ShowS)
-> (Median -> String) -> ([Median] -> ShowS) -> Show Median
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Median] -> ShowS
$cshowList :: [Median] -> ShowS
show :: Median -> String
$cshow :: Median -> String
showsPrec :: Int -> Median -> ShowS
$cshowsPrec :: Int -> Median -> ShowS
Show)

-- | 'Median' constructor enforcing its invariant.
median :: G -> G -> Median
median :: G -> G -> Median
median G
l G
h | G
l G -> G -> Bool
forall a. Ord a => a -> a -> Bool
<= G
h = (G, G) -> Median
Median (G
l,G
h)
           | Bool
otherwise = Median
forall a. HasCallStack => a
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 :: G -> MajorityValue (Ranked grade) -> G
rankOfMajorityValue G
gs MajorityValue (Ranked grade)
mv =
	Rational -> G -> [Middle (Ranked grade)] -> G
forall grade. Rational -> G -> [Middle (Ranked grade)] -> G
go Rational
js G
0 [Middle (Ranked grade)]
mvN
	where
	js :: Rational
js = (Rational
2 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
*) (Rational -> Rational) -> Rational -> Rational
forall a b. (a -> b) -> a -> b
$ [Rational] -> Rational
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Rational] -> Rational) -> [Rational] -> Rational
forall a b. (a -> b) -> a -> b
$ Middle (Ranked grade) -> Rational
forall grade. Middle grade -> Rational
middleShare (Middle (Ranked grade) -> Rational)
-> [Middle (Ranked grade)] -> [Rational]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Middle (Ranked grade)]
mvN
	MajorityValue [Middle (Ranked grade)]
mvN = MajorityValue (Ranked grade) -> MajorityValue (Ranked grade)
forall grade. MajorityValue grade -> MajorityValue grade
normalizeMajorityValue MajorityValue (Ranked grade)
mv
	go :: Rational -> G -> [Middle (Ranked grade)] -> Rank
	go :: Rational -> G -> [Middle (Ranked grade)] -> G
go Rational
_n G
_previousHigh [] = G
0
	go Rational
n G
previousHigh (Middle Rational
s Ranked grade
low Ranked grade
high : [Middle (Ranked grade)]
ms)
	 -- Skip empty Middle.
	 | Rational
s Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
<= Rational
0 = Rational -> G -> [Middle (Ranked grade)] -> G
forall grade. Rational -> G -> [Middle (Ranked grade)] -> G
go Rational
n G
previousHigh [Middle (Ranked grade)]
ms
	 -- Add the number of possible 'MajorityValue's
	 -- before the two middle judgments of the current 'Middle',
	 -- and recurse.
	 | Bool
otherwise =
		G -> G -> G -> Median -> G
countMediansBefore (Rational -> G
forall a. Ratio a -> a
numerator Rational
n) G
gs G
previousHigh ((G, G) -> Median
Median (Ranked grade -> G
forall a. Ranked a -> G
rank Ranked grade
low, Ranked grade -> G
forall a. Ranked a -> G
rank Ranked grade
high)) G -> G -> G
forall a. Num a => a -> a -> a
+
		Rational -> G -> [Middle (Ranked grade)] -> G
forall grade. Rational -> G -> [Middle (Ranked grade)] -> G
go (Rational
n Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
dn) (Ranked grade -> G
forall a. Ranked a -> G
rank Ranked grade
high) (Rational -> Ranked grade -> Ranked grade -> Middle (Ranked grade)
forall grade. Rational -> grade -> grade -> Middle grade
Middle (Rational
s Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
dn Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* (G
1G -> G -> Rational
forall a. Integral a => a -> a -> Ratio a
%G
2)) Ranked grade
low Ranked grade
high Middle (Ranked grade)
-> [Middle (Ranked grade)] -> [Middle (Ranked grade)]
forall a. a -> [a] -> [a]
: [Middle (Ranked grade)]
ms)
		where dn :: Rational
dn = if Rational -> G
forall a. Ratio a -> a
denominator Rational
s G -> G -> Bool
forall a. Eq a => a -> a -> Bool
== G
1 then Rational
2 else Rational
1

-- | The inverse of 'rankOfMajorityValue'.
--
-- @
-- 'majorityValueOfRank' js gs . 'rankOfMajorityValue' gs == 'id'
-- @
majorityValueOfRank :: JS -> GS -> Rank -> MajorityValue (Ranked ())
majorityValueOfRank :: G -> G -> G -> MajorityValue (Ranked ())
majorityValueOfRank G
js0 G
gs G
rk
 | Bool -> Bool
not (G
0G -> G -> Bool
forall a. Ord a => a -> a -> Bool
<=G
rk Bool -> Bool -> Bool
&& G
rkG -> G -> Bool
forall a. Ord a => a -> a -> Bool
<=G -> G -> G
lastRank G
js0 G
gs) = MajorityValue (Ranked ())
forall a. HasCallStack => a
undefined
	-- error $ "rank="<>show rk<>" but lastRank "<>show js0<>" "<>show gs<>"="<>show (lastRank js0 gs)
 | Bool
otherwise = [Middle (Ranked ())] -> MajorityValue (Ranked ())
forall grade. [Middle grade] -> MajorityValue grade
MajorityValue ([Middle (Ranked ())] -> MajorityValue (Ranked ()))
-> [Middle (Ranked ())] -> MajorityValue (Ranked ())
forall a b. (a -> b) -> a -> b
$ G -> G -> G -> [Middle (Ranked ())]
go G
0 G
js0 G
rk
	where
	go :: G -> G -> G -> [Middle (Ranked ())]
go G
previousHigh G
js G
r
	 | G
js G -> G -> Bool
forall a. Ord a => a -> a -> Bool
<= G
0 = []
	 | Bool
otherwise =
		let ms :: [Median]
ms   = G -> G -> G -> Median -> [Median]
listMediansBefore G
js G
gs G
previousHigh ((G, G) -> Median
Median (G
gs,G
gs)) in
		let skip :: [G]
skip = (G -> Bool) -> [G] -> [G]
forall a. (a -> Bool) -> [a] -> [a]
List.takeWhile (G -> G -> Bool
forall a. Ord a => a -> a -> Bool
<= G
r) ([G] -> [G]) -> [G] -> [G]
forall a b. (a -> b) -> a -> b
$ (G -> G -> G) -> [G] -> [G]
forall a. (a -> a -> a) -> [a] -> [a]
List.scanl1 G -> G -> G
forall a. Num a => a -> a -> a
(+) ([G] -> [G]) -> [G] -> [G]
forall a b. (a -> b) -> a -> b
$ G -> G -> Median -> G
countMedian G
js G
gs (Median -> G) -> [Median] -> [G]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Median]
ms in
		let dr :: G
dr   = if [G] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [G]
skip then G
0 else [G] -> G
forall a. [a] -> a
List.last [G]
skip in
		let dj :: G
dj   = if G
jsG -> G -> G
forall a. Integral a => a -> a -> a
`mod`G
2 G -> G -> Bool
forall a. Eq a => a -> a -> Bool
== G
0 then G
2 else G
1 in
		let Median (G
l,G
h) = [Median]
ms [Median] -> Int -> Median
forall a. [a] -> Int -> a
List.!! [G] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [G]
skip in
		-- trace ("majorityValueOfRank: js="<>show js<>" r="<>show r<>" dr="<>show dr<>" "<>show (l,h)) $
		case G -> G -> G -> [Middle (Ranked ())]
go G
h (G
js G -> G -> G
forall a. Num a => a -> a -> a
- G
dj) (G
r G -> G -> G
forall a. Num a => a -> a -> a
- G
dr) of
		 -- Merge the 'Middle's which have the same 'Median' grades,
		 -- by adding their 'Share'.
		 Middle Rational
s rl1 :: Ranked ()
rl1@(Ranked (G
l1, ())) rh1 :: Ranked ()
rh1@(Ranked (G
h1, ())) : [Middle (Ranked ())]
mv
		  | G
l1 G -> G -> Bool
forall a. Eq a => a -> a -> Bool
== G
l Bool -> Bool -> Bool
&& G
h1 G -> G -> Bool
forall a. Eq a => a -> a -> Bool
== G
h -> Rational -> Ranked () -> Ranked () -> Middle (Ranked ())
forall grade. Rational -> grade -> grade -> Middle grade
Middle (G
djG -> G -> Rational
forall a. Integral a => a -> a -> Ratio a
%G
2 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
s) Ranked ()
rl1 Ranked ()
rh1 Middle (Ranked ()) -> [Middle (Ranked ())] -> [Middle (Ranked ())]
forall a. a -> [a] -> [a]
: [Middle (Ranked ())]
mv
		 [Middle (Ranked ())]
mv -> Rational -> Ranked () -> Ranked () -> Middle (Ranked ())
forall grade. Rational -> grade -> grade -> Middle grade
Middle (G
djG -> G -> Rational
forall a. Integral a => a -> a -> Ratio a
%G
2) ((G, ()) -> Ranked ()
forall a. (G, a) -> Ranked a
Ranked (G
l,())) ((G, ()) -> Ranked ()
forall a. (G, a) -> Ranked a
Ranked (G
h,())) Middle (Ranked ()) -> [Middle (Ranked ())] -> [Middle (Ranked ())]
forall a. a -> [a] -> [a]
: [Middle (Ranked ())]
mv

positionOfMajorityValue :: GS -> MajorityValue (Ranked grade) -> Rational
positionOfMajorityValue :: G -> MajorityValue (Ranked grade) -> Rational
positionOfMajorityValue G
gs MajorityValue (Ranked grade)
mv =
	G -> MajorityValue (Ranked grade) -> G
forall grade. G -> MajorityValue (Ranked grade) -> G
rankOfMajorityValue G
gs MajorityValue (Ranked grade)
mv G -> G -> Rational
forall a. Integral a => a -> a -> Ratio a
%
	G -> G -> G
countMerits (Rational -> G
forall a. Ratio a -> a
numerator Rational
js) G
gs
	where
	js :: Rational
js = (Rational
2 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
*) (Rational -> Rational) -> Rational -> Rational
forall a b. (a -> b) -> a -> b
$ [Rational] -> Rational
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Rational] -> Rational) -> [Rational] -> Rational
forall a b. (a -> b) -> a -> b
$ Middle (Ranked grade) -> Rational
forall grade. Middle grade -> Rational
middleShare (Middle (Ranked grade) -> Rational)
-> [Middle (Ranked grade)] -> [Rational]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Middle (Ranked grade)]
mvN
	MajorityValue [Middle (Ranked grade)]
mvN = MajorityValue (Ranked grade) -> MajorityValue (Ranked grade)
forall grade. MajorityValue grade -> MajorityValue grade
normalizeMajorityValue MajorityValue (Ranked grade)
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 :: G -> G -> G
countMerits G
js G
gs =
	-- debug ("countMerits: js="<>show js<>" gs="<>show gs) $
	(G
jsG -> G -> G
forall a. Num a => a -> a -> a
+G
gsG -> G -> G
forall a. Num a => a -> a -> a
-G
1)G -> G -> G
forall a. Integral a => a -> a -> a
`nCk`(G
gsG -> G -> G
forall a. Num a => a -> a -> a
-G
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 :: G -> G -> G
lastRank G
js G
gs = G -> G -> G
countMerits G
js G
gs G -> G -> G
forall a. Num a => a -> a -> a
- G
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 :: G -> G -> Median -> G
countMedian G
js G
gs (Median (G
l,G
h)) =
	-- debug ("countMedian: js="<>show js<>" gs="<>show gs<>" (l,h)="<>show (l,h)) $
	G -> G -> G
countMerits G
js' (G
lG -> G -> G
forall a. Num a => a -> a -> a
+G
1) G -> G -> G
forall a. Num a => a -> a -> a
* -- NOTE: +1 because 'l' starts at 0
	G -> G -> G
countMerits G
js' (G
gsG -> G -> G
forall a. Num a => a -> a -> a
-G
h)
	where js' :: G
js' = Rational -> G
forall a b. (RealFrac a, Integral b) => a -> b
floor (Rational -> G) -> Rational -> G
forall a b. (a -> b) -> a -> b
$ (G
jsG -> G -> G
forall a. Num a => a -> a -> a
-G
1)G -> G -> Rational
forall a. Integral a => a -> a -> Ratio a
%G
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 :: G -> G -> G -> Median -> G
countMediansBefore G
js G
gs G
previousHigh Median
lh =
	[G] -> G
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([G] -> G) -> [G] -> G
forall a b. (a -> b) -> a -> b
$ G -> G -> Median -> G
countMedian G
js G
gs (Median -> G) -> [Median] -> [G]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> G -> G -> G -> Median -> [Median]
listMediansBefore G
js G
gs G
previousHigh Median
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 :: G -> G -> G -> Median -> [Median]
listMediansBefore G
js G
gs G
previousHigh (Median (G
l1,G
h1))
 | G
jsG -> G -> G
forall a. Integral a => a -> a -> a
`mod`G
2 G -> G -> Bool
forall a. Eq a => a -> a -> Bool
== G
0 = [Median]
evenBegin[Median] -> [Median] -> [Median]
forall a. Semigroup a => a -> a -> a
<>[Median]
even[Median] -> [Median] -> [Median]
forall a. Semigroup a => a -> a -> a
<>[Median]
evenEnd
 | Bool
otherwise = [Median]
odd
	where
	l0 :: G
l0 = G
0
	-- | Walk from the low initial 'l0' upto the low target 'l1'.
	odd :: [Median]
odd = [ (G, G) -> Median
Median (G
l,G
l) | G
l<-[G
l0..G
l1G -> G -> G
forall a. Num a => a -> a -> a
-G
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]
evenBegin =
	 [ (G, G) -> Median
Median (G
l,G
h)
	 | G
l<-[G
l0]
	 , G
h<-[{-l`max`-}G
previousHigh..(if G
l0G -> G -> Bool
forall a. Ord a => a -> a -> Bool
<G
l1 then G
gsG -> G -> G
forall a. Num a => a -> a -> a
-G
1 else G
h1G -> G -> G
forall a. Num a => a -> a -> a
-G
1)]
	  -- NOTE: useless (max l) since 'l' equals l0',
	  -- which is always lower than or equal to 'previousHigh'.
	 ]
	-- | Walk from the grade after the low initial (l0+1) upto
	-- the grade before the low target (l1-1)
	-- while the high 'h' is walking
	-- from the max of the minimal high and the current low,
	-- to the highest (gs-1).
	-- Beware that when recursing by removing a Middle,
	-- the minimal high is not the low initial,
	-- but the high of the lastly removed Middle.
	even :: [Median]
even =
	 [ (G, G) -> Median
Median (G
l,G
h)
	 | G
l<-[G
l0G -> G -> G
forall a. Num a => a -> a -> a
+G
1..G
l1G -> G -> G
forall a. Num a => a -> a -> a
-G
1]
	 , G
h<-[G
lG -> G -> G
forall a. Ord a => a -> a -> a
`max`G
previousHigh..G
gsG -> G -> G
forall a. Num a => a -> a -> a
-G
1]
	 ]
	-- | Walk from the low target (if it hasn't been done yet)
	-- to the high target instead of the highest grade.
	evenEnd :: [Median]
evenEnd =
	 [ (G, G) -> Median
Median (G
l,G
h)
	 | G
l<-[G
l1 | G
l0 G -> G -> Bool
forall a. Ord a => a -> a -> Bool
< G
l1]
	 , G
h<-[G
lG -> G -> G
forall a. Ord a => a -> a -> a
`max`G
previousHigh..G
h1G -> G -> G
forall a. Num a => a -> a -> a
-G
1]
	 ]

-- | @('probaMedian' js gs)@ compute the probability
-- of each grade to be a 'MajorityGrade' given 'js' judges and 'gs' grades.
probaMedian :: JS -> GS -> [Rational]
probaMedian :: G -> G -> [Rational]
probaMedian G
js G
gs =
	[ G -> G -> Median -> G
countMedian G
js G
gs ((G, G) -> Median
Median (G
l,G
l)) G -> G -> Rational
forall a. Integral a => a -> a -> Ratio a
% G
total
	| G
l <- [G
0..G
gsG -> G -> G
forall a. Num a => a -> a -> a
-G
1]
	] where total :: G
total = G -> G -> G
countMerits G
js G
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
i
nnCk :: i -> i -> i
`nCk`i
k | i
ni -> i -> Bool
forall a. Ord a => a -> a -> Bool
<i
0Bool -> Bool -> Bool
||i
ki -> i -> Bool
forall a. Ord a => a -> a -> Bool
<i
0Bool -> Bool -> Bool
||i
ni -> i -> Bool
forall a. Ord a => a -> a -> Bool
<i
k = i
forall a. HasCallStack => a
undefined
        | Bool
otherwise     = i -> i -> i
go i
1 i
1
        where
        go :: i -> i -> i
go i
i i
acc = if i
k' i -> i -> Bool
forall a. Ord a => a -> a -> Bool
< i
i then i
acc else i -> i -> i
go (i
ii -> i -> i
forall a. Num a => a -> a -> a
+i
1) (i
acc i -> i -> i
forall a. Num a => a -> a -> a
* (i
ni -> i -> i
forall a. Num a => a -> a -> a
-i
ii -> i -> i
forall a. Num a => a -> a -> a
+i
1) i -> i -> i
forall a. Integral a => a -> a -> a
`div` i
i)
        -- Use a symmetry to compute over smaller numbers,
        -- which is more efficient and safer
        k' :: i
k' = if i
ni -> i -> i
forall a. Integral a => a -> a -> a
`div`i
2 i -> i -> Bool
forall a. Ord a => a -> a -> Bool
< i
k then i
ni -> i -> i
forall a. Num a => a -> a -> a
-i
k else i
k
infix 7 `nCk`