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

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

View file

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

View file

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

View file

@ -1,11 +1,14 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
module Scenes.Test.Update where
import Affection as A
import Control.Concurrent.STM
import Data.List (sortOn)
import qualified Data.Vector as V
import Data.Maybe
@ -32,115 +35,195 @@ update level dt = liftIO $ do
-- (Typeclasses rock!)
atomically $ do
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)
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
tangibles =
(V.map TTile layer) V.++
(V.map TCast cast) V.++
(V.map TPowerUp powerups) `V.snoc`
TPlayer cat
indexedTangibles = V.zip
(V.fromList [0 .. ((V.length tangibles) - 1)])
tangibles
collidedTangibles =
let collisionPartners =
V.foldl
(\acc (index, tangible1) ->
let partners =
V.foldl
(\acc (qInd, tangible2) ->
let res = collisionCheck dt tangible1 tangible2
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
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
(aindex, res)
in
tangibles `V.update` (A.log A.Debug
("Partner: " <> (fromString $ show collisionPartners))
(V.map updater collisionPartners)
)
walledCast
in
V.map
(\(Cast c) -> Cast $
move dt c
(newCast, newPowerups, mnewCat@(Just _)) = V.foldl
(\acc@(castAcc, puAcc, mcat) input ->
case input of
TCast 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
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
(V.empty, V.empty, Nothing)
collidedTangibles
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)

View file

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

View file

@ -4,5 +4,34 @@ module Types.Cast where
-- internale imports
import Classes.Actor
import Physics.Classes
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

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 =
(\vel@(V2 vx vy) ->
@ -175,7 +179,7 @@ instance Mass Pituicat where
)
in
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))
grounded =
vy >= 0 &&
vy < 200 &&
diry == -1
diry == -1 && abs (vy * ddt) < 2
in
ncat
{ pcGrounded = grounded

View file

@ -1,6 +1,76 @@
{-# LANGUAGE ExistentialQuantification #-}
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

View file

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