CODE RUNNER 予選B

Main.hs

{-# LANGUAGE ViewPatterns #-}

import Control.Monad
import System.Process
import Control.Concurrent
import Network.HTTP.Conduit
import qualified Data.ByteString.Lazy.Char8 as L
import Data.List
import System.IO
import Control.Applicative
import Data.Function
import System.Random
import Data.Array
import System.Timeout
import Data.Maybe

to :: IO a -> IO a
to f = do
  Just ret <- timeout (10^6) f
  return ret

submit :: Int -> IO Int
submit s = to $ do
  let url = "https://game.coderunner.jp/attack?skill="++show s++"&token=CDSHM7XFVOMH144XS9GAYJ3IKH9JCSDF"

  resp <- simpleHttp url

  let Just (sc, _) = L.readInt resp

  putStrLn $ show sc ++ " " ++ show s
  hFlush stdout

  appendFile "log" $ show sc ++ " " ++ show s ++ "\n"

  threadDelay (floor $ 1.01*10^6)

  return sc

type Info = [(Int, Int)]

parse :: [String] -> IO Info
parse
  ("you":
   ((read :: String -> Int) -> uid):
   uname:
   _token:
   _speech:
   roomId:
   ((read :: String -> Int) -> score):
   "members": rest
    ) = do
    let (mems, "history": hist) = span (/=  "history") rest
    print ("score", score, "room", roomId)
    return ([ (read wid, read dmg) | ls <- hist, not $ null ls, let  [_, wid, dmg] = words ls ])

parse e = error $ show e

info :: IO Info
info = to $ do
  let url = "https://game.coderunner.jp/info?style=text&token=CDSHM7XFVOMH144XS9GAYJ3IKH9JCSDF"

  resp <- simpleHttp url

  let s = L.unpack resp

  ret <- parse $ map (unwords . words) $ lines s

  let nears = filter (\(w, s) -> s >= 100) $ nub ret

  when (length nears >= 2) $ do
    appendFile "near" $ show nears ++ "\n"

  return ret

stayScore = 2000

nextCand db inf = do
  let cs = cands db inf

  let ccs = reverse $ sortBy (compare `on` snd) cs

      go [] = do
        ns <- randomRIO (0, 99)
        return ns
      go ((x, _):xs)
        | lookup x inf == Nothing = return x
        | otherwise = go xs

  print ccs

  go ccs

  {-
  if (lookup ns inf == Nothing)
     then return ns
     else nextCand inf
-}

foo db = do
  let go cur inf = do

        let (bestDmg, bestSkill) = head $ sort $ [(0, 0)] ++ map (\(x, y) -> (-y, x)) inf

        print ("dmg", -bestDmg, "skill", bestSkill)
        if (bestDmg <= -stayScore)
          then do
            dmg <- submit bestSkill
            if dmg < stayScore
              then do
              inf <- info
              ns <- nextCand db inf
              go ns inf
              else do
              inf <- info
              go bestSkill inf

          else do
            dmg <- submit cur
            if dmg >= stayScore
              then do
              inf <- info
              go cur inf
              else do
              inf <- info
              s <- nextCand db inf
              go s inf

  go 0 =<< info

type DB = Array (Int, Int) Double

nf :: Int -> Int -> Double
nf x y = abs (log (fromIntegral x) - log (fromIntegral y))

readDB :: IO DB
readDB = do
  con <- readFile "near2"
  let ls = map (read :: String -> Info) $ map head $ group $ lines con

      t = concat [ [ ((fst x, fst y), nf (snd x) (snd y))
                   , ((fst y, fst x), nf (snd x) (snd y))
                   ]
                 | ns <- ls
                 , (x:xs) <- tails ns
                 , y <- xs
                 ]

      db = accumArray (+) 0 ((0, 0), (99, 99)) $ [ ((i, i), 20) | i <- [0..99]] ++ nubS t

  -- print db

  return db

nubS = map head . group . sort

logs d
  | abs d < 5 = 0
  | d > 0 = abs d
  | otherwise = - abs d

cands :: DB -> Info -> [(Int, Double)]
cands db inf = do
  [ (w, sum [ (db!(w, ww)) * (logs $ fromIntegral ss - 200) | (ww, ss) <- nub inf ]) | w <- [0..99] ]

main :: IO ()
main = do
  db <- readDB

  -- print db

  putStrLn "db loaded"

  foo db
  -- return ()