diff --git a/src/Physics/Classes/Collidible.hs b/src/Physics/Classes/Collidible.hs index 1e4918f..6193fef 100644 --- a/src/Physics/Classes/Collidible.hs +++ b/src/Physics/Classes/Collidible.hs @@ -6,20 +6,16 @@ import Affection as A import Linear -import Data.String (fromString) - -import Data.List (sortBy) - -- internal imports import Physics.Classes.Mass -data CollisionResult time direction +data CollisionResult direction = NoCollision - | CollisionImminent - { collisionTime :: time - , collisionDirection :: direction - } + -- | CollisionImminent + -- { collisionTime :: time + -- , collisionDirection :: direction + -- } | OverlapCollision { collisionDepth :: direction } @@ -52,6 +48,9 @@ class (Show c, Mass c) => Collidible c where -- | Flag indicating a collision during the current time step collisionOccured :: c -> Bool + -- | Update the collision occurence flag + updateCollisionOccurence :: c -> (Bool -> c) + -- | 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. @@ -65,72 +64,73 @@ class (Show c, Mass c) => Collidible c where :: (Collidible other) => c -- ^ First object -> other -- ^ second object - -> CollisionResult Double (V2 Int) -- ^ Do the objects collide? + -> CollisionResult (V2 Double) -- ^ Do the objects collide? collisionCheck m1 m2 = - let p1@(V2 p1x p1y) = position m1 - p2@(V2 p2x p2y) = position m2 - v1@(V2 v1x v1y) = velocity m1 - v2@(V2 v2x v2y) = velocity m2 - (V2 dvx dvy) = v1 - v2 - (V2 dx dy) = p1 - p2 + let (V2 p1x p1y) = position m1 + (V2 p2x p2y) = position m2 + (V2 b1minx b1miny, V2 b1maxx b1maxy) = boundary m1 + (V2 b2minx b2miny, V2 b2maxx b2maxy) = boundary m2 + getCoordinates + | p1x <= p2x && p1y <= p2y = + let x1 = p1x + b1maxx + y1 = p1y + b1maxy + x2 = p2x + b2minx + y2 = p2y + b2minx + in (x1, y1, x2, y2) + | p1x > p2x && p1y <= p2y = + let x1 = p1x + b1minx + y1 = p1y + b1maxy + x2 = p2x + b2maxx + y2 = p2y + b2miny + in (x1, y1, x2, y2) + | p1x <= p2x && p1y > p2y = + let x1 = p1x + b1maxx + y1 = p1y + b1miny + x2 = p2x + b2minx + y2 = p2y + b2maxy + in (x1, y1, x2, y2) + | otherwise = + let x1 = p1x + b1minx + y1 = p1y + b1miny + x2 = p2x + b2maxx + y2 = p2y + b2maxy + in (x1, y1, x2, y2) + (ox1, oy1, ox2, oy2) = getCoordinates in - error "collisionCheck: Not yet implemented!" + if ox2 - ox1 < 0 || oy2 - oy1 < 0 + then OverlapCollision + (V2 + (min 0 (ox2 - ox1) * (- 1)) + (min 0 (oy2 - oy1) * (- 1)) + ) + else + NoCollision -- | This Function is called for every collision on both colliding objects. collide :: (Collidible other) - => c -- ^ Original object - -> [(other, CollisionResult Double (V2 Int))] -- ^ Collision partners and results - -> Double -- ^ Timestep length - -> c -- ^ Updated original object - collide coll1 collrs = elasticCollision 0.9 coll1 (head collrs) + => c -- ^ Original object + -> [(other, CollisionResult (V2 Double))] -- ^ Collision partners and results + -> Double -- ^ Timestep length + -> c -- ^ Updated original object + collide coll1 collrs dt = + foldl (\acc a -> elasticCollision 0.9 acc a dt) coll1 collrs -- | Implementation of a dampened elastic collision used as default collision -- implementation of the collision reaction elasticCollision :: (Collidible c1, Collidible c2) - => Double - -> c1 - -> (c2, CollisionResult Double (V2 Int)) - -> Double -- ^ Timestep length - -> c1 + => Double -- ^ Restitution coefficient + -> c1 -- ^ First collision partner + -> (c2, CollisionResult (V2 Double)) -- ^ Second collision partner with collision result + -> Double -- ^ Timestep length + -> c1 -- ^ Updated first collision partner elasticCollision _ mo1 (_, NoCollision) _ = mo1 -elasticCollision damping mo1 (mo2, CollisionImminent ddt (V2 dirx diry)) dt = - let v1@(V2 v1x v1y) = velocity mo1 - (V2 v2x v2y) = velocity mo2 - p1 = position mo1 - m1 = mass mo1 - m2 = mass mo2 - v1x' = 2 * (m1 * v1x + m2 * v2x) / (m1 + m2) - v1x - v1y' = 2 * (m1 * v1y + m2 * v2y) / (m1 + m2) - v1y - nvel = if m1 == recip 0 - then V2 0 0 - else (damping *) <$> - if m2 == recip 0 - then - if dirx /= 0 - then V2 (-v1x) v1y - else V2 v1x (-v1y) - else V2 v1x' v1y' +elasticCollision restitution mo1 (mo2, OverlapCollision depth) dt = + let dvel = (velocity mo1 - velocity mo2) * normalize depth + j = (restitution + 1) * (- (dvel `dot` dvel)) / + (1 / mass mo1 + 1 / mass mo2) + fi = (* (j / dt)) <$> normalize depth in - velocityUpdater - mo1 - nvel -elasticCollision damping mo1 (mo2, OverlapCollision depth) dt = - let m1 = mass mo1 - m2 = mass mo2 - (V2 dx dy) = (/ dt) . fromIntegral <$> depth - v1x' = 2 * (m1 * dx + m2 * (-dx)) / (m1 + m2) - dx - v1y' = 2 * (m1 * dy + m2 * (-dy)) / (m1 + m2) - dy - nvel = if m1 == recip 0 - then V2 0 0 - else (damping *) <$> - if m2 == recip 0 - then - if dx /= 0 - then V2 (-v1x') v1y' - else V2 v1x' (-v1y') - else - V2 v1x' v1y' - in - velocityUpdater mo1 nvel + positionUpdater (addImpactForce (updateCollisionOccurence mo1 True) fi) + (position mo1 - depth) diff --git a/src/Physics/Classes/Mass.hs b/src/Physics/Classes/Mass.hs index 67b8133..44cd10a 100644 --- a/src/Physics/Classes/Mass.hs +++ b/src/Physics/Classes/Mass.hs @@ -52,4 +52,11 @@ class Mass m where dpos = (* dt) <$> nvel npos = position m + dpos in - positionUpdater (velocityUpdater m nvel) npos + resetForces $ positionUpdater (velocityUpdater m nvel) npos + + calculateLoads + :: m -- ^ Original mass object + -> V2 Double -- ^ Gravitational force vector + -> m -- ^ Updated mass object + calculateLoads = + addLoads diff --git a/src/Scenes/Test/Update.hs b/src/Scenes/Test/Update.hs index 67f71d9..140861d 100644 --- a/src/Scenes/Test/Update.hs +++ b/src/Scenes/Test/Update.hs @@ -21,6 +21,7 @@ import Scenes.Test.Types import Classes import Types import Physics +import Util update :: Test @@ -58,7 +59,7 @@ update level dt = liftIO $ do let res = collisionCheck dt tangible1 tangible2 in case res of - c@(CollisionImminent _ _) -> + c@(OverlapCollision _) -> if qInd /= index then jacc `V.snoc` (qInd, c) else jacc @@ -71,7 +72,9 @@ update level dt = liftIO $ do then iacc else iacc `V.snoc` ( index - , sortOn (collisionTime . snd) (V.toList partners) + , sortOn + ((\v -> collisionDepth v `dot` collisionDepth v) . snd) + (V.toList partners) ) ) V.empty @@ -93,7 +96,10 @@ update level dt = liftIO $ do d dt in - inter + resetImpactForces $ resetCollisionOccurence $ + if collisionOccured inter + then addLoads inter (impactForces inter) + else addLoads inter constG ) digest in @@ -112,11 +118,11 @@ update level dt = liftIO $ do (\acc@(castAcc, pAcc, _) input -> case input of TCast c -> - (castAcc `V.snoc` move dt c, pAcc, mnewCat) + (castAcc `V.snoc` updateByEuler c dt, pAcc, mnewCat) TPowerUp p -> - (castAcc, pAcc `V.snoc` move dt p, mnewCat) + (castAcc, pAcc `V.snoc` updateByEuler p dt, mnewCat) TPlayer ncat -> - (castAcc, pAcc, Just (move dt ncat)) + (castAcc, pAcc, Just (updateByEuler ncat dt)) TTile _ -> acc ) @@ -125,144 +131,3 @@ update level dt = liftIO $ do writeTVar (testCast level) newCast writeTVar (testPowerups level) newPowerups writeTVar (testPlayer level) mnewCat - - -- oldCast <- V.map (\(Cast c) -> Cast $ perform dt c) <$> - -- readTVar (testCast level) - -- oldCat <- perform dt <$> fromJust <$> readTVar (testPlayer level) - -- modifyTVar (testCast level) $ \cast -> - -- let playedCast = - -- V.map - -- (\(Cast c) -> Cast (perform dt c)) - -- cast - -- collidedCast = - -- V.map - -- (\(Cast c1) -> - -- let partners = V.foldl - -- (\acc@(Cast _, ires) (Cast c2) -> - -- let res = collisionCheck dt c1 c2 - -- in - -- if res /= NoCollision && - -- collisionTime res < collisionTime ires - -- then (Cast c2, res) - -- else acc - -- ) - -- (Cast c1, NoCollision) - -- playedCast - -- in - -- if null partners - -- then Cast c1 - -- else - -- uncurry - -- (\(Cast c2) result -> Cast $ collide c1 c2 result) - -- partners - -- ) - -- playedCast - -- wallCast (Cast c) = - -- Cast $ performWorldCollision c layer dt - -- walledCast = - -- V.map wallCast collidedCast - -- cattedCast = V.map - -- (\(Cast c) -> - -- Cast $ collide c oldCat $ collisionCheck dt c oldCat - -- ) - -- walledCast - -- in - -- V.map - -- (\(Cast c) -> Cast $ - -- move dt c - -- ) - -- walledCast - -- releasedEffects <- stateTVar (testPowerups level) $ \pus -> - -- let living = V.foldl - -- (\acc pu -> - -- let npu = perform dt pu - -- in - -- if puTTL npu > 0 - -- then npu `V.cons` acc - -- else acc - -- ) - -- V.empty - -- pus - -- indexCollected = V.filter ((/= NoCollision) . snd) $ - -- V.zip (V.fromList [0..length living]) - -- (V.map - -- (collisionCheck dt oldCat) - -- living - -- ) - -- collected = V.foldl - -- (\acc (ind, _) -> - -- (living V.! ind) `V.cons` acc - -- ) - -- V.empty - -- indexCollected - -- differ = V.foldl - -- (\acc life -> if life `V.elem` collected - -- then acc - -- else life `V.cons` acc - -- ) - -- V.empty - -- living - -- fin = V.map - -- (\pu -> move dt $ performWorldCollision pu layer dt) - -- differ - -- in - -- (collected, fin) - -- modifyTVar - -- (testPlayer level) $ \(Just pituicat) -> - -- let playedCat = perform dt pituicat - -- castCat = - -- let allPartners = V.zip (V.fromList [0..V.length oldCast]) - -- (V.map - -- (\(Cast c) -> collisionCheck dt playedCat c) - -- oldCast - -- ) - -- filtered = (V.filter ((/= NoCollision) . snd) allPartners) - -- partner = V.minimumBy - -- (\(_, e) (_, f) -> collisionTime e `compare` collisionTime f) - -- filtered - -- in - -- if V.null filtered - -- then - -- playedCat - -- else - -- uncurry - -- (\(Cast c) cr -> collide playedCat c cr) - -- (oldCast V.! fst partner, snd partner) - -- walledCat = performWorldCollision castCat layer dt - -- affectedCat = walledCat - -- { pcEffects = pcEffects walledCat ++ - -- map puEffect (V.toList releasedEffects) - -- } - -- in Just $ move dt affectedCat - --- performWorldCollision --- :: (Collidible c) --- => c -- ^ Cast member to check --- -> Layer -- ^ The walk layer of the level --- -> Double -- ^ Tick length --- -> c -- ^ Updated cast member --- performWorldCollision c layer dt = --- let partner = V.foldl --- (\acc@(part, cr) tile -> --- let res = collisionCheck dt c tile --- ret = if cr == NoCollision && res == NoCollision --- then --- acc --- else --- if cr == NoCollision && res /= NoCollision --- then (tile, res) --- else --- if cr /= NoCollision && res == NoCollision --- then --- acc --- else --- if collisionTime cr < collisionTime res --- then acc --- else (tile, res) --- in --- ret --- ) --- (V.head layer, collisionCheck dt c $ V.head layer) --- layer --- in --- (uncurry (collide c) partner) dt diff --git a/src/Types/Cast.hs b/src/Types/Cast.hs index da5ba98..80fe2e0 100644 --- a/src/Types/Cast.hs +++ b/src/Types/Cast.hs @@ -16,22 +16,32 @@ instance Mass Cast where mass (Cast a) = mass a - acceleration (Cast a) = acceleration a - - accelerationUpdater (Cast a) = Cast . accelerationUpdater a - velocity (Cast a) = velocity a velocityUpdater (Cast a) = Cast . velocityUpdater a + forces (Cast a) = forces a + + forcesUpdater (Cast a) = Cast . forcesUpdater a + position (Cast a) = position a positionUpdater (Cast a) = Cast . positionUpdater a instance Collidible Cast where + prevPosition (Cast c) = prevPosition c + + impactForces (Cast c) = impactForces c + + impactForcesUpdater (Cast c) = Cast . impactForcesUpdater c + + collisionOccured (Cast c) = collisionOccured c + + updateCollisionOccurence (Cast c) = Cast . updateCollisionOccurence c + boundary (Cast c) = boundary c - collisionCheck dt (Cast c1) c2 = collisionCheck dt c1 c2 + collisionCheck (Cast c1) c2 = collisionCheck c1 c2 collide (Cast c1) res dt = Cast $ collide c1 res dt diff --git a/src/Types/Map.hs b/src/Types/Map.hs index 27fbe15..6053d1e 100644 --- a/src/Types/Map.hs +++ b/src/Types/Map.hs @@ -41,6 +41,7 @@ data Tile = Tile { tilePosition :: V2 Word -- ^ , tileOffset :: (V2 Float, V2 Float) -- ^ Graphics offset on 'TileMap' , tileType :: TileType -- ^ Type of tile + , tileCollided :: Bool } deriving (Eq, Show) @@ -48,7 +49,7 @@ instance Drawable Tile where -- type VertexList Tile = V.Vector - toVertices (Tile (V2 x y) (V2 u1 v1, V2 u2 v2) _) = + toVertices (Tile (V2 x y) (V2 u1 v1, V2 u2 v2) _ _) = ( V.fromList [ 0, 1, 2, 2, 3, 0 ] , V.fromList [ newVertex @@ -76,12 +77,12 @@ instance Drawable Tile where instance Mass Tile where + forces _ = V2 0 0 + + forcesUpdater t _ = t + mass _ = recip 0 - acceleration _ = V2 0 0 - - accelerationUpdater t = const t - velocity _ = V2 0 0 velocityUpdater t = const t @@ -95,6 +96,18 @@ instance Mass Tile where instance Collidible Tile where + prevPosition t = position t + + impactForces _ = V2 0 0 + + impactForcesUpdater t _ = t + + collisionOccured t = tileCollided t + + updateCollisionOccurence t coll = t + { tileCollided = coll + } + boundary _ = ( V2 (-16) (-16) , V2 16 16 diff --git a/src/Types/Player.hs b/src/Types/Player.hs index 2fb0b07..6624eaf 100644 --- a/src/Types/Player.hs +++ b/src/Types/Player.hs @@ -31,7 +31,10 @@ catMoveVelocity = 100 data Pituicat = Pituicat { pcPos :: V2 Double + , pcPrevPos :: V2 Double , pcVel :: V2 Double + , pcForces :: V2 Double + , pcImpactForces :: V2 Double , pcMoveVel :: V2 Double , pcTMoveVel :: V2 Double , pcAcc :: V2 Double @@ -42,6 +45,7 @@ data Pituicat = Pituicat , pcViewDirection :: ViewDirection , pcEffects :: [EffectHolder] , pcXColl :: Bool + , pcCollisionOcc :: Bool } deriving (Eq, Show) @@ -50,7 +54,7 @@ data ViewDirection = ViewLeft | ViewRight instance Drawable Pituicat where - toVertices (Pituicat (V2 x y) _ _ _ _ _ _ _ _ vd _ _) = + toVertices (Pituicat (V2 x y) _ _ _ _ _ _ _ _ _ _ _ vd _ _ _) = ( V.fromList [0, 1, 2, 2, 3, 0] , V.fromList [ newVertex @@ -103,7 +107,7 @@ instance Actor Pituicat where not (any ((SpeedUp ==) . effectReleased) (pcEffects p)) then 1 else 2 - physCat = (accelerate dt . gravitate constG) + physCat = (p { pcAcc = V2 0 0 , pcTMoveVel = @@ -149,13 +153,6 @@ instance Mass Pituicat where mass _ = 100 - acceleration = pcAcc - - accelerationUpdater cat = - \accel -> cat - { pcAcc = accel - } - velocity = pcVel @@ -164,6 +161,12 @@ instance Mass Pituicat where { pcVel = vel } + forces = pcForces + + forcesUpdater c force = c + { pcForces = force + } + position = pcPos positionUpdater cat = @@ -171,15 +174,22 @@ instance Mass Pituicat where { pcPos = pos } - move dt cat = - let dpos = (dt *) <$> velocity cat - mpos = (dt *) <$> - (if pcXColl cat then V2 (-1) 1 else V2 1 1) * pcMoveVel cat - in - positionUpdater cat (position cat + dpos + mpos) - instance Collidible Pituicat where + impactForces = pcImpactForces + + impactForcesUpdater c force = c + { pcImpactForces = force + } + + collisionOccured = pcCollisionOcc + + updateCollisionOccurence c coll = c + { pcCollisionOcc = coll + } + + prevPosition = pcPrevPos + boundary cat = if pcViewDirection cat == ViewRight then @@ -196,12 +206,12 @@ instance Collidible Pituicat where } collide cat collrs@((_, NoCollision):_) _ = cat { pcXColl = any - (\(_, CollisionImminent _ (V2 cx _)) -> cx /= 0) + (\(_, OverlapCollision (V2 cx _)) -> cx /= 0) (filter ((NoCollision /= ) . snd) collrs) } collide cat collrs@(collr@(_, OverlapCollision direction):_) dt = elasticCollision 0.3 cat collr dt - collide cat collrs@(collr@(other, CollisionImminent ddt (V2 dirx diry)):_) dt = + collide cat collrs@(collr@(other, OverlapCollision (V2 dirx diry)):_) dt = let ncat = elasticCollision 0.3 cat collr dt vel@(V2 vx vy) = velocity ncat moveVel@(V2 mx my) = pcMoveVel cat diff --git a/src/Types/PowerUp.hs b/src/Types/PowerUp.hs index c722343..2095bf0 100644 --- a/src/Types/PowerUp.hs +++ b/src/Types/PowerUp.hs @@ -17,21 +17,23 @@ import Graphics.Types.Texture import Graphics.Classes.Drawable import Graphics.Classes.Bindable -import Util - data PowerUp = PowerUp - { puPos :: V2 Double - , puVel :: V2 Double - , puAcc :: V2 Double - , puTTL :: Double - , puTexture :: Texture - , puEffect :: EffectHolder + { puPos :: V2 Double + , puPrevPos :: V2 Double + , puVel :: V2 Double + , puAcc :: V2 Double + , puTTL :: Double + , puTexture :: Texture + , puEffect :: EffectHolder + , puForces :: V2 Double + , puImpactForces :: V2 Double + , puCollided :: Bool } deriving (Eq, Show) instance Drawable PowerUp where - toVertices (PowerUp (V2 x y) _ _ _ _ _) = + toVertices (PowerUp (V2 x y) _ _ _ _ _ _ _ _ _) = ( V.fromList [0, 1, 2, 2, 3, 0] , V.fromList [ newVertex @@ -66,7 +68,7 @@ instance Prop PowerUp where instance Actor PowerUp where perform dt o = - let phys = (accelerate dt . gravitate constG) + let phys = o { puAcc = V2 0 0 , puTTL = puTTL o - dt @@ -78,12 +80,11 @@ instance Mass PowerUp where mass _ = 0.1 - acceleration = puAcc + forces = puForces - accelerationUpdater o = - \acc -> o - { puAcc = acc - } + forcesUpdater p force = p + { puForces = force + } velocity = puVel @@ -101,6 +102,20 @@ instance Mass PowerUp where instance Collidible PowerUp where + prevPosition = puPrevPos + + impactForces = puImpactForces + + impactForcesUpdater p force = p + { puImpactForces = force + } + + collisionOccured = puCollided + + updateCollisionOccurence p coll = p + { puCollided = coll + } + boundary _ = ( V2 (-20) (-20) , V2 20 20 diff --git a/src/Util.hs b/src/Util.hs index 1e72a20..1e348d7 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -3,20 +3,18 @@ module Util where import Affection import qualified SDL -import qualified SDL.Internal.Numbered as SDL import Linear -- internal imports import Types.Application -import Types.Subsystems globalKeyHandle :: GameData -> KeyboardMessage -> Affection () -globalKeyHandle gd mesg@(MsgKeyboardEvent time win motion repeat keysym) = +globalKeyHandle _ mesg@MsgKeyboardEvent {} = case mesg of MsgKeyboardEvent _