171 lines
6.3 KiB
Haskell
171 lines
6.3 KiB
Haskell
{-# LANGUAGE ScopedTypeVariables, LambdaCase, ViewPatterns, TupleSections #-}
|
|
|
|
import Control.Applicative
|
|
import Control.Arrow
|
|
import Control.Monad
|
|
import Data.Array
|
|
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.Timeout
|
|
|
|
import qualified Data.Array.ST as STA
|
|
import qualified Data.Foldable as F
|
|
import qualified Data.Traversable as T
|
|
import qualified Data.Set as S
|
|
|
|
main :: IO ()
|
|
main = do
|
|
hSetBuffering stdout NoBuffering -- DO NOT REMOVE
|
|
opponentCount <- readLn
|
|
|
|
trailRef <- newIORef []
|
|
nPointsRef <- newIORef 10
|
|
|
|
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
|
|
|
|
modifyIORef trailRef (((myX, myY):) . take 2)
|
|
trail <- readIORef trailRef
|
|
|
|
-- treat recent "collisions" as occupied spaces
|
|
let grid' = accum (\c _ -> if c == '.' then 'X' else c) grid $ map (,()) trail
|
|
|
|
startTime <- getCPUTime
|
|
|
|
let (action, nPts) = findTarget (myX, myY) trail 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)
|
|
-> [(Int, Int)]
|
|
-> Array (Int, Int) Char
|
|
-> [((Int, Int), Bool)]
|
|
-> Bool
|
|
-> (Either Int (Int, Int), Int)
|
|
findTarget myPt@(myX,myY) trail grid opponents myBackInTimeLeft =
|
|
(Right $ fromMaybe myPt $ fmap fst $ safeMaximumBy (compare `on` snd) scoredPts, length scoredPts)
|
|
where
|
|
scoredPts = unsafeTimeoutList 90000
|
|
. (\xs -> trace (unlines $ map show $ take 6 xs) xs)
|
|
. map (\rt -> (head rt,) $! score rt)
|
|
. map fst . sortBy (compare `on` snd)
|
|
. map (\rt -> (rt, length rt))
|
|
. map (\(x,y) -> findRoute grid (myX,myY) (x,y))
|
|
. filter (\p -> p /= myPt && grid!p == '.')
|
|
$ indices grid
|
|
baseScore = scoreGrid grid
|
|
score rt = (scoreGrid (updateGrid grid rt) - baseScore) -- / (fromIntegral $ 1 + length rt)
|
|
|
|
diagonals (x0,y0) i =
|
|
[ (x0+i, y0 )
|
|
, (x0+i, y0-i)
|
|
, (x0, y0-i)
|
|
, (x0-i, y0-i)
|
|
, (x0-i, y0 )
|
|
, (x0-i, y0+i)
|
|
, (x0, y0+i)
|
|
, (x0+i, y0+i)
|
|
]
|
|
|
|
scoreCells :: Array (Int, Int) Char -> Array (Int, Int) Int
|
|
scoreCells grid = STA.runSTArray $ do
|
|
scores <- STA.newArray (bounds grid) 100
|
|
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
|
|
|
|
scoreGrid grid = sum $ map (sqrt . fromIntegral) $ elems $ scoreCells grid
|
|
|
|
findRoute grid here@(x0,y0) there@(x1,y1) = filter ((=='.') . (grid!)) pts
|
|
where
|
|
pts = map (x0,) (tail (y0 `to` y1)) ++
|
|
map (,y1) (tail (x0 `to` x1)) ++
|
|
map (x1,) (tail (y1 `to` y0)) ++
|
|
map (,y0) (tail (x1 `to` x0))
|
|
x `to` y = [x,x+(if y > x then 1 else -1)..y]
|
|
|
|
updateGrid :: Array (Int,Int) Char -> [(Int, Int)] -> Array (Int,Int) Char
|
|
updateGrid grid pts = accum update grid $ map (,()) pts
|
|
where update c _ = if c == '.' then '0' else c
|
|
|
|
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 :: F.Foldable f => (a -> Bool) -> f a -> Int
|
|
count f xs = getSum $ F.foldMap (\x -> if f x then Sum 1 else Sum 0) xs
|
|
|
|
-- 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 |