From 05ba371d66271ffebd88878231d2fe47da7ea75e Mon Sep 17 00:00:00 2001 From: Jesse McDonald Date: Sun, 2 Oct 2016 12:09:10 -0500 Subject: [PATCH] Hypersonic contest -- Final version --- Contests/Hypersonic/Hypersonic.hs | 481 ++++++++++++++++++++++++++++++ Contests/Hypersonic/test.in | 14 + 2 files changed, 495 insertions(+) create mode 100644 Contests/Hypersonic/Hypersonic.hs create mode 100644 Contests/Hypersonic/test.in diff --git a/Contests/Hypersonic/Hypersonic.hs b/Contests/Hypersonic/Hypersonic.hs new file mode 100644 index 0000000..5a8f36b --- /dev/null +++ b/Contests/Hypersonic/Hypersonic.hs @@ -0,0 +1,481 @@ +{-# 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: diff --git a/Contests/Hypersonic/test.in b/Contests/Hypersonic/test.in new file mode 100644 index 0000000..9320acd --- /dev/null +++ b/Contests/Hypersonic/test.in @@ -0,0 +1,14 @@ +13 11 0 +............. +............. +............. +............. +............. +............. +............. +............. +............. +............. +............. +1 +0 0 0 0 0 3