abhin4v
/
hastron
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Adds collision detection logic.

engine_abhinav
Abhinav Sarkar 2015-08-09 17:11:37 +05:30
parent 8631d00bcc
commit 819bad43e7
2 changed files with 183 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

241
src/Hastron/Game/Engine.hs
View File

@ -3,48 +3,55 @@
module Hastron.Game.Engine where module Hastron.Game.Engine where
import Control.Applicative (Applicative) import Control.Applicative (Applicative)
import Control.Monad (guard)
import Control.Monad.Identity (Identity, runIdentity) import Control.Monad.Identity (Identity, runIdentity)
import Control.Monad.Reader (MonadReader, ask) import Control.Monad.Reader (MonadReader, ask)
import Control.Monad.RWS (MonadRWS, RWST, execRWST) 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 Control.Monad.Writer (MonadWriter, tell)
import Data.Bifunctor (second) import Data.Bifunctor (second)
import Data.DList (DList) import Data.DList (DList)
import qualified Data.DList as DList import qualified Data.DList as DList
import qualified Data.HashMap.Strict as Map import qualified Data.HashMap.Strict as Map
import qualified Data.HashSet as Set 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 Hastron.Game.Types
import Prelude hiding (Left, Right) import Prelude hiding (Left, Right)
import Data.Foldable (msum)
type Projection = ((Point, Timestamp), (Point, Timestamp))
newtype GameEngine a = 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 deriving ( Functor
, Applicative , Applicative
, Monad , Monad
, MonadReader GameSettings , MonadReader (GameSettings, GameMap)
, MonadWriter (DList OutEvent) , MonadWriter (DList Projection)
, MonadState (GameMap, Player) , MonadState Player
, MonadRWS GameSettings (DList OutEvent) (GameMap, 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 = stepGameEngine gameSettings gameMap player =
(\((gameMap', player'), outEvents) -> (gameMap', player', DList.toList outEvents)) (\(player', outEvents) -> (player', DList.toList outEvents))
. runIdentity . runIdentity
. (\rwst -> execRWST rwst gameSettings (gameMap, player)) . (\rwst -> execRWST rwst (gameSettings, gameMap) player)
. _runGameEngine . _runGameEngine
move :: TimeInterval -> GameEngine () movePlayer :: Timestamp -> Timestamp -> GameEngine ()
move timeElapsed = do movePlayer startTime endTime = do
state <- get state <- get
settings <- ask settings <- ask
go settings state go settings state
where where
go GameSettings{ .. } (gameMap@GameMap{ .. }, player@Player{ .. }) go (GameSettings{ .. }, GameMap{ .. }) player@Player{ .. }
| playerState /= PlayerAlive || timeElapsed < 0 = return () | playerState /= PlayerAlive || timeElapsed < 0 = return ()
| not boostActive || boostFuel >= timeElapsed = move' | not boostActive || boostFuel >= timeElapsed = movePlayer'
| otherwise = | otherwise =
move boostFuel >> move (timeElapsed - boostFuel) movePlayer startTime (startTime + boostFuel) >>
movePlayer (startTime + boostFuel) endTime
where where
(x, y) = playerPosition (x, y) = playerPosition
(Velocity speed dir) = playerVelocity (Velocity speed dir) = playerVelocity
@ -60,13 +67,14 @@ move timeElapsed = do
checkTrail trail = checkTrail trail =
let trail' = takeWhile (not . flip Set.member gameMapBlockedPoints) trail let trail' = takeWhile (not . flip Set.member gameMapBlockedPoints) trail
in if trail' == trail in if trail' == trail
then (trail, PlayerAlive) then (trail, PlayerAlive, endTime)
else (trail', PlayerDead) -- 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 let
revTrail = makeTrail dir revTrail = makeTrail dir
(checkedTrail, playerState') = checkTrail revTrail (checkedTrail, playerState', endTime') = checkTrail revTrail
trail = reverse checkedTrail trail = reverse checkedTrail
pos' = if null trail then playerPosition else head trail pos' = if null trail then playerPosition else head trail
boostFuel' = if boostActive then boostFuel - timeElapsed else boostFuel boostFuel' = if boostActive then boostFuel - timeElapsed else boostFuel
@ -76,12 +84,15 @@ move timeElapsed = do
, playerTrail = trail ++ playerTrail , playerTrail = trail ++ playerTrail
, playerBoost = playerBoost { boostFuel = boostFuel' } , playerBoost = playerBoost { boostFuel = boostFuel' }
} }
gameMap' = gameMap { gameMapBlockedPoints = -- gameMap' = gameMap { gameMapBlockedPoints =
foldl' (flip Set.insert) gameMapBlockedPoints trail } -- foldl' (flip Set.insert) gameMapBlockedPoints trail }
outEvents = [OutPlayerStateChange playerId playerState' | playerState /= playerState'] -- outEvents = [OutPlayerStateChange playerId playerState' | playerState /= playerState']
put (gameMap', player') put player'
tell $ DList.fromList outEvents -- tell $ DList.fromList outEvents
tell $ DList.fromList [((playerPosition, startTime), (pos', endTime'))]
timeElapsed = endTime - startTime
leftTurn :: Direction -> Direction leftTurn :: Direction -> Direction
leftTurn Left = Down leftTurn Left = Down
@ -96,53 +107,165 @@ rightTurn Up = Right
rightTurn Down = Left rightTurn Down = Left
turn :: (Direction -> Direction) -> GameEngine () 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 } player { playerVelocity = Velocity speed $ turnFn dir }
changeBoost :: Bool -> GameEngine () changeBoost :: Bool -> GameEngine ()
changeBoost boostActive = modify . second $ \player@Player{ .. } -> changeBoost boostActive = modify $ \player@Player{ .. } ->
player { playerBoost = playerBoost { boostActive = boostActive } } player { playerBoost = playerBoost { boostActive = boostActive } }
refillBoost :: Timestamp -> GameEngine () refillBoost :: TimeInterval -> GameEngine ()
refillBoost timeElapsed = do refillBoost timeElapsed = do
(gameMap, player@Player{ .. }) <- get player@Player{ .. } <- get
GameSettings{ .. } <- ask (GameSettings{ .. }, _) <- ask
let boostFuel' = floor (fromIntegral timeElapsed * gameBoostRefillFactor) let boostFuel' = floor (fromIntegral timeElapsed * gameBoostRefillFactor)
playerBoost' = playerBoost { boostFuel = boostFuel playerBoost + boostFuel' } playerBoost' = playerBoost { boostFuel = boostFuel playerBoost + boostFuel' }
put (gameMap, player { playerBoost = playerBoost' }) put player { playerBoost = playerBoost' }
tell $ DList.fromList [OutPlayerBoostChange playerId playerBoost' | playerBoost /= playerBoost'] -- tell $ DList.fromList [OutPlayerBoostChange playerId playerBoost' | playerBoost /= playerBoost']
stepGame :: Game -> Timestamp -> InEvent -> (Game, [OutEvent]) stepPlayer :: (Timestamp, InEvent) -> GameEngine ()
stepGame game@Game{ gameMap = gameMap@GameMap{ .. }, .. } time = stepGame' stepPlayer (time, inEvent) = do
player@Player { .. } <- get
let timeElapsed =time - playerLastEventTime
movePlayer time timeElapsed >> eventStep inEvent >> refillBoost timeElapsed
put $ player { playerLastEventTime = time }
where where
stepGame' (InPlayerTurnLeft playerId) = stepEvent playerId $ turn leftTurn eventStep :: InEvent -> GameEngine ()
stepGame' (InPlayerTurnRight playerId) = stepEvent playerId $ turn rightTurn eventStep (InPlayerTurnLeft _) = turn leftTurn
stepGame' (InPlayerIdle playerId) = stepEvent playerId $ return () eventStep (InPlayerTurnRight _) = turn rightTurn
stepGame' (InPlayerBoostChange playerId boostActive) = stepEvent playerId $ changeBoost boostActive eventStep (InPlayerIdle _) = return ()
eventStep (InPlayerBoostChange _ boostActive) = changeBoost boostActive
stepEvent pId step = getPlayerId :: InEvent -> Maybe PlayerId
flip (maybe (game, [])) (Map.lookup pId gamePlayers) $ \player@Player{ .. } -> getPlayerId (InPlayerTurnLeft playerId) = Just playerId
if playerState /= PlayerAlive getPlayerId (InPlayerTurnRight playerId) = Just playerId
then (game, []) getPlayerId (InPlayerIdle playerId) = Just playerId
else let getPlayerId (InPlayerBoostChange playerId _) = Just playerId
timeElapsed = time - playerLastEventTime getPlayerId _ = Nothing
fullStep = move timeElapsed >> step >> refillBoost timeElapsed
(gameMap', player'@Player{ playerPosition = pos' -- stepGame :: Game -> (Timestamp, InEvent) -> (Game, [OutEvent])
, playerVelocity = Velocity _ dir' }, outEvents) = -- stepGame game@Game{ gameMap = gameMap@GameMap{ .. }, .. } (time, inEvent) =
stepGameEngine gameSettings gameMap player fullStep
player'' = player' { playerScore = playerScore + score playerPosition pos' -- where
, playerLastEventTime = time } -- stepGame' (InPlayerTurnLeft playerId) = stepEvent playerId $ turn leftTurn
game' = game { gamePlayers = Map.insert playerId player'' gamePlayers -- stepGame' (InPlayerTurnRight playerId) = stepEvent playerId $ turn rightTurn
, gameMap = gameMap' } -- stepGame' (InPlayerIdle playerId) = stepEvent playerId $ return ()
outEvents' = outEvents ++ [OutPlayerPosition playerId pos' dir'] -- stepGame' (InPlayerBoostChange playerId boostActive) = stepEvent playerId $ changeBoost boostActive
in (game', outEvents')
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]) -- (gameMap', player'@Player{ playerPosition = pos'
runGame initialGame = -- , playerVelocity = Velocity _ dir' }, outEvents) =
foldl (\(game, outEvents) (time, inEvent) -> -- stepGameEngine gameSettings gameMap player fullStep
fmap (outEvents ++) $ stepGame game time inEvent)
(initialGame, []) -- 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

1
src/Hastron/Game/Types.hs
View File

@ -23,6 +23,7 @@ data PlayerState = PlayerAlive
| PlayerDead | PlayerDead
| PlayerDisconnected | PlayerDisconnected
| PlayerLeft | PlayerLeft
| PlayerStopped
deriving (Show, Eq, Ord, Enum) deriving (Show, Eq, Ord, Enum)
type PlayerTrail = [Point] type PlayerTrail = [Point]