200 lines
7.5 KiB
Haskell
200 lines
7.5 KiB
Haskell
{-# LANGUAGE ScopedTypeVariables, LambdaCase, ViewPatterns, TupleSections #-}
|
|
{-# LANGUAGE BangPatterns, FlexibleContexts #-}
|
|
|
|
import Control.Applicative
|
|
import Control.Arrow
|
|
import Control.Parallel
|
|
import Control.Monad
|
|
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.Traversable as T
|
|
|
|
main :: IO ()
|
|
main = do
|
|
hSetBuffering stdout NoBuffering -- DO NOT REMOVE
|
|
opponentCount <- readLn
|
|
trail <- newIORef []
|
|
forever $ 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
|
|
|
|
let claim c pt grid = if grid!pt == '.' then grid // [(pt,c)] else grid
|
|
grid' <- foldl' (\g p -> claim 'X' p g) grid <$> readIORef trail
|
|
modifyIORef trail (((myX,myY):) . take 4)
|
|
|
|
startTime <- getCPUTime
|
|
|
|
(action, nPts) <- findTarget (myX, myY) grid' opponents myBackInTimeLeft
|
|
|
|
-- action: "x y" to move or "BACK rounds" to go back in time
|
|
case action of
|
|
Left n -> putStrLn $ "BACK " ++ show n
|
|
Right (tx, ty) -> putStrLn $ unwords $ map show [tx, ty]
|
|
|
|
stopTime <- getCPUTime
|
|
let diff = stopTime - startTime
|
|
|
|
hPutStrLn stderr $ show (diff `div` 1000000000) ++ " " ++ show nPts
|
|
|
|
findTarget :: (Int, Int)
|
|
-> UArray (Int, Int) Char
|
|
-> [((Int, Int), Bool)]
|
|
-> Bool
|
|
-> IO (Either Int (Int, Int), Int)
|
|
findTarget myPt@(myX,myY) grid opponents myBackInTimeLeft = do
|
|
gen <- newStdGen
|
|
scoredPts <- evaluateListWithTimeout 90000
|
|
. map (\(rt,_) -> (rt,) $! score rt)
|
|
. sortBy (compare `on` snd)
|
|
. zipWith (\r pt -> (bestRoute grid myPt pt, r + score' pt))
|
|
(randomRs (0, 1.0::Double) gen)
|
|
. filter (\p -> p /= myPt && grid!p == '.')
|
|
$ indices grid
|
|
return ( Right $ fromMaybe myPt $ fmap (head . fst) $
|
|
safeMaximumBy (compare `on` snd) scoredPts
|
|
, length scoredPts)
|
|
where
|
|
baseScore = scoreGrid' myPt grid
|
|
score rt = (scoreGrid' (last rt) (updateGrid grid rt) - baseScore)
|
|
/ (fromIntegral (length rt) ** 2)
|
|
score' pt = dist myPt pt + sum (map (sqrt . dist pt . fst) opponents)
|
|
scoreGrid' pt grid = scoreGrid grid
|
|
+ 3 * sum (map (sqrt . dist pt . fst) opponents)
|
|
dist (x0,y0) (x1,y1) = fromIntegral (abs (x1-x0) + abs (y1-y0))
|
|
|
|
neighbours :: (Int,Int) -> Int -> [(Int,Int)]
|
|
neighbours (x0,y0) n =
|
|
[0..2*n-1] >>= \i ->
|
|
[ (x0-n+i,y0-n)
|
|
, (x0+n,y0-n+i)
|
|
, (x0+n-i,y0+n)
|
|
, (x0-n,y0+n-i)
|
|
]
|
|
|
|
bestRoute :: UArray (Int,Int) Char -> (Int,Int) -> (Int,Int) -> [(Int,Int)]
|
|
bestRoute grid from@(x0,y0) to@(x1,y1) =
|
|
if freeCells rt1 < freeCells rt2 then rt2 else rt1
|
|
where
|
|
freeCells = count (\p -> grid!p == '.')
|
|
rt1 = map (,y0) (x0 `to` x1) ++ map (x1,) (y0 `to` y1)
|
|
rt2 = map (x0,) (y0 `to` y1) ++ map (,y1) (x0 `to` x1)
|
|
x `to` y = if y >= x then [x+1..y] else [x-1,x-2..y]
|
|
|
|
updateGrid :: UArray (Int,Int) Char -> [(Int, Int)] -> UArray (Int,Int) Char
|
|
updateGrid grid route = STA.runSTUArray $ do
|
|
let valid = inRange (bounds grid)
|
|
grid' <- STA.thaw grid
|
|
forM_ route $ \p -> when (grid!p == '.') $ STA.writeArray grid' p '0'
|
|
doWhileM_ . fmap getAny . flip foldMapA (indices grid) $ \p -> do
|
|
g <- STA.readArray grid' p
|
|
if g /= '.' then pure (Any False) else do
|
|
gs <- mapM (\p' -> if valid p' then STA.readArray grid' p' else pure 'X')
|
|
(neighbours p 1)
|
|
if any (not . (`elem` ['.','0'])) gs
|
|
then Any True <$ STA.writeArray grid' p 'M'
|
|
else pure (Any False)
|
|
forM_ (indices grid) $ \p -> do
|
|
g <- STA.readArray grid' p
|
|
if g == '.' then STA.writeArray grid' p '0'
|
|
else when (g == 'M') $ STA.writeArray grid' p '.'
|
|
return grid'
|
|
|
|
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
|
|
|
|
scoreGrid :: UArray (Int, Int) Char -> Double
|
|
scoreGrid grid = sum $ map ((**0.8) . fromIntegral) $ elems $ scoreCells grid
|
|
|
|
theArray :: Array i e -> Array i e
|
|
theArray = id
|
|
|
|
scoreCells :: UArray (Int, Int) Char -> UArray (Int, Int) Int
|
|
scoreCells grid = STA.runSTUArray $ do
|
|
scores <- STA.newArray (bounds grid) 5
|
|
let neighbours' p = filter (inRange (bounds grid)) $ neighbours p 1
|
|
let nsArray = theArray $ array (bounds grid) $ flip map (indices grid) $ \p -> (p,) $
|
|
let ns = map (grid!) (neighbours' p) in
|
|
( 8 - length ns
|
|
, count (=='.') ns
|
|
, count (=='0') ns
|
|
)
|
|
doWhileM_ $ fmap getAny $ flip foldMapA (assocs grid) $ \(p,g) -> do
|
|
v <- STA.readArray scores p
|
|
nv <- forM (neighbours' p) $ STA.readArray scores
|
|
let (outside, free, mine) = nsArray!p
|
|
let other = 8 - (outside + free + mine)
|
|
let v' | g == '0' = 100 + 10*mine + 35*(min 1 $ outside + other) + 10*free
|
|
| g /= '.' = 0
|
|
| isBorder p = 0
|
|
| otherwise = min v $ minimum nv + (max 0 $ 2*mine - other) + 1
|
|
Any (v' /= v) <$ STA.writeArray scores p v'
|
|
pure scores
|
|
where
|
|
isBorder (x,y) = x == xMin || x == xMax || y == yMin || y == yMax
|
|
where ((xMin,yMin),(xMax,yMax)) = bounds grid
|