nek0/pituicat
2
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

tinker more on collision. objects move, but glitches ensue.

Browse source
This commit is contained in:
nek0 2021-07-08 18:39:31 +02:00
parent 40e82e26f6
commit b3a2e58af4
8 changed files with 388 additions and 168 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

139
src/Physics/Classes/Collidible.hs
View file

@ -90,6 +90,27 @@ class (Show c, Mass c) => Collidible c where
b2maxy > b1miny && b2maxy < b1maxy) b2maxy > b1miny && b2maxy < b1maxy)
in in
in2 || in1 in2 || in1
overlap =
let in1 =
(m1b1x > m2b1x && m1b1x < m2b2x &&
m1b1y > m2b1y && m1b1y < m2b2y) ||
(m1b2x > m2b1x && m1b2x < m2b2x &&
m1b1y > m2b1y && m1b1y < m2b2y) ||
(m1b1x > m2b1x && m1b2x < m2b2x &&
m1b2y > m2b1y && m1b2y < m2b2y) ||
(m1b2x > m2b1x && m1b2x < m2b2x &&
m1b2y > m2b1y && m1b2y < m2b2y)
in2 =
(m2b1x > m1b1x && m2b1x < m1b2x &&
m2b1y > m1b1y && m2b1y < m1b2y) ||
(m2b2x > m1b1x && m2b2x < m1b2x &&
m2b1y > m1b1y && m2b1y < m1b2y) ||
(m2b1x > m1b1x && m2b2x < m1b2x &&
m2b2y > m1b1y && m2b2y < m1b2y) ||
(m2b2x > m1b1x && m2b2x < m1b2x &&
m2b2y > m1b1y && m2b2y < m1b2y)
in
in2 || in1
tx = tx =
let p1x = (\(V2 x _) -> x) (if d1x < 0 then m1p1 else m1p4) let p1x = (\(V2 x _) -> x) (if d1x < 0 then m1p1 else m1p4)
p2x = (\(V2 x _) -> x) (if d1x < 0 then m2p4 else m2p1) p2x = (\(V2 x _) -> x) (if d1x < 0 then m2p4 else m2p1)
@ -103,57 +124,75 @@ class (Show c, Mass c) => Collidible c where
in in
if broadphaseOverlap if broadphaseOverlap
then then
let coll xdir = -- if overlap
let (p11, p12, p21, p22) = if False
if xdir then
then Collision
if d1x < 0 (if tx < ty then tx else ty)
(if tx < ty
then V2 (floor $ signum d1x) 0
else V2 0 (floor $ signum d1y)
)
else
let coll xdir =
let (p11, p12, p21, p22) =
if xdir
then then
(m1p1, m1p2, m2p4, m2p3) if d1x < 0
then
(m1p1, m1p2, m2p4, m2p3)
else
(m1p4, m1p3, m2p1, m2p2)
else else
(m1p4, m1p3, m2p1, m2p2) if d1y < 0
else then
if d1y < 0 (m1p1, m1p4, m2p2, m2p3)
then else
(m1p1, m1p4, m2p2, m2p3) (m1p2, m1p3, m2p1, m2p4)
else vselector (V2 x y) = if xdir then y else x
(m1p2, m1p3, m2p1, m2p4) tick = if xdir then tx else ty
vselector (V2 x y) = if xdir then y else x g1s = vselector $ p11 + ((tick *) <$> d1)
tick = if xdir then tx else ty g1e = vselector $ p12 + ((tick *) <$> d1)
g1s = vselector $ p11 + ((tick *) <$> d1) g2s = vselector $ p21 + ((tick *) <$> d2)
g1e = vselector $ p12 + ((tick *) <$> d1) g2e = vselector $ p22 + ((tick *) <$> d2)
g2s = vselector $ p21 + ((tick *) <$> d2) s11 = (g1s - g2s) / (g2e - g2s)
g2e = vselector $ p22 + ((tick *) <$> d2) s12 = (g1e - g2s) / (g2e - g2s)
s11 = (g1s - g2s) / (g2e - g2s) s21 = (g2s - g1s) / (g1e - g1s)
s12 = (g1e - g2s) / (g2e - g2s) s22 = (g2e - g1s) / (g1e - g1s)
s21 = (g2s - g1s) / (g1e - g1s) in
s22 = (g2e - g1s) / (g1e - g1s) any (\x -> x > 0 && x < 1) [s11, s12, s21 ,s22]
in res = case (tx < dt, ty < dt, tx < ty, coll True, coll False) of
any (\x -> x > 0 && x < 1) [s11, s12, s21 ,s22] (True, _, True, True, _) ->
res = case (tx < dt, ty < dt, tx < ty, coll True, coll False) of Collision tx (V2 (floor $ signum d1x) 0)
(True, _, True, True, _) -> (_, True, False, _, True) ->
Collision tx (V2 (floor $ signum d1x) 0) Collision ty (V2 0 (floor $ signum d1y))
(_, True, False, _, True) -> (True, _, False, True, False) ->
Collision ty (V2 0 (floor $ signum d1y)) Collision tx (V2 (floor $ signum d1x) 0)
(True, _, False, True, False) -> (_, True, True, False, True) ->
Collision tx (V2 (floor $ signum d1x) 0) Collision ty (V2 0 (floor $ signum d1y))
(_, True, True, False, True) -> (True, _, True, False, _) ->
Collision ty (V2 0 (floor $ signum d1y)) NoCollision
(True, _, True, False, _) -> (_, True, False, _, False) ->
NoCollision NoCollision
(_, True, False, _, False) -> (_, _, _, False, False) ->
NoCollision NoCollision
(_, _, _, False, False) -> (_, _, True, _, _) ->
NoCollision A.log A.Debug ("CORNER CASE!") NoCollision
(_, _, True, _, _) -> (False, False, _, _, _) ->
A.log A.Debug ("CORNER CASE!") NoCollision NoCollision
(False, False, _, _, _) -> x -> error $
NoCollision "Unhandled combination of collision check results: "
x -> error $ <> (fromString $ show x)
"Unhandled combination of collision check results: " in
<> (fromString $ show x) -- res
in if tx < 0 || ty < 0
res then A.log A.Debug ("PING!") res
else res
-- case res of
-- Collision _ _ ->
-- A.log A.Debug "colliding!" res
-- NoCollision ->
-- res
else else
NoCollision NoCollision
@ -189,7 +228,7 @@ elasticCollision damping mo1 mo2 (Collision ddt (V2 dirx _)) =
else (damping *) <$> else (damping *) <$>
if m2 == recip 0 if m2 == recip 0
then then
if abs dirx > 0 if dirx /= 0
then (V2 (-v1x) v1y) then (V2 (-v1x) v1y)
else (V2 v1x (-v1y)) else (V2 v1x (-v1y))
else (V2 v1x' v1y') else (V2 v1x' v1y')

2
src/Physics/Classes/Mass.hs
View file

@ -15,7 +15,7 @@ class Mass m where
-- | Overwrite the acceleration of the mass object. -- | Overwrite the acceleration of the mass object.
accelerationUpdater :: m -> (V2 Double -> m) accelerationUpdater :: m -> (V2 Double -> m)
-- | retrieve the elocity of the mass object. -- | retrieve the velocity of the mass object.
velocity :: m -> V2 Double velocity :: m -> V2 Double
-- | Overwrite the velocity of the mass object. -- | Overwrite the velocity of the mass object.

291
src/Scenes/Test/Update.hs
View file

@ -1,11 +1,14 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
module Scenes.Test.Update where module Scenes.Test.Update where
import Affection as A import Affection as A
import Control.Concurrent.STM import Control.Concurrent.STM
import Data.List (sortOn)
import qualified Data.Vector as V import qualified Data.Vector as V
import Data.Maybe import Data.Maybe
@ -32,115 +35,195 @@ update level dt = liftIO $ do
-- (Typeclasses rock!) -- (Typeclasses rock!)
atomically $ do atomically $ do
lmap <- readTMVar (testMap level) lmap <- readTMVar (testMap level)
cast <-
V.map (\(Cast c) -> Cast $ perform dt c) <$> readTVar (testCast level)
powerups <- V.filter ((0 <) . puTTL) <$>
V.map (perform dt) <$>
readTVar (testPowerups level)
cat <- perform dt <$> fromJust <$> readTVar (testPlayer level)
let layer = mapLayers lmap V.! fromIntegral (mapWalkLayer lmap) let layer = mapLayers lmap V.! fromIntegral (mapWalkLayer lmap)
oldCast <- V.map (\(Cast c) -> Cast $ perform dt c) <$> tangibles =
readTVar (testCast level) (V.map TTile layer) V.++
oldCat <- perform dt <$> fromJust <$> readTVar (testPlayer level) (V.map TCast cast) V.++
modifyTVar (testCast level) $ \cast -> (V.map TPowerUp powerups) `V.snoc`
let playedCast = TPlayer cat
V.map
(\(Cast c) -> Cast (perform dt c))
cast indexedTangibles = V.zip
collidedCast = (V.fromList [0 .. ((V.length tangibles) - 1)])
V.map tangibles
(\(Cast c1) -> collidedTangibles =
let partners = V.foldl let collisionPartners =
(\acc@(Cast _, ires) (Cast c2) -> V.foldl
let res = collisionCheck dt c1 c2 (\acc (index, tangible1) ->
in let partners =
if res /= NoCollision && V.foldl
collisionTime res < collisionTime ires (\acc (qInd, tangible2) ->
then (Cast c2, res) let res = collisionCheck dt tangible1 tangible2
else acc in
if res /= NoCollision && qInd /= index
then acc `V.snoc` (qInd, res)
else acc
)
V.empty
indexedTangibles
in
if V.null partners
then acc
else acc `V.snoc`
( index
, head
(sortOn (collisionTime . snd) (V.toList partners))
) )
(Cast c1, NoCollision) )
playedCast V.empty
indexedTangibles
updater (aindex, partner) =
let aobject = (snd $ indexedTangibles V.! aindex)
res =
(\(pindex, presult) ->
let inter =
collide
aobject
(snd $ indexedTangibles V.! pindex)
presult
in
inter
)
partner
in in
if null partners (aindex, res)
then Cast c1 in
else tangibles `V.update` (A.log A.Debug
uncurry ("Partner: " <> (fromString $ show collisionPartners))
(\(Cast c2) result -> Cast $ collide c1 c2 result) (V.map updater collisionPartners)
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 (newCast, newPowerups, mnewCat@(Just _)) = V.foldl
in (\acc@(castAcc, puAcc, mcat) input ->
V.map case input of
(\(Cast c) -> Cast $ TCast c ->
move dt c (castAcc `V.snoc` move dt c, puAcc, mnewCat)
TPowerUp p ->
(castAcc, puAcc `V.snoc` move dt p, mnewCat)
TPlayer cat ->
(castAcc, puAcc, Just (move dt cat))
TTile t ->
acc
) )
walledCast (V.empty, V.empty, Nothing)
releasedEffects <- stateTVar (testPowerups level) $ \pus -> collidedTangibles
let living = V.foldl writeTVar (testCast level) newCast
(\acc pu -> writeTVar (testPowerups level) newPowerups
let npu = perform dt pu writeTVar (testPlayer level) mnewCat
in
if puTTL npu > 0 -- oldCast <- V.map (\(Cast c) -> Cast $ perform dt c) <$>
then npu `V.cons` acc -- readTVar (testCast level)
else acc -- oldCat <- perform dt <$> fromJust <$> readTVar (testPlayer level)
) -- modifyTVar (testCast level) $ \cast ->
V.empty -- let playedCast =
pus -- V.map
indexCollected = V.filter ((/= NoCollision) . snd) $ -- (\(Cast c) -> Cast (perform dt c))
V.zip (V.fromList [0..length living]) -- cast
(V.map -- collidedCast =
(collisionCheck dt oldCat) -- V.map
living -- (\(Cast c1) ->
) -- let partners = V.foldl
collected = V.foldl -- (\acc@(Cast _, ires) (Cast c2) ->
(\acc (ind, _) -> -- let res = collisionCheck dt c1 c2
(living V.! ind) `V.cons` acc -- in
) -- if res /= NoCollision &&
V.empty -- collisionTime res < collisionTime ires
indexCollected -- then (Cast c2, res)
differ = V.foldl -- else acc
(\acc life -> if life `V.elem` collected -- )
then acc -- (Cast c1, NoCollision)
else life `V.cons` acc -- playedCast
) -- in
V.empty -- if null partners
living -- then Cast c1
fin = V.map -- else
(\pu -> move dt $ performWorldCollision pu layer dt) -- uncurry
differ -- (\(Cast c2) result -> Cast $ collide c1 c2 result)
in -- partners
(collected, fin) -- )
modifyTVar -- playedCast
(testPlayer level) $ \(Just pituicat) -> -- wallCast (Cast c) =
let playedCat = perform dt pituicat -- Cast $ performWorldCollision c layer dt
castCat = -- walledCast =
let allPartners = V.zip (V.fromList [0..V.length oldCast]) -- V.map wallCast collidedCast
(V.map -- cattedCast = V.map
(\(Cast c) -> collisionCheck dt playedCat c) -- (\(Cast c) ->
oldCast -- Cast $ collide c oldCat $ collisionCheck dt c oldCat
) -- )
filtered = (V.filter ((/= NoCollision) . snd) allPartners) -- walledCast
partner = V.minimumBy -- in
(\(_, e) (_, f) -> collisionTime e `compare` collisionTime f) -- V.map
filtered -- (\(Cast c) -> Cast $
in -- move dt c
if V.null filtered -- )
then -- walledCast
playedCat -- releasedEffects <- stateTVar (testPowerups level) $ \pus ->
else -- let living = V.foldl
uncurry -- (\acc pu ->
(\(Cast c) cr -> collide playedCat c cr) -- let npu = perform dt pu
(oldCast V.! fst partner, snd partner) -- in
walledCat = performWorldCollision castCat layer dt -- if puTTL npu > 0
affectedCat = walledCat -- then npu `V.cons` acc
{ pcEffects = pcEffects walledCat ++ -- else acc
map puEffect (V.toList releasedEffects) -- )
} -- V.empty
in Just $ move dt affectedCat -- 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 performWorldCollision
:: (Collidible c) :: (Collidible c)

1
src/Types.hs
View file

@ -10,3 +10,4 @@ import Types.StageSet as T
import Types.Player as T import Types.Player as T
import Types.Util as T import Types.Util as T
import Types.PowerUp as T import Types.PowerUp as T
import Types.Tangible as T

29
src/Types/Cast.hs
View file

@ -4,5 +4,34 @@ module Types.Cast where
-- internale imports -- internale imports
import Classes.Actor import Classes.Actor
import Physics.Classes
data Cast = forall a. Actor a => Cast a data Cast = forall a. Actor a => Cast a
instance Show Cast where
show (Cast a) = show a
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
position (Cast a) = position a
positionUpdater (Cast a) = Cast . positionUpdater a
instance Collidible Cast where
boundary (Cast c) = boundary c
collisionCheck dt (Cast c1) c2 = collisionCheck dt c1 c2
collide (Cast c1) c2 res = Cast $ collide c1 c2 res

12
src/Types/Player.hs
View file

@ -158,7 +158,11 @@ instance Mass Pituicat where
} }
) )
velocity cat = pcVel cat + pcMoveVel cat velocity cat =
let mvel@(V2 mx my) = pcMoveVel cat
nvel@(V2 x y) = pcVel cat + mvel
in
if abs x > abs mx then V2 (signum x * abs mx) y else nvel
velocityUpdater cat = velocityUpdater cat =
(\vel@(V2 vx vy) -> (\vel@(V2 vx vy) ->
@ -175,7 +179,7 @@ instance Mass Pituicat where
) )
in in
cat cat
{ pcVel = nvel { pcVel = vel
} }
) )
@ -212,9 +216,7 @@ instance Collidible Pituicat where
) )
((\(V2 _ y) -> y) (if diry /= 0 then pcVel ncat else pcVel cat)) ((\(V2 _ y) -> y) (if diry /= 0 then pcVel ncat else pcVel cat))
grounded = grounded =
vy >= 0 && diry == -1 && abs (vy * ddt) < 2
vy < 200 &&
diry == -1
in in
ncat ncat
{ pcGrounded = grounded { pcGrounded = grounded

74
src/Types/Tangible.hs
View file

@ -1,6 +1,76 @@
{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ExistentialQuantification #-}
module Types.Tangible where module Types.Tangible where
import Classes.Collectable (Collectable) import Physics.Classes
import Types.Player
import Types.Cast
import Types.PowerUp
import Types.Map
data Tangible = forall a . Collectable a => Tangible a -- wrapper type for everything that can be collided with.
data Tangible
= TPlayer Pituicat
| TCast Cast
| TPowerUp PowerUp
| TTile Tile
instance Show Tangible where
show (TPlayer a) = show a
show (TCast a) = show a
show (TPowerUp a) = show a
show (TTile a) = show a
instance Mass Tangible where
mass (TPlayer a) = mass a
mass (TCast a) = mass a
mass (TPowerUp a) = mass a
mass (TTile a) = mass a
acceleration (TPlayer a) = acceleration a
acceleration (TCast a) = acceleration a
acceleration (TPowerUp a) = acceleration a
acceleration (TTile a) = acceleration a
accelerationUpdater (TPlayer a) = TPlayer . accelerationUpdater a
accelerationUpdater (TCast a) = TCast . accelerationUpdater a
accelerationUpdater (TPowerUp a) = TPowerUp . accelerationUpdater a
accelerationUpdater (TTile a) = TTile . accelerationUpdater a
velocity (TPlayer a) = velocity a
velocity (TCast a) = velocity a
velocity (TPowerUp a) = velocity a
velocity (TTile a) = velocity a
velocityUpdater (TPlayer a) = TPlayer . velocityUpdater a
velocityUpdater (TCast a) = TCast . velocityUpdater a
velocityUpdater (TPowerUp a) = TPowerUp . velocityUpdater a
velocityUpdater (TTile a) = TTile . velocityUpdater a
position (TPlayer a) = position a
position (TCast a) = position a
position (TPowerUp a) = position a
position (TTile a) = position a
positionUpdater (TPlayer a) = TPlayer . positionUpdater a
positionUpdater (TCast a) = TCast . positionUpdater a
positionUpdater (TPowerUp a) = TPowerUp . positionUpdater a
positionUpdater (TTile a) = TTile . positionUpdater a
instance Collidible Tangible where
boundary (TPlayer c) = boundary c
boundary (TCast c) = boundary c
boundary (TPowerUp c) = boundary c
boundary (TTile c) = boundary c
collisionCheck dt (TPlayer c1) c2 = collisionCheck dt c1 c2
collisionCheck dt (TCast c1) c2 = collisionCheck dt c1 c2
collisionCheck dt (TPowerUp c1) c2 = collisionCheck dt c1 c2
collisionCheck dt (TTile c1) c2 = collisionCheck dt c1 c2
collide (TPlayer c1) c2 res = TPlayer $ collide c1 c2 res
collide (TCast c1) c2 res = TCast $ collide c1 c2 res
collide (TPowerUp c1) c2 res = TPowerUp $ collide c1 c2 res
collide (TTile c1) c2 res = TTile $ collide c1 c2 res

8
src/Util.hs
View file

@ -23,12 +23,8 @@ globalKeyHandle gd mesg@(MsgKeyboardEvent time win motion repeat keysym) =
_ _
SDL.Pressed SDL.Pressed
False False
(SDL.Keysym SDL.ScancodeF11 _ mod) -> (SDL.Keysym SDL.ScancodeF11 _ _) ->
if mod == SDL.fromNumber 0 toggleScreen 0
then
toggleScreen 0
else
return ()
_ -> return () _ -> return ()
constG :: V2 Double constG :: V2 Double