Ghost in the Cell contest -- simulator version

Contests/GhostInTheCell/GhostInTheCell.hs

@@ -1,15 +1,17 @@
-{-# LANGUAGE ViewPatterns, LambdaCase, DataKinds, GADTs #-}
+{-# LANGUAGE ViewPatterns #-}
 
 import System.IO
 import Control.Applicative
-import Control.Arrow (first, second)
+import Control.Arrow (first, second, (>>>))
 import Control.Monad
+import Control.Monad.Writer
 import Data.Either
 import Data.Foldable
 import Data.Function
 import Data.IORef
 import Data.List
 import Data.Maybe
+import Data.Monoid
 
 import qualified Data.Map as M
 
@@ -45,6 +47,16 @@ data Action  = Move FactoryId FactoryId Int
              | Wait
              deriving (Eq, Show)
 
+data GameState =
+   GameState
+      { gsLinks        :: M.Map (FactoryId, FactoryId) Int
+      , gsFactories    :: [Factory]
+      , gsTroops       :: [Troop]
+      , gsBombs        :: [Bomb]
+      , gsMyBombsLeft  :: Int
+      , gsNextEntity   :: EntityId
+      } deriving (Show)
+
 actionString :: Action -> String
 actionString (Move src dst cnt) = unwords ["MOVE", show src, show dst, show cnt]
 actionString (SendBomb src dst) = unwords ["BOMB", show src, show dst]
@@ -68,8 +80,10 @@ main = do
       pure ([((f1, f2), dist), ((f2, f1), dist)] :: [((FactoryId, FactoryId), Int)])
 
    bombsLeftRef <- newIORef 2
+   turnCountRef <- newIORef 1
 
    forever $ do
+      turnCount <- readIORef turnCountRef
       bombsLeft <- readIORef bombsLeftRef
       entityCount <- readLn :: IO Int -- the number of entities (e.g. factories and troops)
 
@@ -80,6 +94,18 @@ main = do
                "TROOP"   -> Right . Left  $ Troop   entityId a1 a2 a3 a4 a5
                "BOMB"    -> Right . Right $ Bomb    entityId a1 a2 a3 a4
 
+      let nextEntity = (+1) $ maximum $ 0 : map factoryId factoryList
+                                         ++ map troopId   troopList
+                                         ++ map bombId    bombList
+
+      let gs = GameState { gsLinks = links
+                         , gsFactories = factoryList
+                         , gsTroops = troopList
+                         , gsBombs = bombList
+                         , gsMyBombsLeft = bombsLeft
+                         , gsNextEntity = nextEntity
+                         }
+
       let factories   = M.fromList [ (factoryId f, f) | f <- factoryList ]
       let myFactories = filter (\f -> factoryOwner f == thisPlayer) factoryList
       let inTransitTo =
@@ -93,8 +119,6 @@ main = do
                   ]
             in \dst -> fromMaybe (0, 0) $ M.lookup dst transitMap
 
-        let myTotalProduction = sum $ map factoryProduction myFactories
-        
       let distributeScores src = do
             dst <- myFactories
             guard $ factoryId dst /= factoryId src
@@ -102,21 +126,12 @@ main = do
             let (dstDefending, dstAttacking) = inTransitTo (factoryId dst)
             let srcTotal = factoryCyborgs src - srcAttacking
             let dstTotal = factoryCyborgs dst + dstDefending - dstAttacking
-                guard $ 2 * srcTotal >= 3 * dstTotal
             let amount = (factoryCyborgs src + 1) `div` 3
-                guard $ amount > 0
+            guard $ amount > 0 && amount <= factoryCyborgs src
             dist <- toList $ M.lookup (factoryId src, factoryId dst) links
-                let threshold = (1.0 - saturate 20.0 (fromIntegral (factoryCyborgs src)))
+            pure $ Move (factoryId src) (factoryId dst) amount
-                              * (fromIntegral (factoryProduction src + 1) / 4.0)
-                              * 0.5
-                let score = saturate 10.0 (fromIntegral (srcTotal - dstTotal))
-                          * saturate 20.0 (fromIntegral (srcTotal - amount))
-                          * (1.0 - 0.25 * saturate 20.0 (fromIntegral dstTotal))
-                guard $ score >= threshold
-                pure (score, [Move (factoryId src) (factoryId dst) amount])
 
       let attackScores src = do
-                guard $ factoryCyborgs src >= 5 * factoryProduction src
             dst <- filter (\f -> factoryOwner f /= thisPlayer) factoryList
             dist <- toList $ M.lookup (factoryId src, factoryId dst) links
             let (mineDefending, theirsAttacking) = inTransitTo (factoryId src)
@@ -126,52 +141,184 @@ main = do
             let theirEstimate
                   | factoryOwner dst == neutralPlayer = theirTotal
                   | otherwise = theirTotal + factoryProduction dst * (1 + dist)
-                guard $ 2 * myTotal >= 3 * theirTotal
             let amount = theirEstimate + 1
-                guard $ amount > 0
+            guard $ amount > 0 && amount <= factoryCyborgs src
-                let threshold = (1.0 - saturate 20.0 (fromIntegral (factoryCyborgs src)))
+            pure $ Move (factoryId src) (factoryId dst) amount
-                              * (fromIntegral (factoryProduction src + 1) / 4.0)
-                              * saturate 6.0 (fromIntegral myTotalProduction)
-                              * 0.5
-                let score = fromIntegral (factoryProduction dst + 8) / 10.0
-                          * saturate 10.0 (fromIntegral (myTotal - amount))
-                          * (40.0 / (39.0 + fromIntegral dist))
-                guard $ score >= threshold
-                pure (score, [Move (factoryId src) (factoryId dst) amount])
 
       let increaseScores src = do
             guard $ factoryProduction src < 3
             guard $ factoryCyborgs src >= 10
-                let score = saturate 10.0 $ fromIntegral myTotalProduction
+            pure $ Increase (factoryId src)
-                pure (score, [Increase (factoryId src)])
 
-        let factoryActions src = concatMap snd $ best 1 $ concatMap ($ src) $
+      let factoryActions src = foldr mplus mempty $ map ($ src) $
             [ distributeScores, attackScores, increaseScores ]
 
       let actions = concatMap factoryActions myFactories
 
-        let bombActions = concatMap snd $ best 1 $ do
+      let bombActions = do
             guard $ bombsLeft > 0 && not (null myFactories)
+            guard $ bombsLeft > 1 || turnCount > 50
             dst <- filter (\f -> factoryOwner f == opponent) factoryList
-                guard $ factoryCyborgs dst >= 50 + 50 * (2 - bombsLeft)
+            --guard $ factoryCyborgs dst >= 50 + 50 * (2 - bombsLeft)
             let src = snd $ minimumBy (compare `on` fst) $
                   [ (dist, s) | s <- myFactories
                   , dist <- toList $ M.lookup (factoryId s, factoryId dst) links
                   ]
-                let score = saturate 100.0 $ fromIntegral $ factoryCyborgs dst
+            pure $ SendBomb (factoryId src) (factoryId dst)
-                pure (score, [SendBomb (factoryId src) (factoryId dst)])
 
-        let actions' = actions ++ bombActions
+      remainingActions <- newIORef (actions ++ bombActions)
-        case actions' of
+      chosenActions <- newIORef []
+      projScore <- newIORef (scoreGame (simulate [] 20 gs))
+
+      fix $ \loop -> do
+         cs <- readIORef chosenActions
+         as <- readIORef remainingActions
+         sc <- readIORef projScore
+         let scoredActions = map (\a -> (scoreGame (simulate [(thisPlayer, cs++[a])] 20 gs), a)) as
+         case best 10 scoredActions of
+            [] -> pure ()
+            (sc',a):rs -> when (sc' > sc) $ do
+               writeIORef chosenActions (cs ++ [a])
+               writeIORef remainingActions (map snd rs)
+               writeIORef projScore sc'
+               loop
+
+      chosenActions' <- readIORef chosenActions
+      case chosenActions' of
          [] -> putStrLn $ actionString Wait
          xs -> putStrLn $ intercalate "; " $ map actionString xs
 
       let isSendBomb act = case act of { SendBomb _ _ -> True; _ -> False }
-        modifyIORef bombsLeftRef (subtract $ length $ filter isSendBomb actions')
+      modifyIORef bombsLeftRef (subtract $ length $ filter isSendBomb chosenActions')
-
+      modifyIORef turnCountRef (+1)
-saturate :: Double -> Double -> Double
-saturate hl x = if x < 0.0 then 0.0 else 1.0 - (2.0 ** (-x / hl))
 
 best :: Ord a => Int -> [(a, b)] -> [(a, b)]
 best n = take n . sortBy (flip compare `on` fst)
 
+gameTurn :: [(PlayerId, [Action])] -> GameState -> GameState
+gameTurn orders = moveTroops
+              >>> moveBombs
+              >>> processOrders orders
+              >>> produceCyborgs
+              >>> solveBattles
+              >>> explodeBombs
+
+simulate :: [(PlayerId, [Action])] -> Int -> GameState -> GameState
+simulate orders n gs
+   | n > 0 = simulate [] (n-1) (gameTurn orders gs)
+   | otherwise = gs
+
+scoreGame :: GameState -> Double
+scoreGame gs = (fromIntegral myCyborgs  + 10 * fromIntegral myProduction  + 10 * fromIntegral myFactories)
+             / (fromIntegral oppCyborgs + 10 * fromIntegral oppProduction + 10 * fromIntegral oppFactories + 1)
+   where
+      myFactories  = length $ filter (\f -> factoryOwner f == thisPlayer) (gsFactories gs)
+      oppFactories = length $ filter (\f -> factoryOwner f == opponent) (gsFactories gs)
+      ((Sum myCyborgs, Sum myProduction),
+       (Sum oppCyborgs, Sum oppProduction)) = execWriter $ do
+         forM_ (gsFactories gs) $ \f -> do
+            when (factoryOwner f == thisPlayer) $
+               tell ((Sum (factoryCyborgs f), Sum (factoryProduction f)), mempty)
+            when (factoryOwner f == opponent) $
+               tell (mempty, (Sum (factoryCyborgs f), Sum (factoryProduction f)))
+         forM_ (gsTroops gs) $ \t -> do
+            when (troopOwner t == thisPlayer) $
+               tell ((Sum (troopCyborgs t), mempty), mempty)
+            when (troopOwner t == opponent) $
+               tell (mempty, (Sum (troopCyborgs t), mempty))
+
+moveTroops, moveBombs, produceCyborgs,
+   solveBattles, explodeBombs :: GameState -> GameState
+
+moveTroops gs0 = gs0 { gsTroops = map moveTroop (gsTroops gs0) }
+   where
+      moveTroop t = t { troopTurnsLeft = troopTurnsLeft t - 1 }
+
+moveBombs gs0 = gs0 { gsBombs = map moveBomb (gsBombs gs0) }
+   where
+      moveBomb b = b { bombDelay = bombDelay b - 1 }
+
+processOrders :: [(PlayerId, [Action])] -> GameState -> GameState
+processOrders orders gs0 = foldl processOrder gs0 orders
+   where
+      processOrder gs (p, as) = foldl (processAction p) gs as
+      processAction p gs a = checkBalances $ case a of
+         Move from to amt -> processMove p from to amt gs
+         SendBomb from to -> processBomb p from to gs
+         Increase factory -> processIncrease p factory gs
+         Wait             -> gs
+      processMove p from to amt gs =
+         gs { gsFactories = map (\f -> if factoryId f /= from then f
+                                       else f { factoryCyborgs = max 0 (factoryCyborgs f - amt) })
+                                (gsFactories gs)
+            , gsTroops     = gsTroops gs ++
+               [Troop { troopId        = gsNextEntity gs
+                      , troopOwner     = p
+                      , troopOrigin    = from
+                      , troopTarget    = to
+                      , troopCyborgs   = min amt (sum $ map (\f -> if factoryId f == from then factoryCyborgs f else 0) (gsFactories gs))
+                      , troopTurnsLeft = fromJust $ M.lookup (from, to) (gsLinks gs)
+                      }]
+            , gsNextEntity = gsNextEntity gs + 1
+            }
+      processBomb p from to gs =
+         gs { gsBombs = gsBombs gs ++
+               [Bomb { bombId = gsNextEntity gs
+                     , bombSender = p
+                     , bombOrigin = from
+                     , bombTarget = to
+                     , bombDelay  = fromJust $ M.lookup (from, to) (gsLinks gs)
+                     }]
+            , gsNextEntity = gsNextEntity gs + 1
+            }
+      processIncrease p factory gs =
+         gs { gsFactories = map (\f -> if factoryId f /= factory || factoryCyborgs f < 10 then f
+                                       else f { factoryCyborgs    = factoryCyborgs f - 10
+                                              , factoryProduction = min 3 (factoryProduction f + 1)
+                                              })
+                                (gsFactories gs)
+            }
+      checkBalances gs
+         | all (\f -> factoryCyborgs f >= 0) (gsFactories gs) = gs
+         | otherwise = error "Cyborg count is negative!"
+
+produceCyborgs gs = gs { gsFactories = map produce (gsFactories gs) }
+   where
+      produce f
+         | factoryDelay f > 0 = f { factoryDelay = factoryDelay f - 1 }
+         | otherwise = f { factoryCyborgs = factoryCyborgs f + factoryProduction f }
+
+solveBattles gs =
+   gs { gsFactories = map solveFactory (gsFactories gs)
+      , gsTroops = troopsInTransit
+      }
+   where
+      (troopsArriving, troopsInTransit) = partition (\t -> troopTurnsLeft t <= 0) (gsTroops gs)
+      solveFactory f
+         | attacking > defending = f { factoryOwner = attackingPlayer
+                                     , factoryCyborgs = attacking - defending
+                                     }
+         | otherwise = f { factoryCyborgs = defending - attacking }
+         where
+            troopsArrivingHere = filter (\t -> troopTarget t == factoryId f) troopsArriving
+            defending = factoryCyborgs f + sum (map troopCyborgs $
+                                                filter (\t -> troopOwner t == factoryOwner f) $
+                                                troopsArrivingHere)
+            attacking = sum (map troopCyborgs $
+                             filter (\t -> troopOwner t /= factoryOwner f) $
+                             troopsArrivingHere)
+            attackingPlayer = if factoryOwner f == opponent
+                              then thisPlayer
+                              else opponent
+
+explodeBombs gs =
+   gs { gsFactories = foldl explodeBomb (gsFactories gs) bombsArrived
+      , gsBombs     = bombsInTransit
+      }
+   where
+      (bombsArrived, bombsInTransit) = partition (\b -> bombDelay b <= 0) (gsBombs gs)
+      explodeBomb fs b = flip map fs $ \f ->
+         if factoryId f /= bombTarget b then f else
+         f { factoryCyborgs = max 0 (factoryCyborgs f - max 10 (factoryCyborgs f `div` 2))
+           , factoryDelay   = 5
+           }