gameServer/OfficialServer/Glicko2.hs
author Wuzzy <Wuzzy2@mail.ru>
Wed, 25 Oct 2017 23:09:41 +0200
changeset 12763 ad67a3804981
parent 11390 36e1bbb6ecea
permissions -rw-r--r--
Fix sometimes ammo schemes not being saved after changing before an ammo scheme got deleted in session This was because the bool isDeleting is not initialized, so its initial value is unpredictable. Which means there's chance it starts with true, confusing the frontend.
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
11380
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
     1
{-
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
     2
    Glicko2, as described in http://www.glicko.net/glicko/glicko2.pdf
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
     3
-}
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
     4
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
     5
module OfficialServer.Glicko2 where
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
     6
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
     7
data RatingData = RatingData {
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
     8
        ratingValue
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
     9
        , rD
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    10
        , volatility :: Double
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    11
    }
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    12
data GameData = GameData {
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    13
        opponentRating :: RatingData,
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    14
        gameScore :: Double
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    15
    }
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    16
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    17
τ, ε :: Double
11390
36e1bbb6ecea - Reduce tau value, as suggested in gecko2 paper
unc0rr
parents: 11381
diff changeset
    18
τ = 0.2
11380
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    19
ε = 0.000001
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    20
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    21
g_φ :: Double -> Double
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    22
g_φ φ = 1 / sqrt (1 + 3 * φ^2 / pi^2)
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    23
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    24
calcE :: RatingData -> GameData -> (Double, Double, Double)
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    25
calcE oldRating (GameData oppRating s) = (
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    26
    1 / (1 + exp (g_φᵢ * (μᵢ - μ)))
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    27
    , g_φᵢ
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    28
    , s
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    29
    )
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    30
    where
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    31
        μ = (ratingValue oldRating - 1500) / 173.7178
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    32
        φ = rD oldRating / 173.7178
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    33
        μᵢ = (ratingValue oppRating - 1500) / 173.7178
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    34
        φᵢ = rD oppRating / 173.7178
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    35
        g_φᵢ = g_φ φᵢ
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    36
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    37
11390
36e1bbb6ecea - Reduce tau value, as suggested in gecko2 paper
unc0rr
parents: 11381
diff changeset
    38
calcNewRating :: RatingData -> [GameData] -> (Int, RatingData)
36e1bbb6ecea - Reduce tau value, as suggested in gecko2 paper
unc0rr
parents: 11381
diff changeset
    39
calcNewRating oldRating [] = (0, RatingData (ratingValue oldRating) (173.7178 * sqrt (φ ^ 2 + σ ^ 2)) σ)
11381
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    40
    where
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    41
        φ = rD oldRating / 173.7178
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    42
        σ = volatility oldRating
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    43
11390
36e1bbb6ecea - Reduce tau value, as suggested in gecko2 paper
unc0rr
parents: 11381
diff changeset
    44
calcNewRating oldRating games = (length games, RatingData (173.7178 * μ' + 1500) (173.7178 * sqrt φ'sqr) σ')
11380
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    45
    where
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    46
        _Es = map (calcE oldRating) games
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    47
        υ = 1 / sum (map υ_p _Es)
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    48
        υ_p (_Eᵢ, g_φᵢ, _) = g_φᵢ ^ 2 * _Eᵢ * (1 - _Eᵢ)
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    49
        _Δ = υ * part1
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    50
        part1 = sum (map _Δ_p _Es)
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    51
        _Δ_p (_Eᵢ, g_φᵢ, sᵢ) = g_φᵢ * (sᵢ - _Eᵢ)
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    52
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    53
        μ = (ratingValue oldRating - 1500) / 173.7178
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    54
        φ = rD oldRating / 173.7178
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    55
        σ = volatility oldRating
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    56
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    57
        a = log (σ ^ 2)
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    58
        f :: Double -> Double
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    59
        f x = exp x * (_Δ ^ 2 - φ ^ 2 - υ - exp x) / 2 / (φ ^ 2 + υ + exp x) ^ 2 - (x - a) / τ ^ 2
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    60
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    61
        _A = a
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    62
        _B = if _Δ ^ 2 > φ ^ 2 + υ then log (_Δ ^ 2 - φ ^ 2 - υ) else head . dropWhile ((>) 0 . f) . map (\k -> a - k * τ) $ [1 ..]
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    63
        fA = f _A
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    64
        fB = f _B
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    65
        σ' = (\(_A, _, _, _) -> exp (_A / 2)) . head . dropWhile (\(_A, _, _B, _) -> abs (_B - _A) > ε) $ iterate step5 (_A, fA, _B, fB)
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    66
        step5 (_A, fA, _B, fB) = let _C = _A + (_A - _B) * fA / (fB - fA); fC = f _C in
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    67
                                     if fC * fB < 0 then (_B, fB, _C, fC) else (_A, fA / 2, _C, fC)
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    68
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    69
        φ'sqr = 1 / (1 / (φ ^ 2 + σ' ^ 2) + 1 / υ)
ff0fa38bdb18 Some WIP
unc0rr
parents:
diff changeset
    70
        μ' = μ + φ'sqr * part1