gameServer/OfficialServer/updateRating.hs
author Wuzzy <Wuzzy2@mail.ru>
Fri, 03 Aug 2018 00:39:50 +0200
changeset 13607 212036414957
parent 11390 36e1bbb6ecea
permissions -rw-r--r--
Make cake bounce off bounce edge, stop cake at wrap edge to prevent other bug The "other bug" is that the cake just walks through terrain when it hits the wrap world edge. This behaviour is even worse.
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
11380
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
     1
{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}
11358
55360683db75 Start work on rating calculator
unc0rr
parents:
diff changeset
     2
module Main where
55360683db75 Start work on rating calculator
unc0rr
parents:
diff changeset
     3
11380
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
     4
import Data.Maybe
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
     5
import Data.TConfig
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
     6
import qualified Data.ByteString.Char8 as B
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
     7
import Database.MySQL.Simple
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
     8
import Database.MySQL.Simple.QueryResults
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
     9
import Database.MySQL.Simple.Result
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    10
import Control.Monad
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    11
import Control.Exception
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    12
import System.IO
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    13
import qualified  Data.Map as Map
11381
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    14
import Data.Time.Clock
11380
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    15
------
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    16
import OfficialServer.Glicko2
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    17
11358
55360683db75 Start work on rating calculator
unc0rr
parents:
diff changeset
    18
11380
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    19
queryEpochDates = "SELECT epoch, todatetime, todatetime + INTERVAL 1 week FROM rating_epochs WHERE epoch = (SELECT MAX(epoch) FROM rating_epochs)"
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    20
queryPreviousRatings = "SELECT v.userid, v.rating, v.rd, v.volatility FROM rating_values as v WHERE (v.epoch = (SELECT MAX(epoch) FROM rating_epochs))"
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    21
queryGameResults =
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    22
        "SELECT \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    23
        \     p.userid \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    24
        \     , p.place \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    25
        \     , COALESCE(vp.rating, 1500) \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    26
        \     , COALESCE(vp.rd, 350) \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    27
        \     , COALESCE(vp.volatility, 0.06) \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    28
        \     , COALESCE(vo.rating, 1500) \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    29
        \     , COALESCE(vo.rd, 350) \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    30
        \     , COALESCE(vo.volatility, 0.06) \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    31
        \ FROM \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    32
        \     (SELECT epoch, todatetime FROM rating_epochs WHERE epoch = (SELECT MAX(epoch) FROM rating_epochs)) as e \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    33
        \     JOIN rating_games as g ON (g.time BETWEEN e.todatetime AND e.todatetime + INTERVAL 1 WEEK - INTERVAL 1 SECOND) \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    34
        \     JOIN rating_players as p ON (p.gameid = g.id) \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    35
        \     JOIN rating_players as o ON (p.gameid = o.gameid AND p.userid <> o.userid AND (p.place = 0 OR (p.place <> o.place))) \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    36
        \     LEFT OUTER JOIN rating_values as vp ON (vp.epoch = e.epoch AND vp.userid = p.userid) \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    37
        \     LEFT OUTER JOIN rating_values as vo ON (vo.epoch = e.epoch AND vo.userid = o.userid) \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    38
        \ GROUP BY p.userid, p.gameid, p.place \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    39
        \ ORDER BY p.userid"
11390
36e1bbb6ecea - Reduce tau value, as suggested in gecko2 paper
unc0rr
parents: 11381
diff changeset
    40
insertNewRatings = "INSERT INTO rating_values (userid, epoch, rating, rd, volatility, games) VALUES (?, ?, ?, ?, ?, ?)"
11381
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    41
insertNewEpoch = "INSERT INTO rating_epochs (epoch, todatetime) VALUES (?, ?)"
11380
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    42
11381
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    43
mergeRatingData :: Map.Map Int (RatingData, [GameData]) -> [(Int, (RatingData, [GameData]))] -> Map.Map Int (RatingData, [GameData])
11390
36e1bbb6ecea - Reduce tau value, as suggested in gecko2 paper
unc0rr
parents: 11381
diff changeset
    44
mergeRatingData m s = foldr (uncurry (Map.insertWith mf)) m s
11381
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    45
    where
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    46
        mf (rd, gds) (_, gds2) = (rd, gds ++ gds2)
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    47
11380
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    48
calculateRatings dbConn = do
11381
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    49
    [(epochNum :: Int, fromDate :: UTCTime, toDate :: UTCTime)] <- query_ dbConn queryEpochDates
11380
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    50
    initRatingData <- (Map.fromList . map fromDBrating) `fmap` query_ dbConn queryPreviousRatings
11381
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    51
    gameData <- map fromGameResult `fmap` query_ dbConn queryGameResults
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    52
    let mData = map getNewRating . Map.toList $ mergeRatingData initRatingData gameData
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    53
    executeMany dbConn insertNewRatings $ map (toInsert epochNum) mData
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    54
    execute dbConn insertNewEpoch (epochNum + 1, toDate)
11380
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    55
    return ()
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    56
    where
11390
36e1bbb6ecea - Reduce tau value, as suggested in gecko2 paper
unc0rr
parents: 11381
diff changeset
    57
        toInsert e (i, (g, RatingData r rd v)) = (i, e + 1, r, rd, v, g)
11381
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    58
        getNewRating (a, d) = (a, uncurry calcNewRating d)
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    59
        convPlace :: Int -> Double
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    60
        convPlace 0 = 0.5
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    61
        convPlace 1 = 1.0
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    62
        convPlace 2 = 0.0
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    63
        convPlace _ = error "Incorrect place value"
11380
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    64
        fromDBrating (a, b, c, d) = (a, (RatingData b c d, []))
11381
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    65
        fromGameResult (pid, place, prating, pRD, pvol, orating, oRD, ovol) =
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    66
            (pid,
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    67
                (RatingData prating pRD pvol
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    68
                , [GameData (RatingData orating oRD ovol) $ convPlace place]))
11380
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    69
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    70
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    71
data DBConnectInfo = DBConnectInfo {
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    72
    dbHost
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    73
    , dbName
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    74
    , dbLogin
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    75
    , dbPassword :: B.ByteString
11358
55360683db75 Start work on rating calculator
unc0rr
parents:
diff changeset
    76
    }
55360683db75 Start work on rating calculator
unc0rr
parents:
diff changeset
    77
11380
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    78
cfgFileName :: String
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    79
cfgFileName = "hedgewars-server.ini"
11358
55360683db75 Start work on rating calculator
unc0rr
parents:
diff changeset
    80
55360683db75 Start work on rating calculator
unc0rr
parents:
diff changeset
    81
11380
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    82
readServerConfig :: ConnectInfo -> IO ConnectInfo
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    83
readServerConfig ci = do
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    84
    cfg <- readConfig cfgFileName
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    85
    return $ ci{
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    86
        connectHost = value "dbHost" cfg
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    87
        , connectDatabase = value "dbName" cfg
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    88
        , connectUser = value "dbLogin" cfg
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    89
        , connectPassword = value "dbPassword" cfg
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    90
    }
11358
55360683db75 Start work on rating calculator
unc0rr
parents:
diff changeset
    91
    where
11380
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    92
        value n c = fromJust2 n $ getValue n c
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    93
        fromJust2 n Nothing = error $ "Missing config entry " ++ n
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    94
        fromJust2 _ (Just a) = a
11358
55360683db75 Start work on rating calculator
unc0rr
parents:
diff changeset
    95
11380
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    96
dbConnectionLoop mySQLConnectionInfo =
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    97
    Control.Exception.handle (\(e :: SomeException) -> hPutStrLn stderr $ show e) $
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    98
        bracket
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    99
            (connect mySQLConnectionInfo)
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
   100
            close
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
   101
            calculateRatings
11358
55360683db75 Start work on rating calculator
unc0rr
parents:
diff changeset
   102
11380
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
   103
main = readServerConfig defaultConnectInfo >>= dbConnectionLoop