482 lines
17 KiB
Haskell
482 lines
17 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-deprecated-flags #-}
|
|
{-# LANGUAGE LambdaCase, TupleSections, ImplicitParams, ConstraintKinds #-}
|
|
{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses #-}
|
|
{-# LANGUAGE UndecidableInstances, OverlappingInstances, ExplicitForAll #-}
|
|
{-# LANGUAGE RankNTypes, TypeFamilies #-}
|
|
|
|
import Control.Applicative
|
|
import Control.Arrow (first, second)
|
|
import Control.DeepSeq
|
|
import Control.Monad
|
|
import Control.Monad.Writer
|
|
import Data.Array (Array,Ix,(//),(!))
|
|
import Data.Function
|
|
import Data.Functor.Identity
|
|
import Data.IORef
|
|
import Data.List
|
|
import Data.Map (Map,(\\))
|
|
import Data.Maybe
|
|
import Data.Monoid
|
|
import Data.Set (Set)
|
|
import Debug.Trace
|
|
import Prelude hiding (fst, snd)
|
|
import System.IO
|
|
import System.Random
|
|
|
|
import qualified Data.Array as A
|
|
import qualified Data.Map as M
|
|
import qualified Data.Set as S
|
|
|
|
data Cell = EmptyC | BoxC (Maybe ItemType) | WallC
|
|
deriving (Eq,Show)
|
|
|
|
type Grid a = Array (Int, Int) a
|
|
|
|
type PlayerID = Int
|
|
type Position = (Int, Int)
|
|
|
|
data Player = Player { playerId :: PlayerID
|
|
, playerPos :: Position
|
|
, bombsLeft :: Int
|
|
, playerRange :: Int
|
|
} deriving Show
|
|
|
|
playerPosL :: Lens' Player Position
|
|
playerPosL f p = (\pos' -> p { playerPos = pos' }) <$> f (playerPos p)
|
|
|
|
playerRangeL :: Lens' Player Int
|
|
playerRangeL f p = (\r' -> p { playerRange = r' }) <$> f (playerRange p)
|
|
|
|
bombsLeftL :: Lens' Player Int
|
|
bombsLeftL f p = (\b' -> p { bombsLeft = b' }) <$> f (bombsLeft p)
|
|
|
|
data Bomb = Bomb { bombOwner :: PlayerID
|
|
, bombPos :: Position
|
|
, bombCountdown :: Int
|
|
, bombRange :: Int
|
|
} deriving Show
|
|
|
|
data ItemType = ExtraRange | ExtraBomb
|
|
deriving (Eq,Ord,Enum,Bounded,Read,Show)
|
|
|
|
data Item = Item { itemPos :: Position
|
|
, itemType :: ItemType
|
|
} deriving Show
|
|
|
|
data Entity = P Player | B Bomb | I Item deriving Show
|
|
|
|
data GameData = GameData { _gridWidth :: Int
|
|
, _gridHeight :: Int
|
|
, _myId :: PlayerID
|
|
} deriving Show
|
|
|
|
type HasGameData = (?gameData :: GameData)
|
|
|
|
data GameState = GameState { gameGrid :: Grid Cell
|
|
, gamePlayers :: [Player]
|
|
, gameBombs :: [Bomb]
|
|
, gameItems :: [Item]
|
|
, gamePaths :: Map Position [Position]
|
|
} deriving Show
|
|
|
|
gamePlayersL :: Lens' GameState [Player]
|
|
gamePlayersL f gs = (\ps' -> gs { gamePlayers = ps' }) <$> f (gamePlayers gs)
|
|
|
|
gameBombsL :: Lens' GameState [Bomb]
|
|
gameBombsL f gs = (\bs' -> gs { gameBombs = bs' }) <$> f (gameBombs gs)
|
|
|
|
gameItemsL :: Lens' GameState [Item]
|
|
gameItemsL f gs = (\is' -> gs { gameItems = is' }) <$> f (gameItems gs)
|
|
|
|
gamePathsL :: Lens' GameState (Map Position [Position])
|
|
gamePathsL f gs = (\ps' -> gs { gamePaths = ps' }) <$> f (gamePaths gs)
|
|
|
|
data Action = MOVE | BOMB deriving (Eq,Ord,Enum,Bounded,Read,Show)
|
|
|
|
gridWidth, gridHeight :: HasGameData => Int
|
|
gridWidth = _gridWidth ?gameData
|
|
gridHeight = _gridHeight ?gameData
|
|
|
|
myId :: HasGameData => PlayerID
|
|
myId = _myId ?gameData
|
|
|
|
main = do
|
|
hSetBuffering stdout NoBuffering -- DO NOT REMOVE
|
|
|
|
gameData <- (\[w,h,myId] -> GameData w h myId)
|
|
. map read . words
|
|
<$> getLine
|
|
|
|
let ?gameData = gameData in loop
|
|
|
|
loop :: HasGameData => IO ()
|
|
loop = do
|
|
target <- newIORef (0, 0)
|
|
best <- newIORef []
|
|
forever $ do
|
|
grid <- getGrid
|
|
nEntities <- readLn
|
|
entities <- replicateM nEntities getEntity
|
|
|
|
let gs = GameState { gameGrid = grid
|
|
, gamePlayers = [ p | P p <- entities ]
|
|
, gameBombs = [ b | B b <- entities ]
|
|
, gameItems = [ i | I i <- entities ]
|
|
, gamePaths = pathsFrom gs myId
|
|
}
|
|
|
|
chooseAction target best gs 0
|
|
|
|
chooseAction :: HasGameData => IORef Position
|
|
-> IORef [Position]
|
|
-> GameState
|
|
-> Int
|
|
-> IO ()
|
|
chooseAction target best gs = fix $ \redo retries -> do
|
|
let Just me = find (\p -> playerId p == myId) (gamePlayers gs)
|
|
let iSurvive = any (\p -> playerId p == myId) . gamePlayers
|
|
|
|
targetPos <- readIORef target
|
|
bestPos <- readIORef best
|
|
|
|
let score (act, trg, acts) = do
|
|
guard $ act /= BOMB || bombsLeft me > 0
|
|
path <- M.lookup trg (gamePaths gs)
|
|
let (ptsMap, gs'') = simulate gs $ zip (act : acts ++ repeat MOVE) (tail path)
|
|
guard $ iSurvive gs''
|
|
let Just me' = find (\p -> playerId p == myId) (gamePlayers gs'')
|
|
let boxes = getSum $ M.findWithDefault 0 myId ptsMap
|
|
let kills = length (gamePlayers gs) - length (gamePlayers gs'')
|
|
let total = getSum . execWriter $ do
|
|
tell . Sum $ (12 * boxes)^2
|
|
tell . Sum $ 10 * kills
|
|
when (trg /= playerPos me) $ tell (Sum 20)
|
|
when (trg == targetPos) $ tell (Sum 15)
|
|
tell . Sum $ 5 * playerRange me
|
|
tell . Sum $ 3 * bombsLeft me
|
|
tell . Sum $ max 0 (5 - length path `div` 2)
|
|
pure (total, (act, trg, path, gs''))
|
|
|
|
targets <- fmap S.toList . execWriterT $ do
|
|
tell $ S.singleton targetPos
|
|
tell $ S.fromList bestPos
|
|
tell $ S.fromList $ do
|
|
let (x0,y0) = playerPos me
|
|
x <- [x0-2..x0+2]
|
|
guard $ 0 <= x && x < gridWidth
|
|
y <- [y0-2..y0+2]
|
|
guard $ 0 <= y && y < gridHeight
|
|
pure (x,y)
|
|
tell . S.fromList =<< liftIO (replicateM 25 $ randomTarget gs)
|
|
|
|
actions' <- (fmap (,) [MOVE,BOMB] <*>) <$> shuffleIO targets
|
|
actions <- forM actions' $ \(act,trg) -> do
|
|
delay <- randomRIO (0,8)
|
|
pure (act, trg, replicate delay MOVE ++ [BOMB])
|
|
let scores = sortBy (flip compare `on` fst) $ mapMaybe score actions
|
|
|
|
-- forM_ scores $ \(sc, (act, trg, path, _)) -> do
|
|
-- traceM $ fromWords "SCORE:" sc act path
|
|
|
|
writeIORef best . map (snd . snd) . take 15 $ scores
|
|
|
|
case scores of
|
|
((_, (action, trg, path, gs')):_) -> do
|
|
when (trg /= targetPos) $ target .= pure trg
|
|
let (myX, myY) = playerPos me
|
|
let (nx, ny) = case path of { (_:(x,y):_) -> (x,y); _ -> (myX,myY) }
|
|
putStrLn $ fromWords action nx ny
|
|
_ -> do
|
|
target .= randomTarget gs
|
|
if retries < 5 then
|
|
redo (retries + 1)
|
|
else
|
|
let (myX, myY) = playerPos me
|
|
in trace "Stuck!" $ putStrLn $ fromWords MOVE myX myY
|
|
|
|
mwhen :: Monoid m => m -> Bool -> m
|
|
mwhen x False = mempty
|
|
mwhen x True = x
|
|
|
|
shuffleIO :: [a] -> IO [a]
|
|
shuffleIO [] = pure []
|
|
shuffleIO xs = do
|
|
n <- randomRIO (0, length xs - 1)
|
|
let (as, x:bs) = splitAt n xs
|
|
(x:) <$> shuffleIO (as ++ bs)
|
|
|
|
getGrid :: HasGameData => IO (Grid Cell)
|
|
getGrid = A.array ((0,0),(gridWidth-1,gridHeight-1))
|
|
. concat . zipWith (\y -> map (\(x,v) -> ((x,y),v))) [0..]
|
|
<$> replicateM gridHeight (zip [0..] . map readCell <$> getLine)
|
|
|
|
readCell '.' = EmptyC
|
|
readCell '0' = BoxC Nothing
|
|
readCell '1' = BoxC (Just ExtraRange)
|
|
readCell '2' = BoxC (Just ExtraBomb)
|
|
readCell 'X' = WallC
|
|
|
|
getEntity = flip fmap (map read . words <$> getLine) $
|
|
\[entityType,owner,x,y,p1,p2] -> case entityType of
|
|
0 -> P $ Player owner (x,y) p1 p2
|
|
1 -> B $ Bomb owner (x,y) p1 p2
|
|
2 -> I $ Item (x,y) (decodeItemType p1)
|
|
|
|
decodeItemType 1 = ExtraRange
|
|
decodeItemType 2 = ExtraBomb
|
|
|
|
randomTarget :: HasGameData => GameState -> IO Position
|
|
randomTarget gs = join $ maybe randomPosIO pure <$> randomItemIO (nubOrd targets)
|
|
where
|
|
randomPosIO = (,) <$> randomRIO (0, gridWidth - 1)
|
|
<*> randomRIO (0, gridHeight - 1)
|
|
targets = [ p' | (p, BoxC _) <- A.assocs (gameGrid gs)
|
|
, p' <- neighbours p
|
|
, (gameGrid gs)!p' == EmptyC
|
|
, not (any (\b -> bombPos b == p') (gameBombs gs))
|
|
] ++ map itemPos (gameItems gs)
|
|
++ map playerPos (gamePlayers gs)
|
|
nubOrd = S.toList . S.fromList
|
|
|
|
neighbours :: HasGameData => Position -> [Position]
|
|
neighbours (x0,y0) =
|
|
[ (x,y) | (x,y) <- [(x0-1,y0),(x0+1,y0),(x0,y0-1),(x0,y0+1)]
|
|
, x >= 0, y >= 0, x < gridWidth, y < gridHeight ]
|
|
|
|
randomItemIO :: [a] -> IO (Maybe a)
|
|
randomItemIO xs
|
|
| null xs = pure Nothing
|
|
| otherwise = Just . (xs!!) <$> randomRIO (0, length xs - 1)
|
|
|
|
gamePlayerById :: PlayerID -> GameState -> Maybe Player
|
|
gamePlayerById plId = find (\p -> playerId p == plId) . gamePlayers
|
|
|
|
pathsFrom :: HasGameData => GameState -> PlayerID -> Map Position [Position]
|
|
pathsFrom gs plId = go M.empty $ M.singleton plPos [plPos]
|
|
where
|
|
Just plPos = playerPos <$> gamePlayerById plId gs
|
|
go visited fringe
|
|
| M.null fringe' = visited'
|
|
| otherwise = go visited' fringe'
|
|
where
|
|
visited' = visited <> fringe
|
|
fringe' = M.fromList
|
|
[ (pos', path ++ [pos'])
|
|
| (pos@(x,y), path) <- M.toList fringe
|
|
, pos'@(nx, ny) <- [ (x-1,y),(x+1,y),(x,y-1),(x,y+1) ]
|
|
, nx >= 0, ny >= 0, nx < gridWidth, ny < gridHeight
|
|
, not (M.member pos' visited')
|
|
, not (blocked pos') || pos' == plPos
|
|
]
|
|
blocked p = (gameGrid gs)!p /= EmptyC || S.member p obstacles
|
|
obstacles = S.fromList $ bombPos <$> gameBombs gs
|
|
|
|
simulate :: HasGameData => GameState -> [(Action, Position)] -> (Map PlayerID (Sum Int), GameState)
|
|
simulate gs0 path
|
|
| null path && null (gameBombs gs0) = (M.empty, gs0)
|
|
| otherwise = (ptsMap1 <> ptsMap2, gs3)
|
|
where
|
|
(ptsMap1, gs1) = step gs0
|
|
maybeMe = find (\p -> playerId p == myId) (gamePlayers gs1)
|
|
(gs2, path') = case path of
|
|
((act,pos):path') | (gameGrid gs0)!pos == EmptyC
|
|
, not (any (\b -> bombPos b == pos) $ gameBombs gs1)
|
|
-> let gs' = over gamePlayersL (map (updatePlayer pos)) gs1
|
|
gs'' = set gamePathsL (pathsFrom gs' myId) gs'
|
|
in (,path') . ($ gs'') $ case act of
|
|
BOMB | Just me <- maybeMe, bombsLeft me > 0
|
|
-> over gameBombsL (newBomb me :)
|
|
_ -> id
|
|
_ -> (gs1, [])
|
|
(ptsMap2, gs3) = simulate gs2 path'
|
|
updatePlayer pos p
|
|
| playerId p == myId = set playerPosL pos p
|
|
| otherwise = p
|
|
newBomb p = Bomb { bombOwner = playerId p
|
|
, bombPos = playerPos p
|
|
, bombCountdown = 8
|
|
, bombRange = playerRange p
|
|
}
|
|
|
|
step :: HasGameData => GameState -> (Map PlayerID (Sum Int), GameState)
|
|
step gs = ptsMap `deepseq` newGrid `deepseq` (ptsMap, gs')
|
|
where
|
|
bombs = map timeStep $ gameBombs gs
|
|
timeStep b = b { bombCountdown = bombCountdown b - 1 }
|
|
expired b = bombCountdown b < 1
|
|
(expiredBombs, remainingBombs0) = partition expired bombs
|
|
(explodedBombs, remainingBombs) = explodeBombs gs expiredBombs remainingBombs0
|
|
boxesDestroyed = [ ((pos, itm), (bombOwner b, Sum 1))
|
|
| (pos, BoxC itm) <- A.assocs (gameGrid gs)
|
|
, b <- explodedBombs
|
|
, bombInRange gs pos b
|
|
]
|
|
itemsCollected = M.fromListWith (<>)
|
|
$ [ (playerId p, [itemType i])
|
|
| p <- gamePlayers gs
|
|
, i <- gameItems gs
|
|
, itemPos i == playerPos p
|
|
]
|
|
items' = filter (not . \i -> any (bombInRange gs (itemPos i)) explodedBombs
|
|
|| any (\p -> playerPos p == itemPos i) (gamePlayers gs))
|
|
(gameItems gs)
|
|
++ [ Item { itemPos = p, itemType = i } | ((p, Just i), _) <- boxesDestroyed ]
|
|
players' = map (\p -> foldl' applyItem p $ M.findWithDefault [] (playerId p) itemsCollected)
|
|
$ map (\p -> over bombsLeftL (+ countBombs (playerId p)) p)
|
|
$ filter (not . \p -> any (bombInRange gs (playerPos p)) explodedBombs)
|
|
(gamePlayers gs)
|
|
countBombs plId = length $ filter (\b -> bombOwner b == plId) explodedBombs
|
|
applyItem = flip $ \case
|
|
ExtraRange -> over playerRangeL (+1)
|
|
ExtraBomb -> over bombsLeftL (+1)
|
|
ptsMap = M.map getSum $ M.fromListWith (<>) $ map snd boxesDestroyed
|
|
newGrid = gameGrid gs // [ (p, EmptyC) | ((p, _), _) <- boxesDestroyed ]
|
|
gs' = gs { gameGrid = newGrid
|
|
, gamePlayers = players'
|
|
, gameBombs = remainingBombs
|
|
, gameItems = items'
|
|
}
|
|
|
|
explodeBombs :: GameState -> [Bomb] -> [Bomb] -> ([Bomb], [Bomb])
|
|
explodeBombs gs triggered remaining
|
|
| null triggered' = (triggered, remaining)
|
|
| otherwise = first (triggered++) $
|
|
explodeBombs gs triggered' remaining'
|
|
where
|
|
isTriggered b = any (bombInRange gs (bombPos b)) triggered
|
|
(triggered', remaining') = partition isTriggered remaining
|
|
|
|
bombInRange :: GameState -> Position -> Bomb -> Bool
|
|
bombInRange gs (x,y) b
|
|
= (x == bx && y > (by - r) && y <= by && allEmpty [(x,y')|y'<-[y+1..by-1]])
|
|
|| (x == bx && y >= by && y < (by + r) && allEmpty [(x,y')|y'<-[by+1..y-1]])
|
|
|| (y == by && x > (bx - r) && x <= bx && allEmpty [(x',y)|x'<-[x+1..bx-1]])
|
|
|| (y == by && x >= bx && x < (bx + r) && allEmpty [(x',y)|x'<-[bx+1..x-1]])
|
|
where
|
|
allEmpty ps =
|
|
and [ all (\p -> (gameGrid gs)!p == EmptyC) ps
|
|
, all (\b -> not (bombPos b `elem` ps)) (gameBombs gs)
|
|
, all (\i -> not (itemPos i `elem` ps)) (gameItems gs)
|
|
]
|
|
(bx, by) = bombPos b
|
|
r = bombRange b
|
|
|
|
inGrid :: HasGameData => Position -> Bool
|
|
inGrid (x, y) = x >= 0 && y >= 0 && x < gridWidth && y < gridHeight
|
|
|
|
(.=) :: IORef a -> IO a -> IO ()
|
|
r .= m = m >>= writeIORef r
|
|
infixr 1 .=
|
|
|
|
(%=) :: IORef a -> (a -> IO a) -> IO ()
|
|
r %= f = readIORef r >>= f >>= writeIORef r
|
|
infixr 1 %=
|
|
|
|
instance NFData Cell where rnf x = x `seq` ()
|
|
|
|
class IsWord a where
|
|
fromWord :: a -> String
|
|
|
|
instance IsWord String where
|
|
fromWord = id
|
|
{-# INLINABLE fromWord #-}
|
|
|
|
instance {-# OVERLAPPABLE #-} Show a => IsWord a where
|
|
fromWord = show
|
|
{-# INLINABLE fromWord #-}
|
|
|
|
class Words a r where
|
|
fromWords' :: (String -> String) -> a -> r
|
|
|
|
instance (IsWord a, Words b r) => Words a ((->) b r) where
|
|
fromWords' s a = fromWords' (s . (fromWord a ++) . (" " ++))
|
|
{-# INLINABLE fromWords' #-}
|
|
|
|
instance IsWord a => Words a String where
|
|
fromWords' s a = s (fromWord a)
|
|
{-# INLINABLE fromWords' #-}
|
|
|
|
fromWords :: Words a r => a -> r
|
|
fromWords = fromWords' id
|
|
|
|
type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t
|
|
type Lens' s a = Lens s s a a
|
|
|
|
view :: Lens s t a b -> s -> a
|
|
view l = getConst . l Const
|
|
|
|
over :: Lens s t a b -> (a -> b) -> s -> t
|
|
over l f = runIdentity . l (Identity . f)
|
|
|
|
set :: Lens s t a b -> b -> s -> t
|
|
set l x = over l (const x)
|
|
|
|
fst :: Tuple1 s => s -> Elem1 s
|
|
fst = view _1
|
|
|
|
snd :: Tuple2 s => s -> Elem2 s
|
|
snd = view _2
|
|
|
|
class Tuple1 s where
|
|
type Elem1 s
|
|
type Repl1 s b
|
|
_1 :: Lens s (Repl1 s b) (Elem1 s) b
|
|
|
|
class Tuple1 s => Tuple2 s where
|
|
type Elem2 s
|
|
type Repl2 s b
|
|
_2 :: Lens s (Repl2 s b) (Elem2 s) b
|
|
|
|
class Tuple2 s => Tuple3 s where
|
|
type Elem3 s
|
|
type Repl3 s b
|
|
_3 :: Lens s (Repl3 s b) (Elem3 s) b
|
|
|
|
class Tuple3 s => Tuple4 s where
|
|
type Elem4 s
|
|
type Repl4 s b
|
|
_4 :: Lens s (Repl4 s b) (Elem4 s) b
|
|
|
|
instance Tuple1 (a,b) where
|
|
type Elem1 (a,b) = a
|
|
type Repl1 (a,b) a' = (a',b)
|
|
_1 f (a,b) = fmap (,b) (f a)
|
|
instance Tuple2 (a,b) where
|
|
type Elem2 (a,b) = b
|
|
type Repl2 (a,b) b' = (a,b')
|
|
_2 f (a,b) = fmap (a,) (f b)
|
|
|
|
instance Tuple1 (a,b,c) where
|
|
type Elem1 (a,b,c) = a
|
|
type Repl1 (a,b,c) a' = (a',b,c)
|
|
_1 f (a,b,c) = fmap (,b,c) (f a)
|
|
instance Tuple2 (a,b,c) where
|
|
type Elem2 (a,b,c) = b
|
|
type Repl2 (a,b,c) b' = (a,b',c)
|
|
_2 f (a,b,c) = fmap (a,,c) (f b)
|
|
instance Tuple3 (a,b,c) where
|
|
type Elem3 (a,b,c) = c
|
|
type Repl3 (a,b,c) c' = (a,b,c')
|
|
_3 f (a,b,c) = fmap (a,b,) (f c)
|
|
|
|
instance Tuple1 (a,b,c,d) where
|
|
type Elem1 (a,b,c,d) = a
|
|
type Repl1 (a,b,c,d) a' = (a',b,c,d)
|
|
_1 f (a,b,c,d) = fmap (,b,c,d) (f a)
|
|
instance Tuple2 (a,b,c,d) where
|
|
type Elem2 (a,b,c,d) = b
|
|
type Repl2 (a,b,c,d) b' = (a,b',c,d)
|
|
_2 f (a,b,c,d) = fmap (a,,c,d) (f b)
|
|
instance Tuple3 (a,b,c,d) where
|
|
type Elem3 (a,b,c,d) = c
|
|
type Repl3 (a,b,c,d) c' = (a,b,c',d)
|
|
_3 f (a,b,c,d) = fmap (a,b,,d) (f c)
|
|
instance Tuple4 (a,b,c,d) where
|
|
type Elem4 (a,b,c,d) = d
|
|
type Repl4 (a,b,c,d) d' = (a,b,c,d')
|
|
_4 f (a,b,c,d) = fmap (a,b,c,) (f d)
|
|
|
|
instance NFData a => NFData (Sum a) where rnf (Sum x) = rnf x
|
|
|
|
-- vim:set sw=4 et:
|