198 lines
7.9 KiB
Haskell
198 lines
7.9 KiB
Haskell
{-# 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
|