{-# LANGUAGE ScopedTypeVariables, LambdaCase, ViewPatterns, TupleSections #-} {-# LANGUAGE BangPatterns, FlexibleContexts #-} import Control.Applicative import Control.Arrow import Control.Parallel import Control.Monad import Control.Monad.Trans import Data.Array.Unboxed import Data.Function import Data.List import Data.Maybe import Data.Monoid import Data.IORef import Data.STRef import Debug.Trace import System.CPUTime import System.IO import System.IO.Unsafe import System.Random import System.Timeout import qualified Data.Array.ST as STA import qualified Data.Foldable as F import qualified Data.Map as M import qualified Data.Traversable as T 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 goal <- case mgoal of Just g | checkGoal (gsGrid gs) g, inRange g (gsCell gs) -> return g _ -> planNewGoal gs history if gsJumpLeft gs && isJust mgoal && Just goal /= mgoal && gsRound gs > 100 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 :: GameState -> M.Map Int (GameState, Goal) -> IO Goal planNewGoal gs history = do let 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 timed <- evaluateListWithTimeout 80000 scored traceM . show $ length timed pure $ fromMaybe (dup $ gsCell gs) $ fmap fst $ safeMaximumBy (compare `on` snd) timed where dup x = (x,x) grid = gsGrid gs // ((gsCell gs, '0') : concat (mapMaybe (\r -> map ((,'X') . fst) . gsOpponents . fst <$> flip M.lookup history r) [gsRound gs+1..gsRound gs+10])) 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, checkFree (map (x0,) [y0..y1]), check (map (x0-1,) [y0..y1]) = expand ((x0-1,y0),(x1,y1)) | height <= 2*width, y0 > 0, checkFree (map (,y0) [x0..x1]), check (map (,y0-1) [x0..x1]) = expand ((x0,y0-1),(x1,y1)) | width <= 2*height, x1 < 34, checkFree (map (x1,) [y0..y1]), check (map (x1+1,) [y0..y1]) = expand ((x0,y0),(x1+1,y1)) | height <= 2*width, y1 < 19, checkFree (map (,y1) [x0..x1]), check (map (,y1+1) [x0..x1]) = expand ((x0,y0),(x1,y1+1)) | x0 > 0, checkFree (map (x0,) [y0..y1]), check (map (x0-1,) [y0..y1]) = expand ((x0-1,y0),(x1,y1)) | y0 > 0, checkFree (map (,y0) [x0..x1]), check (map (,y0-1) [x0..x1]) = expand ((x0,y0-1),(x1,y1)) | x1 < 34, checkFree (map (x1,) [y0..y1]), check (map (x1+1,) [y0..y1]) = expand ((x0,y0),(x1+1,y1)) | y1 < 19, checkFree (map (,y1) [x0..x1]), check (map (,y1+1) [x0..x1]) = expand ((x0,y0),(x1,y1+1)) | otherwise = goal where width = x1 - x0 height = y1 - y0 check pts = not (any (\p -> grid!p /= '0' && grid!p /= '.') pts) checkFree pts = any (\p -> grid!p == '.') pts 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 whileM_ :: Monad m => m Bool -> m a -> m () whileM_ mc m = mc >>= \c -> when c (m >> whileM_ mc m) doWhileM_ :: Monad m => m Bool -> m () doWhileM_ mc = mc >>= \c -> when c (doWhileM_ mc) 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 foldMapA :: (Applicative f, F.Foldable t, Monoid v) => (a -> f v) -> t a -> f v foldMapA f t = F.foldr (\x v -> mappend <$> v <*> f x) (pure mempty) t filterA :: Applicative f => (a -> f Bool) -> [a] -> f [a] filterA f [] = pure [] filterA f (x:xs) = (\c xs' -> if c then x:xs' else xs') <$> f x <*> filterA f xs 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