Ghost in the Cell contest -- simulator version

This commit is contained in:
Jesse D. McDonald 2017-02-27 22:45:39 -06:00
parent 05ba371d66
commit 175c641522
1 changed files with 259 additions and 112 deletions

View File

@ -1,15 +1,17 @@
{-# LANGUAGE ViewPatterns, LambdaCase, DataKinds, GADTs #-} {-# LANGUAGE ViewPatterns #-}
import System.IO import System.IO
import Control.Applicative import Control.Applicative
import Control.Arrow (first, second) import Control.Arrow (first, second, (>>>))
import Control.Monad import Control.Monad
import Control.Monad.Writer
import Data.Either import Data.Either
import Data.Foldable import Data.Foldable
import Data.Function import Data.Function
import Data.IORef import Data.IORef
import Data.List import Data.List
import Data.Maybe import Data.Maybe
import Data.Monoid
import qualified Data.Map as M import qualified Data.Map as M
@ -45,6 +47,16 @@ data Action = Move FactoryId FactoryId Int
| Wait | Wait
deriving (Eq, Show) 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 :: Action -> String
actionString (Move src dst cnt) = unwords ["MOVE", show src, show dst, show cnt] actionString (Move src dst cnt) = unwords ["MOVE", show src, show dst, show cnt]
actionString (SendBomb src dst) = unwords ["BOMB", show src, show dst] actionString (SendBomb src dst) = unwords ["BOMB", show src, show dst]
@ -58,120 +70,255 @@ opponent = -1
main :: IO () main :: IO ()
main = do main = do
hSetBuffering stdout NoBuffering -- DO NOT REMOVE hSetBuffering stdout NoBuffering -- DO NOT REMOVE
factoryCount <- readLn :: IO Int -- the number of factories factoryCount <- readLn :: IO Int -- the number of factories
linkCount <- readLn :: IO Int -- the number of links between factories linkCount <- readLn :: IO Int -- the number of links between factories
links <- fmap (M.fromList . concat) $ replicateM linkCount $ do links <- fmap (M.fromList . concat) $ replicateM linkCount $ do
[f1, f2, dist] <- map read . words <$> getLine [f1, f2, dist] <- map read . words <$> getLine
pure ([((f1, f2), dist), ((f2, f1), dist)] :: [((FactoryId, FactoryId), Int)]) pure ([((f1, f2), dist), ((f2, f1), dist)] :: [((FactoryId, FactoryId), Int)])
bombsLeftRef <- newIORef 2 bombsLeftRef <- newIORef 2
turnCountRef <- newIORef 1
forever $ do forever $ do
bombsLeft <- readIORef bombsLeftRef turnCount <- readIORef turnCountRef
entityCount <- readLn :: IO Int -- the number of entities (e.g. factories and troops) bombsLeft <- readIORef bombsLeftRef
entityCount <- readLn :: IO Int -- the number of entities (e.g. factories and troops)
(partitionEithers -> (factoryList, partitionEithers -> (troopList, bombList))) <- replicateM entityCount $ do (partitionEithers -> (factoryList, partitionEithers -> (troopList, bombList))) <- replicateM entityCount $ do
((read -> entityId):entityType:(map read -> [a1,a2,a3,a4,a5])) <- words <$> getLine ((read -> entityId):entityType:(map read -> [a1,a2,a3,a4,a5])) <- words <$> getLine
pure $ case entityType of pure $ case entityType of
"FACTORY" -> Left $ Factory entityId a1 a2 a3 a4 "FACTORY" -> Left $ Factory entityId a1 a2 a3 a4
"TROOP" -> Right . Left $ Troop entityId a1 a2 a3 a4 a5 "TROOP" -> Right . Left $ Troop entityId a1 a2 a3 a4 a5
"BOMB" -> Right . Right $ Bomb entityId a1 a2 a3 a4 "BOMB" -> Right . Right $ Bomb entityId a1 a2 a3 a4
let factories = M.fromList [ (factoryId f, f) | f <- factoryList ] let nextEntity = (+1) $ maximum $ 0 : map factoryId factoryList
let myFactories = filter (\f -> factoryOwner f == thisPlayer) factoryList ++ map troopId troopList
let inTransitTo = ++ map bombId bombList
let transitMap = M.fromList
[ (to, (mine, theirs))
| let myTroops = filter (\t -> troopOwner t == thisPlayer) troopList
, let theirTroops = filter (\t -> troopOwner t /= thisPlayer) troopList
, to <- map factoryId factoryList
, let mine = sum $ map troopCyborgs $ filter (\t -> troopTarget t == to) myTroops
, let theirs = sum $ map troopCyborgs $ filter (\t -> troopTarget t == to) theirTroops
]
in \dst -> fromMaybe (0, 0) $ M.lookup dst transitMap
let myTotalProduction = sum $ map factoryProduction myFactories let gs = GameState { gsLinks = links
, gsFactories = factoryList
, gsTroops = troopList
, gsBombs = bombList
, gsMyBombsLeft = bombsLeft
, gsNextEntity = nextEntity
}
let distributeScores src = do let factories = M.fromList [ (factoryId f, f) | f <- factoryList ]
dst <- myFactories let myFactories = filter (\f -> factoryOwner f == thisPlayer) factoryList
guard $ factoryId dst /= factoryId src let inTransitTo =
let (srcDefending, srcAttacking) = inTransitTo (factoryId src) let transitMap = M.fromList
let (dstDefending, dstAttacking) = inTransitTo (factoryId dst) [ (to, (mine, theirs))
let srcTotal = factoryCyborgs src - srcAttacking | let myTroops = filter (\t -> troopOwner t == thisPlayer) troopList
let dstTotal = factoryCyborgs dst + dstDefending - dstAttacking , let theirTroops = filter (\t -> troopOwner t /= thisPlayer) troopList
guard $ 2 * srcTotal >= 3 * dstTotal , to <- map factoryId factoryList
let amount = (factoryCyborgs src + 1) `div` 3 , let mine = sum $ map troopCyborgs $ filter (\t -> troopTarget t == to) myTroops
guard $ amount > 0 , let theirs = sum $ map troopCyborgs $ filter (\t -> troopTarget t == to) theirTroops
dist <- toList $ M.lookup (factoryId src, factoryId dst) links ]
let threshold = (1.0 - saturate 20.0 (fromIntegral (factoryCyborgs src))) in \dst -> fromMaybe (0, 0) $ M.lookup dst transitMap
* (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 let distributeScores src = do
guard $ factoryCyborgs src >= 5 * factoryProduction src dst <- myFactories
dst <- filter (\f -> factoryOwner f /= thisPlayer) factoryList guard $ factoryId dst /= factoryId src
dist <- toList $ M.lookup (factoryId src, factoryId dst) links let (srcDefending, srcAttacking) = inTransitTo (factoryId src)
let (mineDefending, theirsAttacking) = inTransitTo (factoryId src) let (dstDefending, dstAttacking) = inTransitTo (factoryId dst)
let (mineAttacking, theirsDefending) = inTransitTo (factoryId dst) let srcTotal = factoryCyborgs src - srcAttacking
let myTotal = factoryCyborgs src - theirsAttacking let dstTotal = factoryCyborgs dst + dstDefending - dstAttacking
let theirTotal = factoryCyborgs dst + theirsDefending - mineAttacking let amount = (factoryCyborgs src + 1) `div` 3
let theirEstimate guard $ amount > 0 && amount <= factoryCyborgs src
| factoryOwner dst == neutralPlayer = theirTotal dist <- toList $ M.lookup (factoryId src, factoryId dst) links
| otherwise = theirTotal + factoryProduction dst * (1 + dist) pure $ Move (factoryId src) (factoryId dst) amount
guard $ 2 * myTotal >= 3 * theirTotal
let amount = theirEstimate + 1
guard $ amount > 0
let threshold = (1.0 - saturate 20.0 (fromIntegral (factoryCyborgs src)))
* (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 let attackScores src = do
guard $ factoryProduction src < 3 dst <- filter (\f -> factoryOwner f /= thisPlayer) factoryList
guard $ factoryCyborgs src >= 10 dist <- toList $ M.lookup (factoryId src, factoryId dst) links
let score = saturate 10.0 $ fromIntegral myTotalProduction let (mineDefending, theirsAttacking) = inTransitTo (factoryId src)
pure (score, [Increase (factoryId src)]) let (mineAttacking, theirsDefending) = inTransitTo (factoryId dst)
let myTotal = factoryCyborgs src - theirsAttacking
let theirTotal = factoryCyborgs dst + theirsDefending - mineAttacking
let theirEstimate
| factoryOwner dst == neutralPlayer = theirTotal
| otherwise = theirTotal + factoryProduction dst * (1 + dist)
let amount = theirEstimate + 1
guard $ amount > 0 && amount <= factoryCyborgs src
pure $ Move (factoryId src) (factoryId dst) amount
let factoryActions src = concatMap snd $ best 1 $ concatMap ($ src) $ let increaseScores src = do
[ distributeScores, attackScores, increaseScores ] guard $ factoryProduction src < 3
guard $ factoryCyborgs src >= 10
pure $ Increase (factoryId src)
let actions = concatMap factoryActions myFactories let factoryActions src = foldr mplus mempty $ map ($ src) $
[ distributeScores, attackScores, increaseScores ]
let bombActions = concatMap snd $ best 1 $ do let actions = concatMap factoryActions myFactories
guard $ bombsLeft > 0 && not (null myFactories)
dst <- filter (\f -> factoryOwner f == opponent) factoryList
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 (score, [SendBomb (factoryId src) (factoryId dst)])
let actions' = actions ++ bombActions let bombActions = do
case actions' of guard $ bombsLeft > 0 && not (null myFactories)
[] -> putStrLn $ actionString Wait guard $ bombsLeft > 1 || turnCount > 50
xs -> putStrLn $ intercalate "; " $ map actionString xs dst <- filter (\f -> factoryOwner f == opponent) factoryList
--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
]
pure $ SendBomb (factoryId src) (factoryId dst)
let isSendBomb act = case act of { SendBomb _ _ -> True; _ -> False } remainingActions <- newIORef (actions ++ bombActions)
modifyIORef bombsLeftRef (subtract $ length $ filter isSendBomb actions') chosenActions <- newIORef []
projScore <- newIORef (scoreGame (simulate [] 20 gs))
saturate :: Double -> Double -> Double fix $ \loop -> do
saturate hl x = if x < 0.0 then 0.0 else 1.0 - (2.0 ** (-x / hl)) 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 chosenActions')
modifyIORef turnCountRef (+1)
best :: Ord a => Int -> [(a, b)] -> [(a, b)] best :: Ord a => Int -> [(a, b)] -> [(a, b)]
best n = take n . sortBy (flip compare `on` fst) 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
}