{-# 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 :: Int) <- readLn [read -> (myX :: Int), read -> (myY :: Int), (/= 0) . read -> myBackInTimeLeft] <- words <$> getLine opponents <- replicateM opponentCount $ do [read -> (x :: Int), read -> (y :: Int), (/= 0) . read -> backInTimeLeft] <- words <$> getLine return ((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 return $ GameState { gsRound = gameRound , gsCell = (myX, myY) , gsJumpLeft = myBackInTimeLeft , gsOpponents = opponents , gsGrid = grid } (action, state) <- 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, state) -- 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 grid = gsGrid gs let invalid = maybe False (any (\p -> grid!p /= '0' && grid!p /= '.') . range) mgoal goal <- case mgoal of Just g | checkGoal (gsGrid gs) g, inRange g (gsCell gs) -> return g _ -> planNewGoal gs history (evaluateListWithTimeout 80000) if gsJumpLeft gs && gsRound gs > 100 && invalid then pure (Left 17, goal) else let gp@(gx,gy) = nextGoalPoint gs goal in if gp == gsCell gs then (,goal) . Right <$> (chooseIO $ filter (inRange (bounds (gsGrid gs))) [(gx-1,gy),(gx+1,gy),(gx,gy-1),(gx,gy+1)]) else pure (Right gp, goal) chooseIO :: [a] -> IO a chooseIO xs = (xs!!) <$> randomRIO (0, length xs - 1) checkGoal :: Grid -> Goal -> Bool checkGoal grid goal = not (any (\p -> grid!p /= '0' && grid!p /= '.') $ range goal) && any (\p -> grid!p == '.') (border goal) 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 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 dup x = (x,x) grid = accum claim (gsGrid gs) ((gsCell gs, '0') : projections) projections = concat (mapMaybe (\r -> map ((,'X') . fst) . gsOpponents . fst <$> flip M.lookup history r) [gsRound gs+1..gsRound gs+10]) claim '.' c1 = c1 claim c0 _ = c0 scoreGoal g@((x0,y0),(x1,y1)) = 5 * (count (\p -> grid!p == '.') $ range g) - 5 * (count (\p -> grid!p == '.') $ border g) - 2 * (fromMaybe 1000 $ dist (gsCell gs) <$> nearestFree grid (gsCell gs) (range g)) + 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 ] expand goal@((x0,y0),(x1,y1)) | width + height >= 24 = goal | width <= 2*height, x0 > 0, any free left, all (not . other) left' = expand ((x0-1,y0),(x1,y1)) | height <= 2*width, y0 > 0, any free top, all (not . other) top' = expand ((x0,y0-1),(x1,y1)) | width <= 2*height, x1 < 34, any free right, all (not . other) right' = expand ((x0,y0),(x1+1,y1)) | height <= 2*width, y1 < 19, any free bottom, all (not . other) bottom' = expand ((x0,y0),(x1,y1+1)) | x0 > 0, any free left, all (not . other) left' = expand ((x0-1,y0),(x1,y1)) | y0 > 0, any free top, all (not . other) top' = expand ((x0,y0-1),(x1,y1)) | x1 < 34, any free right, all (not . other) right' = expand ((x0,y0),(x1+1,y1)) | y1 < 19, any free bottom, all (not . other) 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' 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 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) where 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 [] -> return [] (a:as) -> return $! a `seq` (a:as) case r of Nothing -> return [] Just [] -> return [] Just (a:as) -> (a:) <$> loop as