abhin4v
/
hastron
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Major refactoring to use Monads for the game engine. 

Also adds support for boost change and refill.
engine-govind
Abhinav Sarkar 2015-07-16 02:33:19 +05:30
parent 1cb9490566
commit 7ecb72ff04
3 changed files with 154 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
hastron.cabal
View File

@ -22,6 +22,9 @@ executable hastron
build-depends: base >=4.7 && <4.9, build-depends: base >=4.7 && <4.9,
text >=1.2 && <1.3, text >=1.2 && <1.3,
unordered-containers >=0.2.5 && <0.3, unordered-containers >=0.2.5 && <0.3,
dlist >= 0.7 && <0.8,
mtl >= 2.2 && <2.3,
hashable >=1.2 && <1.3 hashable >=1.2 && <1.3
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall

169
src/Hastron/Game/Engine.hs
View File

@ -1,11 +1,20 @@
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
module Hastron.Game.Engine where module Hastron.Game.Engine where
import qualified Data.HashMap.Strict as Map import Control.Applicative (Applicative)
import qualified Data.HashSet as Set import Control.Monad.Identity (Identity, runIdentity)
import Data.List (foldl') 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 Hastron.Game.Types
import Prelude hiding (Left, Right) import Prelude hiding (Left, Right)
leftTurn :: Direction -> Direction leftTurn :: Direction -> Direction
leftTurn Left = Down leftTurn Left = Down
@ -22,69 +31,127 @@ rightTurn Down = Left
noTurn :: Direction -> Direction noTurn :: Direction -> Direction
noTurn = id noTurn = id
move :: Int -> Point -> Velocity -> PlayerTrail newtype GameEngine a =
move timeElapsed (x, y) (Velocity speed dir) = move' dir 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 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' Left = tail [(x', y) | x' <- [x, x - 1 .. x - dist]]
move' Right = tail [(x', y) | x' <- [x .. x + dist]] move' Right = tail [(x', y) | x' <- [x .. x + dist]]
move' Up = tail [(x, y') | y' <- [y, y - 1 .. y - dist]] move' Up = tail [(x, y') | y' <- [y, y - 1 .. y - dist]]
move' Down = tail [(x, y') | y' <- [y .. y + dist]] move' Down = tail [(x, y') | y' <- [y .. y + dist]]
turn :: (Direction -> Direction) -> Velocity -> Velocity checkTrail trail =
turn turnFn (Velocity speed dir) = let trail' = takeWhile (not . flip Set.member gameMapBlockedPoints) trail
Velocity speed $ turnFn dir in if trail' == trail
then (trail, PlayerAlive)
else (trail', PlayerDead)
moveAndTurn :: (Direction -> Direction) -> Int -> Point -> Velocity -> (PlayerTrail, Velocity) movePlayer = do
moveAndTurn turnFn timeElapsed point vel = let
(move timeElapsed point vel, turn turnFn vel) 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) player' = player { playerState = playerState'
checkTrail GameMap{..} trail = , playerPosition = pos'
let trail' = takeWhile (not . flip Set.member gameMapBlockedPoints) trail , playerTrail = trail ++ playerTrail
in if trail' == trail , playerBoost = playerBoost { boostFuel = boostFuel' }
then (trail, PlayerAlive) }
else (trail', PlayerDead) 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 -> Int -> InEvent -> (Game, [OutEvent])
stepGame game@Game{gameMap = gameMap@GameMap{..}, ..} time = stepGame' stepGame game@Game{gameMap = gameMap@GameMap{..}, ..} time = stepGame'
where where
stepGame' (InPlayerTurnLeft playerId) = stepGame' (InPlayerTurnLeft playerId) = stepEvent playerId $ turn leftTurn
stepTurnEvent playerId $ moveAndTurn leftTurn stepGame' (InPlayerTurnRight playerId) = stepEvent playerId $ turn rightTurn
stepGame' (InPlayerTurnRight playerId) = stepGame' (InPlayerIdle playerId) = stepEvent playerId $ turn noTurn
stepTurnEvent playerId $ moveAndTurn rightTurn stepGame' (InPlayerBoostChange playerId boostActive) = stepEvent playerId $ changeBoost boostActive
stepGame' (InPlayerIdle playerId) =
stepTurnEvent playerId $ moveAndTurn noTurn
stepTurnEvent pId moveFn = stepEvent pId step =
flip (maybe (game, [])) (Map.lookup pId gamePlayers) $ \player@Player{..} -> flip (maybe (game, [])) (Map.lookup pId gamePlayers) $ \player@Player{..} ->
if playerState /= PlayerAlive if playerState /= PlayerAlive
then (game, []) then (game, [])
else let else let
(revTrail, vel'@(Velocity _ dir')) = moveFn (time - playerLastEvent) playerPosition playerVelocity timeElapsed = (time - playerLastEventTime)
(checkedTrail, playerState') = checkTrail gameMap revTrail fullStep = move timeElapsed >> step >> refillBoost timeElapsed
trail = reverse checkedTrail
pos' = if null trail then playerPosition else head trail (gameMap', player'@Player{ playerPosition = pos'
player' = player { playerState = playerState' , playerVelocity = Velocity _ dir' }, outEvents) =
, playerPosition = pos' stepGameEngine gameSettings gameMap player fullStep
, playerVelocity = vel'
, playerTrail = trail ++ playerTrail player'' = player' { playerScore = playerScore + score playerPosition pos'
, playerScore = playerScore + score playerPosition pos' , playerLastEventTime = time }
, playerLastEvent = time game' = game { gamePlayers = Map.insert playerId player'' gamePlayers
} , gameMap = gameMap' }
gameMap' = gameMap { gameMapBlockedPoints = outEvents' = outEvents ++ [OutPlayerPosition playerId pos' dir']
foldl' (flip Set.insert) gameMapBlockedPoints trail } in (game', outEvents')
game' = game { gamePlayers = Map.insert playerId player' gamePlayers
, gameMap = gameMap' }
outEvents = OutPlayerPosition playerId pos' dir' :
[OutPlayerStateChange playerId playerState' | playerState /= playerState']
in (game', outEvents)
score (x1, y1) (x2, y2) = abs (x1 - x2) + abs (y1 - y2) score (x1, y1) (x2, y2) = abs (x1 - x2) + abs (y1 - y2)
runGame :: Game -> [(Int, InEvent)] -> (Game, [OutEvent]) runGame :: Game -> [(Int, InEvent)] -> (Game, [OutEvent])
runGame initialGame inEvents = runGame initialGame =
foldl (\(game, outEvents) (time, inEvent) -> foldl (\(game, outEvents) (time, inEvent) ->
fmap (outEvents ++) $ stepGame game time inEvent) fmap (outEvents ++) $ stepGame game time inEvent)
(initialGame, []) inEvents (initialGame, [])

55
src/Hastron/Game/Types.hs
View File

@ -24,19 +24,19 @@ data PlayerState = PlayerAlive
type PlayerTrail = [Point] type PlayerTrail = [Point]
data PlayerBoost = PlayerBoost { boostActive :: Bool data PlayerBoost = PlayerBoost { boostActive :: Bool
, boostFuel :: Double , boostFuel :: Int
} deriving (Show, Eq) } deriving (Show, Eq)
type PlayerScore = Int type PlayerScore = Int
data Player = Player { playerId :: PlayerId data Player = Player { playerId :: PlayerId
, playerState :: PlayerState , playerState :: PlayerState
, playerPosition :: Point , playerPosition :: Point
, playerVelocity :: Velocity , playerVelocity :: Velocity
, playerTrail :: PlayerTrail , playerTrail :: PlayerTrail
, playerBoost :: PlayerBoost , playerBoost :: PlayerBoost
, playerScore :: PlayerScore , playerScore :: PlayerScore
, playerLastEvent :: Int , playerLastEventTime :: Int
} deriving (Show, Eq) } deriving (Show, Eq)
data PlayerEndState = PlayerWinner | PlayerLoser | PlayerDropped data PlayerEndState = PlayerWinner | PlayerLoser | PlayerDropped
@ -49,41 +49,52 @@ data GameMap = GameMap { size :: Int
, gameMapBlockedPoints :: HashSet Point } , gameMapBlockedPoints :: HashSet Point }
deriving (Show, Eq) deriving (Show, Eq)
data Game = Game { gamePlayers :: HashMap PlayerId Player data GameSettings = GameSettings { gameBoostFactor :: Int
, gameState :: GameState , gameBoostRefillFactor :: Double
, gameMap :: GameMap }
deriving (Show, Eq)
data Game = Game { gamePlayers :: HashMap PlayerId Player
, gameState :: GameState
, gameSettings :: GameSettings
, gameMap :: GameMap
} deriving (Show, Eq) } deriving (Show, Eq)
type GameResult = HashMap PlayerId (PlayerScore, PlayerEndState) type GameResult = HashMap PlayerId (PlayerScore, PlayerEndState)
data InEvent = InPlayerTurnLeft PlayerId data InEvent = InPlayerTurnLeft PlayerId
| InPlayerTurnRight PlayerId | InPlayerTurnRight PlayerId
| InPlayerBoostActivate PlayerId | InPlayerBoostChange PlayerId Bool
| InPlayerBoostDeactivate PlayerId
| InPlayerStateChange PlayerId PlayerState | InPlayerStateChange PlayerId PlayerState
| InPlayerIdle PlayerId | InPlayerIdle PlayerId
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord)
data OutEvent = OutPlayerPosition PlayerId Point Direction data OutEvent = OutPlayerPosition PlayerId Point Direction
| OutPlayerStateChange PlayerId PlayerState | OutPlayerStateChange PlayerId PlayerState
| OutPlayerBoostChange PlayerId PlayerBoost
| OutGameStateChange GameState | OutGameStateChange GameState
| OutGameOver GameResult | OutGameOver GameResult
deriving (Show, Eq) deriving (Show, Eq)
emptyGameMap :: Int -> GameMap newGameMap :: Int -> GameMap
emptyGameMap size = GameMap size $ Set.fromList borderPoints newGameMap size = GameMap size $ Set.fromList borderPoints
where where
borderPoints = let xs = [(x, y) | x <- [-1, size], y <- [0 .. size - 1]] borderPoints = let xs = [(x, y) | x <- [-1, size], y <- [0 .. size - 1]]
in xs ++ map swap xs in xs ++ map swap xs
emptyGame :: Int -> Game newGame :: Int -> GameSettings -> Game
emptyGame size = Game Map.empty GameInit $ emptyGameMap size newGame size gameSettings = Game { gamePlayers = Map.empty
, gameState = GameInit
, gameSettings = gameSettings
, gameMap = newGameMap size
}
newPlayer :: Int -> Point -> Velocity -> Double -> Player newPlayer :: Int -> Point -> Velocity -> Int -> Player
newPlayer pId pos velocity boost = Player pId PlayerAlive pos velocity [pos] (PlayerBoost False boost) 0 0 newPlayer pId pos velocity boost =
Player pId PlayerAlive pos velocity [pos] (PlayerBoost False boost) 0 0
addPlayer :: Game -> Player -> Game addPlayer :: Game -> Player -> Game
addPlayer game@Game{gameMap = gameMap@GameMap{..}, ..} player@Player{..} = addPlayer game@Game{gameMap = gameMap@GameMap{..}, ..} player@Player{..} =
game { gamePlayers = Map.insert playerId player gamePlayers game { gamePlayers = Map.insert playerId player gamePlayers
, gameMap = gameMap { gameMapBlockedPoints = , gameMap = gameMap { gameMapBlockedPoints =
Set.insert playerPosition gameMapBlockedPoints }} Set.insert playerPosition gameMapBlockedPoints }}