191 lines
7.4 KiB
Haskell
191 lines
7.4 KiB
Haskell
{-# LANGUAGE ScopedTypeVariables, LambdaCase, ViewPatterns, TupleSections #-}
|
|
{-# LANGUAGE BangPatterns #-}
|
|
|
|
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 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
|
|
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
|
|
|
|
startTime <- getCPUTime
|
|
|
|
gen <- newStdGen
|
|
let (action, nPts) = findTarget (myX, myY) (claim 'X' (myX,myY) grid) opponents myBackInTimeLeft gen
|
|
|
|
-- 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 :: RandomGen g
|
|
=> (Int, Int)
|
|
-> UArray (Int, Int) Char
|
|
-> [((Int, Int), Bool)]
|
|
-> Bool
|
|
-> g
|
|
-> (Either Int (Int, Int), Int)
|
|
findTarget myPt@(myX,myY) grid opponents myBackInTimeLeft gen =
|
|
(Right $ fromMaybe myPt $ fmap fst $ safeMaximumBy (compare `on` snd) scoredPts, length scoredPts)
|
|
where
|
|
scoredPts = unsafeTimeoutList 90000
|
|
. map (\pt -> let rt = bestRoute grid myPt pt in (head rt,) $! score rt)
|
|
. map fst . sortBy (compare `on` snd)
|
|
. map (\(r, (x,y)) -> ((x,y), r + dist myPt (x,y)))
|
|
. zip (randomRs (0, 2.0::Double) gen)
|
|
. filter (\p -> inRange (bounds grid) p && grid!p == '.')
|
|
$ indices grid
|
|
baseScore = scoreGrid' myPt grid
|
|
score rt = (scoreGrid' (last rt) (updateGrid grid rt) - baseScore) / (fromIntegral (length rt) ** 2)
|
|
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 | y >= x = [x+1..y]
|
|
| otherwise = [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'
|
|
|
|
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
|
|
|
|
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
|
|
|
|
-- Compute elements of the list to WHNF for `t` microseconds.
|
|
-- After `t` microseconds, abandon the calculation and terminate
|
|
-- the list. Note that this causes the length of the result to depend
|
|
-- on timing and system load. Marked "unsafe" for a reason!
|
|
unsafeTimeoutList :: Integer -> [a] -> [a]
|
|
unsafeTimeoutList t xs = unsafePerformIO $ do
|
|
start <- getCPUTime
|
|
return $ evalUntil (start + (1000000 * t)) xs
|
|
where
|
|
evalUntil end xs = unsafePerformIO $ do
|
|
now <- getCPUTime
|
|
r <- timeout (fromIntegral $ max 0 (end - now) `div` 1000000) $ return $! case xs of
|
|
[] -> []
|
|
(a:as) -> a `seq` (a:as)
|
|
return $ case r of
|
|
Nothing -> []
|
|
Just [] -> []
|
|
Just (a:as) -> (a : evalUntil end as)
|
|
|
|
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
|
|
|
|
scoreGrid :: UArray (Int, Int) Char -> Double
|
|
scoreGrid grid = sum $ map (sqrt . fromIntegral) $ elems $ scoreCells grid
|
|
|
|
scoreCells :: UArray (Int, Int) Char -> UArray (Int, Int) Int
|
|
scoreCells grid = STA.runSTUArray $ do
|
|
scores <- STA.newArray (bounds grid) 80
|
|
doWhileM_ $ do
|
|
fmap getAny $ flip foldMapA (assocs grid) $ \(p,g) -> do
|
|
v <- STA.readArray scores p
|
|
nv <- mapM (STA.readArray scores) (neighbours p)
|
|
let outside = 8 - length (neighbours p)
|
|
let free = count ((=='.') . (grid!)) $ neighbours p
|
|
let mine = count ((=='0') . (grid!)) $ neighbours p
|
|
let other = 8 - (outside + mine + free)
|
|
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
|
|
when (v' /= v) $ STA.writeArray scores p v'
|
|
return $ Any (v' /= v)
|
|
return scores
|
|
where
|
|
isBorder (x,y) = x == xMin || x == xMax || y == yMin || y == yMax
|
|
where ((xMin,yMin),(xMax,yMax)) = bounds grid
|
|
neighbours (x,y) = filter (inRange $ bounds grid) $ diagonals (x,y) 1 |