Code Runner

Main.hs

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.MWC

submit :: String -> IO Int
submit s = do
  let url = "https://game.coderunner.jp/q?str="++s++"&&token=CDSHM7XFVOMH144XS9GAYJ3IKH9JCSDF"

  resp <- simpleHttp url

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

  putStrLn $ show sc ++ " " ++ s
  hFlush stdout
  threadDelay (floor $ 1.01*10^6)

  return sc

isGood :: String -> Bool
isGood s =
  let x = map (take 8) $ tails s
      y = nub x
  in length x == length y

numSubstr :: String -> Int
numSubstr s =
  let ss = tails s
      ws = nub $ concat [ map (take len) ss | len <- [1..8] ]

  in length ws

solve :: IO ()
solve = do
  dat <- map words . lines <$> getContents
  let rank = reverse $ sort $ [ (read sc :: Int, wd) | [sc, wd] <- dat ]

      qq = "AA" ++ (concat $ map snd $ take 6 rank)

  submit qq

  return ()

dat :: [(Int, String)]
dat =
  [ (322, "DACAAAAC")
  , (293, "DACACAAA")
  , (279, "DBADADDB")
  , (261, "BADDAAAB")
  , (265, "CBCAABCD")
  , (253, "DDBBBDCC")
  , (254, "BCDBAAB")
  , (241, "CAAADCA")
  , (189, "CBDDBAA")
  , (183, "CDCDBCB")
  ]

calcMin :: [String] -> String
calcMin ss = minimumBy (compare `on` length)
  [ foldl' conc "" ps
  | ps <- permutations ss
  ]

conc :: String -> String -> String
conc s t =
  let plen = length $ takeWhile id $ zipWith (==) (reverse s) t
  in s ++ drop plen t

upd ix c s = take ix s ++ [c] ++ drop (ix+1) s

rep gen s = do
  ix1 <- uniformR (0, 49) gen
  ix2 <- uniformR (0, 48) gen
  c  <- ("ABCD" !!) <$> uniformR (0, 3) gen
  -- c  <- uniformR ('A', 'D') gen
  let ss = take ix1 s ++ drop (ix1+1) s
  return $ take ix2 ss ++ [c] ++ drop (ix2) ss


yama :: String -> Double -> IO ()
yama ini iniTemp = do
  gen <- createSystemRandom

  is <- submit ini

  let go s sc temp = do
        t <- uniformR (0, 3 :: Int) gen

        s' <- case t of
                   0 -> do
                     print 0
                     rep gen s

                   2 -> do
                     -- print 2
                     -- rep gen =<< rep gen s
                     n <- uniformR (1, 1) gen
                     print (1, n)
                     upds <- replicateM n $ do
                       ix <- uniformR (0, 49) gen
                       c  <- ("ABCD" !!) <$> uniformR (0, 3) gen
                       return (ix, c)
                     return $ foldl' (\s (ix, c) -> upd ix c s) s upds -- upd ix c s

                   1 -> do
                     n <- uniformR (2, 2) gen
                     print (1, n)
                     upds <- replicateM n $ do
                       ix <- uniformR (0, 49) gen
                       c  <- ("ABCD" !!) <$> uniformR (0, 3) gen
                       return (ix, c)
                     return $ foldl' (\s (ix, c) -> upd ix c s) s upds -- upd ix c s

                   3 -> do
                     n <- uniformR (3, 3) gen
                     print (3, n)
                     upds <- replicateM n $ do
                       ix <- uniformR (0, 49) gen
                       c  <- ("ABCD" !!) <$> uniformR (0, 3) gen
                       return (ix, c)
                     return $ foldl' (\s (ix, c) -> upd ix c s) s upds -- upd ix c s

        if s == s'
          then
          go s sc temp
          else do
          print temp

          sc' <- submit s'

          rand <- uniformR (0, 1.0 :: Double) gen

          if (rand < exp ((fromIntegral sc' - fromIntegral sc) / temp))
            then do
            print ("***", s', sc')
            go s' sc' (temp*0.99)
            else
            go s sc (temp*0.99)

  go ini is iniTemp

main :: IO ()
main = do
  -- ini <- replicateM 50 (randomRIO ('A', 'D'))
  let ini = "DACCBBBACABDDBBCDCDCCAAACBADBDDDBCCADABDCBCDBAABCB"
  yama ini 100

  print $ calcMin $ take 8 (map snd dat)

  -- solve
{-
  forever $ do
    s <- replicateM 15 (randomRIO ('A', 'D'))

    score <- submit s
    when (score > 350) $ do
      let qs = nub $
               (map (take 8) $ filter ((6 <) . length) $ inits s ++ tails s) ++
               (map (take 7) $ filter ((6 <) . length) $ inits s ++ tails s)
      print qs
      mapM_ submit qs
    return ()
-}