implement physics including collision detection and handling

pituicat.cabal

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

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

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')
+        )

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)

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")

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

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

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)