Fixes boostfuel refill calculation.

Also adds support for boost change and refill.

hastron.cabal

@@ -22,6 +22,10 @@ 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,
+                       bifunctors >=5 && <6,
                        hashable >=1.2 && <1.3
   hs-source-dirs:      src
   default-language:    Haskell2010
+  ghc-options:         -Wall

src/Hastron/Game/Engine.hs

@@ -1,11 +1,87 @@
-{-# 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, modify)
+import           Control.Monad.Writer   (MonadWriter, tell)
+import           Data.Bifunctor         (second)
+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)
+
+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 :: TimeInterval -> GameEngine ()
+move timeElapsed = do
+  state    <- get
+  settings <- ask
+  go settings state
+  where
+    go GameSettings{ .. } (gameMap@GameMap{ .. }, player@Player{ .. })
+      | playerState /= PlayerAlive    || timeElapsed < 0 = return ()
+      | not boostActive || boostFuel >= timeElapsed      = move'
+      | otherwise                                        =
+          move boostFuel >> move (timeElapsed - boostFuel)
+      where
+        (x, y)               = playerPosition
+        (Velocity speed dir) = playerVelocity
+        PlayerBoost{ .. }    = playerBoost
+        dist                 =
+          timeElapsed * speed * (if boostActive && boostFuel > 0 then gameBoostFactor else 1)
+
+        makeTrail Left  = tail [(x', y) | x' <- [x, x - 1 .. x - dist]]
+        makeTrail Right = tail [(x', y) | x' <- [x .. x + dist]]
+        makeTrail Up    = tail [(x, y') | y' <- [y, y - 1 .. y - dist]]
+        makeTrail Down  = tail [(x, y') | y' <- [y .. y + dist]]
+
+        checkTrail trail =
+          let trail' = takeWhile (not . flip Set.member gameMapBlockedPoints) trail
+          in if trail' == trail
+             then (trail, PlayerAlive)
+             else (trail', PlayerDead)
+
+        move' = do
+          let
+            revTrail                     = makeTrail 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
+
+            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
 
 leftTurn :: Direction -> Direction
 leftTurn Left  = Down
@@ -19,72 +95,54 @@ rightTurn Right = Down
 rightTurn Up    = Right
 rightTurn Down  = Left
 
-noTurn :: Direction -> Direction
-noTurn = id
+turn :: (Direction -> Direction) -> GameEngine ()
+turn turnFn = modify . second $ \player@Player{ playerVelocity = Velocity speed dir } ->
+  player { playerVelocity = Velocity speed $ turnFn dir }
 
-move :: Int -> Point -> Velocity -> PlayerTrail
-move timeElapsed (x, y) (Velocity speed dir) = move' dir
+changeBoost :: Bool -> GameEngine ()
+changeBoost boostActive = modify . second $ \player@Player{ .. } ->
+  player { playerBoost = playerBoost { boostActive = boostActive } }
+
+refillBoost :: Timestamp -> GameEngine ()
+refillBoost timeElapsed = do
+  (gameMap, player@Player{ .. }) <- get
+  GameSettings{ .. }             <- ask
+  let boostFuel'   = floor (fromIntegral timeElapsed * gameBoostRefillFactor)
+      playerBoost' = playerBoost { boostFuel = boostFuel playerBoost + boostFuel' }
+  put (gameMap, player { playerBoost = playerBoost' })
+  tell $ DList.fromList [OutPlayerBoostChange playerId playerBoost' | playerBoost /= playerBoost']
+
+stepGame :: Game -> Timestamp -> InEvent -> (Game, [OutEvent])
+stepGame game@Game{ gameMap = gameMap@GameMap{ .. }, .. } time = stepGame'
   where
-    dist = timeElapsed * speed
+    stepGame' (InPlayerTurnLeft playerId)                = stepEvent playerId $ turn leftTurn
+    stepGame' (InPlayerTurnRight playerId)               = stepEvent playerId $ turn rightTurn
+    stepGame' (InPlayerIdle playerId)                    = stepEvent playerId $ return ()
+    stepGame' (InPlayerBoostChange playerId boostActive) = stepEvent playerId $ changeBoost boostActive
 
-    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
-
-moveAndTurn :: (Direction -> Direction) ->  Int -> Point -> Velocity -> (PlayerTrail, Velocity)
-moveAndTurn turnFn timeElapsed point vel =
-  (move timeElapsed point vel, turn turnFn vel)
-
-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)
-
-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
-
-    stepTurnEvent pId moveFn =
-      flip (maybe (game, [])) (Map.lookup pId gamePlayers) $ \player@Player{..} ->
+    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 :: Game -> [(Timestamp, InEvent)] -> (Game, [OutEvent])
+runGame initialGame =
   foldl (\(game, outEvents) (time, inEvent) ->
             fmap (outEvents ++) $ stepGame game time inEvent)
-        (initialGame, []) inEvents
+        (initialGame, [])

src/Hastron/Game/Types.hs

@@ -7,83 +7,97 @@ import           Data.HashSet        (HashSet)
 import qualified Data.HashSet        as Set
 import           Data.Tuple          (swap)
 
-type Point = (Int, Int)
+type Point          = (Int, Int)
 
-data Direction = Left | Right | Up | Down deriving (Show, Eq, Ord, Enum)
+type Timestamp      = Int
 
-data Velocity = Velocity Int Direction deriving (Show, Eq, Ord)
+type TimeInterval   = Int
 
-type PlayerId = Int
+data Direction      = Left | Right | Up | Down deriving (Show, Eq, Ord, Enum)
 
-data PlayerState = PlayerAlive
-                 | PlayerDead
-                 | PlayerDisconnected
-                 | PlayerLeft
-                 deriving (Show, Eq, Ord, Enum)
+data Velocity       = Velocity Int Direction deriving (Show, Eq, Ord)
 
-type PlayerTrail = [Point]
+type PlayerId       = Int
 
-data PlayerBoost = PlayerBoost { boostActive :: Bool
-                               , boostFuel   :: Double
-                               } deriving (Show, Eq)
+data PlayerState    = PlayerAlive
+                    | PlayerDead
+                    | PlayerDisconnected
+                    | PlayerLeft
+                    deriving (Show, Eq, Ord, Enum)
 
-type PlayerScore = Int
+type PlayerTrail    = [Point]
 
-data Player = Player { playerId       :: PlayerId
-                     , playerState    :: PlayerState
-                     , playerPosition :: Point
-                     , playerVelocity :: Velocity
-                     , playerTrail    :: PlayerTrail
-                     , playerBoost    :: PlayerBoost
-                     , playerScore    :: PlayerScore
-                     , playerLastEvent :: Int
-                     } deriving (Show, Eq)
+data PlayerBoost    = PlayerBoost { boostActive :: Bool
+                                  , 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
+                             , playerLastEventTime :: Int
+                             } deriving (Show, Eq)
 
 data PlayerEndState = PlayerWinner | PlayerLoser | PlayerDropped
                       deriving (Show, Eq, Ord, Enum)
 
-data GameState = GameStarted | GameInit | GameFinished
-                 deriving (Show, Eq, Ord, Enum)
+data GameState      = GameStarted | GameInit | GameFinished
+                      deriving (Show, Eq, Ord, Enum)
 
-data GameMap = GameMap { size                 :: Int
-                       , gameMapBlockedPoints :: HashSet Point }
-               deriving (Show, Eq)
+data GameMap        = GameMap { size                 :: Int
+                              , gameMapBlockedPoints :: HashSet Point
+                              } deriving (Show, Eq)
 
-data Game = Game { gamePlayers :: HashMap PlayerId Player
-                 , gameState   :: GameState
-                 , gameMap     :: GameMap
-                 } deriving (Show, Eq)
+data GameSettings   = GameSettings { gameBoostFactor       :: Int
+                                   , gameBoostRefillFactor :: Double
+                                   } deriving (Show, Eq)
 
-type GameResult = HashMap PlayerId (PlayerScore, PlayerEndState)
+data Game           = Game { gamePlayers  :: HashMap PlayerId Player
+                           , gameState    :: GameState
+                           , gameSettings :: GameSettings
+                           , gameMap      :: GameMap
+                           } deriving (Show, Eq)
 
-data InEvent = InPlayerTurnLeft PlayerId
-             | InPlayerTurnRight PlayerId
-             | InPlayerBoostActivate PlayerId
-             | InPlayerBoostDeactivate PlayerId
-             | InPlayerStateChange PlayerId PlayerState
-             | InPlayerIdle PlayerId
-             deriving (Show, Eq, Ord)
+type GameResult     = HashMap PlayerId (PlayerScore, PlayerEndState)
 
-data OutEvent = OutPlayerPosition PlayerId Point Direction
-              | OutPlayerStateChange PlayerId PlayerState
-              | OutGameStateChange GameState
-              | OutGameOver GameResult
-              deriving (Show, Eq)
+data InEvent        = InPlayerTurnLeft PlayerId
+                    | InPlayerTurnRight PlayerId
+                    | InPlayerBoostChange PlayerId Bool
+                    | InPlayerStateChange PlayerId PlayerState
+                    | InPlayerIdle PlayerId
+                    deriving (Show, Eq, Ord)
 
-emptyGameMap :: Int -> GameMap
-emptyGameMap size = GameMap size $ Set.fromList borderPoints
+data OutEvent       = OutPlayerPosition PlayerId Point Direction
+                    | OutPlayerStateChange PlayerId PlayerState
+                    | OutPlayerBoostChange PlayerId PlayerBoost
+                    | OutGameStateChange GameState
+                    | OutGameOver GameResult
+                    deriving (Show, Eq)
+
+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{..} =
+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 } }