codeforces-cli (empty) → 0.1.0
raw patch · 35 files changed
+3196/−0 lines, 35 filesdep +aesondep +ansi-terminaldep +basesetup-changed
Dependencies added: aeson, ansi-terminal, base, base16-bytestring, bytestring, codeforces-cli, containers, cryptohash-sha512, directory, extra, http-client, http-conduit, http-types, open-browser, optparse-applicative, random, text, time, transformers
Files
- LICENSE +21/−0
- README.md +48/−0
- Setup.hs +2/−0
- app/Main.hs +33/−0
- codeforces-cli.cabal +113/−0
- src/Codeforces/API.hs +257/−0
- src/Codeforces/App.hs +13/−0
- src/Codeforces/App/Commands.hs +17/−0
- src/Codeforces/App/Commands/ContestCmds.hs +148/−0
- src/Codeforces/App/Commands/ProblemsCmd.hs +48/−0
- src/Codeforces/App/Commands/StandingsCmd.hs +126/−0
- src/Codeforces/App/Commands/UserCmds.hs +145/−0
- src/Codeforces/App/Commands/VirtualCmd.hs +70/−0
- src/Codeforces/App/Config.hs +91/−0
- src/Codeforces/App/Format.hs +135/−0
- src/Codeforces/App/Options.hs +306/−0
- src/Codeforces/App/Table.hs +59/−0
- src/Codeforces/App/Watcher.hs +142/−0
- src/Codeforces/Config.hs +117/−0
- src/Codeforces/Error.hs +40/−0
- src/Codeforces/Logging.hs +25/−0
- src/Codeforces/Response.hs +133/−0
- src/Codeforces/Types.hs +25/−0
- src/Codeforces/Types/Common.hs +43/−0
- src/Codeforces/Types/Contest.hs +59/−0
- src/Codeforces/Types/Party.hs +65/−0
- src/Codeforces/Types/Problem.hs +84/−0
- src/Codeforces/Types/Rank.hs +44/−0
- src/Codeforces/Types/RatingChange.hs +36/−0
- src/Codeforces/Types/Standings.hs +103/−0
- src/Codeforces/Types/Submission.hs +137/−0
- src/Codeforces/Types/User.hs +39/−0
- src/Codeforces/Virtual.hs +83/−0
- src/Codeforces/Virtual/RatingCalculator.hs +310/−0
- src/Codeforces/Virtual/Types.hs +79/−0
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2021 Farbod Salamat-Zadeh++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,48 @@+# codeforces-cli++Command line interface to interact with Codeforces.++++## Features++- View/filter contests and problems+- Watch contest standings and submissions+- Calculate rating after a virtual contest+- List rating changes for each contest+- And much more!++## Installation++The pre-compiled binary file can be found+[on the releases page](https://github.com/farbodsz/codeforces-cli/releases).++Download it and place it in a directory in your `PATH`. For example,+`~/.local/bin/cf`.++## Usage++```+Codeforces CLI v0.1.0++Usage: cf COMMAND++Available options:+ -h,--help Show this help text++Available commands:+ agenda Upcoming contests. Alias for contests --upcoming+ contests List of contests+ info Show the problems and your problem results of a+ contest+ friends List your friends (must be authenticated)+ open Open a contest in the browser+ problems View and filter problem sets+ ratings Rating changes of a user+ setup Setup your configuration file+ standings Standings table of a contest+ status Recent submissions of a user+ user Information about a user+ virtual Calculate your rating after a virtual contest, to+ find what it would be if you competed live+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,33 @@+--------------------------------------------------------------------------------++module Main where++import Codeforces.App++--------------------------------------------------------------------------------++main :: IO ()+main = do+ command <- parseCommands+ config <- loadConfig++ case command of+ -- List/tabulate data+ AgendaCmd -> contestList (ContestOpts False False True)+ ContestsCmd opts -> contestList opts+ InfoCmd cId opts -> contestInfo cId config opts+ ProblemsCmd opts -> problemList opts+ StandingsCmd cId opts -> standingsList cId config opts++ -- User-related commands+ UserCmd h -> userInfo h+ RatingsCmd h -> userRatings h+ StatusCmd h opts -> userStatus h opts+ FriendsCmd -> userFriends config+ VirtualCmd cId h pts pen -> virtualRating cId h pts pen++ -- Miscellaneous+ SetupCmd -> setupConfig+ OpenCmd cId -> openContest cId++--------------------------------------------------------------------------------
+ codeforces-cli.cabal view
@@ -0,0 +1,113 @@+cabal-version: 1.12+name: codeforces-cli+version: 0.1.0+license: MIT+license-file: LICENSE+copyright: 2021 Farbod Salamat-Zadeh+maintainer: Farbod Salamat-Zadeh+author: Farbod Salamat-Zadeh+homepage: https://github.com/farbodsz/codeforces-cli#readme+bug-reports: https://github.com/farbodsz/codeforces-cli/issues+synopsis: Command line interface to interact with Codeforces.+description:+ Please see the README on GitHub at <https://github.com/farbodsz/codeforces-cli#readme>++category: CLI+build-type: Simple+extra-source-files: README.md++source-repository head+ type: git+ location: https://github.com/farbodsz/codeforces-cli++library+ exposed-modules:+ Codeforces.API+ Codeforces.App+ Codeforces.App.Commands+ Codeforces.App.Commands.ContestCmds+ Codeforces.App.Commands.ProblemsCmd+ Codeforces.App.Commands.StandingsCmd+ Codeforces.App.Commands.UserCmds+ Codeforces.App.Commands.VirtualCmd+ Codeforces.App.Config+ Codeforces.App.Format+ Codeforces.App.Options+ Codeforces.App.Table+ Codeforces.App.Watcher+ Codeforces.Config+ Codeforces.Error+ Codeforces.Logging+ Codeforces.Response+ Codeforces.Types+ Codeforces.Types.Common+ Codeforces.Types.Contest+ Codeforces.Types.Party+ Codeforces.Types.Problem+ Codeforces.Types.Rank+ Codeforces.Types.RatingChange+ Codeforces.Types.Standings+ Codeforces.Types.Submission+ Codeforces.Types.User+ Codeforces.Virtual+ Codeforces.Virtual.RatingCalculator+ Codeforces.Virtual.Types++ hs-source-dirs: src+ other-modules: Paths_codeforces_cli+ default-language: Haskell2010+ default-extensions:+ LambdaCase OverloadedStrings RecordWildCards ScopedTypeVariables+ TupleSections++ ghc-options: -Wall+ build-depends:+ aeson >=1.5.6.0 && <1.6,+ ansi-terminal >=0.10.3 && <0.11,+ base >=4.7 && <5,+ base16-bytestring >=0.1.1.7 && <0.2,+ bytestring >=0.10.12.0 && <0.11,+ containers >=0.6.2.1 && <0.7,+ cryptohash-sha512 >=0.11.100.1 && <0.12,+ directory >=1.3.6.0 && <1.4,+ extra >=1.7.9 && <1.8,+ http-client >=0.6.4.1 && <0.7,+ http-conduit >=2.3.8 && <2.4,+ http-types >=0.12.3 && <0.13,+ open-browser >=0.2.1.0 && <0.3,+ optparse-applicative >=0.15.1.0 && <0.16,+ random ==1.1.*,+ text >=1.2.4.1 && <1.3,+ time >=1.9.3 && <1.10,+ transformers >=0.5.6.2 && <0.6++executable cf+ main-is: Main.hs+ hs-source-dirs: app+ other-modules: Paths_codeforces_cli+ default-language: Haskell2010+ default-extensions:+ LambdaCase OverloadedStrings RecordWildCards ScopedTypeVariables+ TupleSections++ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+ build-depends:+ aeson >=1.5.6.0 && <1.6,+ ansi-terminal >=0.10.3 && <0.11,+ base >=4.7 && <5,+ base16-bytestring >=0.1.1.7 && <0.2,+ bytestring >=0.10.12.0 && <0.11,+ codeforces-cli -any,+ containers >=0.6.2.1 && <0.7,+ cryptohash-sha512 >=0.11.100.1 && <0.12,+ directory >=1.3.6.0 && <1.4,+ extra >=1.7.9 && <1.8,+ http-client >=0.6.4.1 && <0.7,+ http-conduit >=2.3.8 && <2.4,+ http-types >=0.12.3 && <0.13,+ open-browser >=0.2.1.0 && <0.3,+ optparse-applicative >=0.15.1.0 && <0.16,+ random ==1.1.*,+ text >=1.2.4.1 && <1.3,+ time >=1.9.3 && <1.10,+ transformers >=0.5.6.2 && <0.6
+ src/Codeforces/API.hs view
@@ -0,0 +1,257 @@+--------------------------------------------------------------------------------++module Codeforces.API+ ( module Codeforces.Types+ , ResponseError(..)+ , handleAPI++ -- * Contests+ , getContests+ , getContestStandings+ , getContestStandings'+ , StandingsParams(..)++ -- * Problems+ , getAllProblemData+ , getProblems+ , getProblemStats+ , getContestProblems++ -- * Ratings and ranks+ , getContestRatingChanges+ , getUserRatingHistory++ -- * Problem submissions+ , getContestSubmissions+ , getUserStatus++ -- * User details+ , getUser+ , getUsers+ , getFriends++ -- * Virtual rating calculation+ , calculateVirtualResult+ , Delta+ , Seed+ , VirtualResult(..)++ -- * Configuration options+ , UserConfig(..)+ ) where++import Codeforces.Config+import Codeforces.Error+import Codeforces.Response+import Codeforces.Types+import Codeforces.Virtual++import Control.Arrow ( left )+import Control.Monad.Trans.Except++import qualified Data.ByteString.Char8 as BC+import qualified Data.Map as M+import qualified Data.Text as T+import qualified Data.Text.Encoding as T++--------------------------------------------------------------------------------++handleAPI :: IO (Either ResponseError a) -> ExceptT CodeforcesError IO a+handleAPI m = ExceptT $ left ResponseError <$> m++--------------------------------------------------------------------------------++-- | Query parameters for retrieving contest standings.+data StandingsParams = StandingsParams+ {+ -- | ID of the contest+ paramContestId :: ContestId+ -- | The starting index of the ranklist (1-based)+ , paramFrom :: Maybe Int+ -- | The number of standing rows to return+ , paramRowCount :: Maybe Int+ -- | If specified, only standings of this room are returned+ , paramRoom :: Maybe Int+ -- | If true, all participations are included. Otherwise only 'Contestant'+ -- participations are included.+ , paramUnofficial :: Bool+ -- | If specified, the standings includes only these users.+ , paramHandles :: Maybe [Handle]+ }+ deriving Show++--------------------------------------------------------------------------------++-- | 'getContests' @isGym@ returns a list of contests that may or may not be gym+-- contests.+getContests :: Bool -> IO (Either ResponseError [Contest])+getContests isGym = getData "/contest.list" [("gym", argBool isGym)]++-- | 'getContestStandings' @standingsParams@ returns information about the+-- contest and a part of the standings list.+getContestStandings :: StandingsParams -> IO (Either ResponseError Standings)+getContestStandings StandingsParams {..} = getData+ "/contest.standings"+ [ ("contestId" , argContestId paramContestId)+ , ("from" , argInt =<< paramFrom)+ , ("count" , argInt =<< paramRowCount)+ , ("room" , argInt =<< paramRoom)+ , ("showUnofficial", argBool paramUnofficial)+ , ("handles" , argHandles =<< paramHandles)+ ]++-- | Like 'getContestStandings' but returns the standings and the+-- 'RatingChange's for each user participating.+getContestStandings'+ :: StandingsParams+ -> IO (Either ResponseError (Standings, M.Map Handle RatingChange))+getContestStandings' params = runExceptT $ do+ ss <- ExceptT $ getContestStandings params+ rcs <- ExceptT $ getContestRatingChanges (paramContestId params)++ let rcsMap = M.fromList $ map (rcHandle >>= (,)) rcs++ pure (ss, rcsMap)++-- | 'getContestSubmissions' @contestId handle@ returns the submissions made by+-- the user in the contest given by @contestId@+getContestSubmissions+ :: ContestId -> Handle -> IO (Either ResponseError [Submission])+getContestSubmissions cId h = getData+ "/contest.status"+ [("contestId", argContestId cId), ("handle", argHandle h)]++--------------------------------------------------------------------------------++-- | 'getAllProblemData' @tags@ returns a 'ProblemsResponse' filtered by the+-- @tags@, if supplied.+getAllProblemData :: [ProblemTag] -> IO (Either ResponseError ProblemsResponse)+getAllProblemData ts = getData "/problemset.problems" [("tags", argTags ts)]++-- | 'getProblems' @tags@ returns a list of 'Problem's containing the @tags@, if+-- provided.+getProblems :: [ProblemTag] -> IO (Either ResponseError [Problem])+getProblems ts = fmap prProblems <$> getAllProblemData ts++-- | Like 'getProblems' but returns a list of 'ProblemStats'.+getProblemStats :: [ProblemTag] -> IO (Either ResponseError [ProblemStats])+getProblemStats ts = fmap prStats <$> getAllProblemData ts++-- | 'getContestProblems' @contestId@ returns the list of problems for the given+-- contest.+--+-- This should be used instead of filtering results from 'getProblems' for two+-- main reasons:+--+-- (1) 'problemContestId' can only refer to one contest, so problems+-- appearing in multiple contests may not be filtered correctly.+-- (2) 'getProblems' returns larger output potentially affecting performance+--+getContestProblems :: ContestId -> IO (Either ResponseError [Problem])+getContestProblems cId = fmap standingsProblems <$> getContestStandings+ StandingsParams { paramContestId = cId+ , paramFrom = Just 1+ , paramRowCount = Just 1+ , paramRoom = Nothing+ , paramUnofficial = False+ , paramHandles = Nothing+ }++--------------------------------------------------------------------------------++-- | 'getContestRatingChanges' @contestId@ returns a list of 'RatingChange's+-- for the contest.+getContestRatingChanges+ :: ContestId -> IO (Either ResponseError [RatingChange])+getContestRatingChanges cId =+ getData "/contest.ratingChanges" [("contestId", argContestId cId)]++-- | 'getUserRatingHistory' @handle@ returns a list of 'RatingChange's for the+-- requested user+getUserRatingHistory :: Handle -> IO (Either ResponseError [RatingChange])+getUserRatingHistory h = getData "/user.rating" [("handle", argHandle h)]++--------------------------------------------------------------------------------++-- | 'getUser' @handle@ returns the 'User' with the given @handle@+getUser :: Handle -> IO (Either ResponseError User)+getUser h = fmap head <$> getUsers [h]++-- | 'getUsers' @handles@ returns a list of 'User's with the given @handles@+getUsers :: [Handle] -> IO (Either ResponseError [User])+getUsers [] = pure $ Right []+getUsers hs = getData "/user.info" [("handles", argHandles hs)]++-- 'getFriends' @config@ returns the handles of the friends of the currently+-- authenticated user.+getFriends :: UserConfig -> IO (Either ResponseError [Handle])+getFriends cfg = getAuthorizedData cfg "/user.friends" []++-- | 'getUserStatus' @handle from count@ returns the @count@ most recent+-- submissions by the user, starting from the @from@-th one.+getUserStatus :: Handle -> Int -> Int -> IO (Either ResponseError [Submission])+getUserStatus h f n = getData+ "/user.status"+ [("handle", argHandle h), ("from", argInt f), ("count", argInt n)]++--------------------------------------------------------------------------------++-- | 'calculateVirtualResult' @contestId handle points penalty@ computes the+-- rating change the user would gain had they competed in the contest live, and+-- their expected ranking for the contest.+--+calculateVirtualResult+ :: ContestId+ -> Handle+ -> Points+ -> Int+ -> IO (Either ResponseError (User, Maybe VirtualResult))+calculateVirtualResult cId handle points penalty = runExceptT $ do+ rcs <- ExceptT $ getContestRatingChanges cId++ standings <- ExceptT $ getContestStandings $ StandingsParams+ { paramContestId = cId+ , paramFrom = Nothing+ , paramRowCount = Nothing+ , paramRoom = Nothing+ , paramUnofficial = False+ , paramHandles = Nothing+ }++ user <- ExceptT $ getUser handle+ let vUser = VirtualUser { vuPoints = points+ , vuPenalty = penalty+ , vuRating = userRating user+ }+ result = calculateResult vUser rcs (standingsRanklist standings)++ pure (user, result)++--------------------------------------------------------------------------------++argBool :: Bool -> Maybe BC.ByteString+argBool = Just . BC.pack . show++argText :: T.Text -> Maybe BC.ByteString+argText = Just . T.encodeUtf8++argTexts :: [T.Text] -> Maybe BC.ByteString+argTexts xs | null xs = Nothing+ | otherwise = (Just . T.encodeUtf8 . T.intercalate ";") xs++argInt :: Int -> Maybe BC.ByteString+argInt = Just . BC.pack . show++argContestId :: ContestId -> Maybe BC.ByteString+argContestId = argInt . unContestId++argHandle :: Handle -> Maybe BC.ByteString+argHandle = argText . unHandle++argHandles :: [Handle] -> Maybe BC.ByteString+argHandles = argTexts . map unHandle++argTags :: [ProblemTag] -> Maybe BC.ByteString+argTags = argTexts++--------------------------------------------------------------------------------
+ src/Codeforces/App.hs view
@@ -0,0 +1,13 @@+--------------------------------------------------------------------------------++module Codeforces.App+ ( module Codeforces.App.Commands+ , module Codeforces.App.Config+ , module Codeforces.App.Options+ ) where++import Codeforces.App.Commands+import Codeforces.App.Config+import Codeforces.App.Options++--------------------------------------------------------------------------------
+ src/Codeforces/App/Commands.hs view
@@ -0,0 +1,17 @@+--------------------------------------------------------------------------------++module Codeforces.App.Commands+ ( module Codeforces.App.Commands.ContestCmds+ , module Codeforces.App.Commands.ProblemsCmd+ , module Codeforces.App.Commands.StandingsCmd+ , module Codeforces.App.Commands.UserCmds+ , module Codeforces.App.Commands.VirtualCmd+ ) where++import Codeforces.App.Commands.ContestCmds+import Codeforces.App.Commands.ProblemsCmd+import Codeforces.App.Commands.StandingsCmd+import Codeforces.App.Commands.UserCmds+import Codeforces.App.Commands.VirtualCmd++--------------------------------------------------------------------------------
+ src/Codeforces/App/Commands/ContestCmds.hs view
@@ -0,0 +1,148 @@+--------------------------------------------------------------------------------++-- | Contest-related commands.+module Codeforces.App.Commands.ContestCmds+ ( contestList+ , contestInfo+ , openContest+ ) where++import Codeforces.API+import Codeforces.App.Format+import Codeforces.App.Options+import Codeforces.App.Table+import Codeforces.App.Watcher+import Codeforces.Error++import Control.Monad.Trans.Class+import Control.Monad.Trans.Except++import qualified Data.Map as M+import Data.Maybe+import Data.Text ( Text )+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Data.Time++import Web.Browser++--------------------------------------------------------------------------------++contestList :: ContestOpts -> IO ()+contestList ContestOpts {..} = handleE $ runExceptT $ do+ contests <- handleAPI $ getContests optIsGym+ now <- lift getCurrentTime++ let headers = [("#", 4), ("Name", 50), ("Date", 16), ("Duration", 10)]+ rows = map+ (\Contest {..} ->+ plainCell+ <$> [ showText $ unContestId contestId+ , contestName+ , fmtStartTime contestStartTime+ , fmtDuration contestDuration+ ]+ )+ (filterContests optIsPast optIsUpcoming now contests)++ lift $ mapM_ T.putStrLn $ makeTable headers rows++-- | 'filterContests' @onlyPast onlyUpcoming currentTime@ filters and orders a+-- list of contests depending on whether past or upcoming (or both/all) contests+-- should be shown.+filterContests :: Bool -> Bool -> UTCTime -> [Contest] -> [Contest]+filterContests False False _ = id+filterContests False True now = reverse . filter (not . isContestPast now)+filterContests True False now = filter (isContestPast now)+filterContests True True _ = id++-- | Whether the contest is in the past relative to the given time.+isContestPast :: UTCTime -> Contest -> Bool+isContestPast now c = maybe False (< now) (contestStartTime c)++fmtStartTime :: Maybe UTCTime -> Text+fmtStartTime =+ maybe "" (T.pack . formatTime defaultTimeLocale "%H:%M %d-%b-%y")++fmtDuration :: DiffTime -> Text+fmtDuration = T.pack . formatTime defaultTimeLocale "%h:%0M hrs"++--------------------------------------------------------------------------------++contestInfo :: ContestId -> UserConfig -> InfoOpts -> IO ()+contestInfo cId cfg opts =+ handleWatch (optInfoWatch opts) (contestInfoTable cId cfg opts)++-- | 'contestInfoTable' @problems submissions statistics@ fetches data about the+-- contest and constructs a table of its problems.+--+-- The table includes problem statistics, and if the user has made a submission,+-- their submission verdict for the problem.+--+contestInfoTable+ :: ContestId -> UserConfig -> InfoOpts -> IO (Either CodeforcesError Table)+contestInfoTable cId cfg opts = runExceptT $ do+ let handle = fromMaybe (cfgHandle cfg) (optHandle opts)++ ps <- handleAPI $ getContestProblems cId+ statMap <- handleAPI $ fmap problemStatsMap <$> getProblemStats []+ subMap <-+ handleAPI $ fmap submissionsMap <$> getContestSubmissions cId handle++ let headers =+ [ ("#" , 2)+ , ("Problem", 30)+ , ("Verdict", 35)+ , ("Time" , 7)+ , ("Memory" , 8)+ , ("Solved" , 7)+ ]+ rows = map+ (\Problem {..} ->+ let mSub = M.lookup problemIndex subMap+ mStats = M.lookup problemIndex statMap+ in [ plainCell problemIndex+ , plainCell problemName+ , contestSubmissionCell mSub+ , plainCell $ maybeTimeTaken mSub+ , plainCell $ maybeMemTaken mSub+ , plainCell $ maybeSolved mStats+ ]+ )+ ps++ pure $ makeTable headers rows+ where+ maybeTimeTaken = maybe "-" (fmtTimeConsumed . submissionTimeConsumed)+ maybeMemTaken = maybe "-" (fmtMemoryConsumed . submissionMemoryConsumed)+ maybeSolved = maybe "" (("x" <>) . showText . pStatSolvedCount)++-- | Shows the verdict of a contest submission.+contestSubmissionCell :: Maybe Submission -> Cell+contestSubmissionCell Nothing = plainCell "-"+contestSubmissionCell (Just Submission {..}) = verdictCell+ submissionTestset+ submissionPassedTestCount+ submissionPoints+ submissionVerdict++-- | 'problemStatsMap' @stats@ computes a map of each problem's index to the+-- corresponding 'ProblemStats' for it.+problemStatsMap :: [ProblemStats] -> M.Map ProblemIndex ProblemStats+problemStatsMap = M.fromList . map (pStatProblemIndex >>= (,))++-- | 'submissionsMap' @submissions@ computes a map of each problem's index to+-- the most recent submission for it.+submissionsMap :: [Submission] -> M.Map ProblemIndex Submission+submissionsMap =+ M.fromListWith (const id) . map (problemIndex . submissionProblem >>= (,))++--------------------------------------------------------------------------------++-- | 'openContest' @contestId@ opens the URL to the specified contest in the+-- user's preferred web browser.+openContest :: ContestId -> IO ()+openContest cId =+ openBrowser ("https://codeforces.com/contest/" <> show cId) >> pure ()++--------------------------------------------------------------------------------
+ src/Codeforces/App/Commands/ProblemsCmd.hs view
@@ -0,0 +1,48 @@+--------------------------------------------------------------------------------++-- | Problems command.+module Codeforces.App.Commands.ProblemsCmd+ ( problemList+ ) where++import Codeforces.API+import Codeforces.App.Format+import Codeforces.App.Options+import Codeforces.App.Table+import Codeforces.Error++import Control.Monad.Trans.Class+import Control.Monad.Trans.Except++import Data.Text ( Text )+import qualified Data.Text.IO as T++--------------------------------------------------------------------------------++problemList :: ProblemOpts -> IO ()+problemList ProblemOpts {..} = handleE $ runExceptT $ do+ let ratingBounds = inRatingRange (optMinRating, optMaxRating)++ problems <- handleAPI $ fmap (filter ratingBounds) <$> getProblems []++ let headers = [("#", 6), ("Name", 40), ("Rating", 6)]+ rows = map+ (\Problem {..} ->+ [ plainCell $ fmtProblemIndex problemContestId problemIndex+ , plainCell problemName+ , maybe blankCell ratingCell problemRating+ ]+ )+ problems++ lift $ mapM_ T.putStrLn $ makeTable headers rows++fmtProblemIndex :: Maybe ContestId -> ProblemIndex -> Text+fmtProblemIndex cId pIdx = maybe "" (showText . unContestId) cId <> pIdx++inRatingRange :: (Rating, Rating) -> Problem -> Bool+inRatingRange (minr, maxr) p = case problemRating p of+ Nothing -> False+ Just r -> minr <= r && r <= maxr++--------------------------------------------------------------------------------
+ src/Codeforces/App/Commands/StandingsCmd.hs view
@@ -0,0 +1,126 @@+--------------------------------------------------------------------------------++-- | Standings command.+module Codeforces.App.Commands.StandingsCmd+ ( standingsList+ ) where++import Codeforces.API hiding ( RankColor(..) )+import Codeforces.App.Format+import Codeforces.App.Options+import Codeforces.App.Table+import Codeforces.App.Watcher+import Codeforces.Error++import Control.Monad.Trans.Except++import qualified Data.Map as M+import Data.Text ( Text )+import qualified Data.Text as T++import System.Console.ANSI.Types++--------------------------------------------------------------------------------++standingsList :: ContestId -> UserConfig -> StandingOpts -> IO ()+standingsList cId cfg StandingOpts {..} =+ handleWatch optStandWatch $ runExceptT $ do+ friends <- handleAPI $ getFriends cfg++ let mHs = if optFriends+ then Just (cfgHandle cfg : friends)+ else Nothing++ (standings, rcs) <- handleAPI $ getContestStandings' StandingsParams+ { paramContestId = cId+ , paramFrom = Just optFromIndex+ , paramRowCount = Just optRowCount+ , paramRoom = optRoom+ , paramUnofficial = optShowUnofficial+ , paramHandles = mHs+ }++ if null (standingsRanklist standings)+ then+ throwE+ (if optFriends+ then StandingsWithFriendsEmpty+ else StandingsEmpty+ )+ else pure $ standingsTable standings rcs++standingsTable :: Standings -> M.Map Handle RatingChange -> Table+standingsTable s rcs = makeTable headers rows+ where+ headers = [("#", 5), ("Who", 20), ("=", totalPointsColW), ("*", 5)]+ ++ map (\p -> (problemIndex p, problemColW)) (standingsProblems s)+ rows = map+ (\RanklistRow {..} ->+ [ plainCell $ showText rrRank+ , partyCell rrParty rcs+ , totalPointsCell rrPoints+ , plainCell $ showText rrPenalty+ ]+ ++ map (problemResultCell scoringType) rrProblemResults+ )+ (standingsRanklist s)++ scoringType = contestType $ standingsContest s++ -- Final score in ICPC contest is number of problems solved (single digit)+ totalPointsColW = if scoringType == ScoringICPC then 2 else 5+ -- Problem score in ICPC contest is only 2-3 chars wide (e.g. "+5", "-2")+ problemColW = if scoringType == ScoringICPC then 3 else 5++partyCell :: Party -> M.Map Handle RatingChange -> Cell+partyCell Party {..} rcs = case partyMembers of+ [Member {..}] -> case M.lookup memberHandle rcs of+ Nothing -> plainCell $ participant $ unHandle memberHandle+ Just rc ->+ coloredCell (userColor rc) (participant $ unHandle memberHandle)++ ms -> case partyTeamName of+ Nothing -> plainCell $ participant $ memberList ms+ Just teamName -> plainCell $ participant teamName+ where+ participant = fmtParticipation partyParticipantType+ memberList = T.intercalate "," . map (unHandle . memberHandle)+ userColor = convertRankColor . rankColor . getRank . rcOldRating++-- | 'fmtParticipation' @participantType text@ returns the @text@ with either a+-- prefix/suffix/no changes, to indicate the type of contest participation.+fmtParticipation :: ParticipantType -> Text -> Text+fmtParticipation Virtual t = t <> " #"+fmtParticipation Contestant t = t+fmtParticipation _ t = "* " <> t++-- | 'showPoints' @points@ returns a textual representation of the points type.+-- If @points@ is an integer (e.g. @42.0@) then the integer without decimals+-- is returned (@42@), otherwise the decimals are shown.+showPoints :: Points -> Text+showPoints x = if x == fromInteger r then showText r else showText x+ where r = round x++-- | Cell showing the total points obtained by a user in the contest.+totalPointsCell :: Points -> Cell+totalPointsCell = plainCell . showPoints++-- | Cell showing the points obtained for a problem submission.+problemResultCell :: ScoringType -> ProblemResult -> Cell+problemResultCell st pr@ProblemResult {..} = if prNotAttempted pr+ then blankCell+ else case st of+ ScoringCF -> if prPoints == 0+ then coloredCell Red $ "-" <> showText prRejectedAttemptCount+ else coloredCell Green $ showPoints prPoints+ ScoringICPC -> if prPoints == 0+ then coloredCell Blue $ "-" <> showText prRejectedAttemptCount+ else coloredCell Green $ if prRejectedAttemptCount == 0+ then "+"+ else "+" <> showText prRejectedAttemptCount+ ScoringIOI -> case prPoints of+ 0 -> blankCell+ 100 -> coloredCell Green "100"+ x -> plainCell (showPoints x)++--------------------------------------------------------------------------------
+ src/Codeforces/App/Commands/UserCmds.hs view
@@ -0,0 +1,145 @@+--------------------------------------------------------------------------------++-- | User-related commands.+module Codeforces.App.Commands.UserCmds+ ( userInfo+ , userRatings+ , userStatus+ , userFriends+ ) where++import Codeforces.API+import Codeforces.App.Format+import Codeforces.App.Options+import Codeforces.App.Table+import Codeforces.App.Watcher+import Codeforces.Error++import Control.Monad.Extra+import Control.Monad.Trans.Class+import Control.Monad.Trans.Except++import Data.Text ( Text )+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Data.Time++--------------------------------------------------------------------------------++userInfo :: Handle -> IO ()+userInfo h = handleE $ runExceptT $ do+ u <- handleAPI $ getUser h++ let rank = getRank (userRating u)++ lift $ do+ putStrLn ""+ T.putStrLn $ rankColored (rankColor rank) $ T.concat+ [indent, rankName rank, " ", unHandle $ userHandle u]+ whenJust (sequenceA [userFirstName u, userLastName u])+ $ \ns -> T.putStrLn $ indent <> T.unwords ns++ printRatings u+ printPlace u+ putStrLn ""++printRatings :: User -> IO ()+printRatings User {..} = do+ putStrLn ""+ T.putStrLn $ T.concat+ [ indent+ , "Rating: "+ , rankColored (rankColor (getRank userRating)) (showText userRating)+ ]+ let maxRank = getRank userRating+ T.putStrLn $ T.concat+ [ indent+ , " (max: "+ , rankColored+ (rankColor maxRank)+ (T.concat [rankName maxRank, ", ", showText userMaxRating])+ , ")"+ ]++printPlace :: User -> IO ()+printPlace User {..} = do+ whenJust (sequenceA [userCity, userCountry]) $ \xs ->+ T.putStrLn $ indent <> "City: " <> T.intercalate ", " xs+ whenJust userOrganization+ $ \o -> T.putStrLn $ indent <> "Organisation: " <> o++--------------------------------------------------------------------------------++userRatings :: Handle -> IO ()+userRatings h = handleE $ runExceptT $ do+ rcs <- handleAPI $ getUserRatingHistory h++ let headers =+ [ ("#" , 3)+ , ("Contest", 50)+ , ("Rank" , 5)+ , ("Change" , 6)+ , ("Rating" , 6)+ ]+ rows = reverse $ zipWith+ (\RatingChange {..} num ->+ [ plainCell $ showText num+ , plainCell rcContestName+ , plainCell $ showText rcRank+ , differenceCell (rcNewRating - rcOldRating)+ , ratingCell rcNewRating+ ]+ )+ rcs+ ([1 ..] :: [Int])++ lift $ mapM_ T.putStrLn $ makeTable headers rows++--------------------------------------------------------------------------------++userStatus :: Handle -> StatusOpts -> IO ()+userStatus h opts = handleWatch (optStatusWatch opts) (userStatusTable h opts)++userStatusTable :: Handle -> StatusOpts -> IO (Either CodeforcesError Table)+userStatusTable h StatusOpts {..} = runExceptT $ do+ ss <- handleAPI $ getUserStatus h optStatusFrom optStatusCount++ let headers =+ [ ("When" , 12)+ , ("Problem", 35)+ , ("Lang" , 11)+ , ("Verdict", 35)+ , ("Time" , 7)+ , ("Memory" , 8)+ ]+ rows = map+ (\Submission {..} ->+ [ plainCell $ fmtTime submissionTime+ , plainCell $ fmtProblem submissionProblem+ , plainCell submissionProgrammingLanguage+ , verdictCell submissionTestset+ submissionPassedTestCount+ submissionPoints+ submissionVerdict+ , plainCell $ fmtTimeConsumed submissionTimeConsumed+ , plainCell $ fmtMemoryConsumed submissionMemoryConsumed+ ]+ )+ ss++ pure $ makeTable headers rows++fmtTime :: UTCTime -> Text+fmtTime = T.pack . formatTime defaultTimeLocale "%b/%d %H:%M"++fmtProblem :: Problem -> Text+fmtProblem p = T.concat [problemIndex p, " - ", problemName p]++--------------------------------------------------------------------------------++userFriends :: UserConfig -> IO ()+userFriends cfg = handleE $ runExceptT $ do+ fs <- handleAPI $ getFriends cfg+ lift $ mapM_ (T.putStrLn . unHandle) fs++--------------------------------------------------------------------------------
+ src/Codeforces/App/Commands/VirtualCmd.hs view
@@ -0,0 +1,70 @@+--------------------------------------------------------------------------------++-- | Virtual contest/rating command.+module Codeforces.App.Commands.VirtualCmd+ ( virtualRating+ ) where++import Codeforces.API+import Codeforces.App.Format+import Codeforces.Error++import Control.Monad.Trans.Class+import Control.Monad.Trans.Except++import qualified Data.Text as T+import qualified Data.Text.IO as T++--------------------------------------------------------------------------------++virtualRating :: ContestId -> Handle -> Points -> Int -> IO ()+virtualRating cId h pts pen = handleE $ runExceptT $ do+ (u, mRes) <- handleAPI $ calculateVirtualResult cId h pts pen++ case mRes of+ Nothing -> throwE VirtualNoResult+ Just res -> lift $ printVirtualRes u res++printVirtualRes :: User -> VirtualResult -> IO ()+printVirtualRes u VirtualResult {..} = do+ printRankings virtualSeed virtualRank++ putStrLn ""+ putStrLn "Rating change:"++ let currRating = userRating u+ let currRank = getRank currRating+ let newRating = currRating + virtualDelta+ let newRank = getRank newRating++ putStrLn $ concat [" (", show currRating, " -> ", show newRating, ")"]+ putStrLn ""++ T.putStrLn $ T.concat [" ", indent, diffColored virtualDelta]+ putStrLn ""++ let handle = unHandle (userHandle u)+ desc = if currRank == newRank+ then T.concat+ [ "Would remain "+ , rankName currRank+ , " "+ , rankColored (rankColor currRank) handle+ ]+ else T.concat+ [ "Would become "+ , rankName newRank+ , ": "+ , rankColored (rankColor currRank) handle+ , " -> "+ , rankColored (rankColor newRank) handle+ ]+ T.putStrLn $ T.concat [" ", desc, "\n"]++printRankings :: Seed -> Int -> IO ()+printRankings seed rank = do+ putStrLn ""+ putStrLn $ "Expected ranking: " ++ show (round seed :: Int)+ putStrLn $ "Actual ranking: " ++ show rank++-------------------------------------------------------------------------------
+ src/Codeforces/App/Config.hs view
@@ -0,0 +1,91 @@+--------------------------------------------------------------------------------++module Codeforces.App.Config+ ( loadConfig+ , setupConfig+ ) where++import Codeforces.Config+import Codeforces.Types++import Data.Aeson+import qualified Data.ByteString.Lazy as BL+import Data.Maybe+import qualified Data.Text.IO as T++import System.Directory+import System.IO++--------------------------------------------------------------------------------++-- | 'loadConfig' returns the user configuration instance from the config file.+loadConfig :: IO UserConfig+loadConfig = do+ path <- configPath+ hasConfig <- doesPathExist path+ mConfig <- if hasConfig then decode <$> BL.readFile path else pure Nothing+ pure $ fromMaybe emptyConfig mConfig++-- | The user configuration file path is+-- @configPath/codeforces-cli/config.json@ where @configPath@ is the user's+-- 'XdgConfig' directory.+configPath :: IO FilePath+configPath = getXdgDirectory XdgConfig "codeforces-cli/config.json"++emptyConfig :: UserConfig+emptyConfig = UserConfig { cfgHandle = Handle "", cfgKey = "", cfgSecret = "" }++--------------------------------------------------------------------------------++-- | Creates a configuration file with user prompts.+--+-- The user must decide whether to overwrite their configuration file if one+-- already exists.+--+setupConfig :: IO ()+setupConfig = do+ hSetBuffering stdin LineBuffering+ hSetBuffering stdout NoBuffering++ path <- configPath+ exists <- doesPathExist path++ continue <- if exists+ then do+ putStrLn+ $ "Warning: A configuration file already exists in "+ ++ path+ putStr "Do you want to continue? [Y/n]: "+ resp <- getLine+ pure $ resp == "Y"+ else pure True++ if not continue then pure () else createConfig path++-- | 'createConfig' is an interactive prompt tool to help users create+-- configuration files easily.+createConfig :: FilePath -> IO ()+createConfig path = do+ putStrLn ""+ putStrLn+ "You'll need to generate an API key via \+ \<https://codeforces.com/settings/api>\n"+ putStrLn "Then, complete the following details:\n"++ putStr "Codeforces handle: "+ handle <- T.getLine++ putStr "API key: "+ key <- T.getLine++ putStr "API secret: "+ secret <- T.getLine++ BL.writeFile path $ encode UserConfig { cfgHandle = Handle handle+ , cfgKey = key+ , cfgSecret = secret+ }+ putStrLn ""+ putStrLn $ "Successfully created a configuration file in " ++ path++--------------------------------------------------------------------------------
+ src/Codeforces/App/Format.hs view
@@ -0,0 +1,135 @@+--------------------------------------------------------------------------------++-- | Utility functions for formatting data.+module Codeforces.App.Format where++import Codeforces.Types hiding ( RankColor(..) )+import qualified Codeforces.Types.Rank as R++import Codeforces.App.Table++import Data.Fixed+import Data.Text ( Text )+import qualified Data.Text as T+import Data.Time++import System.Console.ANSI++--------------------------------------------------------------------------------++-- | 'showText' @x@ is a 'Data.Text' version of 'show'+showText :: Show a => a -> Text+showText = T.pack . show++-- | 'colored' @color text@ wraps some text around SGR codes to display it in+-- the given color.+colored :: Color -> Text -> Text+colored c s = T.concat+ [ T.pack $ setSGRCode [SetColor Foreground Dull c]+ , s+ , T.pack $ setSGRCode [Reset]+ ]++rankColored :: R.RankColor -> Text -> Text+rankColored = colored . convertRankColor++convertRankColor :: R.RankColor -> Color+convertRankColor R.Gray = White+convertRankColor R.Green = Green+convertRankColor R.Cyan = Cyan+convertRankColor R.Blue = Blue+convertRankColor R.Violet = Magenta+convertRankColor R.Orange = Yellow+convertRankColor R.Red = Red++-- | Like 'differenceCell' but returns a 'Text' rather than a 'Cell'.+diffColored :: Int -> Text+diffColored x | x > 0 = colored Green $ "+" <> showText x+ | x == 0 = " " <> showText x+ | otherwise = colored Red $ showText x++indent :: Text+indent = T.replicate 6 " "++--------------------------------------------------------------------------------++fmtTimeConsumed :: Int -> Text+fmtTimeConsumed x = showText x <> " ms"++fmtMemoryConsumed :: Int -> Text+fmtMemoryConsumed x = showText (x `div` 1000) <> " KB"++-- | Returns an approximate and human-friendly time difference.+--+-- Possible options are:+-- * "just now"+-- * "5 seconds ago"+-- * "X seconds ago" where X is a multiple of 10+-- * "X minutes ago"+--+fmtDiffTime :: NominalDiffTime -> Text+fmtDiffTime diff = go (nominalDiffTimeToSeconds diff)+ where+ go x | x < 5 = "just now"+ | x < 10 = "5 seconds ago"+ | x < 60 = showText (x `div'` 10 :: Int) <> "0 seconds ago"+ | otherwise = showText (x `div'` 60 :: Int) <> " minutes ago"++--------------------------------------------------------------------------------++plainCell :: Text -> Cell+plainCell = Cell [Reset]++coloredCell :: Color -> Text -> Cell+coloredCell c = Cell [SetColor Foreground Dull c]++blankCell :: Cell+blankCell = plainCell ""++ratingCell :: Rating -> Cell+ratingCell x =+ let color = convertRankColor $ rankColor $ getRank x+ in coloredCell color (showText x)++-- | 'differenceCell' @diff@ colors a number red, white or green, depending on+-- whether it's negative, 0, or positive.+differenceCell :: Int -> Cell+differenceCell x | x > 0 = coloredCell Green $ "+" <> showText x+ | x == 0 = plainCell $ " " <> showText x+ | otherwise = coloredCell Red $ showText x++-- | 'verdictCell' @testset passedTestCount points verdict@ returns a cell+-- displaying the status of a submission, such as "Accepted" or "Wrong answer on+-- pretest 2".+verdictCell :: Testset -> Int -> Maybe Points -> Maybe Verdict -> Cell+verdictCell _ _ _ Nothing = plainCell "In queue"+verdictCell testset passed points (Just v) = case v of+ Ok -> case testset of+ Tests -> coloredCell Green "Accepted"+ Samples -> coloredCell Green "Samples passed"+ Pretests -> coloredCell Green "Pretests passed"+ Challenges -> coloredCell Green "Challenges passed"+ Partial -> coloredCell Yellow $ maybe+ "Partial result"+ (\pts -> T.concat ["Partial result: ", showText pts, " points"])+ points+ Challenged -> coloredCell Red "Hacked"+ CompilationError -> plainCell $ verdictText v+ Skipped -> plainCell $ verdictText v+ SecurityViolated -> plainCell $ verdictText v+ Crashed -> plainCell $ verdictText v+ InputPreparationCrashed -> plainCell $ verdictText v+ Rejected -> plainCell $ verdictText v+ _ ->+ let currTest = passed + 1+ clr = if v == Testing then White else Blue+ text = T.concat+ [ verdictText v+ , " on "+ , T.toLower . T.init $ showText testset+ , " "+ , showText currTest+ ]+ in coloredCell clr text++--------------------------------------------------------------------------------
+ src/Codeforces/App/Options.hs view
@@ -0,0 +1,306 @@+--------------------------------------------------------------------------------++module Codeforces.App.Options+ ( Command(..)+ , ContestOpts(..)+ , InfoOpts(..)+ , ProblemOpts(..)+ , StandingOpts(..)+ , StatusOpts(..)+ , parseCommands+ ) where++import Codeforces.Types+import Paths_codeforces_cli ( version )++import Data.Version ( showVersion )++import Options.Applicative++--------------------------------------------------------------------------------++data Command+ = AgendaCmd+ | ContestsCmd ContestOpts+ | FriendsCmd+ | InfoCmd ContestId InfoOpts+ | OpenCmd ContestId+ | ProblemsCmd ProblemOpts+ | RatingsCmd Handle+ | SetupCmd+ | StandingsCmd ContestId StandingOpts+ | StatusCmd Handle StatusOpts+ | UserCmd Handle+ | VirtualCmd ContestId Handle Points Int+ deriving Eq++data ContestOpts = ContestOpts+ { optIsGym :: Bool+ , optIsPast :: Bool+ , optIsUpcoming :: Bool+ }+ deriving Eq++data InfoOpts = InfoOpts+ { optHandle :: Maybe Handle+ , optInfoWatch :: Bool+ }+ deriving Eq++data ProblemOpts = ProblemOpts+ { optMinRating :: Rating+ , optMaxRating :: Rating+ }+ deriving Eq++data StandingOpts = StandingOpts+ { optShowUnofficial :: Bool+ , optFromIndex :: Int+ , optRowCount :: Int+ , optRoom :: Maybe Int+ , optFriends :: Bool+ , optStandWatch :: Bool+ }+ deriving Eq++data StatusOpts = StatusOpts+ { optStatusFrom :: Int+ , optStatusCount :: Int+ , optStatusWatch :: Bool+ }+ deriving Eq++--------------------------------------------------------------------------------++parseCommands :: IO Command+parseCommands = execParser opts++opts :: ParserInfo Command+opts = info (commandP <**> helper) (appHeader <> fullDesc)++-- | CLI name and version number.+appHeader :: InfoMod Command+appHeader = header $ "Codeforces CLI v" ++ appVersion++-- | Version number of the CLI.+appVersion :: String+appVersion = showVersion version++--------------------------------------------------------------------------------++commandP :: Parser Command+commandP =+ hsubparser+ $ command+ "agenda"+ (info+ agendaP+ (progDesc "Upcoming contests. Alias for contests --upcoming")+ )+ <> command "contests" (info contestsP (progDesc "List of contests"))+ <> command+ "info"+ (info+ contestInfoP+ (progDesc+ "Show the problems and your problem results of a contest"+ )+ )+ <> command+ "friends"+ (info friendsP+ (progDesc "List your friends (must be authenticated)")+ )+ <> command "open"+ (info openP (progDesc "Open a contest in the browser"))+ <> command+ "problems"+ (info problemsP (progDesc "View and filter problem sets"))+ <> command "ratings"+ (info ratingsP (progDesc "Rating changes of a user"))+ <> command "setup"+ (info setupP (progDesc "Setup your configuration file"))+ <> command+ "standings"+ (info standingsP (progDesc "Standings table of a contest"))+ <> command "status"+ (info statusP (progDesc "Recent submissions of a user"))+ <> command "user" (info userP (progDesc "Information about a user"))+ <> command+ "virtual"+ (info+ virtualP+ (progDesc+ "Calculate your rating after a virtual contest,\+ \ to find what it would be if you competed live"+ )+ )++agendaP :: Parser Command+agendaP = pure AgendaCmd++contestsP :: Parser Command+contestsP =+ fmap ContestsCmd+ $ ContestOpts+ <$> switch+ ( long "gym"+ <> short 'g'+ <> help+ "If true then gym contests are returned,\+ \ otherwise, just regular contests are shown."+ )+ <*> switch (long "past" <> short 'p' <> help "Show only past contests.")+ <*> switch+ ( long "upcoming"+ <> short 'u'+ <> help+ "Show only upcoming contests.\+ \ This can also be done with the `agenda` command."+ )+++contestInfoP :: Parser Command+contestInfoP = InfoCmd <$> contestIdArg <*> contestInfoOpts++contestInfoOpts :: Parser InfoOpts+contestInfoOpts =+ InfoOpts+ <$> optional+ (Handle <$> strOption+ ( long "user"+ <> short 'u'+ <> help+ "Codeforces user handle. If specified, it shows the\+ \ contest details of another user. If not specified,\+ \ your contest details will be shown."+ <> metavar "HANDLE"+ )+ )+ <*> watchOpt++friendsP :: Parser Command+friendsP = pure FriendsCmd++openP :: Parser Command+openP = OpenCmd <$> contestIdArg++problemsP :: Parser Command+problemsP =+ fmap ProblemsCmd+ $ ProblemOpts+ <$> option+ auto+ ( long "minRating"+ <> short 'r'+ <> help "Filter problems by minimum rating."+ <> showDefault+ <> value 0+ <> metavar "INT"+ )+ <*> option+ auto+ ( long "maxRating"+ <> short 'R'+ <> help "Filter problems by maximum rating."+ <> showDefault+ <> value 3500+ <> metavar "INT"+ )++ratingsP :: Parser Command+ratingsP = RatingsCmd <$> handleArg++setupP :: Parser Command+setupP = pure SetupCmd++standingsP :: Parser Command+standingsP = StandingsCmd <$> contestIdArg <*> standingOpts++standingOpts :: Parser StandingOpts+standingOpts =+ StandingOpts+ <$> switch+ ( long "unofficial"+ <> short 'u'+ <> help+ "If true then all participants (virtual, out of\+ \ competition) are shown. Otherwise, only official\+ \ contestants are shown."+ )+ <*> fromOpt+ <*> countOpt+ <*> optional+ (option+ auto+ ( long "room"+ <> short 'r'+ <> help+ "If specified, then only participants from this room\+ \ are shown. Otherwise, all participants are shown."+ <> metavar "INT"+ )+ )+ <*> switch+ ( long "friends"+ <> short 'f'+ <> help+ "If true then only you and your friends will be shown\+ \ in the standings."+ )+ <*> watchOpt++statusP :: Parser Command+statusP = StatusCmd <$> handleArg <*> statusOpts++statusOpts :: Parser StatusOpts+statusOpts = StatusOpts <$> fromOpt <*> countOpt <*> watchOpt++userP :: Parser Command+userP = UserCmd <$> handleArg++virtualP :: Parser Command+virtualP =+ VirtualCmd+ <$> contestIdArg+ <*> handleArg+ <*> argument auto (metavar "POINTS" <> help "Total points")+ <*> argument auto (metavar "PENALTY" <> help "Total penalty")++--------------------------------------------------------------------------------++handleArg :: Parser Handle+handleArg =+ Handle <$> argument str (metavar "HANDLE" <> help "Codeforces user handle.")++contestIdArg :: Parser ContestId+contestIdArg = ContestId+ <$> argument auto (metavar "CONTEST_ID" <> help "ID of the contest")++fromOpt :: Parser Int+fromOpt = option+ auto+ ( long "from"+ <> short 'i'+ <> help "1-based index of the row to start from."+ <> showDefault+ <> value 1+ <> metavar "INT"+ )++countOpt :: Parser Int+countOpt = option+ auto+ ( long "count"+ <> short 'n'+ <> help "Number of rows to return."+ <> showDefault+ <> value 40+ <> metavar "INT"+ )++watchOpt :: Parser Bool+watchOpt = switch $ long "watch" <> short 'w' <> help+ "Watch this command and update output whenever it changes."++--------------------------------------------------------------------------------
+ src/Codeforces/App/Table.hs view
@@ -0,0 +1,59 @@+--------------------------------------------------------------------------------++module Codeforces.App.Table+ ( Cell(..)+ , Row+ , Table+ , makeTable+ , ColConfig+ ) where++import Data.Text ( Text )+import qualified Data.Text as T++import System.Console.ANSI++--------------------------------------------------------------------------------++-- | A cell of a table consists of SGR styles and some text content+data Cell = Cell [SGR] Text++cellToText :: Cell -> Text+cellToText (Cell sgrs x) =+ T.concat [T.pack $ setSGRCode sgrs, x, T.pack $ setSGRCode [Reset]]++--------------------------------------------------------------------------------++-- | Name and width of a column+type ColConfig = (Text, Int)++type Row = [Cell]++-- | The table output is a list of row strings.+type Table = [Text]++-- | `makeTable` @colConfigs rows@ returns a list of row strings including the+-- header row+makeTable :: [ColConfig] -> [Row] -> Table+makeTable hs rs = makeHeader hs : map (makeRow hs) rs++makeHeader :: [ColConfig] -> Text+makeHeader hs = T.intercalate colSep $ map (\(s, w) -> pad w s) hs++-- | `makeRow` @colConfigs row@ makes a row string from the supplied column+-- widths and row cells.+makeRow :: [ColConfig] -> Row -> Text+makeRow hs row = T.intercalate colSep paddedCells+ where+ paddedCells = zipWith (\(_, w) cell -> fmtCell w cell) hs row+ fmtCell w (Cell sgrs x) = cellToText $ Cell sgrs (pad w x)++colSep :: Text+colSep = " "++pad :: Int -> Text -> Text+pad w s | len > w = T.take (w - 2) s <> ".."+ | otherwise = s <> T.replicate (w - len) " "+ where len = T.length s++--------------------------------------------------------------------------------
+ src/Codeforces/App/Watcher.hs view
@@ -0,0 +1,142 @@+--------------------------------------------------------------------------------++module Codeforces.App.Watcher where++import Codeforces.App.Format+import Codeforces.App.Table+import Codeforces.Error+import Codeforces.Logging++import Control.Concurrent+import Control.Exception ( bracket )+import Control.Monad.Extra ( forM_ )+import Control.Monad.Trans.Class+import Control.Monad.Trans.State++import Data.Maybe ( catMaybes )+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Data.Time++import System.Console.ANSI+import System.IO++--------------------------------------------------------------------------------++-- | Values used for watching output.+data WatchState = WatchState+ { wsTable :: Table+ , wsUpdateTime :: Maybe UTCTime+ }++initWatchState :: WatchState+initWatchState = WatchState [] Nothing++--------------------------------------------------------------------------------++-- | 'handleWatch' @shouldWatch m@ runs computation @m@ once if @shouldWatch@ is+-- false, otherwise 'watchTable' watches it.+--+-- In the latter case, it clears the terminal and sets up terminal behaviour for+-- watching data.+--+handleWatch :: Bool -> IO (Either CodeforcesError Table) -> IO ()+handleWatch False m =+ m >>= either (putStrLn . elErrorMsg . showE) (mapM_ T.putStrLn)+handleWatch True m = withDisabledStdin $ do+ resetScreen+ evalStateT (watchTable 2 m) initWatchState++-- | 'watchTable' @delaySecs m@ runs computation @m@ every @delaySecs@ amount of+-- seconds. The terminal output from @m@ is changed if the next run of @m@+-- yields a different result.+watchTable+ :: Int -- ^ Delay, in seconds.+ -> IO (Either CodeforcesError Table) -- ^ Fetches an updated table.+ -> StateT WatchState IO () -- ^ Data from previous iteration.+watchTable delaySecs m = do+ oldState <- get+ now <- lift getCurrentTime++ output <- lift m >>= \case+ Left e -> do+ -- Include error message but table data remains the same+ let oldTable = wsTable oldState+ lastUpdate = wsUpdateTime oldState+ pure $ addInfo oldTable (Just e) now lastUpdate++ Right newTable -> do+ let currUpdate = Just now+ put $ WatchState newTable currUpdate+ pure $ addInfo newTable Nothing now currUpdate++ lift $ do+ currTermH <- fmap fst <$> getTerminalSize+ let output' = truncateTable output (subtract 1 <$> currTermH)++ setCursorPosition 0 0+ forM_ output' $ \r -> clearLine >> T.putStrLn r++ threadDelay (delaySecs * 1000000)++ watchTable delaySecs m++--------------------------------------------------------------------------------++-- | Takes a table with a potential error message and last successful update+-- time, and returns the table with extra rows for various messages.+--+-- When tables are displayed in watch mode, these extra rows are placed before+-- the table:+-- * The first displays a message for how to exit watch mode.+-- * The second row displays errors if there are any and the last update time.+-- * The third row is blank.+--+addInfo+ :: Table -- ^ Table to modify.+ -> Maybe CodeforcesError -- ^ Error message, if exists.+ -> UTCTime -- ^ Current system time.+ -> Maybe UTCTime -- ^ Last successful update time, if any.+ -> Table+addInfo table me now lastUpdate =+ colored Cyan "Watching for updates. Press CTRL+c to exit."+ : statusMsg+ : ""+ : table+ where+ statusMsg = T.concat $ catMaybes [errorMsg, updateMsg]++ errorMsg = colored Red . (<> ". ") . T.pack . elErrorMsg . showE <$> me+ updateMsg = T.concat <$> sequenceA+ [Just "Last update: ", fmtDiffTime <$> (diffUTCTime now <$> lastUpdate)]++-- | 'truncateTable' @table x@ returns the table with the first @x@ rows, or the+-- original table if @x@ is @Nothing@.+truncateTable :: Table -> Maybe Int -> Table+truncateTable = maybe <*> flip take++--------------------------------------------------------------------------------++resetScreen :: IO ()+resetScreen = setSGR [Reset] >> clearScreen >> setCursorPosition 0 0++-- | Prevents any input into the terminal while running the IO computation.+withDisabledStdin :: IO a -> IO a+withDisabledStdin io = bracket+ (do+ prevBuff <- hGetBuffering stdin+ prevEcho <- hGetEcho stdin++ -- Disable terminal input+ hSetBuffering stdin NoBuffering+ hSetEcho stdin False++ pure (prevBuff, prevEcho)+ )+ (\(prevBuff, prevEcho) ->+ -- Revert stdin buffering and echo+ hSetBuffering stdin prevBuff >> hSetEcho stdin prevEcho+ )+ (const io)++--------------------------------------------------------------------------------
+ src/Codeforces/Config.hs view
@@ -0,0 +1,117 @@+--------------------------------------------------------------------------------++module Codeforces.Config+ ( UserConfig(..)+ , AuthQuery(..)+ , generateRequestParams+ ) where++import Codeforces.Types++import qualified Crypto.Hash.SHA512 as SHA512++import Data.Aeson+import qualified Data.ByteString.Base16 as Base16+import Data.ByteString.Char8 ( ByteString )+import qualified Data.ByteString.Char8 as BC+import Data.Text ( Text )+import qualified Data.Text.Encoding as T+import Data.Time.Clock.POSIX++import Network.HTTP.Simple+import Network.HTTP.Types ( renderQuery )++import System.Random++--------------------------------------------------------------------------------++-- | Represents the user's configuration settings.+--+-- The API key must first be generated on+-- <https://codeforces.com/settings/api the Codeforces API page>.+-- An API key consists of two parameters: @key@ and @secret@.+--+-- To use the API key in a request, some parameters need to be generated from+-- this configuration.+--+data UserConfig = UserConfig+ { cfgHandle :: Handle -- ^ Codeforces handle of the user+ , cfgKey :: Text -- ^ First part of the API key+ , cfgSecret :: Text -- ^ Second part of the API key+ }+ deriving Show++instance FromJSON UserConfig where+ parseJSON = withObject "Config" $ \v ->+ UserConfig <$> (v .: "handle") <*> (v .: "key") <*> (v .: "secret")++instance ToJSON UserConfig where+ toJSON UserConfig {..} =+ object ["handle" .= cfgHandle, "key" .= cfgKey, "secret" .= cfgSecret]++--------------------------------------------------------------------------------++-- | Contains the data needed to make an authorized GET request.+-- See 'generateRequestParams'.+data AuthQuery = AuthQuery+ { aqOriginalQuery :: Query+ , aqMethodName :: String+ , aqKey :: Text+ , aqSecret :: Text+ , aqTime :: POSIXTime+ , aqRand :: Int+ }++-- | 'generateRequestParams' @config path query@ returns a query string with+-- extra query items that are generated to allow for authorized access.+--+-- The parameters are of the form:+-- @+-- ?paramI=valueI&apiKey=<key>&time=<time>&apiSig=<rand><hash>+-- @+--+-- Where+--+-- * @<rand>@ is a random 6-digit integer+-- * @<time>@ is current time since epoch in seconds+-- * @<hash>@ is the SHA-512 hashcode of the UTF-8 encoded string:+--+-- @+-- <rand>/<methodName>?paramI=valueI&apiKey=<key>&time=<time>#<secret>+-- @+generateRequestParams :: UserConfig -> String -> Query -> IO Query+generateRequestParams UserConfig {..} path query = do+ (rand :: Int) <- randomRIO (100000, 999999)+ time <- getPOSIXTime++ let authQuery = AuthQuery { aqOriginalQuery = query+ , aqMethodName = path+ , aqKey = cfgKey+ , aqSecret = cfgSecret+ , aqTime = time+ , aqRand = rand+ }+ let apiSig = (BC.pack . show) rand <> generateHash authQuery++ pure $ concat+ [query, keyAndTimeParams cfgKey time, [("apiSig", Just apiSig)]]++generateHash :: AuthQuery -> ByteString+generateHash AuthQuery {..} = Base16.encode $ SHA512.hash $ BC.concat+ [ BC.pack (show aqRand)+ , BC.pack aqMethodName+ , renderQuery True $ aqOriginalQuery ++ keyAndTimeParams aqKey aqTime+ , "#"+ , T.encodeUtf8 aqSecret+ ]++-- | A 'Query' consisting the correctly formatted @apiKey@ and POSIX @time@.+keyAndTimeParams :: Text -> POSIXTime -> Query+keyAndTimeParams key time =+ fmap Just+ <$> [("apiKey", T.encodeUtf8 key), ("time", posixToByteString time)]++posixToByteString :: POSIXTime -> ByteString+posixToByteString = BC.pack . (show :: Int -> String) . round++--------------------------------------------------------------------------------
+ src/Codeforces/Error.hs view
@@ -0,0 +1,40 @@+--------------------------------------------------------------------------------++-- | Provides a way of dealing with errors encountered during the retrieval or+-- processing of data from the Codeforces API.+--+module Codeforces.Error where++import Codeforces.Logging+import qualified Codeforces.Response as R++--------------------------------------------------------------------------------++-- | An error that may occur in this application.+data CodeforcesError+ = ResponseError R.ResponseError+ | StandingsEmpty+ | StandingsWithFriendsEmpty+ | VirtualNoResult++-- | Returns a human-friendly error message with error details.+showE :: CodeforcesError -> ErrorLog+showE (ResponseError e) = R.responseErrorMsg e+showE StandingsEmpty = mkErrorLog "Standings empty."+showE StandingsWithFriendsEmpty =+ mkErrorLog "Neither you nor your friends participated in this contest."+showE VirtualNoResult =+ mkErrorLog+ "An unexpected error occurred.\+ \ Your rating change could not be calculated."++--------------------------------------------------------------------------------++-- | 'handleE' @m@ runs the computation @m@ that may produce a+-- 'CodeforcesError'. If an error is encountered, its error message is printed.+handleE :: IO (Either CodeforcesError a) -> IO ()+handleE m = m >>= \case+ Left e -> putStrLn . elErrorMsg . showE $ e+ Right _ -> pure ()++--------------------------------------------------------------------------------
+ src/Codeforces/Logging.hs view
@@ -0,0 +1,25 @@+--------------------------------------------------------------------------------++-- | Utility functions for producing and writing error logs.+--+module Codeforces.Logging where++--------------------------------------------------------------------------------++-- | Contains a brief, user-friendly error message and potential loggable data.+data ErrorLog = ErrorLog+ { elErrorMsg :: String+ , elErrorLog :: Maybe String+ }+ deriving Show++-- | Produces an error and log using a single error message.+mkErrorLog :: String -> ErrorLog+mkErrorLog = flip ErrorLog Nothing++-- | Takes an error message and error details and produces a pair of the message+-- and full error details.+(<~>) :: String -> String -> ErrorLog+(<~>) msg details = ErrorLog msg (Just $ msg ++ ": " ++ details)++--------------------------------------------------------------------------------
+ src/Codeforces/Response.hs view
@@ -0,0 +1,133 @@+--------------------------------------------------------------------------------++module Codeforces.Response+ ( ResponseError(..)+ , responseErrorMsg+ , getData+ , getAuthorizedData+ ) where++import Codeforces.Config+import Codeforces.Logging++import Control.Exception ( try )++import Data.Aeson+import Data.Maybe++import Network.HTTP.Client+import Network.HTTP.Simple++--------------------------------------------------------------------------------++data CodeforcesStatus = Ok | Failed+ deriving Show++instance FromJSON CodeforcesStatus where+ parseJSON = withText "CodeforcesStatus"+ $ \t -> pure $ if t == "OK" then Ok else Failed++-- | Represents the result object or error comment returned by the API.+--+-- Each successful response from the API contains a "status" field, and either+-- a "result" or "comment" when status is "OK" or "FAILED" respectively.+--+-- These two possibilities are represented by @ResponseOk@ and @ResponseFail@.+--+data CodeforcesResponse a = ResponseFail String | ResponseOk a+ deriving Show++instance FromJSON a => FromJSON (CodeforcesResponse a) where+ parseJSON = withObject "CodeforcesResponse" $ \o -> do+ st <- o .: "status"+ case st of+ Ok -> ResponseOk <$> o .: "result"+ Failed -> ResponseFail <$> o .: "comment"++--------------------------------------------------------------------------------++-- | An error that could occur during the retrieval and inital parsing of data+-- from the Codeforces API.+data ResponseError+ = ApiFail String+ -- ^ Corresponds to a @ResponseFail@ from the Codeforces API with the fail+ -- comment.+ | JsonError JSONException+ -- ^ Wrapper around 'JSONException', used if the successful JSON response+ -- could not be parsed.+ | HttpError HttpException+ -- ^ Wrapper around 'HttpException', used for situations like a failed+ -- connection.+ deriving Show++-- | Converts a 'ResponseError' to a friendly error message to display, and+-- details that can be logged separately.+responseErrorMsg :: ResponseError -> ErrorLog+responseErrorMsg (ApiFail e) = mkErrorLog e+responseErrorMsg (JsonError e) = "Couldn't parse result" <~> show e+responseErrorMsg (HttpError e) = case e of+ HttpExceptionRequest _ content -> case content of+ StatusCodeException resp _ ->+ mkErrorLog $ "HTTP " <> show (getResponseStatusCode resp)+ TooManyRedirects resps -> "Too many redirects" <~> show resps+ ConnectionTimeout -> mkErrorLog "Connection timeout"+ ConnectionFailure e2 -> "Connection failure" <~> show e2+ other -> "HTTP error" <~> show other+ InvalidUrlException url reason ->+ "Invalid URL" <~> (url <> "\nfor " <> reason)++--------------------------------------------------------------------------------++-- | Converts a possible 'CodeforcesResponse' into an either type.+codeforcesDecode+ :: FromJSON a+ => Either JSONException (CodeforcesResponse a)+ -> Either ResponseError a+codeforcesDecode (Left e1 ) = Left $ JsonError e1+codeforcesDecode (Right resp) = case resp of+ (ResponseFail e2 ) -> Left $ ApiFail e2+ (ResponseOk obj) -> Right obj++--------------------------------------------------------------------------------++-- | Host name and the API's base URL, without trailing slash.+baseUrl :: String+baseUrl = "https://codeforces.com/api"++-- | 'getData' @path query@ is a general function for returning some result data+-- from the Codeforces API.+getData :: FromJSON a => String -> Query -> IO (Either ResponseError a)+getData path query = do+ req <- parseRequest (baseUrl ++ path)+ let request = setRequestQueryString (catQuery query) req++ eresponse <- try $ httpJSONEither request+ pure $ case eresponse of+ Left e -> Left $ HttpError e+ Right resp -> codeforcesDecode $ getResponseBody resp++-- | 'getAuthorizedData' @config path query@ requests and returns some result+-- data that requires authorization.+getAuthorizedData+ :: FromJSON a+ => UserConfig+ -> String+ -> Query+ -> IO (Either ResponseError a)+getAuthorizedData cfg p q = generateRequestParams cfg p q >>= getData p++--------------------------------------------------------------------------------++-- | Takes a list of 'QueryItem's and returns those that have a @Just@ parameter+-- value.+--+-- By default, @Nothing@ items in 'Query' are parsed into "&a&b" format. The+-- Codeforces API seems to be inconsistent with how it interprets requests like+-- this. Most notably, the @contest.standings@ endpoint returns an empty list of+-- ranklist rows when @Nothing@ is passed, but all ranklist rows when completely+-- omitted.+--+catQuery :: Query -> Query+catQuery = filter (isJust . snd)++--------------------------------------------------------------------------------
+ src/Codeforces/Types.hs view
@@ -0,0 +1,25 @@+--------------------------------------------------------------------------------++module Codeforces.Types+ ( module Codeforces.Types.Common+ , module Codeforces.Types.Contest+ , module Codeforces.Types.Party+ , module Codeforces.Types.Problem+ , module Codeforces.Types.Rank+ , module Codeforces.Types.RatingChange+ , module Codeforces.Types.Standings+ , module Codeforces.Types.Submission+ , module Codeforces.Types.User+ ) where++import Codeforces.Types.Common+import Codeforces.Types.Contest+import Codeforces.Types.Party+import Codeforces.Types.Problem+import Codeforces.Types.Rank+import Codeforces.Types.RatingChange+import Codeforces.Types.Standings+import Codeforces.Types.Submission+import Codeforces.Types.User++--------------------------------------------------------------------------------
+ src/Codeforces/Types/Common.hs view
@@ -0,0 +1,43 @@+--------------------------------------------------------------------------------++-- | Common types used across the application.+--+module Codeforces.Types.Common where++import Data.Aeson+import Data.Text ( Text )++--------------------------------------------------------------------------------++-- | ID of the contest.+--+-- Not to be confused with contest round number. The ID appears in the contest+-- URL, for example in: <https://codeforces.com/contest/566/status>.+--+newtype ContestId = ContestId { unContestId :: Int }+ deriving (Eq, Ord, Show)++instance FromJSON ContestId where+ parseJSON v = ContestId <$> parseJSON v++-- | Codeforces user handle.+newtype Handle = Handle { unHandle :: Text }+ deriving (Eq, Ord, Show)++instance FromJSON Handle where+ parseJSON v = Handle <$> parseJSON v++instance ToJSON Handle where+ toJSON = toJSON . unHandle++-- | Number of points gained for a submission or across a contest.+type Points = Float++-- | A letter, or letter with digit(s) indicating the problem index in a+-- contest.+type ProblemIndex = Text++-- | User or problem rating.+type Rating = Int++--------------------------------------------------------------------------------
+ src/Codeforces/Types/Contest.hs view
@@ -0,0 +1,59 @@+--------------------------------------------------------------------------------++module Codeforces.Types.Contest where++import Codeforces.Types.Common++import Data.Aeson+import Data.Text ( Text )+import Data.Time+import Data.Time.Clock.POSIX++--------------------------------------------------------------------------------++data ScoringType = ScoringCF | ScoringIOI | ScoringICPC+ deriving (Show, Eq)++instance FromJSON ScoringType where+ parseJSON = withText "ScoringType" $ \case+ "CF" -> pure ScoringCF+ "IOI" -> pure ScoringIOI+ "ICPC" -> pure ScoringICPC+ _ -> fail "Invalid Scoring Type"++data ContestPhase = Before | Coding | PendingSystemTest | Finished+ deriving Show++instance FromJSON ContestPhase where+ parseJSON = withText "ContestPhase" $ \case+ "BEFORE" -> pure Before+ "CODING" -> pure Before+ "PENDING_SYSTEM_TEST" -> pure PendingSystemTest+ "FINISHED" -> pure Finished+ _ -> fail "Invalid Contest Phase"++data Contest = Contest+ { contestId :: ContestId+ , contestName :: Text+ , contestType :: ScoringType+ , contestPhase :: ContestPhase+ , contestFrozen :: Bool+ , contestDuration :: DiffTime+ , contestStartTime :: Maybe UTCTime+ }+ deriving Show++instance FromJSON Contest where+ parseJSON = withObject "Contest" $ \v ->+ let durationSeconds = (v .: "durationSeconds")+ startTimePosix = (v .:? "startTimeSeconds")+ in Contest+ <$> (v .: "id")+ <*> (v .: "name")+ <*> (v .: "type")+ <*> (v .: "phase")+ <*> (v .: "frozen")+ <*> (secondsToDiffTime <$> durationSeconds)+ <*> (fmap posixSecondsToUTCTime <$> startTimePosix)++--------------------------------------------------------------------------------
+ src/Codeforces/Types/Party.hs view
@@ -0,0 +1,65 @@+--------------------------------------------------------------------------------++module Codeforces.Types.Party where++import Codeforces.Types.Common++import Data.Aeson+import Data.Text ( Text )+import Data.Time.Clock+import Data.Time.Clock.POSIX ( posixSecondsToUTCTime )++--------------------------------------------------------------------------------++-- | Member of a party.+data Member = Member+ { memberHandle :: Handle+ }+ deriving (Eq, Ord, Show)++instance FromJSON Member where+ parseJSON = withObject "Member" $ \v -> Member <$> (v .: "handle")++data ParticipantType+ = Contestant+ | Practice+ | Virtual+ | Manager+ | OutOfCompetition+ deriving (Eq, Ord, Show)++instance FromJSON ParticipantType where+ parseJSON = withText "ParticipantType" $ \case+ "CONTESTANT" -> pure Contestant+ "PRACTICE" -> pure Practice+ "VIRTUAL" -> pure Virtual+ "MANAGER" -> pure Manager+ "OUT_OF_COMPETITION" -> pure OutOfCompetition+ _ -> fail "Invalid ParticipantType"++-- | Represents a party, participating in a contest.+data Party = Party+ { partyContestId :: Maybe ContestId+ , partyMembers :: [Member]+ , partyParticipantType :: ParticipantType+ , partyTeamId :: Maybe Int+ , partyTeamName :: Maybe Text+ , partyIsGhost :: Bool+ , partyRoom :: Maybe Int+ , partyStartTime :: Maybe UTCTime+ }+ deriving (Eq, Ord, Show)++instance FromJSON Party where+ parseJSON = withObject "Party" $ \v ->+ Party+ <$> (v .:? "contestId")+ <*> (v .: "members")+ <*> (v .: "participantType")+ <*> (v .:? "teamId")+ <*> (v .:? "teamName")+ <*> (v .: "ghost")+ <*> (v .:? "room")+ <*> (fmap posixSecondsToUTCTime <$> v .:? "startTimeSeconds")++--------------------------------------------------------------------------------
+ src/Codeforces/Types/Problem.hs view
@@ -0,0 +1,84 @@+--------------------------------------------------------------------------------++module Codeforces.Types.Problem where++import Codeforces.Types.Common++import Data.Aeson+import Data.Text ( Text )++--------------------------------------------------------------------------------++type ProblemTag = Text++data ProblemType = Programming | Question+ deriving Show++instance FromJSON ProblemType where+ parseJSON = withText "ProblemType" $ \case+ "PROGRAMMING" -> pure Programming+ "QUESTION" -> pure Question+ _ -> fail "Invalid ProblemType"++data Problem = Problem+ { problemContestId :: Maybe ContestId+ -- ^ ID of /a/ contest containing the problem.+ --+ -- Note that a problem may appear in multiple contests (such as Div. 1 and+ -- Div. 2 variants of a contest), but this field only contains one.+ --+ , problemSetName :: Maybe Text+ , problemIndex :: ProblemIndex+ , problemName :: Text+ , problemType :: ProblemType+ , problemPoints :: Maybe Points+ , problemRating :: Maybe Rating+ , problemTags :: [ProblemTag]+ }+ deriving Show++instance FromJSON Problem where+ parseJSON = withObject "Problem" $ \v ->+ Problem+ <$> (v .:? "contestId")+ <*> (v .:? "problemsetName")+ <*> (v .: "index")+ <*> (v .: "name")+ <*> (v .: "type")+ <*> (v .:? "points")+ <*> (v .:? "rating")+ <*> (v .: "tags")++data ProblemStats = ProblemStats+ { pStatContestId :: Maybe ContestId+ , pStatProblemIndex :: ProblemIndex+ , pStatSolvedCount :: Int+ }+ deriving Show++instance FromJSON ProblemStats where+ parseJSON = withObject "ProblemStats" $ \v ->+ ProblemStats+ <$> (v .:? "contestId")+ <*> (v .: "index")+ <*> (v .: "solvedCount")++--------------------------------------------------------------------------------++-- | Problem data returned by the API contains two lists: a list of problems+-- followed by a list of corresponding problem statistics.+data ProblemsResponse = ProblemsResponse+ { prProblems :: [Problem]+ , prStats :: [ProblemStats]+ }+ deriving Show++instance FromJSON ProblemsResponse where+ parseJSON =+ withObject "ProblemsResponse"+ $ \v ->+ ProblemsResponse+ <$> (v .: "problems")+ <*> (v .: "problemStatistics")++--------------------------------------------------------------------------------
+ src/Codeforces/Types/Rank.hs view
@@ -0,0 +1,44 @@+--------------------------------------------------------------------------------++module Codeforces.Types.Rank where++import Codeforces.Types.Common++import Data.Text ( Text )++--------------------------------------------------------------------------------++data RankColor = Gray | Green | Cyan | Blue | Violet | Orange | Red+ deriving (Eq, Show)++type RatingBounds = (Rating, Rating)++data Rank = Rank+ { rankName :: Text+ , rankColor :: RankColor+ , rankBounds :: RatingBounds+ }+ deriving (Eq, Show)++-- | A list of all Codeforces ranks.+ranks :: [Rank]+ranks =+ [ Rank "Newbie" Gray (0 , 1199)+ , Rank "Pupil" Green (1200, 1399)+ , Rank "Specialist" Cyan (1400, 1599)+ , Rank "Expert" Blue (1600, 1899)+ , Rank "Candidate Master" Violet (1900, 2099)+ , Rank "Master" Orange (2100, 2299)+ , Rank "International Master" Orange (2300, 2399)+ , Rank "Grandmaster" Red (2400, 2599)+ , Rank "International Grandmaster" Red (2600, 2899)+ , Rank "Legendary Grandmaster" Red (2900, 9999)+ ]++-- | Finds the 'Rank' that matches the supplied rating.+getRank :: Rating -> Rank+getRank x = head $ filter withinRankBounds ranks+ where+ withinRankBounds Rank {..} = fst rankBounds <= x && x <= snd rankBounds++--------------------------------------------------------------------------------
+ src/Codeforces/Types/RatingChange.hs view
@@ -0,0 +1,36 @@+--------------------------------------------------------------------------------++module Codeforces.Types.RatingChange where++import Codeforces.Types.Common++import Data.Aeson+import Data.Text ( Text )+import Data.Time+import Data.Time.Clock.POSIX ( posixSecondsToUTCTime )++--------------------------------------------------------------------------------++data RatingChange = RatingChange+ { rcContestId :: ContestId+ , rcContestName :: Text+ , rcHandle :: Handle+ , rcRank :: Int+ , rcRatingUpdateDate :: UTCTime+ , rcOldRating :: Rating+ , rcNewRating :: Rating+ }+ deriving Show++instance FromJSON RatingChange where+ parseJSON = withObject "RatingChange" $ \v ->+ RatingChange+ <$> (v .: "contestId")+ <*> (v .: "contestName")+ <*> (v .: "handle")+ <*> (v .: "rank")+ <*> (posixSecondsToUTCTime <$> (v .: "ratingUpdateTimeSeconds"))+ <*> (v .: "oldRating")+ <*> (v .: "newRating")++--------------------------------------------------------------------------------
+ src/Codeforces/Types/Standings.hs view
@@ -0,0 +1,103 @@+--------------------------------------------------------------------------------++module Codeforces.Types.Standings where++import Codeforces.Types.Common+import Codeforces.Types.Contest ( Contest )+import Codeforces.Types.Party ( Party )+import Codeforces.Types.Problem ( Problem )++import Data.Aeson+import Data.Time++--------------------------------------------------------------------------------++data ResultType+ -- | Means a party's points can decrease, e.g. if their solution fails+ -- during a system test.+ = ResultPreliminary+ -- | Means a party can only increase points for this problem by submitting+ -- better solutions.+ | ResultFinal+ deriving Show++instance FromJSON ResultType where+ parseJSON = withText "ResultType" $ \case+ "PRELIMINARY" -> pure ResultPreliminary+ "FINAL" -> pure ResultFinal+ _ -> fail "Invalid ResultType"++data ProblemResult = ProblemResult+ { prPoints :: Points+ -- | Penalty (in ICPC meaning) of the party for this problem.+ , prPenalty :: Maybe Int+ , prRejectedAttemptCount :: Int+ , prType :: ResultType+ -- | Number of seconds after the start of the contest before the submission,+ -- that brought maximal amount of points for this problem.+ , prBestSubmissionTime :: Maybe Int+ }+ deriving Show++-- | True if no solution has been submitted for this problem in the contest.+prNotAttempted :: ProblemResult -> Bool+prNotAttempted ProblemResult {..} =+ prPoints == 0 && prRejectedAttemptCount == 0++instance FromJSON ProblemResult where+ parseJSON = withObject "ProblemResult" $ \v ->+ ProblemResult+ <$> (v .: "points")+ <*> (v .:? "penalty")+ <*> (v .: "rejectedAttemptCount")+ <*> (v .: "type")+ <*> (v .:? "bestSubmissionTime")++data RanklistRow = RanklistRow+ { rrParty :: Party+ , rrRank :: Int+ , rrPoints :: Points+ , rrPenalty :: Int+ , rrSuccessfulHackCount :: Int+ , rrUnsuccessfulHackCount :: Int+ , rrProblemResults :: [ProblemResult]+ -- | Time from the start of the contest to the last submission that added+ -- some points to the total score of the party. For IOI contests only.+ , rrLastSubmissionTime :: Maybe DiffTime+ }+ deriving Show++instance FromJSON RanklistRow where+ parseJSON = withObject "RanklistRow" $ \v ->+ RanklistRow+ <$> (v .: "party")+ <*> (v .: "rank")+ <*> (v .: "points")+ <*> (v .: "penalty")+ <*> (v .: "successfulHackCount")+ <*> (v .: "unsuccessfulHackCount")+ <*> (v .: "problemResults")+ <*> (fmap secondsToDiffTime <$> v .:? "lastSubmissionTimeSeconds")++--------------------------------------------------------------------------------++-- | The standings returned by the API consists of 'Contest' details, the list+-- of 'Problem's and the requested portion of the standings list (a list of+-- 'RanklistRow's).+data Standings = Standings+ { standingsContest :: Contest+ , standingsProblems :: [Problem]+ , standingsRanklist :: [RanklistRow]+ }+ deriving Show++instance FromJSON Standings where+ parseJSON =+ withObject "Standings"+ $ \v ->+ Standings+ <$> (v .: "contest")+ <*> (v .: "problems")+ <*> (v .: "rows")++--------------------------------------------------------------------------------
+ src/Codeforces/Types/Submission.hs view
@@ -0,0 +1,137 @@+--------------------------------------------------------------------------------++module Codeforces.Types.Submission where++import Codeforces.Types.Common+import Codeforces.Types.Party ( Party )+import Codeforces.Types.Problem ( Problem )++import Data.Aeson+import Data.Text ( Text )+import qualified Data.Text as T+import Data.Time+import Data.Time.Clock.POSIX ( posixSecondsToUTCTime )++--------------------------------------------------------------------------------++data Verdict+ = Failed+ | Ok+ | Partial+ | CompilationError+ | RuntimeError+ | WrongAnswer+ | PresentationError+ | TimeLimitExceeded+ | MemoryLimitExceeded+ | IdlenessLimitExceeded+ | SecurityViolated+ | Crashed+ | InputPreparationCrashed+ | Challenged+ | Skipped+ | Testing+ | Rejected+ deriving (Show, Eq)++instance FromJSON Verdict where+ parseJSON = withText "Verdict" $ \case+ "FAILED" -> pure Failed+ "OK" -> pure Ok+ "PARTIAL" -> pure Partial+ "COMPILATION_ERROR" -> pure CompilationError+ "RUNTIME_ERROR" -> pure RuntimeError+ "WRONG_ANSWER" -> pure WrongAnswer+ "PRESENTATION_ERROR" -> pure PresentationError+ "TIME_LIMIT_EXCEEDED" -> pure TimeLimitExceeded+ "MEMORY_LIMIT_EXCEEDED" -> pure MemoryLimitExceeded+ "IDLENESS_LIMIT_EXCEEDED" -> pure IdlenessLimitExceeded+ "SECURITY_VIOLATED" -> pure SecurityViolated+ "CRASHED" -> pure Crashed+ "INPUT_PREPARATION_CRASHED" -> pure InputPreparationCrashed+ "CHALLENGED" -> pure Challenged+ "SKIPPED" -> pure Skipped+ "TESTING" -> pure Testing+ "REJECTED" -> pure Rejected+ _ -> fail "Invalid Verdict"++-- | 'verdictText' @verdict@ returns a user-friendly text representation of the+-- Verdict.+verdictText :: Verdict -> Text+verdictText Failed = "Failed"+verdictText Ok = "Ok"+verdictText Partial = "Partial"+verdictText CompilationError = "Compilation error"+verdictText RuntimeError = "Runtime error"+verdictText WrongAnswer = "Wrong answer"+verdictText PresentationError = "Presentation error"+verdictText TimeLimitExceeded = "Time limit exceeded"+verdictText MemoryLimitExceeded = "Memory limit exceeded"+verdictText IdlenessLimitExceeded = "Idleness limit exceeded"+verdictText SecurityViolated = "Security violated"+verdictText Crashed = "Crashed"+verdictText InputPreparationCrashed = "Input preparation crashed"+verdictText Challenged = "Challenged"+verdictText Skipped = "Skipped"+verdictText Testing = "Testing"+verdictText Rejected = "Rejected"++-- | Testset used for judging a submission.+data Testset+ = Samples+ | Pretests+ | Tests+ | Challenges+ deriving Show++instance FromJSON Testset where+ parseJSON = withText "Testset" $ \case+ "SAMPLES" -> pure Samples+ "PRETESTS" -> pure Pretests+ "TESTS" -> pure Tests+ "CHALLENGES" -> pure Challenges+ x -> if "TESTS" `T.isPrefixOf` x+ then pure Tests+ else fail $ "Invalid Testset: " ++ T.unpack x++data Submission = Submission+ { submissionId :: Int+ , submissionContestId :: Maybe ContestId+ -- | Time when the solution was submitted.+ , submissionTime :: UTCTime+ -- | The time passed after the start of the contest (or a virtual start+ -- for virtual parties), before the submission.+ , submissionRelativeTime :: DiffTime+ , submissionProblem :: Problem+ , submissionAuthor :: Party+ , submissionProgrammingLanguage :: Text+ , submissionVerdict :: Maybe Verdict+ , submissionTestset :: Testset+ , submissionPassedTestCount :: Int+ -- | Maximum time (in ms) consumed by the submission for one test.+ , submissionTimeConsumed :: Int+ -- | Maximum memory (in bytes) consumed by the submission for one test.+ , submissionMemoryConsumed :: Int+ -- | Number of scored points for IOI-like contests.+ , submissionPoints :: Maybe Points+ }+ deriving Show++instance FromJSON Submission where+ parseJSON = withObject "Submission" $ \v ->+ Submission+ <$> (v .: "id")+ <*> (v .:? "contestId")+ <*> (posixSecondsToUTCTime <$> v .: "creationTimeSeconds")+ <*> (secondsToDiffTime <$> v .: "relativeTimeSeconds")+ <*> (v .: "problem")+ <*> (v .: "author")+ <*> (v .: "programmingLanguage")+ <*> (v .: "verdict")+ <*> (v .: "testset")+ <*> (v .: "passedTestCount")+ <*> (v .: "timeConsumedMillis")+ <*> (v .: "memoryConsumedBytes")+ <*> (v .:? "points")++--------------------------------------------------------------------------------
+ src/Codeforces/Types/User.hs view
@@ -0,0 +1,39 @@+--------------------------------------------------------------------------------++module Codeforces.Types.User where++import Codeforces.Types.Common++import Data.Aeson+import Data.Maybe+import Data.Text ( Text )++--------------------------------------------------------------------------------++data User = User+ { userHandle :: Handle+ , userFirstName :: Maybe Text+ , userLastName :: Maybe Text+ , userRating :: Rating+ , userMaxRating :: Rating+ , userCity :: Maybe Text+ , userCountry :: Maybe Text+ , userOrganization :: Maybe Text+ , userFriendOfCount :: Int+ }+ deriving Show++instance FromJSON User where+ parseJSON = withObject "User" $ \v ->+ User+ <$> (v .: "handle")+ <*> (v .:? "firstName")+ <*> (v .:? "lastName")+ <*> (fromMaybe 0 <$> v .:? "rating")+ <*> (fromMaybe 0 <$> v .:? "maxRating")+ <*> (v .:? "city")+ <*> (v .:? "country")+ <*> (v .:? "organization")+ <*> (v .: "friendOfCount")++--------------------------------------------------------------------------------
+ src/Codeforces/Virtual.hs view
@@ -0,0 +1,83 @@+--------------------------------------------------------------------------------++module Codeforces.Virtual+ ( VirtualUser(..)+ , VirtualResult(..)+ , Delta+ , Seed+ , calculateResult+ ) where++import Codeforces.Types.Common+import Codeforces.Types.RatingChange+import Codeforces.Types.Standings+import Codeforces.Virtual.RatingCalculator+import Codeforces.Virtual.Types++import Control.Applicative++import qualified Data.Map as M++--------------------------------------------------------------------------------++-- | Computes the results the user would have had, had they participated in this+-- contest live with their current rating.+calculateResult+ :: VirtualUser -- ^ Details about the virtual participation.+ -> [RatingChange] -- ^ Rating changes for this contest+ -> [RanklistRow] -- ^ Standings for this contest.+ -> Maybe VirtualResult -- ^ Contest results for this user+calculateResult vu rcs rrs =+ VirtualResult+ <$> (contestantRank <$> findContestant virtualParty crContestants)+ <*> M.lookup virtualParty crDeltas+ <*> M.lookup (vuRating vu) crSeeds+ where ContestResults {..} = computeResults vu rcs rrs++-- | Computes the complete updated results for a contest after including the+-- virtual user.+computeResults+ :: VirtualUser -> [RatingChange] -> [RanklistRow] -> ContestResults+computeResults vu@VirtualUser {..} rcs rrs = calculateContestResults+ updatedRatings+ updatedRankings+ where+ updatedRatings = M.insert virtualHandle vuRating (previousRatings rcs)+ updatedRankings = virtualRankings vu rrs++-- | 'previousRatings' @ratingChanges@ returns a map of each user's handle to+-- their rating before the contest.+previousRatings :: [RatingChange] -> M.Map Handle Rating+previousRatings = M.fromList . map (liftA2 (,) rcHandle rcOldRating)++--------------------------------------------------------------------------------++-- | Builds an updated list of 'RanklistRow's for this contest by finding the+-- virtual user's rank and including them in the list.+virtualRankings :: VirtualUser -> [RanklistRow] -> [RanklistRow]+virtualRankings vu rrs = go rrs 1+ where+ go [] rank = [mkVirtualRow rank vu]+ go (x : xs) _ | shouldInsert vu x = mkVirtualRow (rrRank x) vu : x : xs+ | otherwise = x : go xs (rrRank x + 1)++ -- | Whether to insert the virtual user's row before the given row.+ shouldInsert VirtualUser {..} RanklistRow {..} =+ (vuPoints > rrPoints)+ || (vuPoints == rrPoints && vuPenalty <= rrPenalty)++-- | Constructs the virtual user's 'RanklistRow', using the virtual user's rank,+-- and their contest results.+mkVirtualRow :: Int -> VirtualUser -> RanklistRow+mkVirtualRow virtualRank VirtualUser {..} = RanklistRow+ { rrParty = virtualParty+ , rrRank = virtualRank+ , rrPoints = vuPoints+ , rrPenalty = vuPenalty+ , rrSuccessfulHackCount = 0+ , rrUnsuccessfulHackCount = 0+ , rrProblemResults = []+ , rrLastSubmissionTime = Nothing+ }++--------------------------------------------------------------------------------
+ src/Codeforces/Virtual/RatingCalculator.hs view
@@ -0,0 +1,310 @@+--------------------------------------------------------------------------------++-- | Implementation of the Open Codeforces Rating System described in+-- <https://codeforces.com/blog/entry/20762 Mike Mirzayanov's blog post>.+--+module Codeforces.Virtual.RatingCalculator+ ( calculateContestResults+ ) where++import Codeforces.Types.Common+import Codeforces.Types.Party hiding ( Contestant )+import Codeforces.Types.Standings+import Codeforces.Virtual.Types++import Control.Monad+import Control.Monad.Trans.State++import Data.Functor ( (<&>) )+import Data.List+import qualified Data.Map as M+import Data.Maybe+import Data.Ord++--------------------------------------------------------------------------------++-- | 'calculateContestResults' @previousRatings updatedRankings@ computes the+-- contest results.+calculateContestResults+ :: M.Map Handle Rating -> [RanklistRow] -> ContestResults+calculateContestResults hs rrs = ContestResults sortedCs deltas seeds+ where+ sortedCs = reassignRanks $ mkContestants hs rrs+ (deltas, seeds) = process sortedCs++-- | Constructs a list of contestants from the previous ratings and rankings.+mkContestants :: M.Map Handle Rating -> [RanklistRow] -> [Contestant]+mkContestants prevRatings = map+ (\RanklistRow {..} -> Contestant { contestantParty = rrParty+ , contestantRank = rrRank+ , contestantPoints = rrPoints+ , contestantRating = getPartyRating rrParty+ }+ )+ where+ getPartyRating = computePartyRating . map lookupRating . partyMembers+ lookupRating m = M.findWithDefault initRating (memberHandle m) prevRatings++--------------------------------------------------------------------------------++-- | Initial rating of a member, if they do not already have a rating.+initRating :: Rating+initRating = 0++-- | Calculates the overall rating for a party using the ratings of its team+-- members.+--+-- >>> computePartyRating [1400]+-- 1400+--+-- >>> computePartyRating [1400, 1500, 1600]+-- 1749+--+computePartyRating :: [Rating] -> Rating+computePartyRating ratings = go 20 100 4000+ where+ go :: Int -> Float -> Float -> Rating+ go 0 l r = round $ (l + r) / 2+ go i l r | computed > mid = go (i - 1) mid r+ | otherwise = go (i - 1) l mid+ where+ mid = (l + r) / 2+ rWinsProbability =+ product $ map (getEloWinProbability mid . fromIntegral) ratings+ computed = logBase 10 (1 / rWinsProbability - 1) * 400 + mid++--------------------------------------------------------------------------------++-- | Ratings mapped to seed (expected ranking)+type SeedCache = M.Map Rating Seed++-- | Computes each party's rating delta and each rating's seed, given a list of+-- contestants.+process :: [Contestant] -> (M.Map Party Delta, SeedCache)+process [] = (M.empty, M.empty)+process cs = flip runState (precomputeSeeds cs) $ do+ ds <- calculateDeltas cs+ pure . adjustTopDeltas cs . adjustAllDeltas $ ds++-- | Computes the seed of each contestant.+precomputeSeeds :: [Contestant] -> SeedCache+precomputeSeeds cs =+ M.fromList $ map (\c -> (contestantRating c, calculateSeedOf c cs)) cs++-- | Adjusts rating deltas to ensure the total sum of deltas is not more than+-- zero. If it is, the extra amount is distributed between all contestants.+adjustAllDeltas :: M.Map Party Delta -> M.Map Party Delta+adjustAllDeltas ds = M.map (+ inc) ds+ where inc = (negate (sum (M.elems ds)) `div` M.size ds) - 1++-- | Adjusts rating deltas to prevent ratings of top competitors becoming+-- inflated.+--+-- /Before/ the round, we choose a group of most highly rated competitors and+-- decide that their /total/ rating shouldn't change. The size of this group is+-- determined by the heuristic:+--+-- \[+-- s = \min(n, 4 \sqrt{n})+-- \]+--+-- The sum of deltas over this group is adjusted to make it 0:+--+-- \[+-- r_i = r_i - \frac{\sum^s d_i}{s}+-- \]+--+adjustTopDeltas :: [Contestant] -> M.Map Party Delta -> M.Map Party Delta+adjustTopDeltas cs ds = M.map (+ inc) ds+ where+ inc = min 0 $ max (-10) (negate sumTopDeltas `div` zeroSumCount)++ sumTopDeltas = sum $ mapMaybe (flip M.lookup ds . contestantParty)+ (take zeroSumCount $ sortByRatingDesc cs)++ zeroSumCount = min (M.size ds) topCount+ topCount = 4 * (round' . sqrt . fromIntegral . M.size) ds+ round' = round :: Double -> Int++-- | Computes the rating delta for each party in this contest.+--+-- The input list of contestants must be correctly ordered with 'reassignRanks'+-- prior to using this function.+--+calculateDeltas :: [Contestant] -> State SeedCache (M.Map Party Delta)+calculateDeltas cs = do+ deltas <- forM cs $ \c -> calculateDelta c cs <&> (contestantParty c, )+ pure $ M.fromList deltas++-- | Sorts and recomputes the rank of each contestant.+--+-- In this assignment, contestants with the same points have the same rank.+-- Repeated ranks are disregarded when assigning ranks to contestants that+-- score lower than them. For example:+--+-- @+-- | Party | Points | Rank |+-- | ----- | ------ | ---- |+-- | A | 2302.0 | 41 |+-- | B | 2302.0 | 41 |+-- | C | 2302.0 | 41 |+-- | D | 2256.0 | 44 | <- rank is not 42, but 44+-- | ... | ... | ... |+-- @+--+-- Reassigning ranks is required because the input list of contestants is not+-- guaranteed to have correct ranks or be in the correct order following the+-- inclusion of the virtual user. E.g. the input list may resemble:+--+-- @+-- | Party | Points | Rank |+-- | ----- | ------ | ---- |+-- | ... | ... | ... |+-- | A | 2302.0 | 41 |+-- | VU* | 2300.0 | 42 |+-- | B | 2266.0 | 42 | <- ranks from here on are incorrect+-- | C | 2256.0 | 43 |+-- | ... | ... | ... |+-- @+--+-- *VU = virtual user+--+reassignRanks :: [Contestant] -> [Contestant]+reassignRanks = go 1 1 . sortByPointsDesc+ where+ go _ _ [] = []+ go _ rank [c ] = [withRank rank c]+ go i rank (c1 : c2 : cs) = withRank rank c1 : go (i + 1) nextRank (c2 : cs)+ where+ nextRank | contestantPoints c2 < contestantPoints c1 = i + 1+ | otherwise = rank++ withRank r c = c { contestantRank = r }++-- | 'calculateDelta' @c cs@ computes the rating delta for contestant @c@ using+-- a seed computed from all other contestants @cs@.+--+-- The rating change for a participant is the between the rating they require+-- (according to their seed) and their current rating:+--+-- \[+-- d_i = \frac{R - r_i}{2}+-- \]+--+calculateDelta :: Contestant -> [Contestant] -> State SeedCache Delta+calculateDelta c cs = do+ mid <- midRank c cs+ needRating <- calculateNeedRating cs mid++ pure $ (needRating - contestantRating c) `div` 2++-- | The geometric mean of a contestant's seed (expected ranking) and actual+-- ranking.+--+-- This ranking is between the expected and actual ranking.+--+midRank :: Contestant -> [Contestant] -> State SeedCache Seed+midRank c cs = do+ seed <- getSeedOf c cs+ pure $ sqrt $ fromIntegral (contestantRank c) * seed++-- | Given a list of contestants and this contestant's 'midRank', calculates+-- the rating a contestant should have to achieve their expected ranking, using+-- binary search.+--+-- In other words, a rating:+--+-- \[+-- R : seed_i = m_i+-- \]+--+calculateNeedRating :: [Contestant] -> Float -> State SeedCache Rating+calculateNeedRating cs rank = go 1 8000+ where+ go l r+ | r - l <= 1 = pure l+ | otherwise = do+ let mid = (l + r) `div` 2+ seed <- getSeed mid cs++ if seed < rank then go l mid else go mid r++--------------------------------------------------------------------------------+-- Seed calculations and lookups++-- | Looks up the seed for a given rating from the cache. If not found, computes+-- it and updates the cache.+getSeed :: Rating -> [Contestant] -> State SeedCache Seed+getSeed rating cs = do+ cache <- get++ case M.lookup rating cache of+ Nothing -> do+ let seed = calculateSeed rating cs+ modify $ M.insert rating seed+ pure seed++ (Just seed) -> pure seed++-- | Like 'getSeed' but takes a contestant and list of /all/ contestants.+getSeedOf :: Contestant -> [Contestant] -> State SeedCache Seed+getSeedOf x ys = getSeed (contestantRating x) (filter (/= x) ys)++-- | Calculates the seed of a contestant with the given rating, using the+-- supplied list of all /other/ contestants.+--+-- \[+-- seed_i = \sum_{j=1, j \ne i}^{n} P_{j,i} + 1+-- \]+--+-- 1 is added to account for 1-based rankings.+--+-- The general idea is to increase the contestant's rating if their actual+-- ranking is better than their seed, and decrease if worse.+--+calculateSeed :: Rating -> [Contestant] -> Seed+calculateSeed rating others =+ 1 + sum [ getEloWinProbability' (contestantRating x) rating | x <- others ]++-- | Like 'calculateSeed' but takes a contestant and list of /all/ contestants.+calculateSeedOf :: Contestant -> [Contestant] -> Seed+calculateSeedOf x ys = calculateSeed (contestantRating x) (filter (/= x) ys)++-- | Computes the Elo win probability given two ratings.+--+-- This is the probability that the @x@th participant has a better result that+-- the @y@th participant, given by:+--+-- \[+-- P_{i,j} = \frac{1}{1 + 10^\frac{r_j - r_i}{400}}+-- \]+--+-- E.g. if the difference between ratings is 200 then the stronger participant+-- will win with probability ~0.75. If the difference is 400 then the stronger+-- participant will win with probability ~0.9.+--+-- __Note:__ reversing the order of rating arguments reverses the result.+--+-- >>> getEloWinProbability 1400 1200+-- 0.7597469+--+-- >>> getEloWinProbability 1200 1400+-- 0.24025308+--+getEloWinProbability :: Float -> Float -> Float+getEloWinProbability x y = 1 / (1 + 10 ** ((y - x) / 400))++-- | Like 'getEloWinProbability' but takes 'Int's instead of 'Float's.+getEloWinProbability' :: Rating -> Rating -> Float+getEloWinProbability' x = getEloWinProbability (fromIntegral x) . fromIntegral++--------------------------------------------------------------------------------+-- Utility functions++sortByPointsDesc :: [Contestant] -> [Contestant]+sortByPointsDesc = sortOn (Down . contestantPoints)++sortByRatingDesc :: [Contestant] -> [Contestant]+sortByRatingDesc = sortOn (Down . contestantRating)++--------------------------------------------------------------------------------
+ src/Codeforces/Virtual/Types.hs view
@@ -0,0 +1,79 @@+--------------------------------------------------------------------------------++module Codeforces.Virtual.Types where++import Codeforces.Types.Common+import Codeforces.Types.Party++import Data.List+import qualified Data.Map as M++--------------------------------------------------------------------------------++virtualHandle :: Handle+virtualHandle = Handle "VIRTUAL_USER"++-- | A 'Party' representing the user's virtual participation.+virtualParty :: Party+virtualParty = Party { partyContestId = Nothing+ , partyMembers = [Member virtualHandle]+ , partyParticipantType = Virtual+ , partyTeamId = Nothing+ , partyTeamName = Nothing+ , partyIsGhost = False+ , partyRoom = Nothing+ , partyStartTime = Nothing+ }++-- | Represents the virtual participation of the user in this contest.+data VirtualUser = VirtualUser+ { vuPoints :: Points -- ^ Points scored in the virtual contest.+ , vuPenalty :: Int -- ^ User's penalty in the virtual contest.+ , vuRating :: Rating -- ^ Current rating of the user.+ }+ deriving Show++--------------------------------------------------------------------------------++-- | Difference in rating between a user's current rating, and their rating+-- following this contest.+type Delta = Int++-- | The seed is the expected ranking for each participant before the contest+-- begins.+--+-- A contestant's rating increases should they perform better than their seed,+-- and decreases should they perform worse.+--+type Seed = Float++-- | The participation of a user in a contest.+data Contestant = Contestant+ { contestantParty :: Party+ , contestantRank :: Int+ , contestantPoints :: Points+ , contestantRating :: Rating+ }+ deriving (Eq, Show)++-- | Finds a single contestant from the given 'Party', or @Nothing@ if none+-- found.+findContestant :: Party -> [Contestant] -> Maybe Contestant+findContestant p = find ((p ==) . contestantParty)++data ContestResults = ContestResults+ { crContestants :: [Contestant]+ , crDeltas :: M.Map Party Delta+ , crSeeds :: M.Map Rating Seed+ }+ deriving Show++-- | A virtual participation result+data VirtualResult = VirtualResult+ { virtualRank :: Int+ , virtualDelta :: Delta+ , virtualSeed :: Seed+ }+ deriving Show++--------------------------------------------------------------------------------