https://obt.tenka1.klab.jp/

Main.hs

{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE NamedFieldPuns #-}

module Main where

import Network.Wreq
import Control.Lens
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Lazy.Char8 as BSLC
import Control.Monad
import Control.Concurrent
import Data.Traversable

import Debug.Trace

token :: String
token = "a2cf428431b4bb82e3e66e55fa6c2a9b497b1194ae014d7543f38a6a0b4008d0"

main :: IO ()
main = do
  ApiGame { gameId = Just gid } <- apiGame
  gameLoop gid

gameLoop :: GameId -> IO ()
gameLoop gid = do
  stage <- apiStage gid
  stageLoop gid stage

stageLoop :: GameId -> ApiStage -> IO ()
stageLoop gid stage@ApiStage { sources, terminations } = do
  let
    vPairs = do
      s <- sources
      t <- terminations
      guard $ distance s t <= 2
      trace (show (s, t)) $ pure (s, t)
    edges = concat $ uncurry edgeBetween <$> vPairs
  for edges $ \edge -> do
    r <- apiClaim gid edge
    traceIO (show r)
    threadDelay $ 500 * 1000
    ApiGame { gameId = Just gid' } <- apiGame
    when (gid /= gid') $ gameLoop gid'
  ApiGame { gameId = Just gid' } <- apiGame
  if gid == gid'
    then stageLoop gid stage
    else gameLoop gid'

distance :: VertexId -> VertexId -> Word
distance (VertexId v0) (VertexId v1) =
  let
    (v0q, v0r) = v0 `divMod` 20
    (v1q, v1r) = v1 `divMod` 20
  in
    (if v0q < v1q then v1q - v0q else v0q - v1q) + (if v0r < v1r then v1r - v0r else v0r - v1r)

edgeBetween :: VertexId -> VertexId -> [EdgeId]
edgeBetween (VertexId v0) (VertexId v1) =
  let
    (v0y, v0x) = v0 `divMod` 20
    (v1y, v1x) = v1 `divMod` 20
    edgesH =
      let
        (vsx, vsy, len) =
          if v0x < v1x
            then (v0x, v0y, v1x - v0x)
            else (v1x, v1y, v0x - v1x)
      in
        (\n -> EdgeId (39 * vsy + vsx + n)) <$> [0 .. len - 1]
    edgesV =
      let
        (vsx, vsy, len) =
          if v0y < v1y
            then (v0x, v0y, v1y - v0y)
            else (v1x, v1y, v0y - v1y)
      in
        (\n -> EdgeId (39 * (vsy + 1 + n) + vsx - 20)) <$> [0 .. len - 1]
  in
    edgesH ++ edgesV

-- API

newtype GameId = GameId Word deriving stock (Show, Eq, Ord) deriving newtype Read
newtype MilliSecs = MilliSecs Word deriving stock (Show, Eq, Ord) deriving newtype Read

data ApiGame = ApiGame { gameId :: Maybe GameId, restTime :: MilliSecs } deriving Show

apiGame :: IO ApiGame
apiGame = do
  r <- get "https://obt.tenka1.klab.jp/api/game"
  let body = r ^. responseBody
  case BSLC.lines body of
    [gidStr, restStr]
      | gidStr == "-1" ->
          pure $ ApiGame Nothing (read $ BSLC.unpack restStr)
      | otherwise ->
          pure $ ApiGame (Just $ read $ BSLC.unpack gidStr) (read $ BSLC.unpack restStr)
    _ -> error $ "apiGame: " ++ show body

newtype VertexId = VertexId Word deriving stock (Show, Eq, Ord) deriving newtype Read
newtype EdgeId = EdgeId Word deriving stock (Show, Eq, Ord) deriving newtype Read

data ApiStage = ApiStage { sources :: [VertexId], terminations :: [VertexId], capacities :: [EdgeId] } deriving Show

apiStage :: GameId -> IO ApiStage
apiStage (GameId i) = do
  r <- get $ "https://obt.tenka1.klab.jp/api/stage/" ++ show i
  let body = r ^. responseBody
  let err = error $ "apiStage: " ++ show body
  case BSLC.lines body of
    [nm, ss, ts, cs, _] ->
      case (BSLC.words nm, BSLC.words ss, BSLC.words ts, BSLC.words cs) of
        ([n, m], ss, ts, cs) ->
          pure
            ApiStage
              { sources = read . BSLC.unpack <$> ss
              , terminations = read . BSLC.unpack <$> ts
              , capacities = read . BSLC.unpack <$> cs
              }
        _ -> err
    _ -> err

data ApiClaim = ClaimOk | AlreadyClaimed | ClaimTimeLimit | InvalidEdgeIndex | GameFinished deriving stock (Show, Eq)

apiClaim :: GameId -> EdgeId -> IO ApiClaim
apiClaim (GameId gid) (EdgeId eid) = do
  traceIO $ "apiClaim: " ++ show (GameId gid) ++ " " ++ show (EdgeId eid)
  r <- get $ "https://obt.tenka1.klab.jp/api/claim/a2cf428431b4bb82e3e66e55fa6c2a9b497b1194ae014d7543f38a6a0b4008d0/" ++ show gid ++ "/" ++ show eid
  let body = r ^. responseBody
  case BSLC.lines body of
    ["ok"] -> pure ClaimOk
    ["already_claimed"] -> pure AlreadyClaimed
    ["claim_time_limit"] -> pure ClaimTimeLimit
    ["invalid edge_index"] -> pure InvalidEdgeIndex
    ["game_finished"] -> pure GameFinished
    _ -> error $ "apiClaim: " ++ show body

data ApiEdges = EdgesOk { owners :: [Word], mines :: [Bool] } | TooManyRequest deriving (Show, Eq)

apiEdges :: GameId -> IO ApiEdges
apiEdges (GameId gid) = do
  r <- get $ "https://obt.tenka1.klab.jp/api/edges/a2cf428431b4bb82e3e66e55fa6c2a9b497b1194ae014d7543f38a6a0b4008d0/" ++ show gid
  let body = r ^. responseBody
  case BSLC.lines body of
    ["ok", os, ms] ->
      pure
        EdgesOk
          { owners = read . BSLC.unpack <$> BSLC.words os
          , mines = (== "1") <$> BSLC.words ms
          }
    ["too_many_request"] -> pure TooManyRequest
    _ -> error $ "apiEdges: " ++ show body

tenka1-game-battle-contest-beta.cabal

cabal-version:       >=1.10
-- Initial package description 'tenka1-game-battle-contest-beta.cabal'
-- generated by 'cabal init'.  For further documentation, see
-- http://haskell.org/cabal/users-guide/

name:                tenka1-game-battle-contest-beta
version:             0.1.0.0
-- synopsis:
-- description:
-- bug-reports:
-- license:
-- license-file:        LICENSE
author:              Kazuki Okamoto
maintainer:          [email protected]
-- copyright:
-- category:
build-type:          Simple
-- extra-source-files:  CHANGELOG.md

executable app
  main-is:             Main.hs
  -- other-modules:
  -- other-extensions:
  build-depends:       base >=4.13 && <4.14
                     , wreq
                     , lens
                     , bytestring
  -- hs-source-dirs:
  default-language:    Haskell2010