From 7ecb72ff04936c537889268ae2108a0f444d26e2 Mon Sep 17 00:00:00 2001 From: Abhinav Sarkar Date: Thu, 16 Jul 2015 02:33:19 +0530 Subject: [PATCH] Major refactoring to use Monads for the game engine. Also adds support for boost change and refill. --- hastron.cabal | 3 + src/Hastron/Game/Engine.hs | 169 ++++++++++++++++++++++++++----------- src/Hastron/Game/Types.hs | 55 +++++++----- 3 files changed, 154 insertions(+), 73 deletions(-) diff --git a/hastron.cabal b/hastron.cabal index 33410fa..284710a 100644 --- a/hastron.cabal +++ b/hastron.cabal @@ -22,6 +22,9 @@ executable hastron build-depends: base >=4.7 && <4.9, text >=1.2 && <1.3, unordered-containers >=0.2.5 && <0.3, + dlist >= 0.7 && <0.8, + mtl >= 2.2 && <2.3, hashable >=1.2 && <1.3 hs-source-dirs: src default-language: Haskell2010 + ghc-options: -Wall diff --git a/src/Hastron/Game/Engine.hs b/src/Hastron/Game/Engine.hs index 4de4050..7bfa90c 100644 --- a/src/Hastron/Game/Engine.hs +++ b/src/Hastron/Game/Engine.hs @@ -1,11 +1,20 @@ -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RecordWildCards #-} module Hastron.Game.Engine where -import qualified Data.HashMap.Strict as Map -import qualified Data.HashSet as Set -import Data.List (foldl') +import Control.Applicative (Applicative) +import Control.Monad.Identity (Identity, runIdentity) +import Control.Monad.Reader (MonadReader, ask) +import Control.Monad.RWS (MonadRWS, RWST, execRWST) +import Control.Monad.State (MonadState, get, put) +import Control.Monad.Writer (MonadWriter, tell) +import Data.DList (DList) +import qualified Data.DList as DList +import qualified Data.HashMap.Strict as Map +import qualified Data.HashSet as Set +import Data.List (foldl') import Hastron.Game.Types -import Prelude hiding (Left, Right) +import Prelude hiding (Left, Right) leftTurn :: Direction -> Direction leftTurn Left = Down @@ -22,69 +31,127 @@ rightTurn Down = Left noTurn :: Direction -> Direction noTurn = id -move :: Int -> Point -> Velocity -> PlayerTrail -move timeElapsed (x, y) (Velocity speed dir) = move' dir +newtype GameEngine a = + GameEngine { _runGameEngine :: RWST GameSettings (DList OutEvent) (GameMap, Player) Identity a } + deriving ( Functor + , Applicative + , Monad + , MonadReader GameSettings + , MonadWriter (DList OutEvent) + , MonadState (GameMap, Player) + , MonadRWS GameSettings (DList OutEvent) (GameMap, Player)) + +stepGameEngine :: GameSettings -> GameMap -> Player -> GameEngine () -> (GameMap, Player, [OutEvent]) +stepGameEngine gameSettings gameMap player = + (\((gameMap', player'), outEvents) -> (gameMap', player', DList.toList outEvents)) + . runIdentity + . (\rwst -> execRWST rwst gameSettings (gameMap, player)) + . _runGameEngine + +move :: Int -> GameEngine () +move timeElapsed = do + state <- get + settings <- ask + go settings state where - dist = timeElapsed * speed + go GameSettings{..} + (gameMap@GameMap{..}, player@Player{playerBoost = playerBoost@PlayerBoost{..}, ..}) + | playerState /= PlayerAlive || timeElapsed < 0 = return () + | not boostActive || boostFuel >= timeElapsed = movePlayer + | otherwise = + move boostFuel >> move (timeElapsed - boostFuel) + where + (x, y) = playerPosition + (Velocity speed dir) = playerVelocity + dist = + timeElapsed * speed * (if boostActive && boostFuel > 0 then gameBoostFactor else 1) - move' Left = tail [(x', y) | x' <- [x, x - 1 .. x - dist]] - move' Right = tail [(x', y) | x' <- [x .. x + dist]] - move' Up = tail [(x, y') | y' <- [y, y - 1 .. y - dist]] - move' Down = tail [(x, y') | y' <- [y .. y + dist]] + move' Left = tail [(x', y) | x' <- [x, x - 1 .. x - dist]] + move' Right = tail [(x', y) | x' <- [x .. x + dist]] + move' Up = tail [(x, y') | y' <- [y, y - 1 .. y - dist]] + move' Down = tail [(x, y') | y' <- [y .. y + dist]] -turn :: (Direction -> Direction) -> Velocity -> Velocity -turn turnFn (Velocity speed dir) = - Velocity speed $ turnFn dir + checkTrail trail = + let trail' = takeWhile (not . flip Set.member gameMapBlockedPoints) trail + in if trail' == trail + then (trail, PlayerAlive) + else (trail', PlayerDead) -moveAndTurn :: (Direction -> Direction) -> Int -> Point -> Velocity -> (PlayerTrail, Velocity) -moveAndTurn turnFn timeElapsed point vel = - (move timeElapsed point vel, turn turnFn vel) + movePlayer = do + let + revTrail = move' dir + (checkedTrail, playerState') = checkTrail revTrail + trail = reverse checkedTrail + pos' = if null trail then playerPosition else head trail + boostFuel' = if boostActive then boostFuel - timeElapsed else boostFuel -checkTrail :: GameMap -> PlayerTrail -> (PlayerTrail, PlayerState) -checkTrail GameMap{..} trail = - let trail' = takeWhile (not . flip Set.member gameMapBlockedPoints) trail - in if trail' == trail - then (trail, PlayerAlive) - else (trail', PlayerDead) + player' = player { playerState = playerState' + , playerPosition = pos' + , playerTrail = trail ++ playerTrail + , playerBoost = playerBoost { boostFuel = boostFuel' } + } + gameMap' = gameMap { gameMapBlockedPoints = + foldl' (flip Set.insert) gameMapBlockedPoints trail } + outEvents = [OutPlayerStateChange playerId playerState' | playerState /= playerState'] + + put (gameMap', player') + tell $ DList.fromList outEvents + +turn :: (Direction -> Direction) -> GameEngine () +turn turnFn = get >>= go + where + go (gameMap, player@Player{playerVelocity = Velocity speed dir}) = + put ( gameMap, player { playerVelocity = Velocity speed $ turnFn dir }) + +changeBoost :: Bool -> GameEngine () +changeBoost boostActive = get >>= go + where + go (gameMap, player@Player{..}) = + put (gameMap, player { playerBoost = playerBoost { boostActive = boostActive } }) + +refillBoost :: Int -> GameEngine () +refillBoost timeElapsed = do + state <- get + settings <- ask + go settings state + where + go GameSettings{..} (gameMap, player@Player{..}) = do + let boostFuel' = floor (fromIntegral timeElapsed * gameBoostRefillFactor) + playerBoost' = playerBoost { boostFuel = boostFuel' } + put (gameMap, player { playerBoost = playerBoost' }) + tell $ DList.fromList [OutPlayerBoostChange playerId playerBoost' | playerBoost /= playerBoost'] stepGame :: Game -> Int -> InEvent -> (Game, [OutEvent]) stepGame game@Game{gameMap = gameMap@GameMap{..}, ..} time = stepGame' where - stepGame' (InPlayerTurnLeft playerId) = - stepTurnEvent playerId $ moveAndTurn leftTurn - stepGame' (InPlayerTurnRight playerId) = - stepTurnEvent playerId $ moveAndTurn rightTurn - stepGame' (InPlayerIdle playerId) = - stepTurnEvent playerId $ moveAndTurn noTurn + stepGame' (InPlayerTurnLeft playerId) = stepEvent playerId $ turn leftTurn + stepGame' (InPlayerTurnRight playerId) = stepEvent playerId $ turn rightTurn + stepGame' (InPlayerIdle playerId) = stepEvent playerId $ turn noTurn + stepGame' (InPlayerBoostChange playerId boostActive) = stepEvent playerId $ changeBoost boostActive - stepTurnEvent pId moveFn = + stepEvent pId step = flip (maybe (game, [])) (Map.lookup pId gamePlayers) $ \player@Player{..} -> if playerState /= PlayerAlive then (game, []) else let - (revTrail, vel'@(Velocity _ dir')) = moveFn (time - playerLastEvent) playerPosition playerVelocity - (checkedTrail, playerState') = checkTrail gameMap revTrail - trail = reverse checkedTrail - pos' = if null trail then playerPosition else head trail - player' = player { playerState = playerState' - , playerPosition = pos' - , playerVelocity = vel' - , playerTrail = trail ++ playerTrail - , playerScore = playerScore + score playerPosition pos' - , playerLastEvent = time - } - gameMap' = gameMap { gameMapBlockedPoints = - foldl' (flip Set.insert) gameMapBlockedPoints trail } - game' = game { gamePlayers = Map.insert playerId player' gamePlayers - , gameMap = gameMap' } - outEvents = OutPlayerPosition playerId pos' dir' : - [OutPlayerStateChange playerId playerState' | playerState /= playerState'] - in (game', outEvents) + timeElapsed = (time - playerLastEventTime) + fullStep = move timeElapsed >> step >> refillBoost timeElapsed + + (gameMap', player'@Player{ playerPosition = pos' + , playerVelocity = Velocity _ dir' }, outEvents) = + stepGameEngine gameSettings gameMap player fullStep + + player'' = player' { playerScore = playerScore + score playerPosition pos' + , playerLastEventTime = time } + game' = game { gamePlayers = Map.insert playerId player'' gamePlayers + , gameMap = gameMap' } + outEvents' = outEvents ++ [OutPlayerPosition playerId pos' dir'] + in (game', outEvents') score (x1, y1) (x2, y2) = abs (x1 - x2) + abs (y1 - y2) runGame :: Game -> [(Int, InEvent)] -> (Game, [OutEvent]) -runGame initialGame inEvents = +runGame initialGame = foldl (\(game, outEvents) (time, inEvent) -> fmap (outEvents ++) $ stepGame game time inEvent) - (initialGame, []) inEvents + (initialGame, []) diff --git a/src/Hastron/Game/Types.hs b/src/Hastron/Game/Types.hs index 9eb78b9..d045909 100644 --- a/src/Hastron/Game/Types.hs +++ b/src/Hastron/Game/Types.hs @@ -24,19 +24,19 @@ data PlayerState = PlayerAlive type PlayerTrail = [Point] data PlayerBoost = PlayerBoost { boostActive :: Bool - , boostFuel :: Double + , boostFuel :: Int } deriving (Show, Eq) type PlayerScore = Int -data Player = Player { playerId :: PlayerId - , playerState :: PlayerState - , playerPosition :: Point - , playerVelocity :: Velocity - , playerTrail :: PlayerTrail - , playerBoost :: PlayerBoost - , playerScore :: PlayerScore - , playerLastEvent :: Int +data Player = Player { playerId :: PlayerId + , playerState :: PlayerState + , playerPosition :: Point + , playerVelocity :: Velocity + , playerTrail :: PlayerTrail + , playerBoost :: PlayerBoost + , playerScore :: PlayerScore + , playerLastEventTime :: Int } deriving (Show, Eq) data PlayerEndState = PlayerWinner | PlayerLoser | PlayerDropped @@ -49,41 +49,52 @@ data GameMap = GameMap { size :: Int , gameMapBlockedPoints :: HashSet Point } deriving (Show, Eq) -data Game = Game { gamePlayers :: HashMap PlayerId Player - , gameState :: GameState - , gameMap :: GameMap +data GameSettings = GameSettings { gameBoostFactor :: Int + , gameBoostRefillFactor :: Double + } + deriving (Show, Eq) + +data Game = Game { gamePlayers :: HashMap PlayerId Player + , gameState :: GameState + , gameSettings :: GameSettings + , gameMap :: GameMap } deriving (Show, Eq) type GameResult = HashMap PlayerId (PlayerScore, PlayerEndState) data InEvent = InPlayerTurnLeft PlayerId | InPlayerTurnRight PlayerId - | InPlayerBoostActivate PlayerId - | InPlayerBoostDeactivate PlayerId + | InPlayerBoostChange PlayerId Bool | InPlayerStateChange PlayerId PlayerState | InPlayerIdle PlayerId deriving (Show, Eq, Ord) data OutEvent = OutPlayerPosition PlayerId Point Direction | OutPlayerStateChange PlayerId PlayerState + | OutPlayerBoostChange PlayerId PlayerBoost | OutGameStateChange GameState | OutGameOver GameResult deriving (Show, Eq) -emptyGameMap :: Int -> GameMap -emptyGameMap size = GameMap size $ Set.fromList borderPoints +newGameMap :: Int -> GameMap +newGameMap size = GameMap size $ Set.fromList borderPoints where borderPoints = let xs = [(x, y) | x <- [-1, size], y <- [0 .. size - 1]] in xs ++ map swap xs -emptyGame :: Int -> Game -emptyGame size = Game Map.empty GameInit $ emptyGameMap size +newGame :: Int -> GameSettings -> Game +newGame size gameSettings = Game { gamePlayers = Map.empty + , gameState = GameInit + , gameSettings = gameSettings + , gameMap = newGameMap size + } -newPlayer :: Int -> Point -> Velocity -> Double -> Player -newPlayer pId pos velocity boost = Player pId PlayerAlive pos velocity [pos] (PlayerBoost False boost) 0 0 +newPlayer :: Int -> Point -> Velocity -> Int -> Player +newPlayer pId pos velocity boost = + Player pId PlayerAlive pos velocity [pos] (PlayerBoost False boost) 0 0 addPlayer :: Game -> Player -> Game addPlayer game@Game{gameMap = gameMap@GameMap{..}, ..} player@Player{..} = game { gamePlayers = Map.insert playerId player gamePlayers - , gameMap = gameMap { gameMapBlockedPoints = - Set.insert playerPosition gameMapBlockedPoints }} + , gameMap = gameMap { gameMapBlockedPoints = + Set.insert playerPosition gameMapBlockedPoints }}