{-# LANGUAGE ScopedTypeVariables, LambdaCase, ViewPatterns, TupleSections #-} {-# LANGUAGE BangPatterns #-} 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) ** 1.5) + sum [ if grid!p == '.' then w else 0 | (p,w) <- zip rt (iterate (*0.7) 10) ] 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) = reverse $ dropWhile (\p -> grid!p /= '.') $ reverse rt where freeCells = count (\p -> grid!p == '.') rt = if freeCells rt1 < freeCells rt2 then rt2 else rt1 rt1 = map (,y0) (x0 `to` x1) ++ map (x1,) (y0 `to` y1) ++ map (,y1) (x1 `to` x0) ++ map (x0,) (y1 `to` y0) rt2 = map (x0,) (y0 `to` y1) ++ map (,y1) (x0 `to` x1) ++ map (x1,) (y1 `to` y0) ++ map (,y0) (x1 `to` x0) 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 = fromIntegral $ sum $ 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) 60 let neighbours' p = filter (inRange (bounds grid)) $ neighbours p 1 let nsArray = theArray $ array (bounds grid) $ flip map (indices grid) $ \(x,y) -> ((x,y),) $ (\(Sum a,Sum b,Sum c) -> (a,b,c)) $ mconcat $ [ if not (inRange (bounds grid) (x',y')) then (Sum 1, Sum 0, Sum 0) else if grid!(x',y') == '.' then (Sum 0, Sum 1, Sum 0) else if grid!(x',y') == '0' then (Sum 0, Sum 0, Sum 1) else mempty | y' <- [y-1..y+1] , x' <- [x-1..x+1] , (x',y') /= (x,y) ] 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' = 50 + 10*mine + 12*(other + free) + 15*(outside + other) | g /= '.' = 0 | isBorder p = 10 | otherwise = max 10 $ min v $ minimum nv + 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