From 2f8b9054f269dc258aff71b86ca2eb6f7fbfe62c Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 2 Jan 2021 13:32:20 +0100 Subject: [PATCH] implement physics including collision detection and handling --- pituicat.cabal | 1 + src/Classes/Actor.hs | 3 +- src/Classes/Physics/Collidible.hs | 74 ++++++++++++++++++++++++++----- src/Classes/Physics/Mass.hs | 56 +++++++++++++++++++++-- src/Scenes/Test.hs | 61 +++++++++++++++---------- src/Types/Graphics/Shader.hs | 12 ++--- src/Types/Map.hs | 27 +++++++++++ src/Types/Player.hs | 52 +++++++++++++++++++++- 8 files changed, 241 insertions(+), 45 deletions(-) diff --git a/pituicat.cabal b/pituicat.cabal index c3339d7..4d37673 100644 --- a/pituicat.cabal +++ b/pituicat.cabal @@ -31,6 +31,7 @@ executable pituicat , Types.Graphics.Shader , Types.Util , Types.Player + , Types.Tangible , Classes , Classes.Scene , Classes.Actor diff --git a/src/Classes/Actor.hs b/src/Classes/Actor.hs index fc74c88..f725845 100644 --- a/src/Classes/Actor.hs +++ b/src/Classes/Actor.hs @@ -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 diff --git a/src/Classes/Physics/Collidible.hs b/src/Classes/Physics/Collidible.hs index 6fb4080..3e54a9d 100644 --- a/src/Classes/Physics/Collidible.hs +++ b/src/Classes/Physics/Collidible.hs @@ -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') + ) diff --git a/src/Classes/Physics/Mass.hs b/src/Classes/Physics/Mass.hs index bbeb40b..f382865 100644 --- a/src/Classes/Physics/Mass.hs +++ b/src/Classes/Physics/Mass.hs @@ -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) diff --git a/src/Scenes/Test.hs b/src/Scenes/Test.hs index 12e0d6d..9d4a984 100644 --- a/src/Scenes/Test.hs +++ b/src/Scenes/Test.hs @@ -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") diff --git a/src/Types/Graphics/Shader.hs b/src/Types/Graphics/Shader.hs index ecf6ec4..6b32082 100644 --- a/src/Types/Graphics/Shader.hs +++ b/src/Types/Graphics/Shader.hs @@ -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 diff --git a/src/Types/Map.hs b/src/Types/Map.hs index 74695a2..7e2b11f 100644 --- a/src/Types/Map.hs +++ b/src/Types/Map.hs @@ -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 diff --git a/src/Types/Player.hs b/src/Types/Player.hs index 42a0015..bce369f 100644 --- a/src/Types/Player.hs +++ b/src/Types/Player.hs @@ -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)