diff --git a/glicko.cabal b/glicko.cabal --- a/glicko.cabal +++ b/glicko.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: glicko -version: 0.1.1.1 +version: 0.3.0.0 synopsis: Glicko-2 implementation in Haskell. description: Implementation of the rating algorithm Glicko-2 by Professor Mark E. Glickman @@ -28,14 +28,14 @@ Ranking.Glicko.Inference Ranking.Glicko.Types build-depends: base >= 4.8 && < 5 - , containers >= 0.5 && < 0.6 + , containers >= 0.6 && < 0.7 , data-default >= 0.5 && < 0.8 , deepseq >= 1.4 && < 1.5 - , lens >= 4.12 && < 5 , parallel >= 3.2 && < 3.3 - , statistics >= 0.13 && < 0.14 + , statistics >= 0.15 && < 0.16 hs-source-dirs: src default-language: Haskell2010 + default-extensions: DataKinds test-suite glicko-test type: exitcode-stdio-1.0 @@ -43,10 +43,10 @@ main-is: Spec.hs other-modules: Paper build-depends: base - , data-default >= 0.5 && < 0.8 + , data-default >= 0.5 && < 0.8 , glicko - , hspec >= 2.1 && < 2.5 - , lens >= 4.12 && < 5 - , QuickCheck >= 2.8 && < 2.10 - ghc-options: -threaded -rtsopts -with-rtsopts=-N -O + , hspec >= 2.7.2 && < 2.8 + , QuickCheck >= 2.13.2 && < 2.14 + ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 + default-extensions: DataKinds diff --git a/src/Ranking/Glicko/Core.hs b/src/Ranking/Glicko/Core.hs --- a/src/Ranking/Glicko/Core.hs +++ b/src/Ranking/Glicko/Core.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE RecordWildCards #-} {-| Module : Ranking.Glicko.Core License : GPL-3 @@ -9,37 +10,37 @@ >>> let ps = compute [] [Match 1 2 1 0] def >>> ps -[ Player { _pid = 1 - , _rating = 1662.3108939062977 - , _dev = 290.31896371798047 - , _vol = 5.999967537233814e-2 - , _inactivity = 0 - , _age = 1 } -, Player { _pid = 2 - , _rating = 1337.6891060937023 - , _dev = 290.31896371798047 - , _vol = 5.999967537233814e-2 - , _inactivity = 0 - , _age = 1 }] +[ Player { playerId = 1 + , playerRating = 1662.3108939062977 + , playerDev = 290.31896371798047 + , playerVol = 5.999967537233814e-2 + , playerInactivity = 0 + , playerAge = 1 } +, Player { playerId = 2 + , playerRating = 1337.6891060937023 + , playerDev = 290.31896371798047 + , playerVol = 5.999967537233814e-2 + , playerInactivity = 0 + , playerAge = 1 }] >>> compute ps [Match 1 3 0 0] def -[ Player { _pid = 1 - , _rating = 1623.996484575735 - , _dev = 256.3451684359266 - , _vol = 5.999869083062934e-2 - , _inactivity = 0 - , _age = 2 } -, Player { _pid = 2 - , _rating = 1337.6891060937023 - , _dev = 290.5060065906196 - , _vol = 5.999967537233814e-2 - , _inactivity = 1 - , _age = 2 } -, Player { _pid = 3 - , _rating = 1557.6214863132009 - , _dev = 286.9272058793522 - , _vol = 5.999899836136578e-2 - , _inactivity = 0 - , _age = 1 }] +[ Player { playerId = 1 + , playerRating = 1623.996484575735 + , playerDev = 256.3451684359266 + , playerVol = 5.999869083062934e-2 + , playerInactivity = 0 + , playerAge = 2 } +, Player { playerId = 2 + , playerRating = 1337.6891060937023 + , playerDev = 290.5060065906196 + , playerVol = 5.999967537233814e-2 + , playerInactivity = 1 + , playerAge = 2 } +, Player { playerId = 3 + , playerRating = 1557.6214863132009 + , playerDev = 286.9272058793522 + , playerVol = 5.999899836136578e-2 + , playerInactivity = 0 + , playerAge = 1 }] -} module Ranking.Glicko.Core ( compute @@ -51,7 +52,6 @@ import qualified Prelude as P import Data.Maybe -import Control.Lens import Control.Parallel.Strategies import Data.Map (Map) import qualified Data.Map.Strict as Map @@ -69,47 +69,47 @@ -- | Computes new ratings from the previous and adds new ones using the -- specified settings. -compute :: [Player] -- ^ Input players - -> [Match] -- ^ Matches played this period - -> GlickoSettings -- ^ Settings for computing the score values and adding new - -- players. - -> [Player] -- ^ Updated player ratings +compute :: [Player 1] -- ^ Input players + -> [Match] -- ^ Matches played this period + -> GlickoSettings -- ^ Settings for computing the score values and adding new + -- players. + -> [Player 1] -- ^ Updated player ratings compute = compute' map -- | Same as 'compute' but runs in parallel using the specified chunkSize -computeP :: Int -> [Player] -> [Match] -> GlickoSettings -> [Player] +computeP :: Int -> [Player 1] -> [Match] -> GlickoSettings -> [Player 1] computeP chunkSize = compute' (pMap chunkSize) -- Update all player ratings -compute' :: (((PlayerId, Player) -> Player) -> [(PlayerId, Player)] -> [Player]) - -> [Player] +compute' :: (((PlayerId, Player 2) -> Player 1) -> [(PlayerId, Player 2)] -> [Player 1]) + -> [Player 1] -> [Match] -> GlickoSettings - -> [Player] + -> [Player 1] compute' map' ps ms settings = map' (newToOld . updater . snd) . Map.toList $ pmap' - where pmap = Map.fromList $ map (\p -> (_pid p, p)) ps - pmap' = preprocess pmap ms settings + where pmap = Map.fromList $ map (\p -> (playerId p, p)) ps + pmap' = fmap oldToNew (preprocess pmap ms settings) matches = preprocessMatches pmap' ms updater p = updatePlayer p matches settings -- Compute new rating for player -updatePlayer :: Player -> [RatedMatch] -> GlickoSettings -> Player +updatePlayer :: Player 2 -> [RatedMatch] -> GlickoSettings -> Player 2 updatePlayer p ms GlickoSettings{ tau = tau, scoreFunction = scoreFun } - | null matches = (dev .~ sqrt (pφ^2 + pσ^2)) - . (inactivity +~ 1) - . (age +~ 1) $ p - | otherwise = (dev .~ φ') - . (rating .~ µ') - . (vol .~ σ') - . (inactivity .~ 0) - . (age +~ 1) $ p + | null matches = p { playerDev = sqrt (pφ^2 + pσ^2) + , playerInactivity = playerInactivity p + 1 + , playerAge = playerAge p + 1 } + | otherwise = p { playerDev = φ' + , playerRating = µ' + , playerVol = σ' + , playerInactivity = 0 + , playerAge = playerAge p + 1 } where -- Initial values for player - pµ = _rating p - pφ = _dev p - pσ = _vol p + pµ = playerRating p + pφ = playerDev p + pσ = playerVol p -- Values for opponent in match `m` - µ (_, opp, _, _) = _rating opp - φ (_, opp, _, _) = _dev opp + µ (_, opp, _, _) = playerRating opp + φ (_, opp, _, _) = playerDev opp -- Score value for match s :: RatedMatch -> Double s (_,_,sa,sb) = compareScores scoreFun sa sb @@ -135,14 +135,16 @@ -- All matches `p` played in, arranged so that `p` is the first player matches :: [RatedMatch] - matches = map swap . filter (\(pla, plb, _, _) -> pla == p || plb == p) $ ms + matches = map swap + . filter (\(pla, plb, _, _) -> pla == p || plb == p) + $ ms swap :: RatedMatch -> RatedMatch swap m@(pla, plb, sca, scb) | pla == p = m | otherwise = (plb, pla, scb, sca) -type RatedMatch = (Player, Player, Score, Score) +type RatedMatch = (Player 2, Player 2, Score, Score) -- g and E from step 3-4 _g :: Double -> Double @@ -170,46 +172,46 @@ ε = 0.000001 -- Add new default players where missing -preprocess :: Map PlayerId Player -> [Match] -> GlickoSettings -> Map PlayerId Player +preprocess :: Map PlayerId (Player 1) + -> [Match] + -> GlickoSettings + -> Map PlayerId (Player 1) preprocess ps ms settings = - Map.map oldToNew - . Map.union ps - . Map.fromList - . map (\i -> (i, defaultPlayer {_pid=i})) - . Set.toList $ diff - where playersInMatches = Set.fromList $ (\m -> [_pla m, _plb m]) =<< ms + Map.union ps + . Map.fromSet (\i -> defaultPlayer { playerId = i }) + $ playersInMatches `Set.difference` players + where playersInMatches = Set.fromList $ (\m -> [matchPlayerA m, matchPlayerB m]) =<< ms players = Map.keysSet ps - diff = Set.difference playersInMatches players - defaultPlayer = Player { _pid = -1 - , _rating = initialRating settings - , _dev = initialDeviation settings - , _vol = initialVolatility settings - , _inactivity = 0 - , _age = 0} + defaultPlayer = Player { playerId = -1 + , playerRating = initialRating settings + , playerDev = initialDeviation settings + , playerVol = initialVolatility settings + , playerInactivity = 0 + , playerAge = 0} -- Pull the players into the matches -preprocessMatches :: Map PlayerId Player -> [Match] -> [RatedMatch] -preprocessMatches ps = mapMaybe ( - \m -> (,,,) - <$> Map.lookup (_pla m) ps - <*> Map.lookup (_plb m) ps - <*> pure (_sca m) - <*> pure (_scb m) - ) +preprocessMatches :: Map PlayerId (Player 2) -> [Match] -> [RatedMatch] +preprocessMatches ps = mapMaybe f + where f m = do + pla <- Map.lookup (matchPlayerA m) ps + plb <- Map.lookup (matchPlayerB m) ps + pure (pla, plb, matchScoreA m, matchScoreB m) -- | Convert ratings from Glicko to Glicko-2 -oldToNew :: Player -> Player -oldToNew p@Player{ _rating = r, _dev = d} = p { _rating = (r - 1500) / glicko2Multiplier - , _dev = d / glicko2Multiplier } +oldToNew :: Player 1 -> Player 2 +oldToNew p@Player{ playerRating = r, playerDev = d} = + p { playerRating = (r - 1500) / glicko2Multiplier + , playerDev = d / glicko2Multiplier } -- | Convert ratings from Glicko-2 to Glicko -newToOld :: Player -> Player -newToOld p@Player{ _rating = r, _dev = d} = p { _rating = r*glicko2Multiplier + 1500 - , _dev = d*glicko2Multiplier} +newToOld :: Player 2 -> Player 1 +newToOld p@Player{ playerRating = r, playerDev = d} = + p { playerRating = r * glicko2Multiplier + 1500 + , playerDev = d * glicko2Multiplier} glicko2Multiplier :: Double glicko2Multiplier = 173.7178 -playersToMap :: [Player] -> Map PlayerId Player -playersToMap = Map.fromList . map (\p -> (_pid p, p)) +playersToMap :: [Player v] -> Map PlayerId (Player v) +playersToMap = Map.fromList . map (\p -> (playerId p, p)) diff --git a/src/Ranking/Glicko/Inference.hs b/src/Ranking/Glicko/Inference.hs --- a/src/Ranking/Glicko/Inference.hs +++ b/src/Ranking/Glicko/Inference.hs @@ -12,19 +12,19 @@ >>> :m + Data.Default >>> let p1:p2:_ = compute players matches def >>> p1 -Player { _pid = 1 - , _rating = 1464.0506705393013 - , _dev = 151.51652412385727 - , _vol = 5.9995984286488495e-2 - , _inactivity = 0 - , _age = 1 } +Player { playerId = 1 + , playerRating = 1464.0506705393013 + , playerDev = 151.51652412385727 + , playerVol = 5.9995984286488495e-2 + , playerInactivity = 0 + , playerAge = 1 } >>> p2 -Player { _pid = 2 - , _rating = 1398.1435582337338 - , _dev = 31.67021528115062 - , _vol = 5.999912372888531e-2 - , _inactivity = 0 - , _age = 1 } +Player { playerId = 2 + , playerRating = 1398.1435582337338 + , playerDev = 31.67021528115062 + , playerVol = 5.999912372888531e-2 + , playerInactivity = 0 + , playerAge = 1 } >>> predict p1 p2 0.5732533698644847 -- Player 1 has a 57.3% chance of winning a single game. >>> let Just f = boX 5 @@ -46,12 +46,12 @@ import Statistics.Distribution.Normal -- | Computes the probability that Player A wins against Player B -predict :: Player -- ^ Player A - -> Player -- ^ Player B +predict :: Player 1 -- ^ Player A + -> Player 1 -- ^ Player B -> Double predict pla plb = cumulative dist (ra - rb) - where Player { _rating = ra, _dev = da } = oldToNew pla - Player { _rating = rb, _dev = db } = oldToNew plb + where Player { playerRating = ra, playerDev = da } = oldToNew pla + Player { playerRating = rb, playerDev = db } = oldToNew plb dist = normalDistr 0 (1 + da + db) -- TODO: Check the above ^ @@ -72,7 +72,7 @@ -- | Same as 'predict', but computes the probability that -- Player A wins a match played as best-of-X games. -predictBoX :: BoX -> Player -> Player -> Double +predictBoX :: BoX -> Player 1 -> Player 1 -> Double predictBoX n p1 p2 = sum $ map (\i -> fromInteger ((z + i) `choose` i) * p^w * q^i) [0..z] where p = predict p1 p2 diff --git a/src/Ranking/Glicko/Types.hs b/src/Ranking/Glicko/Types.hs --- a/src/Ranking/Glicko/Types.hs +++ b/src/Ranking/Glicko/Types.hs @@ -6,7 +6,7 @@ For examples, see `Ranking.Glicko.Core` and `Ranking.Glicko.Inference`. -} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE KindSignatures #-} module Ranking.Glicko.Types ( -- * Data types Player(..) @@ -14,47 +14,40 @@ , PlayerId , Score , ScoreFunction(..) - , GlickoSettings(..) - -- * Lenses - -- ** Player - , pid, rating, dev, vol, inactivity, age - -- ** Match - , pla, plb, sca, scb ) + , GlickoSettings(..) ) where import Control.DeepSeq -import Control.Lens import Data.Default +import GHC.TypeLits (Nat) type PlayerId = Int --- | Data type representing a player's Glicko rating. --- --- (NOTE: The system assumes Glicko ratings, to convert to Glicko-2 --- , use 'Ranking.Glicko.Core.oldToNew') -data Player = Player { _pid :: PlayerId -- ^ Player id, can be anything - , _rating :: Double -- ^ Rating - , _dev :: Double -- ^ Deviation - , _vol :: Double -- ^ Volatility - , _inactivity :: Int -- ^ Inactivity (not part of Glicko-2), - -- keeps track of the number of rating - -- updates a player has been inactive. - , _age :: Int -- ^ Age (not part of Glicko-2), - -- keeps track of the number of rating - -- updates since the player was added. +-- | Data type representing a player's Glicko rating. The type +-- 'version' is used to differentiate between Glicko ('Player' 1) and +-- Glicko-2 ('Player' 2). +data Player (version :: Nat) = + Player { playerId :: PlayerId -- ^ Player id, can be anything + , playerRating :: Double -- ^ Rating + , playerDev :: Double -- ^ Deviation + , playerVol :: Double -- ^ Volatility + , playerInactivity :: Int -- ^ Inactivity (not part of Glicko-2), + -- keeps track of the number of rating + -- updates a player has been inactive. + , playerAge :: Int -- ^ Age (not part of Glicko-2), + -- keeps track of the number of rating + -- updates since the player was added. } deriving (Show, Eq) -makeLenses ''Player -instance NFData Player where +instance NFData (Player v) where rnf (Player x1 x2 x3 x4 x5 x6) = rnf (x1, x2, x3, x4, x5, x6) type Score = Int -data Match = Match { _pla :: PlayerId - , _plb :: PlayerId - , _sca :: Score - , _scb :: Score} +data Match = Match { matchPlayerA :: PlayerId + , matchPlayerB :: PlayerId + , matchScoreA :: Score + , matchScoreB :: Score} deriving (Show, Eq) -makeLenses ''Match -- | 'ScoreFunction's are used in 'compute' to evaluate two players performances against -- eachother. It should obey the following laws, diff --git a/test/Paper.hs b/test/Paper.hs --- a/test/Paper.hs +++ b/test/Paper.hs @@ -2,35 +2,35 @@ import Ranking.Glicko -players :: [Player] +players :: [Player 1] players = - [ Player { _pid = 1 - , _rating = 1500 - , _dev = 200 - , _vol = 0.06 - , _inactivity = 0 - , _age = 0 } + [ Player { playerId = 1 + , playerRating = 1500 + , playerDev = 200 + , playerVol = 0.06 + , playerInactivity = 0 + , playerAge = 0 } - , Player { _pid = 2 - , _rating = 1400 - , _dev = 30 - , _vol = 0.06 - , _inactivity = 0 - , _age = 0 } + , Player { playerId = 2 + , playerRating = 1400 + , playerDev = 30 + , playerVol = 0.06 + , playerInactivity = 0 + , playerAge = 0 } - , Player { _pid = 3 - , _rating = 1550 - , _dev = 100 - , _vol = 0.06 - , _inactivity = 0 - , _age = 0 } + , Player { playerId = 3 + , playerRating = 1550 + , playerDev = 100 + , playerVol = 0.06 + , playerInactivity = 0 + , playerAge = 0 } - , Player { _pid = 4 - , _rating = 1700 - , _dev = 300 - , _vol = 0.06 - , _inactivity = 0 - , _age = 0 }] + , Player { playerId = 4 + , playerRating = 1700 + , playerDev = 300 + , playerVol = 0.06 + , playerInactivity = 0 + , playerAge = 0 }] matches :: [Match] matches = diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -15,9 +15,9 @@ describe "Ranking.Glicko.Core" $ do it "Glicko2 paper test case (http://glicko.net/glicko/glicko2.pdf)" $ do let p:_ = compute players matches def - d = _dev p - r = _rating p - v = _vol p + d = playerDev p + r = playerRating p + v = playerVol p r `shouldSatisfy` (`doubleEqual` 1464.0506705393013) d `shouldSatisfy` (`doubleEqual` 151.51652412385727) v `shouldSatisfy` (`doubleEqual` 5.9995984286488495e-2)