178 lines
7.1 KiB
Haskell
178 lines
7.1 KiB
Haskell
{-# 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 = traceM (show goal) *> pure (Right $ nextGoalPoint gs goal, goal)
|
|
where
|
|
goal = case snd <$> M.lookup (gsRound gs - 1) history of
|
|
Just g | checkGoal (gsGrid gs) g -> g
|
|
_ -> planNewGoal gs
|
|
|
|
checkGoal :: Grid -> Goal -> Bool
|
|
checkGoal grid goal = traceShowId $
|
|
not (any (\p -> grid!p /= '0' && grid!p /= '.') $ range goal) &&
|
|
any (\p -> grid!p == '.') (border goal)
|
|
|
|
planNewGoal :: GameState -> Goal
|
|
planNewGoal gs = expand (pt0,pt0) (indices grid)
|
|
where
|
|
grid = gsGrid gs
|
|
pt0 = fromMaybe (gsCell gs) $ nearestFree grid (gsCell gs) (indices grid)
|
|
expand goal@((x0,y0),(x1,y1)) pts'
|
|
| width + height < maxPerim, width <= 2*height, x0 > 0, checkFree (map (x0,) [y0..y1]), check (map (x0-1,) [y0..y1]) = expand ((x0-1,y0),(x1,y1)) pts'
|
|
| width + height < maxPerim, width <= 2*height, x1 < 34, checkFree (map (x1,) [y0..y1]), check (map (x1+1,) [y0..y1]) = expand ((x0,y0),(x1+1,y1)) pts'
|
|
| width + height < maxPerim, height <= 2*width, y0 > 0, checkFree (map (,y0) [x0..x1]), check (map (,y0-1) [x0..x1]) = expand ((x0,y0-1),(x1,y1)) pts'
|
|
| width + height < maxPerim, height <= 2*width, y1 < 19, checkFree (map (,y1) [x0..x1]), check (map (,y1+1) [x0..x1]) = expand ((x0,y0),(x1,y1+1)) pts'
|
|
| width + height < maxPerim, x0 > 0, checkFree (map (x0,) [y0..y1]), check (map (x0-1,) [y0..y1]) = expand ((x0-1,y0),(x1,y1)) pts'
|
|
| width + height < maxPerim, x1 < 34, checkFree (map (x1,) [y0..y1]), check (map (x1+1,) [y0..y1]) = expand ((x0,y0),(x1+1,y1)) pts'
|
|
| width + height < maxPerim, y0 > 0, checkFree (map (,y0) [x0..x1]), check (map (,y0-1) [x0..x1]) = expand ((x0,y0-1),(x1,y1)) pts'
|
|
| width + height < maxPerim, y1 < 19, checkFree (map (,y1) [x0..x1]), check (map (,y1+1) [x0..x1]) = expand ((x0,y0),(x1,y1+1)) pts'
|
|
| width * height < 16, Just pt' <- nearestFree grid (gsCell gs) pts'',
|
|
let goal' = expand (pt',pt') pts'', rangeSize goal' > rangeSize goal = goal'
|
|
| otherwise = goal
|
|
where
|
|
maxPerim = 50
|
|
width = x1 - x0
|
|
height = y1 - y0
|
|
check pts = not (any (\p -> grid!p /= '0' && grid!p /= '.') pts)
|
|
checkFree pts = any (\p -> grid!p == '.') pts
|
|
pts'' = pts' \\ range ((x0,y0),(x1,y1))
|
|
|
|
nextGoalPoint :: GameState -> Goal -> Point
|
|
nextGoalPoint gs goal =
|
|
fromMaybe (gsCell gs) (nearestFree (gsGrid gs) (gsCell gs) (border goal))
|
|
|
|
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
|
|
where
|
|
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
|
|
|
|
-- 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)
|
|
let evalFrom 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:) <$> evalFrom as
|
|
evalFrom xs |