implement physics including collision detection and handling

This commit is contained in:
nek0 2021-01-02 13:32:20 +01:00
parent 4941ec1904
commit 2f8b9054f2
8 changed files with 241 additions and 45 deletions

View file

@ -31,6 +31,7 @@ executable pituicat
, Types.Graphics.Shader
, Types.Util
, Types.Player
, Types.Tangible
, Classes
, Classes.Scene
, Classes.Actor

View file

@ -3,7 +3,8 @@ module Classes.Actor where
-- internal imports
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

View file

@ -1,3 +1,4 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
module Classes.Physics.Collidible where
import Linear
@ -7,17 +8,70 @@ import Linear
import Classes.Physics.Mass
-- | 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
-- positional vector of the axis alignes bounding box (AABB).
-- | returns the bottom left and top right corners relative to the objects
-- positional vector of the axis aligned bounding box (AABB) serving here
-- as collision boundaries.
boundary
:: c -- Object
-> ( V2 Double -- Top left corner of AABB relative to position
, V2 Double -- Bottom right corner of AABB relative to position
:: c -- ^ Object
-> ( V2 Double -- ^ Bottom left 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
:: c -- ^ Original object
-> c -- ^ Collision partner
-> c -- ^ Updated original object
:: (Collidible other)
=> c -- ^ 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')
)

View file

@ -6,11 +6,59 @@ import Linear
-- to implement the basic mass properties of a (very simplified) physical body.
class Mass m where
-- | The mass of the object
-- | The mass of the mass object.
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
-- | The scaling factor for how much this object is affected by gravity.
gravScale :: m -> Double
-- | Overwrite the velocity of the mass object.
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)

View file

@ -1,7 +1,7 @@
{-# LANGUAGE OverloadedStrings #-}
module Scenes.Test where
import Affection
import Affection as A
import qualified Graphics.Rendering.OpenGL as GL
@ -111,7 +111,7 @@ instance Scene Test where
)
let pituicat = Pituicat
(V2 400 1748)
(V2 600 1748)
(V2 0 0)
(V2 0 0)
100
@ -126,7 +126,7 @@ instance Scene Test where
atomically $ do
putTMVar (testGraphics level)
(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
void $ atomically $ do
@ -139,11 +139,42 @@ instance Scene Test where
update level dt = liftIO $ do
logIO Debug ("FPS: " <> fromString (show $ 1 / dt))
-- Let all Actors update themselves (Typeclasses rock!)
atomically $
-- Let all Actors update themselves and check for collisions
-- (Typeclasses rock!)
atomically $ do
lmap <- readTMVar (testMap level)
let layer = mapLayers lmap V.! fromIntegral (mapWalkLayer lmap)
modifyTVar
(testCast level)
(V.map (\(Cast c) -> Cast (perform dt c)))
(testCast level) $ \cast ->
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 ()
@ -152,40 +183,24 @@ instance Scene Test where
(LevelMap layers _ _ tileMap _) <-
atomically (readTMVar $ testMap level)
logIO Debug "loaded level"
stageSet <- readTVarIO (testStageSet level)
cast <- readTVarIO (testCast level)
logIO Debug "Read stage set and cast"
let (indices, vertices) = populate layers stageSet cast
logIO Debug "Populated"
bind va
bind vb
bind ib
logIO Debug "Bound buffers"
write vb 0 vertices
logIO Debug ("Written " <> fromString (show $ VS.length vertices) <> " vertices")
write ib 0 (VS.map fromIntegral indices)
logIO Debug ("Written " <> fromString (show $ VS.length indices) <> " indices")
logIO Debug "Wrote buffers"
bind (tileMapTexture tileMap)
V.mapM_ (\(StageSet p) -> bindPropTexture p) stageSet
V.mapM_ (\(Cast c) -> bindPropTexture c) cast
R.draw va ib sh
logIO Debug "Drawn"
testLevelDesc :: LevelDescriptor
testLevelDesc = LevelDescriptor
[ (0, "res/maps/00_test/00_test.bmp")

View file

@ -119,9 +119,9 @@ newShader shaderSrc = do
-- pass uniform values into Shader program
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
locs <- readMVar shaderUniforms
locs <- readMVar sUniforms
-- retrieve uniform location
let unilocs = filter
@ -142,7 +142,7 @@ setUniformList (Shader shaderProgram _ shaderUniforms) uniname data_ = do
GL.uniformv loc (fromIntegral $ length data_) ptr
--GL.uniform loc $= data_
-- add uniform to cache
modifyMVar_ shaderUniforms
modifyMVar_ sUniforms
(\list -> return $ ShaderUniform uniname loc : list)
[ShaderUniform _ loc] ->
-- set the data
@ -150,9 +150,9 @@ setUniformList (Shader shaderProgram _ shaderUniforms) uniname data_ = do
GL.uniformv loc (fromIntegral $ length data_) ptr
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
locs <- readMVar shaderUniforms
locs <- readMVar sUniforms
-- retrieve uniform location
let unilocs = filter
@ -173,7 +173,7 @@ setUniform (Shader shaderProgram _ shaderUniforms) uniname data_ = do
-- GL.uniformv loc (length data_) ptr
GL.uniform loc $= data_
-- add uniform to cache
modifyMVar_ shaderUniforms
modifyMVar_ sUniforms
(\list -> return $ ShaderUniform uniname loc : list)
[ShaderUniform _ loc] ->
-- set the data

View file

@ -11,6 +11,7 @@ import Linear
import Types.Texture
import Types.Graphics.VertexBuffer
import Classes.Graphics.Drawable
import Classes.Physics
data LevelMap = LevelMap
{ 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
= Solid
| Platform

View file

@ -1,17 +1,23 @@
{-# LANGUAGE OverloadedStrings #-}
module Types.Player where
import Affection as A
import qualified Graphics.Rendering.OpenGL as GL
import Linear
import qualified Data.Vector as V
import Data.String (fromString)
-- internal imports
import Classes.Graphics.Drawable
import Classes.Graphics.Bindable
import Classes.Prop
import Classes.Actor
import Classes.Physics
import Types.Graphics.VertexBuffer
import Types.Texture
@ -23,6 +29,7 @@ data Pituicat = Pituicat
, pcHealth :: Int
, pcTexture :: Texture
}
deriving (Eq, Show)
instance Drawable Pituicat where
@ -60,4 +67,47 @@ instance Prop 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)