CodeBusters contest -- Silver League, rank 61/709

Contests/CodeBusters/CodeBusters.hs

@@ -0,0 +1,158 @@
+{-# 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
+
+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)
+
+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)
+
+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) }
+
+   memory ← newIORef $ array ((0,0),(15,8)) [ ((x,y),(0,0)) | x ← [0..15], y ← [0..8] ]
+   let ptCell (x, y) = (max 0 (min 15 (x `div` 1000)), max 0 (min 8 (y `div` 1000)))
+   let cellCenter (x, y) = (1000 * x + 500, 1000 * y + 500)
+
+   ambusherId <- newIORef 0
+
+   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 theGhosts    = filter ((<= (10 + currentStep `div` 5)) . ghostStamina) theGhosts'
+
+      let countGhosts cell = 
+            length $ flip filter theGhosts $ \g →
+               ptCell (ghostPosition g) == cell
+
+      modifyIORef' memory $ \arr → runIdentity $ do
+         let allCells = indices arr
+         let coveredCells =
+               flip filter allCells $ \c →
+                  flip any myBusters $ \b →
+                     dist (cellCenter c) (busterPosition b) < 1490
+         let knownCells = [ (c, (currentStep, 0)) | c ← coveredCells ]
+         return $! accum (\(t,n) m → (t, max n m)) (arr // knownCells) $
+            map (\c → (c, countGhosts c)) allCells
+   
+      -- MOVE x y | BUST id | RELEASE
+      forM_ (zip [0..] myBusters) $ \(i, buster) → do
+         theAmbusherId ← readIORef ambusherId
+         let ambusher = bustersPerPlayer >= 3 && i == theAmbusherId
+         let here = busterPosition buster
+         let distTo = dist here
+         if busterHasGhost buster && distTo myBase < 1590 then
+            putStrLn "RELEASE"
+         else if busterHasGhost buster then do
+            when (i == theAmbusherId) $ modifyIORef ambusherId ((`mod` bustersPerPlayer) . (+1))
+            putStrLn $ unwords ["MOVE", show (fst myBase), show (snd myBase)]
+         else do
+            let isStunnable b = busterHasGhost b && distTo (busterPosition b) < 1760
+            case filter isStunnable theirBusters of
+               (b:_) → putStrLn $ unwords ["STUN", show (busterId b)]
+               [] → do
+                  let nearGhosts' = filter ((< 1760) . distTo . ghostPosition) theGhosts
+                  let nearGhosts = if not ambusher then nearGhosts'
+                                   else filter ((<= 2) . ghostStamina) nearGhosts'
+                  let eligible = filter ((> 900) . distTo . ghostPosition) nearGhosts
+                  if null nearGhosts then
+                     if ambusher then
+                        putStrLn $ unwords ["MOVE", show (fst theirBase), show (snd theirBase)]
+                     else if null theGhosts then do
+                        arr ← readIORef memory
+                        let ghostCells = filter (\c → snd (arr!c) > 0) (indices arr)
+                        if null ghostCells then do
+                           let sumAges c = sum $ [ fromIntegral age / fromIntegral (d + 500)
+                                                 | (c',(t,_)) ← assocs arr
+                                                 , let age = currentStep - t
+                                                 , let d = dist (cellCenter c) (cellCenter c')
+                                                 , d < 1490
+                                                 ]
+                           let score c = sumAges c / fromIntegral (1000 + distTo (cellCenter c))
+                           let (x, y) = cellCenter $ maximumBy (compare `on` score) (indices arr)
+                           putStrLn $ unwords ["MOVE", show x, show y]
+                        else do
+                           let (x, y) = minimumBy (compare `on` distTo) $ map cellCenter ghostCells
+                           putStrLn $ unwords ["MOVE", show x, show y]
+                           -- let θ = atan2 (fromIntegral $ snd theCenter - snd here)
+                           --             (fromIntegral $ fst here - fst theCenter)
+                           -- let θ' = if even i then θ + (pi / 12) else θ - (pi / 12)
+                           -- let rStep = case bustersPerPlayer of { 2 → 4800; 3 → 2400; 4 → 1600; 5 → 1200 }
+                           -- let r' = 2200 + rStep * fromIntegral i
+                           -- let x' = max 1800 $ min (16000-1800) $ fst theCenter + round (r' * cos θ')
+                           -- let y' = max 1800 $ min  (9000-1800) $ snd theCenter - round (r' * sin θ')
+                           -- putStrLn $ unwords ["MOVE", show x', show y']
+                     else do
+                        let closest = minimumBy (compare `on` (\g -> 800 * ghostStamina g + distTo (ghostPosition g))) theGhosts
+                        let there = ghostPosition closest
+                        if distTo there < 900 then
+                           putStrLn $ unwords ["MOVE", show (2 * fst here - fst there), show (2 * snd here - snd there)]
+                        else
+                           putStrLn $ unwords ["MOVE", show (fst there), show (snd there)]
+                  else if null eligible then do
+                     let farthest = maximumBy (compare `on` distTo . ghostPosition) nearGhosts
+                     let there = ghostPosition farthest
+                     putStrLn $ unwords ["MOVE", show (2 * fst here - fst there), show (2 * snd here - snd there)]
+                  else
+                     putStrLn $ unwords ["BUST", show (ghostId (head eligible))]
+
+dist ∷ Position → Position → Int
+dist (x1, y1) (x2, y2) = round $ sqrt $ fromIntegral ((x2-x1)^2 + (y2-y1)^2)
+
+busterHasGhost = isJust . busterGhostId