{-# LANGUAGE ScopedTypeVariables, LambdaCase, ViewPatterns, TupleSections #-} {-# LANGUAGE BangPatterns, FlexibleContexts, RankNTypes #-} import Control.Applicative import Control.Arrow import Control.Monad import Data.Array.Unboxed import Data.Function import Data.List import Data.Maybe import Data.Monoid import Data.IORef import Debug.Trace import System.CPUTime import System.IO import System.Random import System.Timeout import qualified Data.Map as M type Point = (Int, Int) type Grid = UArray Point Char data GameState = GameState { gsRound :: Int , gsCell :: Point , gsJumpLeft :: Bool , gsOpponents :: [(Point, Bool)] , gsGrid :: Grid } main :: IO () main = do hSetBuffering stdout NoBuffering -- DO NOT REMOVE opponentCount <- readLn history <- newIORef M.empty forever $ do gstate <- do gameRound <- readLn [read -> myX, read -> myY, (/= 0) . read -> myBackInTimeLeft] <- words <$> getLine opponents <- replicateM opponentCount $ do [read -> x, read -> y, (/= 0) . read -> backInTimeLeft] <- words <$> getLine pure ((x, y), backInTimeLeft) -- '.' for empty, '0' for me, otherwise ID of opponent grid <- fmap (array ((0,0),(34,19)) . concat) $ forM [0..19] $ \y -> zipWith (\x c -> ((x,y),c)) [0..] <$> getLine pure $ GameState { gsRound = gameRound , gsCell = (myX, myY) , gsJumpLeft = myBackInTimeLeft , gsOpponents = opponents , gsGrid = grid } (action, gstate') <- findTarget gstate =<< readIORef history -- action: "x y" to move or "BACK rounds" to go back in time putStrLn $ case action of Left n -> "BACK " ++ show n Right (tx, ty) -> unwords $ map show [tx, ty] modifyIORef history $ M.insert (gsRound gstate) (gstate, gstate') -- The upper-left and lower-right corners of a rectangle type Goal = (Point,Point) findTarget :: GameState -> M.Map Int (GameState, Goal) -> IO (Either Int (Int, Int), Goal) findTarget gs history = do let mgoal = snd <$> M.lookup (gsRound gs - 1) history let free p = (gsGrid gs)!p == '.' let other p = (gsGrid gs)!p /= '0' && (gsGrid gs)!p /= '.' goal <- case mgoal of Just g | inRange g (gsCell gs), any free (range g), all (not.other) (range g) -> pure g _ -> planNewGoal gs history (evaluateListWithTimeout 80000) traceM (show mgoal) traceM $ show $ fmap (take 1 . filter other . range) mgoal if gsJumpLeft gs && gsRound gs > 125 && maybe False (any other . range) mgoal then pure (Left 17, goal) else let gp@(gx,gy) = nextGoalPoint gs goal in if gp /= gsCell gs then pure (Right $ head $ bestRoute (gsGrid gs) (gsCell gs) gp, goal) else (,goal) . Right <$> (chooseIO . filter (inRange (bounds (gsGrid gs))) $ [(gx-1,gy),(gx+1,gy),(gx,gy-1),(gx,gy+1)]) chooseIO :: [a] -> IO a chooseIO xs = (xs!!) <$> randomRIO (0, length xs - 1) planNewGoal :: Functor f => GameState -> M.Map Int (GameState, Goal) -> (forall a. [a] -> f [a]) -> f Goal planNewGoal gs history idiom = fromMaybe (dup $ gsCell gs) . fmap fst . safeMaximumBy (compare `on` snd) <$> idiom scored where dup x = (x,x) pts = indices grid : zipWith (\\) pts (map range goals) goals = takeWhileJust $ map (fmap (expand . dup) . nearestFree grid (gsCell gs)) pts scored = map (\g -> (g,) $! scoreGoal g) goals grid = accum claim (gsGrid gs) ((gsCell gs, '0') : projections) claim '.' c1 = c1 claim c0 _ = c0 projections = concat $ mapMaybe (\r -> map ((,'X') . fst) . filter (\((x,_),_) -> x >= 0) . gsOpponents . fst <$> flip M.lookup history r) [gsRound gs+1..gsRound gs+10] scoreGoal g@((x0,y0),(x1,y1)) = 25 * (count (\p -> grid!p == '.') $ range g) - 20 * (count (\p -> grid!p == '.') $ border g) - 15 * (fromMaybe 500 $ dist (gsCell gs) <$> nearestFree grid (gsCell gs) (range g)) + 10 * minimum [ (if ox < x0 then x0-ox else if ox > x1 then ox-x1 else 0) + (if oy < y0 then y0-oy else if oy > y1 then oy-y1 else 0) | ((ox,oy),_) <- gsOpponents gs ] limit = case length (gsOpponents gs) of { 1 -> 30; 2 -> 24; 3 -> 18; } expand goal@((x0,y0),(x1,y1)) | width + height >= limit = goal | 2*width < 3*height, x0 > 0, check left left' = expand ((x0-1,y0),(x1,y1)) | 2*height < 3*width, y0 > 0, check top top' = expand ((x0,y0-1),(x1,y1)) | 2*width < 3*height, x1 < 34, check right right' = expand ((x0,y0),(x1+1,y1)) | 2*height < 3*width, y1 < 19, check bottom bottom' = expand ((x0,y0),(x1,y1+1)) | x0 > 0, check left left' = expand ((x0-1,y0),(x1,y1)) | y0 > 0, check top top' = expand ((x0,y0-1),(x1,y1)) | x1 < 34, check right right' = expand ((x0,y0),(x1+1,y1)) | y1 < 19, check bottom bottom' = expand ((x0,y0),(x1,y1+1)) | otherwise = goal where width = x1 - x0 height = y1 - y0 top = map (,y0) [x0..x1] bottom = map (,y1) [x0..x1] left = map (x0,) [y0..y1] right = map (x1,) [y0..y1] top' = map (,y0-1) [x0..x1] bottom' = map (,y1+1) [x0..x1] left' = map (x0-1,) [y0..y1] right' = map (x1+1,) [y0..y1] free p = grid!p == '.' other p = not (free p) && grid!p /= '0' check s s' = any free s && all (not . other) s' nextGoalPoint :: GameState -> Goal -> Point nextGoalPoint gs goal = fromMaybe (gsCell gs) $ nearestFree (gsGrid gs) (gsCell gs) (border goal) <|> nearestFree (gsGrid gs) (gsCell gs) (indices (gsGrid gs)) nearestFree :: Grid -> Point -> [Point] -> Maybe Point nearestFree grid pt0 pts = fmap fst . safeMinimumBy (compare `on` snd) . map (\pt -> (pt, dist pt0 pt)) $ filter (\pt -> grid!pt == '.') pts bestRoute :: Grid -> Point -> Point -> [Point] bestRoute grid (x0,y0) (x1,y1) = if count free rt1 < count free rt2 then rt2 else rt1 where free p = grid!p == '.' rt1 = map (,y0) (x0 `to` x1) ++ map (x1,) (y0 `to` y1) rt2 = map (x0,) (y0 `to` y1) ++ map (,y1) (x0 `to` x1) dist :: Point -> Point -> Int dist (x0,y0) (x1,y1) = abs (x1-x0) + abs (y1-y0) border :: Goal -> [Point] border ((x0,y0),(x1,y1)) = map (,y0) (x0 `to` x1) ++ map (x1,) (y0 `to` y1) ++ map (,y1) (x1 `to` x0) ++ map (x0,) (y1 `to` y0) to :: Int -> Int -> [Int] n `to` m = if m >= n then [n+1..m] else [n-1,n-2..m] safeMaximumBy :: (a -> a -> Ordering) -> [a] -> Maybe a safeMaximumBy _ [] = Nothing safeMaximumBy f xs = Just $ maximumBy f xs safeMinimumBy :: (a -> a -> Ordering) -> [a] -> Maybe a safeMinimumBy _ [] = Nothing safeMinimumBy f xs = Just $ minimumBy f xs count :: (a -> Bool) -> [a] -> Int count f xs = go xs 0 where go [] !n = n go (x:xs) !n = go xs $ if f x then n+1 else n takeWhileJust :: [Maybe a] -> [a] takeWhileJust [] = [] takeWhileJust (Nothing:_) = [] takeWhileJust (Just x:xs) = x : takeWhileJust xs -- Compute elements of the list to WHNF for `t` microseconds. After -- `t` microseconds, abandon the calculation and terminate the list. evaluateListWithTimeout :: Integer -> [a] -> IO [a] evaluateListWithTimeout t xs = do end <- (+) <$> getCPUTime <*> pure (1000000 * t) flip fix xs $ \loop xs -> do now <- getCPUTime r <- timeout (fromIntegral $ max 0 (end - now) `div` 1000000) $ case xs of [] -> pure [] (a:as) -> pure $! a `seq` (a:as) case r of Nothing -> pure [] Just [] -> pure [] Just (a:as) -> (a:) <$> loop as