tinker more on collision. objects move, but glitches ensue.
This commit is contained in:
parent
40e82e26f6
commit
b3a2e58af4
8 changed files with 388 additions and 168 deletions
|
|
@ -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,6 +124,16 @@ class (Show c, Mass c) => Collidible c where
|
|||
in
|
||||
if broadphaseOverlap
|
||||
then
|
||||
-- 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
|
||||
|
|
@ -153,7 +184,15 @@ class (Show c, Mass c) => Collidible c where
|
|||
"Unhandled combination of collision check results: "
|
||||
<> (fromString $ show x)
|
||||
in
|
||||
res
|
||||
-- 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')
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
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 &&
|
||||
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
|
||||
if res /= NoCollision && qInd /= index
|
||||
then acc `V.snoc` (qInd, res)
|
||||
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
|
||||
indexedTangibles
|
||||
in
|
||||
if V.null partners
|
||||
then acc
|
||||
else life `V.cons` acc
|
||||
else acc `V.snoc`
|
||||
( index
|
||||
, head
|
||||
(sortOn (collisionTime . snd) (V.toList partners))
|
||||
)
|
||||
)
|
||||
V.empty
|
||||
living
|
||||
fin = V.map
|
||||
(\pu -> move dt $ performWorldCollision pu layer dt)
|
||||
differ
|
||||
indexedTangibles
|
||||
updater (aindex, partner) =
|
||||
let aobject = (snd $ indexedTangibles V.! aindex)
|
||||
res =
|
||||
(\(pindex, presult) ->
|
||||
let inter =
|
||||
collide
|
||||
aobject
|
||||
(snd $ indexedTangibles V.! pindex)
|
||||
presult
|
||||
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
|
||||
inter
|
||||
)
|
||||
filtered = (V.filter ((/= NoCollision) . snd) allPartners)
|
||||
partner = V.minimumBy
|
||||
(\(_, e) (_, f) -> collisionTime e `compare` collisionTime f)
|
||||
filtered
|
||||
partner
|
||||
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
|
||||
(aindex, res)
|
||||
in
|
||||
tangibles `V.update` (A.log A.Debug
|
||||
("Partner: " <> (fromString $ show collisionPartners))
|
||||
(V.map updater collisionPartners)
|
||||
)
|
||||
(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
|
||||
)
|
||||
(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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
(SDL.Keysym SDL.ScancodeF11 _ _) ->
|
||||
toggleScreen 0
|
||||
else
|
||||
return ()
|
||||
_ -> return ()
|
||||
|
||||
constG :: V2 Double
|
||||
|
|
|
|||
Loading…
Reference in a new issue