reworked physics
This commit is contained in:
parent
c574671244
commit
9f47b192a5
8 changed files with 177 additions and 259 deletions
|
@ -6,20 +6,16 @@ import Affection as A
|
||||||
|
|
||||||
import Linear
|
import Linear
|
||||||
|
|
||||||
import Data.String (fromString)
|
|
||||||
|
|
||||||
import Data.List (sortBy)
|
|
||||||
|
|
||||||
-- internal imports
|
-- internal imports
|
||||||
|
|
||||||
import Physics.Classes.Mass
|
import Physics.Classes.Mass
|
||||||
|
|
||||||
data CollisionResult time direction
|
data CollisionResult direction
|
||||||
= NoCollision
|
= NoCollision
|
||||||
| CollisionImminent
|
-- | CollisionImminent
|
||||||
{ collisionTime :: time
|
-- { collisionTime :: time
|
||||||
, collisionDirection :: direction
|
-- , collisionDirection :: direction
|
||||||
}
|
-- }
|
||||||
| OverlapCollision
|
| OverlapCollision
|
||||||
{ collisionDepth :: direction
|
{ collisionDepth :: direction
|
||||||
}
|
}
|
||||||
|
@ -52,6 +48,9 @@ class (Show c, Mass c) => Collidible c where
|
||||||
-- | Flag indicating a collision during the current time step
|
-- | Flag indicating a collision during the current time step
|
||||||
collisionOccured :: c -> Bool
|
collisionOccured :: c -> Bool
|
||||||
|
|
||||||
|
-- | Update the collision occurence flag
|
||||||
|
updateCollisionOccurence :: c -> (Bool -> c)
|
||||||
|
|
||||||
-- | returns the bottom left and top right corners relative to the objects
|
-- | returns the bottom left and top right corners relative to the objects
|
||||||
-- positional vector of the axis aligned bounding box (AABB) serving here
|
-- positional vector of the axis aligned bounding box (AABB) serving here
|
||||||
-- as collision boundaries.
|
-- as collision boundaries.
|
||||||
|
@ -65,72 +64,73 @@ class (Show c, Mass c) => Collidible c where
|
||||||
:: (Collidible other)
|
:: (Collidible other)
|
||||||
=> c -- ^ First object
|
=> c -- ^ First object
|
||||||
-> other -- ^ second object
|
-> other -- ^ second object
|
||||||
-> CollisionResult Double (V2 Int) -- ^ Do the objects collide?
|
-> CollisionResult (V2 Double) -- ^ Do the objects collide?
|
||||||
collisionCheck m1 m2 =
|
collisionCheck m1 m2 =
|
||||||
let p1@(V2 p1x p1y) = position m1
|
let (V2 p1x p1y) = position m1
|
||||||
p2@(V2 p2x p2y) = position m2
|
(V2 p2x p2y) = position m2
|
||||||
v1@(V2 v1x v1y) = velocity m1
|
(V2 b1minx b1miny, V2 b1maxx b1maxy) = boundary m1
|
||||||
v2@(V2 v2x v2y) = velocity m2
|
(V2 b2minx b2miny, V2 b2maxx b2maxy) = boundary m2
|
||||||
(V2 dvx dvy) = v1 - v2
|
getCoordinates
|
||||||
(V2 dx dy) = p1 - p2
|
| 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
|
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.
|
-- | This Function is called for every collision on both colliding objects.
|
||||||
collide
|
collide
|
||||||
:: (Collidible other)
|
:: (Collidible other)
|
||||||
=> c -- ^ Original object
|
=> c -- ^ Original object
|
||||||
-> [(other, CollisionResult Double (V2 Int))] -- ^ Collision partners and results
|
-> [(other, CollisionResult (V2 Double))] -- ^ Collision partners and results
|
||||||
-> Double -- ^ Timestep length
|
-> Double -- ^ Timestep length
|
||||||
-> c -- ^ Updated original object
|
-> c -- ^ Updated original object
|
||||||
collide coll1 collrs = elasticCollision 0.9 coll1 (head collrs)
|
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 a dampened elastic collision used as default collision
|
||||||
-- implementation of the collision reaction
|
-- implementation of the collision reaction
|
||||||
elasticCollision
|
elasticCollision
|
||||||
:: (Collidible c1, Collidible c2)
|
:: (Collidible c1, Collidible c2)
|
||||||
=> Double
|
=> Double -- ^ Restitution coefficient
|
||||||
-> c1
|
-> c1 -- ^ First collision partner
|
||||||
-> (c2, CollisionResult Double (V2 Int))
|
-> (c2, CollisionResult (V2 Double)) -- ^ Second collision partner with collision result
|
||||||
-> Double -- ^ Timestep length
|
-> Double -- ^ Timestep length
|
||||||
-> c1
|
-> c1 -- ^ Updated first collision partner
|
||||||
elasticCollision _ mo1 (_, NoCollision) _ = mo1
|
elasticCollision _ mo1 (_, NoCollision) _ = mo1
|
||||||
elasticCollision damping mo1 (mo2, CollisionImminent ddt (V2 dirx diry)) dt =
|
elasticCollision restitution mo1 (mo2, OverlapCollision depth) dt =
|
||||||
let v1@(V2 v1x v1y) = velocity mo1
|
let dvel = (velocity mo1 - velocity mo2) * normalize depth
|
||||||
(V2 v2x v2y) = velocity mo2
|
j = (restitution + 1) * (- (dvel `dot` dvel)) /
|
||||||
p1 = position mo1
|
(1 / mass mo1 + 1 / mass mo2)
|
||||||
m1 = mass mo1
|
fi = (* (j / dt)) <$> normalize depth
|
||||||
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'
|
|
||||||
in
|
in
|
||||||
velocityUpdater
|
positionUpdater (addImpactForce (updateCollisionOccurence mo1 True) fi)
|
||||||
mo1
|
(position mo1 - depth)
|
||||||
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
|
|
||||||
|
|
|
@ -52,4 +52,11 @@ class Mass m where
|
||||||
dpos = (* dt) <$> nvel
|
dpos = (* dt) <$> nvel
|
||||||
npos = position m + dpos
|
npos = position m + dpos
|
||||||
in
|
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
|
||||||
|
|
|
@ -21,6 +21,7 @@ import Scenes.Test.Types
|
||||||
import Classes
|
import Classes
|
||||||
import Types
|
import Types
|
||||||
import Physics
|
import Physics
|
||||||
|
import Util
|
||||||
|
|
||||||
update
|
update
|
||||||
:: Test
|
:: Test
|
||||||
|
@ -58,7 +59,7 @@ update level dt = liftIO $ do
|
||||||
let res = collisionCheck dt tangible1 tangible2
|
let res = collisionCheck dt tangible1 tangible2
|
||||||
in
|
in
|
||||||
case res of
|
case res of
|
||||||
c@(CollisionImminent _ _) ->
|
c@(OverlapCollision _) ->
|
||||||
if qInd /= index
|
if qInd /= index
|
||||||
then jacc `V.snoc` (qInd, c)
|
then jacc `V.snoc` (qInd, c)
|
||||||
else jacc
|
else jacc
|
||||||
|
@ -71,7 +72,9 @@ update level dt = liftIO $ do
|
||||||
then iacc
|
then iacc
|
||||||
else iacc `V.snoc`
|
else iacc `V.snoc`
|
||||||
( index
|
( index
|
||||||
, sortOn (collisionTime . snd) (V.toList partners)
|
, sortOn
|
||||||
|
((\v -> collisionDepth v `dot` collisionDepth v) . snd)
|
||||||
|
(V.toList partners)
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
V.empty
|
V.empty
|
||||||
|
@ -93,7 +96,10 @@ update level dt = liftIO $ do
|
||||||
d
|
d
|
||||||
dt
|
dt
|
||||||
in
|
in
|
||||||
inter
|
resetImpactForces $ resetCollisionOccurence $
|
||||||
|
if collisionOccured inter
|
||||||
|
then addLoads inter (impactForces inter)
|
||||||
|
else addLoads inter constG
|
||||||
)
|
)
|
||||||
digest
|
digest
|
||||||
in
|
in
|
||||||
|
@ -112,11 +118,11 @@ update level dt = liftIO $ do
|
||||||
(\acc@(castAcc, pAcc, _) input ->
|
(\acc@(castAcc, pAcc, _) input ->
|
||||||
case input of
|
case input of
|
||||||
TCast c ->
|
TCast c ->
|
||||||
(castAcc `V.snoc` move dt c, pAcc, mnewCat)
|
(castAcc `V.snoc` updateByEuler c dt, pAcc, mnewCat)
|
||||||
TPowerUp p ->
|
TPowerUp p ->
|
||||||
(castAcc, pAcc `V.snoc` move dt p, mnewCat)
|
(castAcc, pAcc `V.snoc` updateByEuler p dt, mnewCat)
|
||||||
TPlayer ncat ->
|
TPlayer ncat ->
|
||||||
(castAcc, pAcc, Just (move dt ncat))
|
(castAcc, pAcc, Just (updateByEuler ncat dt))
|
||||||
TTile _ ->
|
TTile _ ->
|
||||||
acc
|
acc
|
||||||
)
|
)
|
||||||
|
@ -125,144 +131,3 @@ update level dt = liftIO $ do
|
||||||
writeTVar (testCast level) newCast
|
writeTVar (testCast level) newCast
|
||||||
writeTVar (testPowerups level) newPowerups
|
writeTVar (testPowerups level) newPowerups
|
||||||
writeTVar (testPlayer level) mnewCat
|
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
|
|
||||||
|
|
|
@ -16,22 +16,32 @@ instance Mass Cast where
|
||||||
|
|
||||||
mass (Cast a) = mass a
|
mass (Cast a) = mass a
|
||||||
|
|
||||||
acceleration (Cast a) = acceleration a
|
|
||||||
|
|
||||||
accelerationUpdater (Cast a) = Cast . accelerationUpdater a
|
|
||||||
|
|
||||||
velocity (Cast a) = velocity a
|
velocity (Cast a) = velocity a
|
||||||
|
|
||||||
velocityUpdater (Cast a) = Cast . velocityUpdater a
|
velocityUpdater (Cast a) = Cast . velocityUpdater a
|
||||||
|
|
||||||
|
forces (Cast a) = forces a
|
||||||
|
|
||||||
|
forcesUpdater (Cast a) = Cast . forcesUpdater a
|
||||||
|
|
||||||
position (Cast a) = position a
|
position (Cast a) = position a
|
||||||
|
|
||||||
positionUpdater (Cast a) = Cast . positionUpdater a
|
positionUpdater (Cast a) = Cast . positionUpdater a
|
||||||
|
|
||||||
instance Collidible Cast where
|
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
|
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
|
collide (Cast c1) res dt = Cast $ collide c1 res dt
|
||||||
|
|
|
@ -41,6 +41,7 @@ data Tile = Tile
|
||||||
{ tilePosition :: V2 Word -- ^
|
{ tilePosition :: V2 Word -- ^
|
||||||
, tileOffset :: (V2 Float, V2 Float) -- ^ Graphics offset on 'TileMap'
|
, tileOffset :: (V2 Float, V2 Float) -- ^ Graphics offset on 'TileMap'
|
||||||
, tileType :: TileType -- ^ Type of tile
|
, tileType :: TileType -- ^ Type of tile
|
||||||
|
, tileCollided :: Bool
|
||||||
}
|
}
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
@ -48,7 +49,7 @@ instance Drawable Tile where
|
||||||
|
|
||||||
-- type VertexList Tile = V.Vector
|
-- 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 [ 0, 1, 2, 2, 3, 0 ]
|
||||||
, V.fromList
|
, V.fromList
|
||||||
[ newVertex
|
[ newVertex
|
||||||
|
@ -76,12 +77,12 @@ instance Drawable Tile where
|
||||||
|
|
||||||
instance Mass Tile where
|
instance Mass Tile where
|
||||||
|
|
||||||
|
forces _ = V2 0 0
|
||||||
|
|
||||||
|
forcesUpdater t _ = t
|
||||||
|
|
||||||
mass _ = recip 0
|
mass _ = recip 0
|
||||||
|
|
||||||
acceleration _ = V2 0 0
|
|
||||||
|
|
||||||
accelerationUpdater t = const t
|
|
||||||
|
|
||||||
velocity _ = V2 0 0
|
velocity _ = V2 0 0
|
||||||
|
|
||||||
velocityUpdater t = const t
|
velocityUpdater t = const t
|
||||||
|
@ -95,6 +96,18 @@ instance Mass Tile where
|
||||||
|
|
||||||
instance Collidible 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 _ =
|
boundary _ =
|
||||||
( V2 (-16) (-16)
|
( V2 (-16) (-16)
|
||||||
, V2 16 16
|
, V2 16 16
|
||||||
|
|
|
@ -31,7 +31,10 @@ catMoveVelocity = 100
|
||||||
|
|
||||||
data Pituicat = Pituicat
|
data Pituicat = Pituicat
|
||||||
{ pcPos :: V2 Double
|
{ pcPos :: V2 Double
|
||||||
|
, pcPrevPos :: V2 Double
|
||||||
, pcVel :: V2 Double
|
, pcVel :: V2 Double
|
||||||
|
, pcForces :: V2 Double
|
||||||
|
, pcImpactForces :: V2 Double
|
||||||
, pcMoveVel :: V2 Double
|
, pcMoveVel :: V2 Double
|
||||||
, pcTMoveVel :: V2 Double
|
, pcTMoveVel :: V2 Double
|
||||||
, pcAcc :: V2 Double
|
, pcAcc :: V2 Double
|
||||||
|
@ -42,6 +45,7 @@ data Pituicat = Pituicat
|
||||||
, pcViewDirection :: ViewDirection
|
, pcViewDirection :: ViewDirection
|
||||||
, pcEffects :: [EffectHolder]
|
, pcEffects :: [EffectHolder]
|
||||||
, pcXColl :: Bool
|
, pcXColl :: Bool
|
||||||
|
, pcCollisionOcc :: Bool
|
||||||
}
|
}
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
@ -50,7 +54,7 @@ data ViewDirection = ViewLeft | ViewRight
|
||||||
|
|
||||||
instance Drawable Pituicat where
|
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 [0, 1, 2, 2, 3, 0]
|
||||||
, V.fromList
|
, V.fromList
|
||||||
[ newVertex
|
[ newVertex
|
||||||
|
@ -103,7 +107,7 @@ instance Actor Pituicat where
|
||||||
not (any ((SpeedUp ==) . effectReleased) (pcEffects p))
|
not (any ((SpeedUp ==) . effectReleased) (pcEffects p))
|
||||||
then 1
|
then 1
|
||||||
else 2
|
else 2
|
||||||
physCat = (accelerate dt . gravitate constG)
|
physCat =
|
||||||
(p
|
(p
|
||||||
{ pcAcc = V2 0 0
|
{ pcAcc = V2 0 0
|
||||||
, pcTMoveVel =
|
, pcTMoveVel =
|
||||||
|
@ -149,13 +153,6 @@ instance Mass Pituicat where
|
||||||
|
|
||||||
mass _ = 100
|
mass _ = 100
|
||||||
|
|
||||||
acceleration = pcAcc
|
|
||||||
|
|
||||||
accelerationUpdater cat =
|
|
||||||
\accel -> cat
|
|
||||||
{ pcAcc = accel
|
|
||||||
}
|
|
||||||
|
|
||||||
velocity =
|
velocity =
|
||||||
pcVel
|
pcVel
|
||||||
|
|
||||||
|
@ -164,6 +161,12 @@ instance Mass Pituicat where
|
||||||
{ pcVel = vel
|
{ pcVel = vel
|
||||||
}
|
}
|
||||||
|
|
||||||
|
forces = pcForces
|
||||||
|
|
||||||
|
forcesUpdater c force = c
|
||||||
|
{ pcForces = force
|
||||||
|
}
|
||||||
|
|
||||||
position = pcPos
|
position = pcPos
|
||||||
|
|
||||||
positionUpdater cat =
|
positionUpdater cat =
|
||||||
|
@ -171,15 +174,22 @@ instance Mass Pituicat where
|
||||||
{ pcPos = pos
|
{ 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
|
instance Collidible Pituicat where
|
||||||
|
|
||||||
|
impactForces = pcImpactForces
|
||||||
|
|
||||||
|
impactForcesUpdater c force = c
|
||||||
|
{ pcImpactForces = force
|
||||||
|
}
|
||||||
|
|
||||||
|
collisionOccured = pcCollisionOcc
|
||||||
|
|
||||||
|
updateCollisionOccurence c coll = c
|
||||||
|
{ pcCollisionOcc = coll
|
||||||
|
}
|
||||||
|
|
||||||
|
prevPosition = pcPrevPos
|
||||||
|
|
||||||
boundary cat =
|
boundary cat =
|
||||||
if pcViewDirection cat == ViewRight
|
if pcViewDirection cat == ViewRight
|
||||||
then
|
then
|
||||||
|
@ -196,12 +206,12 @@ instance Collidible Pituicat where
|
||||||
}
|
}
|
||||||
collide cat collrs@((_, NoCollision):_) _ = cat
|
collide cat collrs@((_, NoCollision):_) _ = cat
|
||||||
{ pcXColl = any
|
{ pcXColl = any
|
||||||
(\(_, CollisionImminent _ (V2 cx _)) -> cx /= 0)
|
(\(_, OverlapCollision (V2 cx _)) -> cx /= 0)
|
||||||
(filter ((NoCollision /= ) . snd) collrs)
|
(filter ((NoCollision /= ) . snd) collrs)
|
||||||
}
|
}
|
||||||
collide cat collrs@(collr@(_, OverlapCollision direction):_) dt =
|
collide cat collrs@(collr@(_, OverlapCollision direction):_) dt =
|
||||||
elasticCollision 0.3 cat collr 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
|
let ncat = elasticCollision 0.3 cat collr dt
|
||||||
vel@(V2 vx vy) = velocity ncat
|
vel@(V2 vx vy) = velocity ncat
|
||||||
moveVel@(V2 mx my) = pcMoveVel cat
|
moveVel@(V2 mx my) = pcMoveVel cat
|
||||||
|
|
|
@ -17,21 +17,23 @@ import Graphics.Types.Texture
|
||||||
import Graphics.Classes.Drawable
|
import Graphics.Classes.Drawable
|
||||||
import Graphics.Classes.Bindable
|
import Graphics.Classes.Bindable
|
||||||
|
|
||||||
import Util
|
|
||||||
|
|
||||||
data PowerUp = PowerUp
|
data PowerUp = PowerUp
|
||||||
{ puPos :: V2 Double
|
{ puPos :: V2 Double
|
||||||
, puVel :: V2 Double
|
, puPrevPos :: V2 Double
|
||||||
, puAcc :: V2 Double
|
, puVel :: V2 Double
|
||||||
, puTTL :: Double
|
, puAcc :: V2 Double
|
||||||
, puTexture :: Texture
|
, puTTL :: Double
|
||||||
, puEffect :: EffectHolder
|
, puTexture :: Texture
|
||||||
|
, puEffect :: EffectHolder
|
||||||
|
, puForces :: V2 Double
|
||||||
|
, puImpactForces :: V2 Double
|
||||||
|
, puCollided :: Bool
|
||||||
}
|
}
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
instance Drawable PowerUp where
|
instance Drawable PowerUp where
|
||||||
|
|
||||||
toVertices (PowerUp (V2 x y) _ _ _ _ _) =
|
toVertices (PowerUp (V2 x y) _ _ _ _ _ _ _ _ _) =
|
||||||
( V.fromList [0, 1, 2, 2, 3, 0]
|
( V.fromList [0, 1, 2, 2, 3, 0]
|
||||||
, V.fromList
|
, V.fromList
|
||||||
[ newVertex
|
[ newVertex
|
||||||
|
@ -66,7 +68,7 @@ instance Prop PowerUp where
|
||||||
instance Actor PowerUp where
|
instance Actor PowerUp where
|
||||||
|
|
||||||
perform dt o =
|
perform dt o =
|
||||||
let phys = (accelerate dt . gravitate constG)
|
let phys =
|
||||||
o
|
o
|
||||||
{ puAcc = V2 0 0
|
{ puAcc = V2 0 0
|
||||||
, puTTL = puTTL o - dt
|
, puTTL = puTTL o - dt
|
||||||
|
@ -78,12 +80,11 @@ instance Mass PowerUp where
|
||||||
|
|
||||||
mass _ = 0.1
|
mass _ = 0.1
|
||||||
|
|
||||||
acceleration = puAcc
|
forces = puForces
|
||||||
|
|
||||||
accelerationUpdater o =
|
forcesUpdater p force = p
|
||||||
\acc -> o
|
{ puForces = force
|
||||||
{ puAcc = acc
|
}
|
||||||
}
|
|
||||||
|
|
||||||
velocity = puVel
|
velocity = puVel
|
||||||
|
|
||||||
|
@ -101,6 +102,20 @@ instance Mass PowerUp where
|
||||||
|
|
||||||
instance Collidible 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 _ =
|
boundary _ =
|
||||||
( V2 (-20) (-20)
|
( V2 (-20) (-20)
|
||||||
, V2 20 20
|
, V2 20 20
|
||||||
|
|
|
@ -3,20 +3,18 @@ module Util where
|
||||||
import Affection
|
import Affection
|
||||||
|
|
||||||
import qualified SDL
|
import qualified SDL
|
||||||
import qualified SDL.Internal.Numbered as SDL
|
|
||||||
|
|
||||||
import Linear
|
import Linear
|
||||||
|
|
||||||
-- internal imports
|
-- internal imports
|
||||||
|
|
||||||
import Types.Application
|
import Types.Application
|
||||||
import Types.Subsystems
|
|
||||||
|
|
||||||
globalKeyHandle
|
globalKeyHandle
|
||||||
:: GameData
|
:: GameData
|
||||||
-> KeyboardMessage
|
-> KeyboardMessage
|
||||||
-> Affection ()
|
-> Affection ()
|
||||||
globalKeyHandle gd mesg@(MsgKeyboardEvent time win motion repeat keysym) =
|
globalKeyHandle _ mesg@MsgKeyboardEvent {} =
|
||||||
case mesg of
|
case mesg of
|
||||||
MsgKeyboardEvent
|
MsgKeyboardEvent
|
||||||
_
|
_
|
||||||
|
|
Loading…
Reference in a new issue