CodinGame/Contests/CodeBusters/CodeBusters.hs

{-# LANGUAGE ScopedTypeVariables, LambdaCase, UnicodeSyntax #-}

import Control.Applicative
import Control.Monad
import Data.Array
import Data.Either
import Data.Function
import Data.Functor.Identity
import Data.IORef
import Data.List
import Data.Maybe
import Debug.Trace
import System.IO

import qualified Data.Map as M

type Team = Int
type BusterId = Int
type GhostId = Int
type Position = (Int, Int)

data Buster = Buster { busterId       ∷ Int
                     , busterPosition ∷ Position
                     , busterTeam     ∷ Team
                     , busterGhostId  ∷ Maybe Int
                     , busterStunned  ∷ Maybe Int
                     } deriving (Show)

data Ghost = Ghost { ghostId          ∷ Int
                   , ghostPosition    ∷ Position
                   , ghostBustersTied ∷ Int
                   , ghostStamina     ∷ Int
                   } deriving (Show)

data Action = Release | Stun BusterId | Bust GhostId | MoveTo Position deriving (Eq, Ord, Show)

readEntity ∷ (Buster → a) → (Ghost → a) → String → a
readEntity buster ghost str
   | entityType == -1 = ghost $ Ghost
       { ghostId          = entityId
       , ghostPosition    = (x, y)
       , ghostBustersTied = value
       , ghostStamina     = state
       }
   | otherwise = buster $ Buster
       { busterId       = entityId
       , busterPosition = (x, y)
       , busterTeam     = entityType
       , busterGhostId  = if state == 1 then Just value else Nothing
       , busterStunned  = if state == 2 then Just value else Nothing
       }
   where [entityId, x, y, entityType, state, value] = map read (words str)

formatAction ∷ Action → String
formatAction = \case
   Release → "RELEASE"
   Stun bId → "STUN " ++ show bId
   Bust gId → "BUST " ++ show gId
   MoveTo (x, y) → "MOVE " ++ show x ++ " " ++ show y

main ∷ IO ()
main = do
   hSetBuffering stdout NoBuffering -- DO NOT REMOVE
   
   -- Send your busters out into the fog to trap ghosts and bring them home!
   -- Team 0 is top left, team 1 is bottom right.
   bustersPerPlayer ∷ Int ← readLn
   ghostCount       ∷ Int ← readLn
   myTeamId         ∷ Int ← readLn
   
   let theCenter = (8000, 4500)
   let myBase    = case myTeamId of { 0 → (0, 0); 1 → (16000, 9000) }
   let theirBase = case myTeamId of { 1 → (1500, 1500); 0 → (14500, 7500) }

   visited ← newIORef $ array ((0,0),(29,17)) [ ((x,y),-50) | x ← [0..29], y ← [0..17] ]
   let cellCenter (x, y) = (500 * x + 250, 500 * y + 250)

   memory ← newIORef $ M.empty

   stunners   ← newIORef []
   ambusherId ← newIORef Nothing

   forM_ [1..] $ \currentStep → do
      numEntities ∷ Int ← readLn
   
      entities ← replicateM numEntities (readEntity Left Right <$> getLine)
      
      let myBusters    = filter ((== myTeamId) . busterTeam) $ lefts entities
      let theirBusters = filter ((/= myTeamId) . busterTeam) $ lefts entities
      let theGhosts    = rights entities

      let inView pos = any (\b → dist pos (busterPosition b) < 2000) myBusters

      modifyIORef' visited $ \arr →
         let coveredCells = filter (inView . cellCenter) (indices arr) in
         arr // [ (c, currentStep) | c ← coveredCells ]

      modifyIORef' memory $ \mem →
         let scrubbed = M.filter (not . inView . ghostPosition . snd) mem in
         foldl (\m g → M.insert (ghostId g) (currentStep, g) m) scrubbed theGhosts

      modifyIORef' stunners $ filter ((> currentStep) . snd)
   
      -- MOVE x y | BUST id | RELEASE
      forM_ (zip [0..] myBusters) $ \(i, buster) → (putStrLn . formatAction =<<) $ do
         canStun ← isNothing . lookup (busterId buster) <$> readIORef stunners
         modifyIORef' ambusherId (<|> Just (busterId buster))
         theAmbusherId ← readIORef ambusherId
         let ambusher = bustersPerPlayer >= 3 && Just i == theAmbusherId
         let here = busterPosition buster
         let distTo = dist here
         let threats = [ b | b ← theirBusters, distTo (busterPosition b) < 1760, isNothing (busterStunned b) ]
         let targets = [ b | b ← theirBusters, distTo (busterPosition b) < 1760, busterHasGhost b ]
         if isJust (busterStunned buster) then do
            when ambusher $ writeIORef ambusherId Nothing
            pure $ MoveTo myBase
         else if busterHasGhost buster && distTo myBase < 1590 then
            pure Release
         else if busterHasGhost buster && canStun && not (null threats) then do
            modifyIORef' stunners $ (:) (busterId buster, currentStep + 20)
            pure $ Stun $ busterId $ minimumBy (compare `on` distTo . busterPosition) threats
         else if busterHasGhost buster then do
            when ambusher $ writeIORef ambusherId Nothing
            pure $ MoveTo myBase
         else if canStun && not (null targets) then do
            modifyIORef' stunners $ (:) (busterId buster, currentStep + 20)
            pure $ Stun $ busterId $ head targets
         else do
            visitArr ← readIORef visited
            let sumAges c = sum [ fromIntegral (min 100 $ currentStep - t) -- * (500 / fromIntegral (500 + d))
                                | (c', t) ← assocs visitArr, let d = dist (cellCenter c) (cellCenter c'), d < 1000 ]
            let scoreCell c = 667 * (sumAges c / 1000) * (500 / fromIntegral (500 + distTo (cellCenter c)))
            let mapScores = [ (MoveTo $ cellCenter c, scoreCell c) | c ← indices visitArr ]
            let scoreGhost g = 800 * (5000 / fromIntegral (5000 + distTo (ghostPosition g))) * (4 / fromIntegral (4 + ghostStamina g))
            let adjust (x, y) = let (x0, y0) = here; (dx, dy) = (x0 - x, y0 - y); d = sqrt (fromIntegral (dx^2 + dy^2)) + 0.01 in
                                let (dx', dy') = (1000 * (fromIntegral dx + 0.01) / d, 1000 * (fromIntegral dy + 0.01) / d) in
                                (x + round dx', y + round dy')
            knownGhosts ← map snd . M.elems <$> readIORef memory
            let ghostScores = [ (MoveTo (adjust (ghostPosition g)), scoreGhost g) | g ← knownGhosts ]
            let followScores = [ (MoveTo (adjust (busterPosition b)), prio * (2000 / (2000 + fromIntegral d)))
                               | b ← theirBusters, let d = distTo (busterPosition b), let prio = if busterHasGhost b then 850 else 200 ]
            let bustScores = [ (Bust (ghostId g), 1000 * 4 / (4 + fromIntegral (ghostStamina g)))
                             | g ← knownGhosts, let d = distTo (ghostPosition g), d > 900, d < 1760 ]
            let ambushScores = if ambusher then [(MoveTo theirBase, 300)] else []
            traceM $ ("M: " ++) $ show $ take 3 $ sortBy (flip compare) $ map (round . snd) $ mapScores
            traceM $ ("G: " ++) $ show $ take 3 $ sortBy (flip compare) $ map (round . snd) $ ghostScores
            traceM $ ("F: " ++) $ show $ take 3 $ sortBy (flip compare) $ map (round . snd) $ followScores
            traceM $ ("B: " ++) $ show $ take 3 $ sortBy (flip compare) $ map (round . snd) $ bustScores
            pure $ fst $ maximumBy (compare `on` snd) $ concat [mapScores, ghostScores, bustScores, followScores, ambushScores ]

dist ∷ Position → Position → Int
dist (x1, y1) (x2, y2) = round $ sqrt $ fromIntegral ((x2-x1)^2 + (y2-y1)^2)

busterHasGhost = isJust . busterGhostId

count ∷ (a → Bool) → [a] → Int
count = (length .) . filter