hastron.cabal

@@ -22,10 +22,6 @@ 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,87 +1,11 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE RecordWildCards #-}
 module Hastron.Game.Engine where
 
-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 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)
-
-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
+import           Prelude             hiding (Left, Right)
 
 leftTurn :: Direction -> Direction
 leftTurn Left  = Down
@@ -95,54 +19,72 @@ rightTurn Right = Down
 rightTurn Up    = Right
 rightTurn Down  = Left
 
-turn :: (Direction -> Direction) -> GameEngine ()
-turn turnFn = modify . second $ \player@Player{ playerVelocity = Velocity speed dir } ->
-  player { playerVelocity = Velocity speed $ turnFn dir }
+noTurn :: Direction -> Direction
+noTurn = id
 
-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'
+move :: Int -> Point -> Velocity -> PlayerTrail
+move timeElapsed (x, y) (Velocity speed dir) = move' dir
   where
-    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
+    dist = timeElapsed * speed
 
-    stepEvent pId step =
-      flip (maybe (game, [])) (Map.lookup pId gamePlayers) $ \player@Player{ .. } ->
+    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{..} ->
         if playerState /= PlayerAlive
         then (game, [])
         else let
-            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')
+            (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)
 
     score (x1, y1) (x2, y2) = abs (x1 - x2) + abs (y1 - y2)
 
-runGame :: Game -> [(Timestamp, InEvent)] -> (Game, [OutEvent])
-runGame initialGame =
+runGame :: Game -> [(Int, InEvent)] -> (Game, [OutEvent])
+runGame initialGame inEvents =
   foldl (\(game, outEvents) (time, inEvent) ->
             fmap (outEvents ++) $ stepGame game time inEvent)
-        (initialGame, [])
+        (initialGame, []) inEvents

src/Hastron/Game/Types.hs

@@ -7,97 +7,83 @@ import           Data.HashSet        (HashSet)
 import qualified Data.HashSet        as Set
 import           Data.Tuple          (swap)
 
-type Point          = (Int, Int)
+type Point = (Int, Int)
 
-type Timestamp      = Int
+data Direction = Left | Right | Up | Down deriving (Show, Eq, Ord, Enum)
 
-type TimeInterval   = Int
+data Velocity = Velocity Int Direction deriving (Show, Eq, Ord)
 
-data Direction      = Left | Right | Up | Down deriving (Show, Eq, Ord, Enum)
+type PlayerId = Int
 
-data Velocity       = Velocity Int Direction deriving (Show, Eq, Ord)
+data PlayerState = PlayerAlive
+                 | PlayerDead
+                 | PlayerDisconnected
+                 | PlayerLeft
+                 deriving (Show, Eq, Ord, Enum)
 
-type PlayerId       = Int
+type PlayerTrail = [Point]
 
-data PlayerState    = PlayerAlive
-                    | PlayerDead
-                    | PlayerDisconnected
-                    | PlayerLeft
-                    deriving (Show, Eq, Ord, Enum)
+data PlayerBoost = PlayerBoost { boostActive :: Bool
+                               , boostFuel   :: Double
+                               } deriving (Show, Eq)
 
-type PlayerTrail    = [Point]
+type PlayerScore = Int
 
-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 Player = Player { playerId       :: PlayerId
+                     , playerState    :: PlayerState
+                     , playerPosition :: Point
+                     , playerVelocity :: Velocity
+                     , playerTrail    :: PlayerTrail
+                     , playerBoost    :: PlayerBoost
+                     , playerScore    :: PlayerScore
+                     , playerLastEvent :: 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 GameSettings   = GameSettings { gameBoostFactor       :: Int
-                                   , gameBoostRefillFactor :: Double
-                                   } deriving (Show, Eq)
+data Game = Game { gamePlayers :: HashMap PlayerId Player
+                 , gameState   :: GameState
+                 , gameMap     :: GameMap
+                 } 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)
 
-type GameResult     = HashMap PlayerId (PlayerScore, PlayerEndState)
+data InEvent = InPlayerTurnLeft PlayerId
+             | InPlayerTurnRight PlayerId
+             | InPlayerBoostActivate PlayerId
+             | InPlayerBoostDeactivate PlayerId
+             | InPlayerStateChange PlayerId PlayerState
+             | InPlayerIdle PlayerId
+             deriving (Show, Eq, Ord)
 
-data InEvent        = InPlayerTurnLeft PlayerId
-                    | InPlayerTurnRight PlayerId
-                    | InPlayerBoostChange PlayerId Bool
-                    | InPlayerStateChange PlayerId PlayerState
-                    | InPlayerIdle PlayerId
-                    deriving (Show, Eq, Ord)
+data OutEvent = OutPlayerPosition PlayerId Point Direction
+              | OutPlayerStateChange PlayerId PlayerState
+              | OutGameStateChange GameState
+              | OutGameOver GameResult
+              deriving (Show, Eq)
 
-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
+emptyGameMap :: Int -> GameMap
+emptyGameMap size = GameMap size $ Set.fromList borderPoints
   where
     borderPoints = let xs = [(x, y) | x <- [-1, size], y <- [0 .. size - 1]]
                    in xs ++ map swap xs
 
-newGame :: Int -> GameSettings -> Game
-newGame size gameSettings = Game { gamePlayers  = Map.empty
-                                 , gameState    = GameInit
-                                 , gameSettings = gameSettings
-                                 , gameMap      = newGameMap size
-                                 }
+emptyGame :: Int -> Game
+emptyGame size = Game Map.empty GameInit $ emptyGameMap size
 
-newPlayer :: Int -> Point -> Velocity -> Int -> Player
-newPlayer pId pos velocity boost =
-  Player pId PlayerAlive pos velocity [pos] (PlayerBoost False boost) 0 0
+newPlayer :: Int -> Point -> Velocity -> Double -> 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 }}