more work on collision
This commit is contained in:
parent
7799387cf2
commit
7654888f6f
|
@ -107,27 +107,27 @@ class (Show c, Mass c) => Collidible c where
|
||||||
in
|
in
|
||||||
in2 || in1
|
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 m1p2)
|
||||||
p2x = (\(V2 x _) -> x) (if d1x < 0 then m2p4 else m2p1)
|
p2x = (\(V2 x _) -> x) (if d1x < 0 then m2p2 else m2p1)
|
||||||
in
|
in
|
||||||
if d2x - d1x == 0 then dt else (p1x - p2x) / (d2x - d1x)
|
if d2x - d1x == 0 then dt else (p1x - p2x) / (d2x - d1x)
|
||||||
ty =
|
ty =
|
||||||
let p1y = (\(V2 _ y) -> y) (if d1y < 0 then m1p1 else m1p2)
|
let p1y = (\(V2 _ y) -> y) (if d1y < 0 then m1p4 else m1p1)
|
||||||
p2y = (\(V2 _ y) -> y) (if d1y < 0 then m2p2 else m2p1)
|
p2y = (\(V2 _ y) -> y) (if d1y < 0 then m2p1 else m2p4)
|
||||||
in
|
in
|
||||||
if d2y - d1y == 0 then dt else (p1y - p2y) / (d2y - d1y)
|
if d2y - d1y == 0 then dt else (p1y - p2y) / (d2y - d1y)
|
||||||
in
|
in
|
||||||
if broadphaseOverlap
|
if broadphaseOverlap
|
||||||
then
|
then
|
||||||
if tx < ty
|
if tx <= ty
|
||||||
then
|
then
|
||||||
if tx < dt
|
if tx < dt
|
||||||
then
|
then
|
||||||
if d1x < 0
|
if d1x <= 0
|
||||||
then
|
then
|
||||||
let (V2 _ g1s) = m1p1 + ((tx *) <$> d1)
|
let (V2 _ g1s) = m1p1 + ((tx *) <$> d1)
|
||||||
(V2 _ g1e) = m1p2 + ((tx *) <$> d1)
|
(V2 _ g1e) = m1p4 + ((tx *) <$> d1)
|
||||||
(V2 _ g2s) = m2p4 + ((tx *) <$> d2)
|
(V2 _ g2s) = m2p2 + ((tx *) <$> d2)
|
||||||
(V2 _ g2e) = m2p3 + ((tx *) <$> d2)
|
(V2 _ g2e) = m2p3 + ((tx *) <$> d2)
|
||||||
s11 = (g1s - g2s) / (g2e - g2s)
|
s11 = (g1s - g2s) / (g2e - g2s)
|
||||||
s12 = (g1e - g2s) / (g2e - g2s)
|
s12 = (g1e - g2s) / (g2e - g2s)
|
||||||
|
@ -138,10 +138,10 @@ class (Show c, Mass c) => Collidible c where
|
||||||
then Collision tx (V2 (floor $ signum d1x) 0)
|
then Collision tx (V2 (floor $ signum d1x) 0)
|
||||||
else NoCollision
|
else NoCollision
|
||||||
else
|
else
|
||||||
let (V2 _ g1s) = m1p4 + ((tx *) <$> d1)
|
let (V2 _ g1s) = m1p2 + ((tx *) <$> d1)
|
||||||
(V2 _ g1e) = m1p3 + ((tx *) <$> d1)
|
(V2 _ g1e) = m1p3 + ((tx *) <$> d1)
|
||||||
(V2 _ g2s) = m2p1 + ((tx *) <$> d2)
|
(V2 _ g2s) = m2p1 + ((tx *) <$> d2)
|
||||||
(V2 _ g2e) = m2p2 + ((tx *) <$> d2)
|
(V2 _ g2e) = m2p4 + ((tx *) <$> d2)
|
||||||
s11 = (g1s - g2s) / (g2e - g2s)
|
s11 = (g1s - g2s) / (g2e - g2s)
|
||||||
s12 = (g1e - g2s) / (g2e - g2s)
|
s12 = (g1e - g2s) / (g2e - g2s)
|
||||||
s21 = (g2s - g1s) / (g1e - g1s)
|
s21 = (g2s - g1s) / (g1e - g1s)
|
||||||
|
@ -155,12 +155,12 @@ class (Show c, Mass c) => Collidible c where
|
||||||
else
|
else
|
||||||
if ty < dt
|
if ty < dt
|
||||||
then
|
then
|
||||||
if d1y < 0
|
if d1y <= 0
|
||||||
then
|
then
|
||||||
let (V2 g1s _) = m1p2 + ((ty *) <$> d1)
|
let (V2 g1s _) = m1p1 + ((ty *) <$> d1)
|
||||||
(V2 g1e _) = m1p3 + ((ty *) <$> d1)
|
(V2 g1e _) = m1p2 + ((ty *) <$> d1)
|
||||||
(V2 g2s _) = m2p1 + ((ty *) <$> d2)
|
(V2 g2s _) = m2p4 + ((ty *) <$> d2)
|
||||||
(V2 g2e _) = m2p4 + ((ty *) <$> d2)
|
(V2 g2e _) = m2p3 + ((ty *) <$> d2)
|
||||||
s11 = (g1s - g2s) / (g2e - g2s)
|
s11 = (g1s - g2s) / (g2e - g2s)
|
||||||
s12 = (g1e - g2s) / (g2e - g2s)
|
s12 = (g1e - g2s) / (g2e - g2s)
|
||||||
s21 = (g2s - g1s) / (g1e - g1s)
|
s21 = (g2s - g1s) / (g1e - g1s)
|
||||||
|
@ -170,10 +170,10 @@ class (Show c, Mass c) => Collidible c where
|
||||||
then Collision ty (V2 0 (floor $ signum d1y))
|
then Collision ty (V2 0 (floor $ signum d1y))
|
||||||
else NoCollision
|
else NoCollision
|
||||||
else
|
else
|
||||||
let (V2 g1s _) = m1p1 + ((ty *) <$> d1)
|
let (V2 g1s _) = m1p4 + ((ty *) <$> d1)
|
||||||
(V2 g1e _) = m1p4 + ((ty *) <$> d1)
|
(V2 g1e _) = m1p3 + ((ty *) <$> d1)
|
||||||
(V2 g2s _) = m2p2 + ((ty *) <$> d2)
|
(V2 g2s _) = m2p1 + ((ty *) <$> d2)
|
||||||
(V2 g2e _) = m2p3 + ((ty *) <$> d2)
|
(V2 g2e _) = m2p2 + ((ty *) <$> d2)
|
||||||
s11 = (g1s - g2s) / (g2e - g2s)
|
s11 = (g1s - g2s) / (g2e - g2s)
|
||||||
s12 = (g1e - g2s) / (g2e - g2s)
|
s12 = (g1e - g2s) / (g2e - g2s)
|
||||||
s21 = (g2s - g1s) / (g1e - g1s)
|
s21 = (g2s - g1s) / (g1e - g1s)
|
||||||
|
@ -223,7 +223,7 @@ elasticCollision damping mo1 mo2 (Collision ddt (V2 dirx diry)) =
|
||||||
else (damping *) <$>
|
else (damping *) <$>
|
||||||
if m2 == recip 0
|
if m2 == recip 0
|
||||||
then
|
then
|
||||||
if abs dy < abs dx
|
if abs 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')
|
||||||
|
|
|
@ -1,4 +1,5 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
module Scenes.Test.Update where
|
module Scenes.Test.Update where
|
||||||
|
|
||||||
import Affection
|
import Affection
|
||||||
|
@ -7,6 +8,8 @@ import Control.Concurrent.STM
|
||||||
|
|
||||||
import qualified Data.Vector as V
|
import qualified Data.Vector as V
|
||||||
|
|
||||||
|
import Data.Maybe
|
||||||
|
|
||||||
import Data.String (fromString)
|
import Data.String (fromString)
|
||||||
|
|
||||||
import Linear
|
import Linear
|
||||||
|
@ -47,7 +50,7 @@ update level dt = liftIO $ do
|
||||||
then (Cast c2, res)
|
then (Cast c2, res)
|
||||||
else acc
|
else acc
|
||||||
)
|
)
|
||||||
(Cast c1, Collision dt (V2 0 0))
|
(Cast c1, NoCollision)
|
||||||
playedCast
|
playedCast
|
||||||
in
|
in
|
||||||
if null partners
|
if null partners
|
||||||
|
@ -58,18 +61,8 @@ update level dt = liftIO $ do
|
||||||
partners
|
partners
|
||||||
)
|
)
|
||||||
playedCast
|
playedCast
|
||||||
wallCast (Cast c) = Cast $ uncurry (collide c) $
|
wallCast (Cast c) =
|
||||||
V.foldl
|
Cast $ performWorldCollision c layer dt
|
||||||
(\acc@(_, ires) tile ->
|
|
||||||
let res = collisionCheck dt c tile
|
|
||||||
in
|
|
||||||
if res /= NoCollision &&
|
|
||||||
collisionTime res < collisionTime ires
|
|
||||||
then (tile, res)
|
|
||||||
else acc
|
|
||||||
)
|
|
||||||
(V.head layer, Collision dt (V2 0 0))
|
|
||||||
layer
|
|
||||||
walledCast =
|
walledCast =
|
||||||
V.map wallCast collidedCast
|
V.map wallCast collidedCast
|
||||||
in
|
in
|
||||||
|
@ -93,7 +86,7 @@ update level dt = liftIO $ do
|
||||||
then (Cast c, res)
|
then (Cast c, res)
|
||||||
else acc
|
else acc
|
||||||
)
|
)
|
||||||
(V.head updatedCast, Collision dt (V2 0 0))
|
(V.head updatedCast, NoCollision)
|
||||||
updatedCast
|
updatedCast
|
||||||
in
|
in
|
||||||
if (collisionTime $ snd partner) == dt
|
if (collisionTime $ snd partner) == dt
|
||||||
|
@ -102,20 +95,33 @@ update level dt = liftIO $ do
|
||||||
(\(Cast cx) res -> collide playedCat cx res)
|
(\(Cast cx) res -> collide playedCat cx res)
|
||||||
partner
|
partner
|
||||||
walledCat =
|
walledCat =
|
||||||
let partner =
|
performWorldCollision playedCat layer dt
|
||||||
V.foldl
|
|
||||||
(\acc@(_, ires) tile ->
|
|
||||||
let res = collisionCheck dt collidedCat tile
|
|
||||||
in
|
|
||||||
if res /= NoCollision &&
|
|
||||||
collisionTime res < collisionTime ires
|
|
||||||
then (tile, res)
|
|
||||||
else acc
|
|
||||||
)
|
|
||||||
(V.head layer, Collision dt (V2 0 0))
|
|
||||||
layer
|
|
||||||
in
|
|
||||||
if (collisionTime $ snd partner) == dt
|
|
||||||
then collidedCat
|
|
||||||
else uncurry (collide collidedCat) partner
|
|
||||||
in Just $ move dt walledCat
|
in Just $ move dt walledCat
|
||||||
|
|
||||||
|
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 tile ->
|
||||||
|
let res = collisionCheck dt c tile
|
||||||
|
ret = if isNothing acc
|
||||||
|
then if res /= NoCollision && collisionTime res < dt
|
||||||
|
then Just (c, res)
|
||||||
|
else Nothing
|
||||||
|
else if res /= NoCollision &&
|
||||||
|
collisionTime res < collisionTime (snd (fromJust acc))
|
||||||
|
then Just (c, res)
|
||||||
|
else acc
|
||||||
|
in
|
||||||
|
ret
|
||||||
|
)
|
||||||
|
Nothing
|
||||||
|
layer
|
||||||
|
in
|
||||||
|
if isNothing partner
|
||||||
|
then c
|
||||||
|
else uncurry (collide c) (fromJust partner)
|
||||||
|
|
Loading…
Reference in New Issue