Adds basic game step logic
parent
e530f3aa68
commit
8b4f606469
|
@ -1,8 +1,81 @@
|
|||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Hastron.Game.Engine where
|
||||
|
||||
import Hastron.Game.Types
|
||||
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)
|
||||
|
||||
type GameStep = Game -> InEvent -> (Game, [OutEvent])
|
||||
leftTurn :: Direction -> Direction
|
||||
leftTurn Left = Down
|
||||
leftTurn Right = Up
|
||||
leftTurn Up = Left
|
||||
leftTurn Down = Right
|
||||
|
||||
stepGame :: GameStep
|
||||
stepGame game inEvent = undefined
|
||||
rightTurn :: Direction -> Direction
|
||||
rightTurn Left = Up
|
||||
rightTurn Right = Down
|
||||
rightTurn Up = Right
|
||||
rightTurn Down = Left
|
||||
|
||||
noTurn :: Direction -> Direction
|
||||
noTurn = id
|
||||
|
||||
move :: Point -> Velocity -> PlayerTrail
|
||||
move (x, y) (Velocity speed Left) = tail [(x', y) | x' <- [x, x - 1 .. x - speed]]
|
||||
move (x, y) (Velocity speed Right) = tail [(x', y) | x' <- [x .. x + speed]]
|
||||
move (x, y) (Velocity speed Up) = tail [(x, y') | y' <- [y, y - 1 .. y - speed]]
|
||||
move (x, y) (Velocity speed Down) = tail [(x, y') | y' <- [y .. y + speed]]
|
||||
|
||||
moveAfterTurn :: (Direction -> Direction) -> Point -> Velocity -> (PlayerTrail, Velocity)
|
||||
moveAfterTurn turn point (Velocity speed dir) =
|
||||
let vel' = Velocity speed $ turn dir
|
||||
in (move point vel', 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 -> InEvent -> (Game, [OutEvent])
|
||||
stepGame game@Game{gameMap = gameMap@GameMap{..}, ..} inEvent = stepGame' inEvent
|
||||
where
|
||||
stepGame' (InPlayerTurnLeft playerId) = stepTurnEvent playerId $ moveAfterTurn leftTurn
|
||||
stepGame' (InPlayerTurnRight playerId) = stepTurnEvent playerId $ moveAfterTurn rightTurn
|
||||
stepGame' (InPlayerIdle playerId) = stepTurnEvent playerId $ moveAfterTurn noTurn
|
||||
|
||||
stepTurnEvent pId moveFn =
|
||||
flip (maybe (game, [])) (Map.lookup pId gamePlayers) $ \player@Player{..} ->
|
||||
if playerState /= PlayerAlive
|
||||
then (game, [])
|
||||
else let
|
||||
(revTrail, vel'@(Velocity _ dir')) = moveFn 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'
|
||||
}
|
||||
gameMap' = gameMap { gameMapBlockedPoints =
|
||||
foldl' (flip Set.insert) gameMapBlockedPoints trail }
|
||||
game' = game { gamePlayers = Map.insert playerId player' gamePlayers
|
||||
, gameMap = gameMap' }
|
||||
outEvents = [OutPlayerPosition playerId pos' dir'] ++
|
||||
(if playerState /= playerState'
|
||||
then [OutPlayerStateChange playerId playerState']
|
||||
else [])
|
||||
in (game', outEvents)
|
||||
|
||||
score (x1, y1) (x2, y2) = abs (x1 - x2) + abs (y1 - y2)
|
||||
|
||||
runGame :: Game -> [InEvent] -> (Game, [OutEvent])
|
||||
runGame initialGame =
|
||||
foldl (\(game, outEvents) inEvent -> let (game', outEvents') = stepGame game inEvent
|
||||
in (game', outEvents ++ outEvents'))
|
||||
(initialGame, [])
|
||||
|
|
|
@ -1,12 +1,17 @@
|
|||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Hastron.Game.Types where
|
||||
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.HashMap.Strict as Map
|
||||
import Data.HashSet (HashSet)
|
||||
import qualified Data.HashSet as Set
|
||||
import Data.Tuple (swap)
|
||||
|
||||
type Point = (Int, Int)
|
||||
|
||||
data Direction = Left | Right | Up | Down deriving (Show, Eq, Ord, Enum)
|
||||
|
||||
data Velocity = Velocity Double Direction deriving (Show, Eq, Ord)
|
||||
data Velocity = Velocity Int Direction deriving (Show, Eq, Ord)
|
||||
|
||||
type PlayerId = Int
|
||||
|
||||
|
@ -39,19 +44,42 @@ data PlayerEndState = PlayerWinner | PlayerLoser | PlayerDropped
|
|||
data GameState = GameStarted | GameInit | GameFinished
|
||||
deriving (Show, Eq, Ord, Enum)
|
||||
|
||||
data Game = Game { gamePlayers :: [Player]
|
||||
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)
|
||||
|
||||
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 OutEvent = OutPlayerPosition PlayerId Point Direction
|
||||
| OutPlayerStateChange PlayerId PlayerState Point
|
||||
| OutPlayerStateChange PlayerId PlayerState
|
||||
| OutGameStateChange GameState
|
||||
| OutGameOver (HashMap PlayerId (PlayerScore, PlayerEndState))
|
||||
| OutGameOver GameResult
|
||||
deriving (Show, Eq)
|
||||
|
||||
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
|
||||
|
||||
emptyGame :: Int -> Game
|
||||
emptyGame size = Game Map.empty GameInit $ emptyGameMap size
|
||||
|
||||
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 }}
|
||||
|
|
|
@ -1,6 +1,7 @@
|
|||
module Main where
|
||||
|
||||
import Hastron.Server.Types
|
||||
import Hastron.Game.Engine
|
||||
|
||||
main :: IO()
|
||||
main = putStrLn "Hello World"
|
||||
|
|
Loading…
Reference in New Issue