Major refactoring to use Monads for the game engine.
Also adds support for boost change and refill.engine-govind
parent
1cb9490566
commit
7ecb72ff04
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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, [])
|
||||
|
|
|
|||
|
|
@ -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 }}
|
||||
|
|
|
|||
Loading…
Reference in New Issue