implement physics including collision detection and handling
This commit is contained in:
parent
4941ec1904
commit
2f8b9054f2
|
@ -31,6 +31,7 @@ executable pituicat
|
||||||
, Types.Graphics.Shader
|
, Types.Graphics.Shader
|
||||||
, Types.Util
|
, Types.Util
|
||||||
, Types.Player
|
, Types.Player
|
||||||
|
, Types.Tangible
|
||||||
, Classes
|
, Classes
|
||||||
, Classes.Scene
|
, Classes.Scene
|
||||||
, Classes.Actor
|
, Classes.Actor
|
||||||
|
|
|
@ -3,7 +3,8 @@ module Classes.Actor where
|
||||||
-- internal imports
|
-- internal imports
|
||||||
|
|
||||||
import Classes.Prop
|
import Classes.Prop
|
||||||
|
import Classes.Physics.Collidible
|
||||||
|
|
||||||
class (Prop a) => Actor a where
|
class (Prop a, Collidible a) => Actor a where
|
||||||
|
|
||||||
perform :: Double -> a -> a
|
perform :: Double -> a -> a
|
||||||
|
|
|
@ -1,3 +1,4 @@
|
||||||
|
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||||
module Classes.Physics.Collidible where
|
module Classes.Physics.Collidible where
|
||||||
|
|
||||||
import Linear
|
import Linear
|
||||||
|
@ -7,17 +8,70 @@ import Linear
|
||||||
import Classes.Physics.Mass
|
import Classes.Physics.Mass
|
||||||
|
|
||||||
-- | Typeclass for implementing collision results on objects.
|
-- | Typeclass for implementing collision results on objects.
|
||||||
class Mass c => Collidible c where
|
class (Show c, Mass c) => Collidible c where
|
||||||
|
|
||||||
-- | returns the top left and bottom right corners relative to the objects
|
-- | returns the bottom left and top right corners relative to the objects
|
||||||
-- positional vector of the axis alignes bounding box (AABB).
|
-- positional vector of the axis aligned bounding box (AABB) serving here
|
||||||
|
-- as collision boundaries.
|
||||||
boundary
|
boundary
|
||||||
:: c -- Object
|
:: c -- ^ Object
|
||||||
-> ( V2 Double -- Top left corner of AABB relative to position
|
-> ( V2 Double -- ^ Bottom left corner of AABB relative to position
|
||||||
, V2 Double -- Bottom right corner of AABB relative to position
|
, V2 Double -- ^ Top right corner of AABB relative to position
|
||||||
)
|
)
|
||||||
-- | This Function is called for every collision for both colliding objects.
|
|
||||||
|
collisionCheck
|
||||||
|
:: (Collidible other)
|
||||||
|
=> c -- ^ First object
|
||||||
|
-> other -- ^ second object
|
||||||
|
-> Bool -- ^ Do the objects collide?
|
||||||
|
collisionCheck m1 m2 =
|
||||||
|
let (V2 m1x1 m1y1) = position m1 + fst (boundary m1)
|
||||||
|
(V2 m1x2 m1y2) = position m1 + snd (boundary m1)
|
||||||
|
(V2 m2x1 m2y1) = position m2 + fst (boundary m2)
|
||||||
|
(V2 m2x2 m2y2) = position m2 + snd (boundary m2)
|
||||||
|
in
|
||||||
|
or
|
||||||
|
[ m1x1 < m2x2 && m1x1 > m2x1
|
||||||
|
, m1x2 < m2x2 && m1x2 > m2x1
|
||||||
|
, m2x1 < m1x2 && m2x1 > m1x1
|
||||||
|
, m2x2 < m1x2 && m2x2 > m1x1
|
||||||
|
] && or
|
||||||
|
[ m1y1 < m2y2 && m1y1 > m2y1
|
||||||
|
, m1y2 < m2y2 && m1y2 > m2y1
|
||||||
|
, m2y1 < m1y2 && m2y1 > m1y1
|
||||||
|
, m2y2 < m1y2 && m2y2 > m1y1
|
||||||
|
]
|
||||||
|
|
||||||
|
|
||||||
|
-- | This Function is called for every collision on both colliding objects.
|
||||||
collide
|
collide
|
||||||
:: c -- ^ Original object
|
:: (Collidible other)
|
||||||
-> c -- ^ Collision partner
|
=> c -- ^ Original object
|
||||||
-> c -- ^ Updated original object
|
-> other -- ^ Collision partner
|
||||||
|
-> c -- ^ Updated original object
|
||||||
|
collide = elasticCollision 0.9
|
||||||
|
|
||||||
|
-- | Implementation of a dampened elastic collision used as default collision
|
||||||
|
-- implementation of the collision reaction
|
||||||
|
elasticCollision
|
||||||
|
:: (Collidible c1, Collidible c2)
|
||||||
|
=> Double
|
||||||
|
-> c1
|
||||||
|
-> c2
|
||||||
|
-> c1
|
||||||
|
elasticCollision damping mo1 mo2 =
|
||||||
|
let (V2 v1x v1y) = velocity mo1
|
||||||
|
(V2 v2x v2y) = velocity mo2
|
||||||
|
m1 = mass mo1
|
||||||
|
m2 = mass mo2
|
||||||
|
v1x' = 2 * (m1 * v1x + m2 * v2x) / (m1 + m2) - v1x
|
||||||
|
v1y' = 2 * (m1 * v1y + m2 * v2y) / (m1 + m2) - v1y
|
||||||
|
in
|
||||||
|
(velocityUpdater mo1)
|
||||||
|
(if m1 == recip 0
|
||||||
|
then V2 0 0
|
||||||
|
else (damping *) <$>
|
||||||
|
if m2 == recip 0
|
||||||
|
then negate <$> velocity mo1
|
||||||
|
else (V2 v1x' v1y')
|
||||||
|
)
|
||||||
|
|
|
@ -6,11 +6,59 @@ import Linear
|
||||||
-- to implement the basic mass properties of a (very simplified) physical body.
|
-- to implement the basic mass properties of a (very simplified) physical body.
|
||||||
class Mass m where
|
class Mass m where
|
||||||
|
|
||||||
-- | The mass of the object
|
-- | The mass of the mass object.
|
||||||
mass :: m -> Double
|
mass :: m -> Double
|
||||||
|
|
||||||
-- | velocity of the object
|
-- | Retrieve the acceleration of the mass object.
|
||||||
|
acceleration :: m -> V2 Double
|
||||||
|
|
||||||
|
-- | Overwrite the acceleration of the mass object.
|
||||||
|
accelerationUpdater :: m -> (V2 Double -> m)
|
||||||
|
|
||||||
|
-- | retrieve the elocity of the mass object.
|
||||||
velocity :: m -> V2 Double
|
velocity :: m -> V2 Double
|
||||||
|
|
||||||
-- | The scaling factor for how much this object is affected by gravity.
|
-- | Overwrite the velocity of the mass object.
|
||||||
gravScale :: m -> Double
|
velocityUpdater :: m -> (V2 Double -> m)
|
||||||
|
|
||||||
|
-- | Retrieve the position of the mass object.
|
||||||
|
position :: m -> V2 Double
|
||||||
|
|
||||||
|
-- | Overwrite the position of the mass object.
|
||||||
|
positionUpdater :: m -> (V2 Double -> m)
|
||||||
|
|
||||||
|
-- | The update function to let a mass react to gravitational pull.
|
||||||
|
-- Apply all accelerations before calling the default implementation of
|
||||||
|
-- this function, since it will add the gravitational pull to already
|
||||||
|
-- existing accelerations.
|
||||||
|
gravitate
|
||||||
|
:: V2 Double -- ^ Vector of gravitational acceleration
|
||||||
|
-> m -- ^ Original mass object
|
||||||
|
-> m -- ^ Updated mass object
|
||||||
|
gravitate g m =
|
||||||
|
let acc = acceleration m + g
|
||||||
|
in
|
||||||
|
(accelerationUpdater m) acc
|
||||||
|
|
||||||
|
-- | Apply acceleration to mass object und thus change its velocity
|
||||||
|
accelerate
|
||||||
|
:: Double -- ^ Time step duration
|
||||||
|
-> m -- ^ Original mass object
|
||||||
|
-> m -- ^ Updated mass object
|
||||||
|
accelerate dt m =
|
||||||
|
let vel = velocity m + ((dt *) <$> acceleration m)
|
||||||
|
in
|
||||||
|
(velocityUpdater m) vel
|
||||||
|
|
||||||
|
-- | Apply velocity to mass object and thus change its position
|
||||||
|
-- Changes in position smaller than a pixel are ignored.
|
||||||
|
move
|
||||||
|
:: Double -- ^ Time step duration
|
||||||
|
-> m -- ^ Original mass object
|
||||||
|
-> m -- ^ Updated mass object
|
||||||
|
move dt m =
|
||||||
|
let dpos = ((dt *) <$> velocity m)
|
||||||
|
in
|
||||||
|
if quadrance dpos < 1
|
||||||
|
then m
|
||||||
|
else (positionUpdater m) (position m + dpos)
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
module Scenes.Test where
|
module Scenes.Test where
|
||||||
|
|
||||||
import Affection
|
import Affection as A
|
||||||
|
|
||||||
import qualified Graphics.Rendering.OpenGL as GL
|
import qualified Graphics.Rendering.OpenGL as GL
|
||||||
|
|
||||||
|
@ -111,7 +111,7 @@ instance Scene Test where
|
||||||
)
|
)
|
||||||
|
|
||||||
let pituicat = Pituicat
|
let pituicat = Pituicat
|
||||||
(V2 400 1748)
|
(V2 600 1748)
|
||||||
(V2 0 0)
|
(V2 0 0)
|
||||||
(V2 0 0)
|
(V2 0 0)
|
||||||
100
|
100
|
||||||
|
@ -126,7 +126,7 @@ instance Scene Test where
|
||||||
atomically $ do
|
atomically $ do
|
||||||
putTMVar (testGraphics level)
|
putTMVar (testGraphics level)
|
||||||
(GLAssets vertexArray vertexBuffer indexBuffer shader [tex])
|
(GLAssets vertexArray vertexBuffer indexBuffer shader [tex])
|
||||||
modifyTVar (testStageSet level) (\set -> StageSet pituicat `V.cons` set)
|
modifyTVar (testCast level) (\cast -> Cast pituicat `V.cons` cast)
|
||||||
writeTVar (testLoaded level) True
|
writeTVar (testLoaded level) True
|
||||||
|
|
||||||
void $ atomically $ do
|
void $ atomically $ do
|
||||||
|
@ -139,11 +139,42 @@ instance Scene Test where
|
||||||
update level dt = liftIO $ do
|
update level dt = liftIO $ do
|
||||||
logIO Debug ("FPS: " <> fromString (show $ 1 / dt))
|
logIO Debug ("FPS: " <> fromString (show $ 1 / dt))
|
||||||
|
|
||||||
-- Let all Actors update themselves (Typeclasses rock!)
|
-- Let all Actors update themselves and check for collisions
|
||||||
atomically $
|
-- (Typeclasses rock!)
|
||||||
|
atomically $ do
|
||||||
|
lmap <- readTMVar (testMap level)
|
||||||
|
let layer = mapLayers lmap V.! fromIntegral (mapWalkLayer lmap)
|
||||||
modifyTVar
|
modifyTVar
|
||||||
(testCast level)
|
(testCast level) $ \cast ->
|
||||||
(V.map (\(Cast c) -> Cast (perform dt c)))
|
let playedCast =
|
||||||
|
V.map
|
||||||
|
(\(Cast c) -> Cast (perform dt c))
|
||||||
|
cast
|
||||||
|
collidedCast =
|
||||||
|
(\(Cast c1) (Cast c2) ->
|
||||||
|
Cast $
|
||||||
|
if collisionCheck c1 c2
|
||||||
|
then collide c1 c2
|
||||||
|
else c1
|
||||||
|
)
|
||||||
|
<$> playedCast <*> playedCast
|
||||||
|
wallCast (Cast c) = Cast $
|
||||||
|
V.foldl
|
||||||
|
(\member tile ->
|
||||||
|
if collisionCheck member tile
|
||||||
|
then collide member tile
|
||||||
|
else member
|
||||||
|
)
|
||||||
|
c
|
||||||
|
layer
|
||||||
|
walledCast =
|
||||||
|
V.map wallCast collidedCast
|
||||||
|
in
|
||||||
|
V.map
|
||||||
|
(\(Cast c) -> Cast $
|
||||||
|
move dt c
|
||||||
|
)
|
||||||
|
walledCast
|
||||||
|
|
||||||
onEvents _ _ = return ()
|
onEvents _ _ = return ()
|
||||||
|
|
||||||
|
@ -152,40 +183,24 @@ instance Scene Test where
|
||||||
(LevelMap layers _ _ tileMap _) <-
|
(LevelMap layers _ _ tileMap _) <-
|
||||||
atomically (readTMVar $ testMap level)
|
atomically (readTMVar $ testMap level)
|
||||||
|
|
||||||
logIO Debug "loaded level"
|
|
||||||
|
|
||||||
stageSet <- readTVarIO (testStageSet level)
|
stageSet <- readTVarIO (testStageSet level)
|
||||||
cast <- readTVarIO (testCast level)
|
cast <- readTVarIO (testCast level)
|
||||||
|
|
||||||
logIO Debug "Read stage set and cast"
|
|
||||||
|
|
||||||
let (indices, vertices) = populate layers stageSet cast
|
let (indices, vertices) = populate layers stageSet cast
|
||||||
|
|
||||||
logIO Debug "Populated"
|
|
||||||
|
|
||||||
bind va
|
bind va
|
||||||
bind vb
|
bind vb
|
||||||
bind ib
|
bind ib
|
||||||
|
|
||||||
logIO Debug "Bound buffers"
|
|
||||||
|
|
||||||
write vb 0 vertices
|
write vb 0 vertices
|
||||||
|
|
||||||
logIO Debug ("Written " <> fromString (show $ VS.length vertices) <> " vertices")
|
|
||||||
|
|
||||||
write ib 0 (VS.map fromIntegral indices)
|
write ib 0 (VS.map fromIntegral indices)
|
||||||
|
|
||||||
logIO Debug ("Written " <> fromString (show $ VS.length indices) <> " indices")
|
|
||||||
|
|
||||||
logIO Debug "Wrote buffers"
|
|
||||||
|
|
||||||
bind (tileMapTexture tileMap)
|
bind (tileMapTexture tileMap)
|
||||||
V.mapM_ (\(StageSet p) -> bindPropTexture p) stageSet
|
V.mapM_ (\(StageSet p) -> bindPropTexture p) stageSet
|
||||||
V.mapM_ (\(Cast c) -> bindPropTexture c) cast
|
V.mapM_ (\(Cast c) -> bindPropTexture c) cast
|
||||||
R.draw va ib sh
|
R.draw va ib sh
|
||||||
|
|
||||||
logIO Debug "Drawn"
|
|
||||||
|
|
||||||
testLevelDesc :: LevelDescriptor
|
testLevelDesc :: LevelDescriptor
|
||||||
testLevelDesc = LevelDescriptor
|
testLevelDesc = LevelDescriptor
|
||||||
[ (0, "res/maps/00_test/00_test.bmp")
|
[ (0, "res/maps/00_test/00_test.bmp")
|
||||||
|
|
|
@ -119,9 +119,9 @@ newShader shaderSrc = do
|
||||||
|
|
||||||
-- pass uniform values into Shader program
|
-- pass uniform values into Shader program
|
||||||
setUniformList :: (Storable a, GL.Uniform a) => Shader -> String -> [a] -> IO ()
|
setUniformList :: (Storable a, GL.Uniform a) => Shader -> String -> [a] -> IO ()
|
||||||
setUniformList (Shader shaderProgram _ shaderUniforms) uniname data_ = do
|
setUniformList (Shader shaderProgram _ sUniforms) uniname data_ = do
|
||||||
-- check if uniform location is already cached
|
-- check if uniform location is already cached
|
||||||
locs <- readMVar shaderUniforms
|
locs <- readMVar sUniforms
|
||||||
|
|
||||||
-- retrieve uniform location
|
-- retrieve uniform location
|
||||||
let unilocs = filter
|
let unilocs = filter
|
||||||
|
@ -142,7 +142,7 @@ setUniformList (Shader shaderProgram _ shaderUniforms) uniname data_ = do
|
||||||
GL.uniformv loc (fromIntegral $ length data_) ptr
|
GL.uniformv loc (fromIntegral $ length data_) ptr
|
||||||
--GL.uniform loc $= data_
|
--GL.uniform loc $= data_
|
||||||
-- add uniform to cache
|
-- add uniform to cache
|
||||||
modifyMVar_ shaderUniforms
|
modifyMVar_ sUniforms
|
||||||
(\list -> return $ ShaderUniform uniname loc : list)
|
(\list -> return $ ShaderUniform uniname loc : list)
|
||||||
[ShaderUniform _ loc] ->
|
[ShaderUniform _ loc] ->
|
||||||
-- set the data
|
-- set the data
|
||||||
|
@ -150,9 +150,9 @@ setUniformList (Shader shaderProgram _ shaderUniforms) uniname data_ = do
|
||||||
GL.uniformv loc (fromIntegral $ length data_) ptr
|
GL.uniformv loc (fromIntegral $ length data_) ptr
|
||||||
|
|
||||||
setUniform :: (GL.Uniform a) => Shader -> String -> a -> IO ()
|
setUniform :: (GL.Uniform a) => Shader -> String -> a -> IO ()
|
||||||
setUniform (Shader shaderProgram _ shaderUniforms) uniname data_ = do
|
setUniform (Shader shaderProgram _ sUniforms) uniname data_ = do
|
||||||
-- check if uniform location is already cached
|
-- check if uniform location is already cached
|
||||||
locs <- readMVar shaderUniforms
|
locs <- readMVar sUniforms
|
||||||
|
|
||||||
-- retrieve uniform location
|
-- retrieve uniform location
|
||||||
let unilocs = filter
|
let unilocs = filter
|
||||||
|
@ -173,7 +173,7 @@ setUniform (Shader shaderProgram _ shaderUniforms) uniname data_ = do
|
||||||
-- GL.uniformv loc (length data_) ptr
|
-- GL.uniformv loc (length data_) ptr
|
||||||
GL.uniform loc $= data_
|
GL.uniform loc $= data_
|
||||||
-- add uniform to cache
|
-- add uniform to cache
|
||||||
modifyMVar_ shaderUniforms
|
modifyMVar_ sUniforms
|
||||||
(\list -> return $ ShaderUniform uniname loc : list)
|
(\list -> return $ ShaderUniform uniname loc : list)
|
||||||
[ShaderUniform _ loc] ->
|
[ShaderUniform _ loc] ->
|
||||||
-- set the data
|
-- set the data
|
||||||
|
|
|
@ -11,6 +11,7 @@ import Linear
|
||||||
import Types.Texture
|
import Types.Texture
|
||||||
import Types.Graphics.VertexBuffer
|
import Types.Graphics.VertexBuffer
|
||||||
import Classes.Graphics.Drawable
|
import Classes.Graphics.Drawable
|
||||||
|
import Classes.Physics
|
||||||
|
|
||||||
data LevelMap = LevelMap
|
data LevelMap = LevelMap
|
||||||
{ mapLayers :: V.Vector Layer -- ^ Layer stack
|
{ mapLayers :: V.Vector Layer -- ^ Layer stack
|
||||||
|
@ -73,6 +74,32 @@ instance Drawable Tile where
|
||||||
]
|
]
|
||||||
)
|
)
|
||||||
|
|
||||||
|
instance Mass Tile where
|
||||||
|
|
||||||
|
mass _ = recip 0
|
||||||
|
|
||||||
|
acceleration _ = V2 0 0
|
||||||
|
|
||||||
|
accelerationUpdater t = const t
|
||||||
|
|
||||||
|
velocity _ = V2 0 0
|
||||||
|
|
||||||
|
velocityUpdater t = const t
|
||||||
|
|
||||||
|
position t =
|
||||||
|
let (V2 x y) = fromIntegral <$> tilePosition t
|
||||||
|
in
|
||||||
|
V2 (x * 32 + 16) (y * 32 + 16)
|
||||||
|
|
||||||
|
positionUpdater t = const t
|
||||||
|
|
||||||
|
instance Collidible Tile where
|
||||||
|
|
||||||
|
boundary _ =
|
||||||
|
( V2 (-16) (-16)
|
||||||
|
, V2 16 16
|
||||||
|
)
|
||||||
|
|
||||||
data TileType
|
data TileType
|
||||||
= Solid
|
= Solid
|
||||||
| Platform
|
| Platform
|
||||||
|
|
|
@ -1,17 +1,23 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
module Types.Player where
|
module Types.Player where
|
||||||
|
|
||||||
|
import Affection as A
|
||||||
|
|
||||||
import qualified Graphics.Rendering.OpenGL as GL
|
import qualified Graphics.Rendering.OpenGL as GL
|
||||||
|
|
||||||
import Linear
|
import Linear
|
||||||
|
|
||||||
import qualified Data.Vector as V
|
import qualified Data.Vector as V
|
||||||
|
|
||||||
|
import Data.String (fromString)
|
||||||
|
|
||||||
-- internal imports
|
-- internal imports
|
||||||
|
|
||||||
import Classes.Graphics.Drawable
|
import Classes.Graphics.Drawable
|
||||||
import Classes.Graphics.Bindable
|
import Classes.Graphics.Bindable
|
||||||
import Classes.Prop
|
import Classes.Prop
|
||||||
import Classes.Actor
|
import Classes.Actor
|
||||||
|
import Classes.Physics
|
||||||
|
|
||||||
import Types.Graphics.VertexBuffer
|
import Types.Graphics.VertexBuffer
|
||||||
import Types.Texture
|
import Types.Texture
|
||||||
|
@ -23,6 +29,7 @@ data Pituicat = Pituicat
|
||||||
, pcHealth :: Int
|
, pcHealth :: Int
|
||||||
, pcTexture :: Texture
|
, pcTexture :: Texture
|
||||||
}
|
}
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
instance Drawable Pituicat where
|
instance Drawable Pituicat where
|
||||||
|
|
||||||
|
@ -60,4 +67,47 @@ instance Prop Pituicat where
|
||||||
|
|
||||||
instance Actor Pituicat where
|
instance Actor Pituicat where
|
||||||
|
|
||||||
perform _ p = p
|
perform dt p = (A.log Debug ("moving from " <> fromString (show $ pcPos p)))
|
||||||
|
(move dt . accelerate dt . gravitate (V2 0 (-250))) (p {pcAcc = 0})
|
||||||
|
|
||||||
|
instance Mass Pituicat where
|
||||||
|
|
||||||
|
mass _ = 1
|
||||||
|
|
||||||
|
acceleration = pcAcc
|
||||||
|
|
||||||
|
accelerationUpdater cat =
|
||||||
|
(\accel -> cat
|
||||||
|
{ pcAcc = accel
|
||||||
|
}
|
||||||
|
)
|
||||||
|
|
||||||
|
velocity = pcVel
|
||||||
|
|
||||||
|
velocityUpdater cat =
|
||||||
|
(\vel -> cat
|
||||||
|
{ pcVel = vel
|
||||||
|
}
|
||||||
|
)
|
||||||
|
|
||||||
|
position = pcPos
|
||||||
|
|
||||||
|
positionUpdater cat =
|
||||||
|
(\pos -> cat
|
||||||
|
{ pcPos = pos
|
||||||
|
}
|
||||||
|
)
|
||||||
|
|
||||||
|
instance Collidible Pituicat where
|
||||||
|
|
||||||
|
boundary _ =
|
||||||
|
( V2 (-25) (-25)
|
||||||
|
, V2 25 25
|
||||||
|
)
|
||||||
|
|
||||||
|
collide cat other =
|
||||||
|
A.log
|
||||||
|
Debug
|
||||||
|
("*boing* meow! other: " <>
|
||||||
|
fromString (show other))
|
||||||
|
(elasticCollision 0.1 cat other)
|
||||||
|
|
Loading…
Reference in New Issue