205 lines
8.1 KiB
Haskell
205 lines
8.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 = 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 |