--------------------------------------------------------------------------------

-- | Implementation of the Open Codeforces Rating System described in
-- <https://codeforces.com/blog/entry/20762 Mike Mirzayanov's blog post>.
--
module Codeforces.Virtual.RatingCalculator
    ( calculateContestResults
    ) where

import           Codeforces.Types.Common
import           Codeforces.Types.Party  hiding ( Contestant )
import           Codeforces.Types.Standings
import           Codeforces.Virtual.Types

import           Control.Monad
import           Control.Monad.Trans.State

import           Data.Functor                   ( (<&>) )
import           Data.List
import qualified Data.Map                      as M
import           Data.Maybe
import           Data.Ord

--------------------------------------------------------------------------------

-- | 'calculateContestResults' @previousRatings updatedRankings@ computes the
-- contest results.
calculateContestResults
    :: M.Map Handle Rating -> [RanklistRow] -> ContestResults
calculateContestResults :: Map Handle Rating -> [RanklistRow] -> ContestResults
calculateContestResults Map Handle Rating
hs [RanklistRow]
rrs = [Contestant]
-> Map Party Rating -> Map Rating Seed -> ContestResults
ContestResults [Contestant]
sortedCs Map Party Rating
deltas Map Rating Seed
seeds
  where
    sortedCs :: [Contestant]
sortedCs        = [Contestant] -> [Contestant]
reassignRanks ([Contestant] -> [Contestant]) -> [Contestant] -> [Contestant]
forall a b. (a -> b) -> a -> b
$ Map Handle Rating -> [RanklistRow] -> [Contestant]
mkContestants Map Handle Rating
hs [RanklistRow]
rrs
    (Map Party Rating
deltas, Map Rating Seed
seeds) = [Contestant] -> (Map Party Rating, Map Rating Seed)
process [Contestant]
sortedCs

-- | Constructs a list of contestants from the previous ratings and rankings.
mkContestants :: M.Map Handle Rating -> [RanklistRow] -> [Contestant]
mkContestants :: Map Handle Rating -> [RanklistRow] -> [Contestant]
mkContestants Map Handle Rating
prevRatings = (RanklistRow -> Contestant) -> [RanklistRow] -> [Contestant]
forall a b. (a -> b) -> [a] -> [b]
map
    (\RanklistRow {Seed
Rating
[ProblemResult]
Maybe DiffTime
Party
rrLastSubmissionTime :: RanklistRow -> Maybe DiffTime
rrProblemResults :: RanklistRow -> [ProblemResult]
rrUnsuccessfulHackCount :: RanklistRow -> Rating
rrSuccessfulHackCount :: RanklistRow -> Rating
rrPenalty :: RanklistRow -> Rating
rrPoints :: RanklistRow -> Seed
rrRank :: RanklistRow -> Rating
rrParty :: RanklistRow -> Party
rrLastSubmissionTime :: Maybe DiffTime
rrProblemResults :: [ProblemResult]
rrUnsuccessfulHackCount :: Rating
rrSuccessfulHackCount :: Rating
rrPenalty :: Rating
rrPoints :: Seed
rrRank :: Rating
rrParty :: Party
..} -> Contestant :: Party -> Rating -> Seed -> Rating -> Contestant
Contestant { contestantParty :: Party
contestantParty  = Party
rrParty
                                     , contestantRank :: Rating
contestantRank   = Rating
rrRank
                                     , contestantPoints :: Seed
contestantPoints = Seed
rrPoints
                                     , contestantRating :: Rating
contestantRating = Party -> Rating
getPartyRating Party
rrParty
                                     }
    )
  where
    getPartyRating :: Party -> Rating
getPartyRating = [Rating] -> Rating
computePartyRating ([Rating] -> Rating) -> (Party -> [Rating]) -> Party -> Rating
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Member -> Rating) -> [Member] -> [Rating]
forall a b. (a -> b) -> [a] -> [b]
map Member -> Rating
lookupRating ([Member] -> [Rating]) -> (Party -> [Member]) -> Party -> [Rating]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Party -> [Member]
partyMembers
    lookupRating :: Member -> Rating
lookupRating Member
m = Rating -> Handle -> Map Handle Rating -> Rating
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Rating
initRating (Member -> Handle
memberHandle Member
m) Map Handle Rating
prevRatings

--------------------------------------------------------------------------------

-- | Initial rating of a member, if they do not already have a rating.
initRating :: Rating
initRating :: Rating
initRating = Rating
0

-- | Calculates the overall rating for a party using the ratings of its team
-- members.
--
-- >>> computePartyRating [1400]
-- 1400
--
-- >>> computePartyRating [1400, 1500, 1600]
-- 1749
--
computePartyRating :: [Rating] -> Rating
computePartyRating :: [Rating] -> Rating
computePartyRating [Rating]
ratings = Rating -> Seed -> Seed -> Rating
go Rating
20 Seed
100 Seed
4000
  where
    go :: Int -> Float -> Float -> Rating
    go :: Rating -> Seed -> Seed -> Rating
go Rating
0 Seed
l Seed
r = Seed -> Rating
forall a b. (RealFrac a, Integral b) => a -> b
round (Seed -> Rating) -> Seed -> Rating
forall a b. (a -> b) -> a -> b
$ (Seed
l Seed -> Seed -> Seed
forall a. Num a => a -> a -> a
+ Seed
r) Seed -> Seed -> Seed
forall a. Fractional a => a -> a -> a
/ Seed
2
    go Rating
i Seed
l Seed
r | Seed
computed Seed -> Seed -> Bool
forall a. Ord a => a -> a -> Bool
> Seed
mid = Rating -> Seed -> Seed -> Rating
go (Rating
i Rating -> Rating -> Rating
forall a. Num a => a -> a -> a
- Rating
1) Seed
mid Seed
r
             | Bool
otherwise      = Rating -> Seed -> Seed -> Rating
go (Rating
i Rating -> Rating -> Rating
forall a. Num a => a -> a -> a
- Rating
1) Seed
l Seed
mid
      where
        mid :: Seed
mid = (Seed
l Seed -> Seed -> Seed
forall a. Num a => a -> a -> a
+ Seed
r) Seed -> Seed -> Seed
forall a. Fractional a => a -> a -> a
/ Seed
2
        rWinsProbability :: Seed
rWinsProbability =
            [Seed] -> Seed
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product ([Seed] -> Seed) -> [Seed] -> Seed
forall a b. (a -> b) -> a -> b
$ (Rating -> Seed) -> [Rating] -> [Seed]
forall a b. (a -> b) -> [a] -> [b]
map (Seed -> Seed -> Seed
getEloWinProbability Seed
mid (Seed -> Seed) -> (Rating -> Seed) -> Rating -> Seed
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rating -> Seed
forall a b. (Integral a, Num b) => a -> b
fromIntegral) [Rating]
ratings
        computed :: Seed
computed = Seed -> Seed -> Seed
forall a. Floating a => a -> a -> a
logBase Seed
10 (Seed
1 Seed -> Seed -> Seed
forall a. Fractional a => a -> a -> a
/ Seed
rWinsProbability Seed -> Seed -> Seed
forall a. Num a => a -> a -> a
- Seed
1) Seed -> Seed -> Seed
forall a. Num a => a -> a -> a
* Seed
400 Seed -> Seed -> Seed
forall a. Num a => a -> a -> a
+ Seed
mid

--------------------------------------------------------------------------------

-- | Ratings mapped to seed (expected ranking)
type SeedCache = M.Map Rating Seed

-- | Computes each party's rating delta and each rating's seed, given a list of
-- contestants.
process :: [Contestant] -> (M.Map Party Delta, SeedCache)
process :: [Contestant] -> (Map Party Rating, Map Rating Seed)
process [] = (Map Party Rating
forall k a. Map k a
M.empty, Map Rating Seed
forall k a. Map k a
M.empty)
process [Contestant]
cs = (State (Map Rating Seed) (Map Party Rating)
 -> Map Rating Seed -> (Map Party Rating, Map Rating Seed))
-> Map Rating Seed
-> State (Map Rating Seed) (Map Party Rating)
-> (Map Party Rating, Map Rating Seed)
forall a b c. (a -> b -> c) -> b -> a -> c
flip State (Map Rating Seed) (Map Party Rating)
-> Map Rating Seed -> (Map Party Rating, Map Rating Seed)
forall s a. State s a -> s -> (a, s)
runState ([Contestant] -> Map Rating Seed
precomputeSeeds [Contestant]
cs) (State (Map Rating Seed) (Map Party Rating)
 -> (Map Party Rating, Map Rating Seed))
-> State (Map Rating Seed) (Map Party Rating)
-> (Map Party Rating, Map Rating Seed)
forall a b. (a -> b) -> a -> b
$ do
    Map Party Rating
ds <- [Contestant] -> State (Map Rating Seed) (Map Party Rating)
calculateDeltas [Contestant]
cs
    Map Party Rating -> State (Map Rating Seed) (Map Party Rating)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Party Rating -> State (Map Rating Seed) (Map Party Rating))
-> (Map Party Rating -> Map Party Rating)
-> Map Party Rating
-> State (Map Rating Seed) (Map Party Rating)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Contestant] -> Map Party Rating -> Map Party Rating
adjustTopDeltas [Contestant]
cs (Map Party Rating -> Map Party Rating)
-> (Map Party Rating -> Map Party Rating)
-> Map Party Rating
-> Map Party Rating
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Party Rating -> Map Party Rating
adjustAllDeltas (Map Party Rating -> State (Map Rating Seed) (Map Party Rating))
-> Map Party Rating -> State (Map Rating Seed) (Map Party Rating)
forall a b. (a -> b) -> a -> b
$ Map Party Rating
ds

-- | Computes the seed of each contestant.
precomputeSeeds :: [Contestant] -> SeedCache
precomputeSeeds :: [Contestant] -> Map Rating Seed
precomputeSeeds [Contestant]
cs =
    [(Rating, Seed)] -> Map Rating Seed
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Rating, Seed)] -> Map Rating Seed)
-> [(Rating, Seed)] -> Map Rating Seed
forall a b. (a -> b) -> a -> b
$ (Contestant -> (Rating, Seed)) -> [Contestant] -> [(Rating, Seed)]
forall a b. (a -> b) -> [a] -> [b]
map (\Contestant
c -> (Contestant -> Rating
contestantRating Contestant
c, Contestant -> [Contestant] -> Seed
calculateSeedOf Contestant
c [Contestant]
cs)) [Contestant]
cs

-- | Adjusts rating deltas to ensure the total sum of deltas is not more than
-- zero. If it is, the extra amount is distributed between all contestants.
adjustAllDeltas :: M.Map Party Delta -> M.Map Party Delta
adjustAllDeltas :: Map Party Rating -> Map Party Rating
adjustAllDeltas Map Party Rating
ds = (Rating -> Rating) -> Map Party Rating -> Map Party Rating
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (Rating -> Rating -> Rating
forall a. Num a => a -> a -> a
+ Rating
inc) Map Party Rating
ds
    where inc :: Rating
inc = (Rating -> Rating
forall a. Num a => a -> a
negate ([Rating] -> Rating
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (Map Party Rating -> [Rating]
forall k a. Map k a -> [a]
M.elems Map Party Rating
ds)) Rating -> Rating -> Rating
forall a. Integral a => a -> a -> a
`div` Map Party Rating -> Rating
forall k a. Map k a -> Rating
M.size Map Party Rating
ds) Rating -> Rating -> Rating
forall a. Num a => a -> a -> a
- Rating
1

-- | Adjusts rating deltas to prevent ratings of top competitors becoming
-- inflated.
--
-- /Before/ the round, we choose a group of most highly rated competitors and
-- decide that their /total/ rating shouldn't change. The size of this group is
-- determined by the heuristic:
--
-- \[
-- s = \min(n, 4 \sqrt{n})
-- \]
--
-- The sum of deltas over this group is adjusted to make it 0:
--
-- \[
-- r_i = r_i - \frac{\sum^s d_i}{s}
-- \]
--
adjustTopDeltas :: [Contestant] -> M.Map Party Delta -> M.Map Party Delta
adjustTopDeltas :: [Contestant] -> Map Party Rating -> Map Party Rating
adjustTopDeltas [Contestant]
cs Map Party Rating
ds = (Rating -> Rating) -> Map Party Rating -> Map Party Rating
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (Rating -> Rating -> Rating
forall a. Num a => a -> a -> a
+ Rating
inc) Map Party Rating
ds
  where
    inc :: Rating
inc          = Rating -> Rating -> Rating
forall a. Ord a => a -> a -> a
min Rating
0 (Rating -> Rating) -> Rating -> Rating
forall a b. (a -> b) -> a -> b
$ Rating -> Rating -> Rating
forall a. Ord a => a -> a -> a
max (-Rating
10) (Rating -> Rating
forall a. Num a => a -> a
negate Rating
sumTopDeltas Rating -> Rating -> Rating
forall a. Integral a => a -> a -> a
`div` Rating
zeroSumCount)

    sumTopDeltas :: Rating
sumTopDeltas = [Rating] -> Rating
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Rating] -> Rating) -> [Rating] -> Rating
forall a b. (a -> b) -> a -> b
$ (Contestant -> Maybe Rating) -> [Contestant] -> [Rating]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((Party -> Map Party Rating -> Maybe Rating)
-> Map Party Rating -> Party -> Maybe Rating
forall a b c. (a -> b -> c) -> b -> a -> c
flip Party -> Map Party Rating -> Maybe Rating
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Map Party Rating
ds (Party -> Maybe Rating)
-> (Contestant -> Party) -> Contestant -> Maybe Rating
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Contestant -> Party
contestantParty)
                                  (Rating -> [Contestant] -> [Contestant]
forall a. Rating -> [a] -> [a]
take Rating
zeroSumCount ([Contestant] -> [Contestant]) -> [Contestant] -> [Contestant]
forall a b. (a -> b) -> a -> b
$ [Contestant] -> [Contestant]
sortByRatingDesc [Contestant]
cs)

    zeroSumCount :: Rating
zeroSumCount = Rating -> Rating -> Rating
forall a. Ord a => a -> a -> a
min (Map Party Rating -> Rating
forall k a. Map k a -> Rating
M.size Map Party Rating
ds) Rating
topCount
    topCount :: Rating
topCount     = Rating
4 Rating -> Rating -> Rating
forall a. Num a => a -> a -> a
* (Double -> Rating
round' (Double -> Rating)
-> (Map Party Rating -> Double) -> Map Party Rating -> Rating
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Double
forall a. Floating a => a -> a
sqrt (Double -> Double)
-> (Map Party Rating -> Double) -> Map Party Rating -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rating -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Rating -> Double)
-> (Map Party Rating -> Rating) -> Map Party Rating -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Party Rating -> Rating
forall k a. Map k a -> Rating
M.size) Map Party Rating
ds
    round' :: Double -> Rating
round'       = Double -> Rating
forall a b. (RealFrac a, Integral b) => a -> b
round :: Double -> Int

-- | Computes the rating delta for each party in this contest.
--
-- The input list of contestants must be correctly ordered with 'reassignRanks'
-- prior to using this function.
--
calculateDeltas :: [Contestant] -> State SeedCache (M.Map Party Delta)
calculateDeltas :: [Contestant] -> State (Map Rating Seed) (Map Party Rating)
calculateDeltas [Contestant]
cs = do
    [(Party, Rating)]
deltas <- [Contestant]
-> (Contestant
    -> StateT (Map Rating Seed) Identity (Party, Rating))
-> StateT (Map Rating Seed) Identity [(Party, Rating)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Contestant]
cs ((Contestant -> StateT (Map Rating Seed) Identity (Party, Rating))
 -> StateT (Map Rating Seed) Identity [(Party, Rating)])
-> (Contestant
    -> StateT (Map Rating Seed) Identity (Party, Rating))
-> StateT (Map Rating Seed) Identity [(Party, Rating)]
forall a b. (a -> b) -> a -> b
$ \Contestant
c -> Contestant -> [Contestant] -> State (Map Rating Seed) Rating
calculateDelta Contestant
c [Contestant]
cs State (Map Rating Seed) Rating
-> (Rating -> (Party, Rating))
-> StateT (Map Rating Seed) Identity (Party, Rating)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Contestant -> Party
contestantParty Contestant
c, )
    Map Party Rating -> State (Map Rating Seed) (Map Party Rating)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Party Rating -> State (Map Rating Seed) (Map Party Rating))
-> Map Party Rating -> State (Map Rating Seed) (Map Party Rating)
forall a b. (a -> b) -> a -> b
$ [(Party, Rating)] -> Map Party Rating
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Party, Rating)]
deltas

-- | Sorts and recomputes the rank of each contestant.
--
-- In this assignment, contestants with the same points have the same rank.
-- Repeated ranks are disregarded when assigning ranks to contestants that
-- score lower than them. For example:
--
-- @
-- | Party | Points | Rank |
-- | ----- | ------ | ---- |
-- | A     | 2302.0 | 41   |
-- | B     | 2302.0 | 41   |
-- | C     | 2302.0 | 41   |
-- | D     | 2256.0 | 44   |   <- rank is not 42, but 44
-- | ...   | ...    | ...  |
-- @
--
-- Reassigning ranks is required because the input list of contestants is not
-- guaranteed to have correct ranks or be in the correct order following the
-- inclusion of the virtual user. E.g. the input list may resemble:
--
-- @
-- | Party | Points | Rank |
-- | ----- | ------ | ---- |
-- | ...   | ...    | ...  |
-- | A     | 2302.0 | 41   |
-- | VU*   | 2300.0 | 42   |
-- | B     | 2266.0 | 42   |   <- ranks from here on are incorrect
-- | C     | 2256.0 | 43   |
-- | ...   | ...    | ...  |
-- @
--
-- *VU = virtual user
--
reassignRanks :: [Contestant] -> [Contestant]
reassignRanks :: [Contestant] -> [Contestant]
reassignRanks = Rating -> Rating -> [Contestant] -> [Contestant]
go Rating
1 Rating
1 ([Contestant] -> [Contestant])
-> ([Contestant] -> [Contestant]) -> [Contestant] -> [Contestant]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Contestant] -> [Contestant]
sortByPointsDesc
  where
    go :: Rating -> Rating -> [Contestant] -> [Contestant]
go Rating
_ Rating
_    []             = []
    go Rating
_ Rating
rank [Contestant
c           ] = [Rating -> Contestant -> Contestant
withRank Rating
rank Contestant
c]
    go Rating
i Rating
rank (Contestant
c1 : Contestant
c2 : [Contestant]
cs) = Rating -> Contestant -> Contestant
withRank Rating
rank Contestant
c1 Contestant -> [Contestant] -> [Contestant]
forall a. a -> [a] -> [a]
: Rating -> Rating -> [Contestant] -> [Contestant]
go (Rating
i Rating -> Rating -> Rating
forall a. Num a => a -> a -> a
+ Rating
1) Rating
nextRank (Contestant
c2 Contestant -> [Contestant] -> [Contestant]
forall a. a -> [a] -> [a]
: [Contestant]
cs)
      where
        nextRank :: Rating
nextRank | Contestant -> Seed
contestantPoints Contestant
c2 Seed -> Seed -> Bool
forall a. Ord a => a -> a -> Bool
< Contestant -> Seed
contestantPoints Contestant
c1 = Rating
i Rating -> Rating -> Rating
forall a. Num a => a -> a -> a
+ Rating
1
                 | Bool
otherwise = Rating
rank

    withRank :: Rating -> Contestant -> Contestant
withRank Rating
r Contestant
c = Contestant
c { contestantRank :: Rating
contestantRank = Rating
r }

-- | 'calculateDelta' @c cs@ computes the rating delta for contestant @c@ using
-- a seed computed from all other contestants @cs@.
--
-- The rating change for a participant is the between the rating they require
-- (according to their seed) and their current rating:
--
-- \[
-- d_i = \frac{R - r_i}{2}
-- \]
--
calculateDelta :: Contestant -> [Contestant] -> State SeedCache Delta
calculateDelta :: Contestant -> [Contestant] -> State (Map Rating Seed) Rating
calculateDelta Contestant
c [Contestant]
cs = do
    Seed
mid        <- Contestant -> [Contestant] -> State (Map Rating Seed) Seed
midRank Contestant
c [Contestant]
cs
    Rating
needRating <- [Contestant] -> Seed -> State (Map Rating Seed) Rating
calculateNeedRating [Contestant]
cs Seed
mid

    Rating -> State (Map Rating Seed) Rating
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Rating -> State (Map Rating Seed) Rating)
-> Rating -> State (Map Rating Seed) Rating
forall a b. (a -> b) -> a -> b
$ (Rating
needRating Rating -> Rating -> Rating
forall a. Num a => a -> a -> a
- Contestant -> Rating
contestantRating Contestant
c) Rating -> Rating -> Rating
forall a. Integral a => a -> a -> a
`div` Rating
2

-- | The geometric mean of a contestant's seed (expected ranking) and actual
-- ranking.
--
-- This ranking is between the expected and actual ranking.
--
midRank :: Contestant -> [Contestant] -> State SeedCache Seed
midRank :: Contestant -> [Contestant] -> State (Map Rating Seed) Seed
midRank Contestant
c [Contestant]
cs = do
    Seed
seed <- Contestant -> [Contestant] -> State (Map Rating Seed) Seed
getSeedOf Contestant
c [Contestant]
cs
    Seed -> State (Map Rating Seed) Seed
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Seed -> State (Map Rating Seed) Seed)
-> Seed -> State (Map Rating Seed) Seed
forall a b. (a -> b) -> a -> b
$ Seed -> Seed
forall a. Floating a => a -> a
sqrt (Seed -> Seed) -> Seed -> Seed
forall a b. (a -> b) -> a -> b
$ Rating -> Seed
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Contestant -> Rating
contestantRank Contestant
c) Seed -> Seed -> Seed
forall a. Num a => a -> a -> a
* Seed
seed

-- | Given a list of contestants and this contestant's 'midRank', calculates
-- the rating a contestant should have to achieve their expected ranking, using
-- binary search.
--
-- In other words, a rating:
--
-- \[
-- R : seed_i = m_i
-- \]
--
calculateNeedRating :: [Contestant] -> Float -> State SeedCache Rating
calculateNeedRating :: [Contestant] -> Seed -> State (Map Rating Seed) Rating
calculateNeedRating [Contestant]
cs Seed
rank = Rating -> Rating -> State (Map Rating Seed) Rating
go Rating
1 Rating
8000
  where
    go :: Rating -> Rating -> State (Map Rating Seed) Rating
go Rating
l Rating
r
        | Rating
r Rating -> Rating -> Rating
forall a. Num a => a -> a -> a
- Rating
l Rating -> Rating -> Bool
forall a. Ord a => a -> a -> Bool
<= Rating
1 = Rating -> State (Map Rating Seed) Rating
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rating
l
        | Bool
otherwise = do
            let mid :: Rating
mid = (Rating
l Rating -> Rating -> Rating
forall a. Num a => a -> a -> a
+ Rating
r) Rating -> Rating -> Rating
forall a. Integral a => a -> a -> a
`div` Rating
2
            Seed
seed <- Rating -> [Contestant] -> State (Map Rating Seed) Seed
getSeed Rating
mid [Contestant]
cs

            if Seed
seed Seed -> Seed -> Bool
forall a. Ord a => a -> a -> Bool
< Seed
rank then Rating -> Rating -> State (Map Rating Seed) Rating
go Rating
l Rating
mid else Rating -> Rating -> State (Map Rating Seed) Rating
go Rating
mid Rating
r

--------------------------------------------------------------------------------
-- Seed calculations and lookups

-- | Looks up the seed for a given rating from the cache. If not found, computes
-- it and updates the cache.
getSeed :: Rating -> [Contestant] -> State SeedCache Seed
getSeed :: Rating -> [Contestant] -> State (Map Rating Seed) Seed
getSeed Rating
rating [Contestant]
cs = do
    Map Rating Seed
cache <- StateT (Map Rating Seed) Identity (Map Rating Seed)
forall (m :: * -> *) s. Monad m => StateT s m s
get

    case Rating -> Map Rating Seed -> Maybe Seed
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Rating
rating Map Rating Seed
cache of
        Maybe Seed
Nothing -> do
            let seed :: Seed
seed = Rating -> [Contestant] -> Seed
calculateSeed Rating
rating [Contestant]
cs
            (Map Rating Seed -> Map Rating Seed)
-> StateT (Map Rating Seed) Identity ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify ((Map Rating Seed -> Map Rating Seed)
 -> StateT (Map Rating Seed) Identity ())
-> (Map Rating Seed -> Map Rating Seed)
-> StateT (Map Rating Seed) Identity ()
forall a b. (a -> b) -> a -> b
$ Rating -> Seed -> Map Rating Seed -> Map Rating Seed
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Rating
rating Seed
seed
            Seed -> State (Map Rating Seed) Seed
forall (f :: * -> *) a. Applicative f => a -> f a
pure Seed
seed

        (Just Seed
seed) -> Seed -> State (Map Rating Seed) Seed
forall (f :: * -> *) a. Applicative f => a -> f a
pure Seed
seed

-- | Like 'getSeed' but takes a contestant and list of /all/ contestants.
getSeedOf :: Contestant -> [Contestant] -> State SeedCache Seed
getSeedOf :: Contestant -> [Contestant] -> State (Map Rating Seed) Seed
getSeedOf Contestant
x [Contestant]
ys = Rating -> [Contestant] -> State (Map Rating Seed) Seed
getSeed (Contestant -> Rating
contestantRating Contestant
x) ((Contestant -> Bool) -> [Contestant] -> [Contestant]
forall a. (a -> Bool) -> [a] -> [a]
filter (Contestant -> Contestant -> Bool
forall a. Eq a => a -> a -> Bool
/= Contestant
x) [Contestant]
ys)

-- | Calculates the seed of a contestant with the given rating, using the
-- supplied list of all /other/ contestants.
--
-- \[
-- seed_i = \sum_{j=1, j \ne i}^{n} P_{j,i} + 1
-- \]
--
-- 1 is added to account for 1-based rankings.
--
-- The general idea is to increase the contestant's rating if their actual
-- ranking is better than their seed, and decrease if worse.
--
calculateSeed :: Rating -> [Contestant] -> Seed
calculateSeed :: Rating -> [Contestant] -> Seed
calculateSeed Rating
rating [Contestant]
others =
    Seed
1 Seed -> Seed -> Seed
forall a. Num a => a -> a -> a
+ [Seed] -> Seed
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ Rating -> Rating -> Seed
getEloWinProbability' (Contestant -> Rating
contestantRating Contestant
x) Rating
rating | Contestant
x <- [Contestant]
others ]

-- | Like 'calculateSeed' but takes a contestant and list of /all/ contestants.
calculateSeedOf :: Contestant -> [Contestant] -> Seed
calculateSeedOf :: Contestant -> [Contestant] -> Seed
calculateSeedOf Contestant
x [Contestant]
ys = Rating -> [Contestant] -> Seed
calculateSeed (Contestant -> Rating
contestantRating Contestant
x) ((Contestant -> Bool) -> [Contestant] -> [Contestant]
forall a. (a -> Bool) -> [a] -> [a]
filter (Contestant -> Contestant -> Bool
forall a. Eq a => a -> a -> Bool
/= Contestant
x) [Contestant]
ys)

-- | Computes the Elo win probability given two ratings.
--
-- This is the probability that the @x@th participant has a better result that
-- the @y@th participant, given by:
--
-- \[
-- P_{i,j} = \frac{1}{1 + 10^\frac{r_j - r_i}{400}}
-- \]
--
-- E.g. if the difference between ratings is 200 then the stronger participant
-- will win with probability ~0.75. If the difference is 400 then the stronger
-- participant will win with probability ~0.9.
--
-- __Note:__ reversing the order of rating arguments reverses the result.
--
-- >>> getEloWinProbability 1400 1200
-- 0.7597469
--
-- >>> getEloWinProbability 1200 1400
-- 0.24025308
--
getEloWinProbability :: Float -> Float -> Float
getEloWinProbability :: Seed -> Seed -> Seed
getEloWinProbability Seed
x Seed
y = Seed
1 Seed -> Seed -> Seed
forall a. Fractional a => a -> a -> a
/ (Seed
1 Seed -> Seed -> Seed
forall a. Num a => a -> a -> a
+ Seed
10 Seed -> Seed -> Seed
forall a. Floating a => a -> a -> a
** ((Seed
y Seed -> Seed -> Seed
forall a. Num a => a -> a -> a
- Seed
x) Seed -> Seed -> Seed
forall a. Fractional a => a -> a -> a
/ Seed
400))

-- | Like 'getEloWinProbability' but takes 'Int's instead of 'Float's.
getEloWinProbability' :: Rating -> Rating -> Float
getEloWinProbability' :: Rating -> Rating -> Seed
getEloWinProbability' Rating
x = Seed -> Seed -> Seed
getEloWinProbability (Rating -> Seed
forall a b. (Integral a, Num b) => a -> b
fromIntegral Rating
x) (Seed -> Seed) -> (Rating -> Seed) -> Rating -> Seed
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rating -> Seed
forall a b. (Integral a, Num b) => a -> b
fromIntegral

--------------------------------------------------------------------------------
-- Utility functions

sortByPointsDesc :: [Contestant] -> [Contestant]
sortByPointsDesc :: [Contestant] -> [Contestant]
sortByPointsDesc = (Contestant -> Down Seed) -> [Contestant] -> [Contestant]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Seed -> Down Seed
forall a. a -> Down a
Down (Seed -> Down Seed)
-> (Contestant -> Seed) -> Contestant -> Down Seed
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Contestant -> Seed
contestantPoints)

sortByRatingDesc :: [Contestant] -> [Contestant]
sortByRatingDesc :: [Contestant] -> [Contestant]
sortByRatingDesc = (Contestant -> Down Rating) -> [Contestant] -> [Contestant]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Rating -> Down Rating
forall a. a -> Down a
Down (Rating -> Down Rating)
-> (Contestant -> Rating) -> Contestant -> Down Rating
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Contestant -> Rating
contestantRating)

--------------------------------------------------------------------------------