Adds collision detection logic.
parent
8631d00bcc
commit
819bad43e7
|
|
@ -3,48 +3,55 @@
|
|||
module Hastron.Game.Engine where
|
||||
|
||||
import Control.Applicative (Applicative)
|
||||
import Control.Monad (guard)
|
||||
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.State (MonadState, get, modify, put)
|
||||
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 Data.List (foldl', sortBy)
|
||||
import Data.Maybe (catMaybes, fromJust, isJust, listToMaybe)
|
||||
import Data.Ord (comparing)
|
||||
import Hastron.Game.Types
|
||||
import Prelude hiding (Left, Right)
|
||||
import Data.Foldable (msum)
|
||||
|
||||
type Projection = ((Point, Timestamp), (Point, Timestamp))
|
||||
|
||||
newtype GameEngine a =
|
||||
GameEngine { _runGameEngine :: RWST GameSettings (DList OutEvent) (GameMap, Player) Identity a }
|
||||
GameEngine { _runGameEngine :: RWST (GameSettings, GameMap) (DList Projection) Player Identity a }
|
||||
deriving ( Functor
|
||||
, Applicative
|
||||
, Monad
|
||||
, MonadReader GameSettings
|
||||
, MonadWriter (DList OutEvent)
|
||||
, MonadState (GameMap, Player)
|
||||
, MonadRWS GameSettings (DList OutEvent) (GameMap, Player))
|
||||
, MonadReader (GameSettings, GameMap)
|
||||
, MonadWriter (DList Projection)
|
||||
, MonadState Player
|
||||
, MonadRWS (GameSettings, GameMap) (DList (Projection)) Player)
|
||||
|
||||
stepGameEngine :: GameSettings -> GameMap -> Player -> GameEngine () -> (GameMap, Player, [OutEvent])
|
||||
stepGameEngine :: GameSettings -> GameMap -> Player -> GameEngine () -> (Player, [Projection])
|
||||
stepGameEngine gameSettings gameMap player =
|
||||
(\((gameMap', player'), outEvents) -> (gameMap', player', DList.toList outEvents))
|
||||
(\(player', outEvents) -> (player', DList.toList outEvents))
|
||||
. runIdentity
|
||||
. (\rwst -> execRWST rwst gameSettings (gameMap, player))
|
||||
. (\rwst -> execRWST rwst (gameSettings, gameMap) player)
|
||||
. _runGameEngine
|
||||
|
||||
move :: TimeInterval -> GameEngine ()
|
||||
move timeElapsed = do
|
||||
movePlayer :: Timestamp -> Timestamp -> GameEngine ()
|
||||
movePlayer startTime endTime = do
|
||||
state <- get
|
||||
settings <- ask
|
||||
go settings state
|
||||
where
|
||||
go GameSettings{ .. } (gameMap@GameMap{ .. }, player@Player{ .. })
|
||||
go (GameSettings{ .. }, GameMap{ .. }) player@Player{ .. }
|
||||
| playerState /= PlayerAlive || timeElapsed < 0 = return ()
|
||||
| not boostActive || boostFuel >= timeElapsed = move'
|
||||
| not boostActive || boostFuel >= timeElapsed = movePlayer'
|
||||
| otherwise =
|
||||
move boostFuel >> move (timeElapsed - boostFuel)
|
||||
movePlayer startTime (startTime + boostFuel) >>
|
||||
movePlayer (startTime + boostFuel) endTime
|
||||
where
|
||||
(x, y) = playerPosition
|
||||
(Velocity speed dir) = playerVelocity
|
||||
|
|
@ -60,13 +67,14 @@ move timeElapsed = do
|
|||
checkTrail trail =
|
||||
let trail' = takeWhile (not . flip Set.member gameMapBlockedPoints) trail
|
||||
in if trail' == trail
|
||||
then (trail, PlayerAlive)
|
||||
else (trail', PlayerDead)
|
||||
then (trail, PlayerAlive, endTime)
|
||||
-- NOTE: we lose some precision in endTime since we're not using Doubles
|
||||
else (trail', PlayerStopped, startTime + length trail' `div` speed)
|
||||
|
||||
move' = do
|
||||
movePlayer' = do
|
||||
let
|
||||
revTrail = makeTrail dir
|
||||
(checkedTrail, playerState') = checkTrail revTrail
|
||||
(checkedTrail, playerState', endTime') = checkTrail revTrail
|
||||
trail = reverse checkedTrail
|
||||
pos' = if null trail then playerPosition else head trail
|
||||
boostFuel' = if boostActive then boostFuel - timeElapsed else boostFuel
|
||||
|
|
@ -76,12 +84,15 @@ move timeElapsed = do
|
|||
, playerTrail = trail ++ playerTrail
|
||||
, playerBoost = playerBoost { boostFuel = boostFuel' }
|
||||
}
|
||||
gameMap' = gameMap { gameMapBlockedPoints =
|
||||
foldl' (flip Set.insert) gameMapBlockedPoints trail }
|
||||
outEvents = [OutPlayerStateChange playerId playerState' | playerState /= playerState']
|
||||
-- gameMap' = gameMap { gameMapBlockedPoints =
|
||||
-- foldl' (flip Set.insert) gameMapBlockedPoints trail }
|
||||
-- outEvents = [OutPlayerStateChange playerId playerState' | playerState /= playerState']
|
||||
|
||||
put (gameMap', player')
|
||||
tell $ DList.fromList outEvents
|
||||
put player'
|
||||
-- tell $ DList.fromList outEvents
|
||||
tell $ DList.fromList [((playerPosition, startTime), (pos', endTime'))]
|
||||
|
||||
timeElapsed = endTime - startTime
|
||||
|
||||
leftTurn :: Direction -> Direction
|
||||
leftTurn Left = Down
|
||||
|
|
@ -96,53 +107,165 @@ rightTurn Up = Right
|
|||
rightTurn Down = Left
|
||||
|
||||
turn :: (Direction -> Direction) -> GameEngine ()
|
||||
turn turnFn = modify . second $ \player@Player{ playerVelocity = Velocity speed dir } ->
|
||||
turn turnFn = modify $ \player@Player{ playerVelocity = Velocity speed dir } ->
|
||||
player { playerVelocity = Velocity speed $ turnFn dir }
|
||||
|
||||
changeBoost :: Bool -> GameEngine ()
|
||||
changeBoost boostActive = modify . second $ \player@Player{ .. } ->
|
||||
changeBoost boostActive = modify $ \player@Player{ .. } ->
|
||||
player { playerBoost = playerBoost { boostActive = boostActive } }
|
||||
|
||||
refillBoost :: Timestamp -> GameEngine ()
|
||||
refillBoost :: TimeInterval -> GameEngine ()
|
||||
refillBoost timeElapsed = do
|
||||
(gameMap, player@Player{ .. }) <- get
|
||||
GameSettings{ .. } <- ask
|
||||
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']
|
||||
put 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'
|
||||
stepPlayer :: (Timestamp, InEvent) -> GameEngine ()
|
||||
stepPlayer (time, inEvent) = do
|
||||
player@Player { .. } <- get
|
||||
let timeElapsed =time - playerLastEventTime
|
||||
movePlayer time timeElapsed >> eventStep inEvent >> refillBoost timeElapsed
|
||||
put $ player { playerLastEventTime = time }
|
||||
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
|
||||
eventStep :: InEvent -> GameEngine ()
|
||||
eventStep (InPlayerTurnLeft _) = turn leftTurn
|
||||
eventStep (InPlayerTurnRight _) = turn rightTurn
|
||||
eventStep (InPlayerIdle _) = return ()
|
||||
eventStep (InPlayerBoostChange _ boostActive) = changeBoost boostActive
|
||||
|
||||
stepEvent pId step =
|
||||
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
|
||||
getPlayerId :: InEvent -> Maybe PlayerId
|
||||
getPlayerId (InPlayerTurnLeft playerId) = Just playerId
|
||||
getPlayerId (InPlayerTurnRight playerId) = Just playerId
|
||||
getPlayerId (InPlayerIdle playerId) = Just playerId
|
||||
getPlayerId (InPlayerBoostChange playerId _) = Just playerId
|
||||
getPlayerId _ = Nothing
|
||||
|
||||
(gameMap', player'@Player{ playerPosition = pos'
|
||||
, playerVelocity = Velocity _ dir' }, outEvents) =
|
||||
stepGameEngine gameSettings gameMap player fullStep
|
||||
-- stepGame :: Game -> (Timestamp, InEvent) -> (Game, [OutEvent])
|
||||
-- stepGame game@Game{ gameMap = gameMap@GameMap{ .. }, .. } (time, inEvent) =
|
||||
|
||||
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')
|
||||
-- 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
|
||||
|
||||
score (x1, y1) (x2, y2) = abs (x1 - x2) + abs (y1 - y2)
|
||||
-- stepEvent pId step =
|
||||
-- flip (maybe (game, [])) (Map.lookup pId gamePlayers) $ \player@Player{ .. } ->
|
||||
-- if playerState /= PlayerAlive
|
||||
-- then (game, [])
|
||||
-- else let
|
||||
-- timeElapsed = time - playerLastEventTime
|
||||
-- fullStep = movePlayer timeElapsed >> step >> refillBoost timeElapsed
|
||||
|
||||
runGame :: Game -> [(Timestamp, InEvent)] -> (Game, [OutEvent])
|
||||
runGame initialGame =
|
||||
foldl (\(game, outEvents) (time, inEvent) ->
|
||||
fmap (outEvents ++) $ stepGame game time inEvent)
|
||||
(initialGame, [])
|
||||
-- (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)
|
||||
|
||||
data Slope = Inf | Zero deriving (Eq)
|
||||
|
||||
intersectProjections :: Projection -> Projection -> Maybe (Point, Double)
|
||||
intersectProjections (((xs1, ys1), ts1), ((xe1, ye1), te1)) (((xs2, ys2), ts2), ((xe2, ye2), te2))
|
||||
-- Head on collision on x-axis
|
||||
| m1 == m2 && m1 == Zero && ys1 == ys2 && signum (xs1 - xs2) /= signum (xe1 - xe2) =
|
||||
let (x, t) = headOnCollisionPointAndTime xs1 xe1 xs2 xe2 in Just ((x, ys1), t)
|
||||
-- Tail on collition on x-axis
|
||||
| m1 == m2 && m1 == Zero && ys1 == ys2 && signum (xs1 - xs2) /= signum (xe1 - xs2) =
|
||||
Just ((xs2, ys1), tailOnCollisionTime xs1 xe1 xs2)
|
||||
-- Head on collision on y-axis
|
||||
| m1 == m2 && m1 == Inf && xs1 == xs2 && signum (ys1 - ys2) /= signum (ye1 - ye2) =
|
||||
let (y, t) = headOnCollisionPointAndTime ys1 ye1 ys2 ye2 in Just ((xs1, y), t)
|
||||
-- Tail on collition on y-axis
|
||||
| m1 == m2 && m1 == Inf && xs1 == xs2 && signum (ys1 - ys2) /= signum (ye1 - ys2) =
|
||||
Just ((xs1, ys2), tailOnCollisionTime ys1 ye1 ys2)
|
||||
-- Parallel projections, no collision
|
||||
| m1 == m2 = Nothing
|
||||
-- Orthogonal collision x and y axis
|
||||
| m1 == Zero = let myTime = timeAtCollision ts1 te1 xs1 xs2
|
||||
otherTime = timeAtCollision ts2 te2 ys1 ys2
|
||||
in guard (myTime >= otherTime - tolerance) >> return ((xs2, ys1), myTime)
|
||||
-- Orthogonal collision y and x axis
|
||||
| otherwise = let myTime = timeAtCollision ts1 te1 ys1 ys2
|
||||
otherTime = timeAtCollision ts2 te2 xs1 xs2
|
||||
in guard (myTime >= otherTime - tolerance) >> return ((xs1, ys2), myTime)
|
||||
where
|
||||
fromI = fromIntegral
|
||||
|
||||
m1 = if (xs1 == xe1) then Inf else Zero
|
||||
m2 = if (xs2 == xe2) then Inf else Zero
|
||||
|
||||
headOnCollisionPointAndTime s1 e1 s2 e2 = let
|
||||
v1 = fromI (e1 - s1) / fromI (te1 - ts1)
|
||||
v2 = fromI (e2 - s2) / fromI (te2 - ts2)
|
||||
t = (fromI s1 - v1 * fromI ts1 - fromI s2 + v2 * fromI ts2) / (v2 - v1)
|
||||
in (s1 + floor (v1 * (t - fromI ts1)), t)
|
||||
|
||||
tailOnCollisionTime s1 e1 s2 = let
|
||||
v1 = fromI (e1 - s1) / fromI (te1 - ts1)
|
||||
in fromIntegral (s2 - s1) / v1
|
||||
|
||||
tolerance = 0.1
|
||||
|
||||
timeAtCollision ts te s1 s2 =
|
||||
fromI ts + (fromI (te - ts) / fromI (abs (s2 - s1)))
|
||||
|
||||
intersectPlayers :: (Player, [Projection]) -> (Player, [Projection]) -> Maybe (Point, Double)
|
||||
intersectPlayers (player1, projections1) (player2, projections2) = listToMaybe $ do
|
||||
projection1 <- projections1
|
||||
projection2 <- projections2
|
||||
let intersection = projection1 `intersectProjections` projection2
|
||||
guard (isJust intersection)
|
||||
return $ fromJust intersection
|
||||
|
||||
tickGame :: Game -> Timestamp -> [(Timestamp, InEvent)] -> (Game, [OutEvent])
|
||||
tickGame game@Game{ .. } tickTime inEvents = let
|
||||
events = sortBy (comparing fst) $ inEvents ++ idleEvents
|
||||
playerEvents = flip (`foldl` Map.empty) events $ \m (ts, event) ->
|
||||
case getPlayerId event of
|
||||
Nothing -> m
|
||||
Just playerId -> Map.insertWith (++) playerId [(ts, event)] m
|
||||
|
||||
playerProjections :: Map.HashMap PlayerId (Player, [Projection])
|
||||
playerProjections = flip Map.mapWithKey playerEvents $ \playerId events ->
|
||||
stepGameEngine gameSettings gameMap (fromJust $ Map.lookup playerId gamePlayers) $
|
||||
sequence_ $ map stepPlayer events
|
||||
|
||||
collisions :: [(Player, Player, Point, Double)]
|
||||
collisions = sortBy (comparing $ \(_, _, _, time) -> time)
|
||||
. catMaybes $ [
|
||||
fmap (\(point, time) -> (fst p1, fst p2, point, time)) $ p1 `intersectPlayers` p2
|
||||
| p1 <- Map.elems playerProjections
|
||||
, p2 <- Map.elems playerProjections
|
||||
, fst p1 /= fst p2 ]
|
||||
|
||||
deadPlayers :: Map.HashMap PlayerId (PlayerState, Point, Timestamp)
|
||||
deadPlayers = flip (`foldl` Map.empty) collisions $ \m (p1, p2, position, time) ->
|
||||
let pId1 = playerId p1
|
||||
pId2 = playerId p2
|
||||
in case Map.lookup pId2 m of
|
||||
Nothing -> case Map.lookup pId1 m of
|
||||
Nothing -> Map.insert pId1 (PlayerDead, position, floor time) m
|
||||
_ -> m
|
||||
_ -> m
|
||||
|
||||
allTheDeadPlayers = flip (`foldl` deadPlayers) (Map.elems playerProjections) $ \m (Player{..}, projections) ->
|
||||
if playerState == PlayerStopped && not (playerId `Map.member` m)
|
||||
then let
|
||||
(position, timestamp) = snd . last $ projections
|
||||
in Map.insert playerId (PlayerDead, position, timestamp) m
|
||||
else m
|
||||
|
||||
in undefined
|
||||
where
|
||||
idleEvents = map (\pId -> (tickTime, InPlayerIdle pId)) $ Map.keys gamePlayers
|
||||
|
|
|
|||
|
|
@ -23,6 +23,7 @@ data PlayerState = PlayerAlive
|
|||
| PlayerDead
|
||||
| PlayerDisconnected
|
||||
| PlayerLeft
|
||||
| PlayerStopped
|
||||
deriving (Show, Eq, Ord, Enum)
|
||||
|
||||
type PlayerTrail = [Point]
|
||||
|
|
|
|||
Loading…
Reference in New Issue