gameServer/OfficialServer/Glicko2.hs
author unc0rr
Sun, 22 Nov 2015 18:06:32 +0300
branchqmlfrontend
changeset 11425 2947f06e8533
parent 11390 36e1bbb6ecea
permissions -rw-r--r--
Another approach to parsing two-lines protocol commands
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