gistfile1.hs

import Test.HUnit

type Rating = Double
type RatingDeviation = Double
type Opponent = (Rating, RatingDeviation, Double)
type Opponents = [Opponent]

data Config = Config RatingDeviation Double Double

epsilon = 0.000001

-- Step 2
scale :: Rating -> RatingDeviation -> (Double, Double)
scale r rd =
      let rf  = r
          rdf = rd
      in
      ((rf - 1500) / 173.7178, rdf / 173.7178)

g :: Double -> Double
g phi = 1 / (sqrt (1 + 3 * phi * phi / (pi * pi)))

e :: Double -> Double -> Double -> Double
e mu muj phij = 1 / (1 + exp (-(g phij) * (mu - muj)))

scale_opponents :: Double -> Opponents -> [(Double, Double, Double, Double, Double)]
scale_opponents mu opponents =
    [scale_opponent rj rdj sj | (rj, rdj, sj) <- opponents]
    where
        scale_opponent rj rdj sj =
                       let (muj, phij) = scale rj rdj
                       in (muj, phij, g phij, e mu muj phij, sj)

-- Step 3
update_rating :: [(Double, Double, Double, Double, Double)] -> Double
update_rating opponents =
    1 / (sum [(square gphij) * emmp * (1 - emmp)
                    | (_, _, gphij, emmp, _) <- opponents])

-- Step 4
compute_delta :: Double -> [(Double, Double, Double, Double, Double)] -> Double
compute_delta v opponents =
    v * (sum [gphij * (sj - emmp)
                   | (_, _, gphij, emmp, sj) <- opponents])

-- Step 5
vol_f :: Double -> Double -> Double -> Double -> Config -> (Double -> Double)
vol_f phi v delta a (Config _ _ tau) =
      let phi2 = phi * phi
      in
      \x ->
         let ex = exp x
             d2 = delta * delta
             a2 = phi2 + v + ex
             p2 = (x - a) / (tau * tau)
             p1 = (ex * (d2 - phi2 - v - ex))  / (2*a2*a2)
          in
          p1 - p2

vol_k :: Double -> (Double -> Double) -> Double -> Config -> Double
vol_k k f a (Config rd s tau) =
    let const = a - k * (sqrt (tau * tau))
    in
    case (f const) < 0 of
         True -> vol_k (k+1) f a $ Config rd s tau
         False -> const

i_compute_volatility :: Double -> Double -> Double -> Double -> Config -> Double
i_compute_volatility sigma phi v delta (Config rd sigma2 tau) =
    let
        a = log (sigma * sigma)
        f = vol_f phi v delta a (Config rd sigma2 tau)
        b = case delta * delta > (phi * phi + v) of
            True -> log (delta*delta - phi*phi - v)
            False -> vol_k 1 f a (Config rd sigma2 tau)
        fa = f a
        fb = f b
    in
        compute_volatility a b f fa fb 100

sign x
     | x > 0 = 1
     | x < 0 = -1
     | x == 0.0   =  0
     | otherwise = 0


compute_volatility :: Double -> Double -> (Double -> Double) ->
                             Double -> Double -> Double -> Double
compute_volatility a b f fa fb k
                   | abs (b - a) <= epsilon =
                     exp (a/2)
                   | otherwise =
    let
        c = (a + b) * 0.5
        fc = f c
        d = c + (c - a) * (sign (fa - fb) * fc) / sqrt (fc*fc - fa*fb)
        fd = f d
    in
    case sign fd /= sign fc of
        True ->
            compute_volatility c d f fc fd (k-1)
        False ->
            case sign fd /= sign fa of
                True ->
                    compute_volatility a d f fa fd (k-1)
                False ->
                    compute_volatility d b f fd fb (k-1)

-- Step 6
phi_star :: Double -> Double -> Double
phi_star sigmap phi =
    sqrt (square phi + square sigmap)

-- Step 7
new_rating :: Double -> Double -> Double ->
           [(Double, Double, Double, Double, Double)] -> (Double, Double)
new_rating phistar mu v opponents =
    let
        phip = 1 / sqrt ((1 / square phistar) + (1 / v))
        l = [gphij * (sj - emmp) | (_, _, gphij, emmp, sj) <- opponents]
        mup  = mu + square phip * (sum l)
    in (mup, phip)

-- Step 8
unscale :: Double -> Double -> (Double, Double)
unscale mup phip =
    let
        rp = (173.7178 * mup) + 1500
        rdp = 173.7178 * phip
    in (rp, rdp)

square x = x * x

rate_def :: Rating -> RatingDeviation -> Double -> Opponents -> Opponent
rate_def r rd s o = rate r rd s o $ Config 350 0.06 0.5

rate :: Rating -> RatingDeviation -> Double -> Opponents -> Config -> Opponent
rate r rd s o c =
    let
        (mu, phi) = scale r rd
        scaled_opponents = scale_opponents mu o
        v = update_rating scaled_opponents
        delta = compute_delta v scaled_opponents
        sigmap = i_compute_volatility s phi v delta c
        phistar = phi_star sigmap phi
        (mup, phip) = new_rating phistar mu v scaled_opponents
        (r1, rd1) = unscale mup phip
    in
        (r1, rd1, sigmap)

-- tests

d =
  let
    player = (1500, 200)
    volatility = 0.06
    opponents = [(1400, 30,  1),
                 (1550, 100, 0),
                 (1700, 300, 0)]
  in  (player, volatility, opponents)

within x y = abs (x - y) < 0.0001

glicko_test = TestCase(
            do
            let ((r, rd), sigma, opponents) = d
                (mu, phi) = scale r rd
                scaled = scale_opponents mu opponents
                v = update_rating scaled
                delta = compute_delta v scaled
                sigmap = i_compute_volatility sigma phi v delta (Config 350 0.06 0.5)
                phistar = phi_star sigmap phi
                (mup, phip) = new_rating phistar mu v scaled
                (r1, rd1) = unscale mup phip

            assertEqual "mu phi" (0.0, 1.1512924985234674) (mu, phi)
            assertEqual "scaled opps" [(-0.5756462492617337,0.1726938747785201,
                                         0.9954980064506083,0.6394677305521533,1),
                                       (0.28782312463086684,0.5756462492617337,
                                         0.9531489778689763,0.4318423561076679,0),
                                       (1.1512924985234674,1.726938747785201,
                                         0.7242354780877526,0.30284072909521925,0)] scaled
            assertEqual "v" 1.7789770897239976 v
            assertEqual "delta" (-0.4839332609836549) delta
            assertEqual "sigmap" True (within 0.059995984286488495 sigmap)
            assertEqual "phistar" True (within 1.1528546895801364 phistar)
            assertEqual "mup" True (within (-0.20694096667525494) mup)
            assertEqual "phip" True (within 0.8721991881307343 phip)
            assertEqual "r1" True (within 1464.0506705393013 r1)
            assertEqual "rd1" True (within 151.51652412385727 rd1))