1 {- |
1 {-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} |
2 Glicko2, as described in http://www.glicko.net/glicko/glicko2.pdf |
|
3 -} |
|
4 |
|
5 module Main where |
2 module Main where |
6 |
3 |
7 --import Data.Map as Map |
4 import Data.Maybe |
|
5 import Data.TConfig |
|
6 import qualified Data.ByteString.Char8 as B |
|
7 import Database.MySQL.Simple |
|
8 import Database.MySQL.Simple.QueryResults |
|
9 import Database.MySQL.Simple.Result |
|
10 import Control.Monad |
|
11 import Control.Exception |
|
12 import System.IO |
|
13 import qualified Data.Map as Map |
|
14 ------ |
|
15 import OfficialServer.Glicko2 |
8 |
16 |
9 data RatingData = RatingData { |
17 |
10 ratingValue |
18 queryEpochDates = "SELECT epoch, todatetime, todatetime + INTERVAL 1 week FROM rating_epochs WHERE epoch = (SELECT MAX(epoch) FROM rating_epochs)" |
11 , rD |
19 queryPreviousRatings = "SELECT v.userid, v.rating, v.rd, v.volatility FROM rating_values as v WHERE (v.epoch = (SELECT MAX(epoch) FROM rating_epochs))" |
12 , volatility :: Double |
20 queryGameResults = |
13 } |
21 "SELECT \ |
14 data GameData = GameData { |
22 \ p.userid \ |
15 rating :: RatingData, |
23 \ , p.place \ |
16 opponentRating :: RatingData, |
24 \ , o.userid \ |
17 gameScore :: Double |
25 \ , o.place \ |
|
26 \ , COALESCE(vp.rating, 1500) \ |
|
27 \ , COALESCE(vp.rd, 350) \ |
|
28 \ , COALESCE(vp.volatility, 0.06) \ |
|
29 \ , COALESCE(vo.rating, 1500) \ |
|
30 \ , COALESCE(vo.rd, 350) \ |
|
31 \ , COALESCE(vo.volatility, 0.06) \ |
|
32 \ FROM \ |
|
33 \ (SELECT epoch, todatetime FROM rating_epochs WHERE epoch = (SELECT MAX(epoch) FROM rating_epochs)) as e \ |
|
34 \ JOIN rating_games as g ON (g.time BETWEEN e.todatetime AND e.todatetime + INTERVAL 1 WEEK - INTERVAL 1 SECOND) \ |
|
35 \ JOIN rating_players as p ON (p.gameid = g.id) \ |
|
36 \ JOIN rating_players as o ON (p.gameid = o.gameid AND p.userid <> o.userid AND (p.place = 0 OR (p.place <> o.place))) \ |
|
37 \ LEFT OUTER JOIN rating_values as vp ON (vp.epoch = e.epoch AND vp.userid = p.userid) \ |
|
38 \ LEFT OUTER JOIN rating_values as vo ON (vo.epoch = e.epoch AND vo.userid = o.userid) \ |
|
39 \ GROUP BY p.userid, p.gameid, p.place \ |
|
40 \ ORDER BY p.userid" |
|
41 |
|
42 --Map Int (RatingData, [GameData]) |
|
43 calculateRatings dbConn = do |
|
44 initRatingData <- (Map.fromList . map fromDBrating) `fmap` query_ dbConn queryPreviousRatings |
|
45 return () |
|
46 |
|
47 where |
|
48 fromDBrating (a, b, c, d) = (a, (RatingData b c d, [])) |
|
49 |
|
50 |
|
51 |
|
52 data DBConnectInfo = DBConnectInfo { |
|
53 dbHost |
|
54 , dbName |
|
55 , dbLogin |
|
56 , dbPassword :: B.ByteString |
18 } |
57 } |
19 |
58 |
20 τ, ε :: Double |
59 cfgFileName :: String |
21 τ = 0.3 |
60 cfgFileName = "hedgewars-server.ini" |
22 ε = 0.000001 |
|
23 |
|
24 g_φ :: Double -> Double |
|
25 g_φ φ = 1 / sqrt (1 + 3 * φ^2 / pi^2) |
|
26 |
|
27 calcE :: GameData -> (Double, Double, Double) |
|
28 calcE (GameData oldRating oppRating s) = ( |
|
29 1 / (1 + exp (g_φᵢ * (μᵢ - μ))) |
|
30 , g_φᵢ |
|
31 , s |
|
32 ) |
|
33 where |
|
34 μ = (ratingValue oldRating - 1500) / 173.7178 |
|
35 φ = rD oldRating / 173.7178 |
|
36 μᵢ = (ratingValue oppRating - 1500) / 173.7178 |
|
37 φᵢ = rD oppRating / 173.7178 |
|
38 g_φᵢ = g_φ φᵢ |
|
39 |
61 |
40 |
62 |
41 calcNewRating :: [GameData] -> RatingData |
63 readServerConfig :: ConnectInfo -> IO ConnectInfo |
42 calcNewRating [] = undefined |
64 readServerConfig ci = do |
43 calcNewRating games@(GameData oldRating _ _ : _) = RatingData (173.7178 * μ' + 1500) (173.7178 * sqrt φ'sqr) σ' |
65 cfg <- readConfig cfgFileName |
|
66 return $ ci{ |
|
67 connectHost = value "dbHost" cfg |
|
68 , connectDatabase = value "dbName" cfg |
|
69 , connectUser = value "dbLogin" cfg |
|
70 , connectPassword = value "dbPassword" cfg |
|
71 } |
44 where |
72 where |
45 _Es = map calcE games |
73 value n c = fromJust2 n $ getValue n c |
46 υ = 1 / sum (map υ_p _Es) |
74 fromJust2 n Nothing = error $ "Missing config entry " ++ n |
47 υ_p (_Eᵢ, g_φᵢ, _) = g_φᵢ ^ 2 * _Eᵢ * (1 - _Eᵢ) |
75 fromJust2 _ (Just a) = a |
48 _Δ = υ * part1 |
|
49 part1 = sum (map _Δ_p _Es) |
|
50 _Δ_p (_Eᵢ, g_φᵢ, sᵢ) = g_φᵢ * (sᵢ - _Eᵢ) |
|
51 |
76 |
52 μ = (ratingValue oldRating - 1500) / 173.7178 |
77 dbConnectionLoop mySQLConnectionInfo = |
53 φ = rD oldRating / 173.7178 |
78 Control.Exception.handle (\(e :: SomeException) -> hPutStrLn stderr $ show e) $ |
54 σ = volatility oldRating |
79 bracket |
|
80 (connect mySQLConnectionInfo) |
|
81 close |
|
82 calculateRatings |
55 |
83 |
56 a = log (σ ^ 2) |
84 main = readServerConfig defaultConnectInfo >>= dbConnectionLoop |
57 f :: Double -> Double |
|
58 f x = exp x * (_Δ ^ 2 - φ ^ 2 - υ - exp x) / 2 / (φ ^ 2 + υ + exp x) ^ 2 - (x - a) / τ ^ 2 |
|
59 |
|
60 _A = a |
|
61 _B = if _Δ ^ 2 > φ ^ 2 + υ then log (_Δ ^ 2 - φ ^ 2 - υ) else head . dropWhile ((>) 0 . f) . map (\k -> a - k * τ) $ [1 ..] |
|
62 fA = f _A |
|
63 fB = f _B |
|
64 σ' = (\(_A, _, _, _) -> exp (_A / 2)) . head . dropWhile (\(_A, _, _B, _) -> abs (_B - _A) > ε) $ iterate step5 (_A, fA, _B, fB) |
|
65 step5 (_A, fA, _B, fB) = let _C = _A + (_A - _B) * fA / (fB - fA); fC = f _C in |
|
66 if fC * fB < 0 then (_B, fB, _C, fC) else (_A, fA / 2, _C, fC) |
|
67 |
|
68 φ'sqr = 1 / (1 / (φ ^ 2 + σ' ^ 2) + 1 / υ) |
|
69 μ' = μ + φ'sqr * part1 |
|
70 |
|
71 main = undefined |
|