From ee9523dabb9281f7787e916dbc10b9d45b141fbc Mon Sep 17 00:00:00 2001 From: justin Date: Sun, 26 Jun 2022 02:30:17 +0100 Subject: [PATCH] Cleanup --- src/Dodge/Base/Collide.hs | 235 +++++++++------------------- src/Dodge/Creature/Action.hs | 4 +- src/Dodge/Item/Equipment/Booster.hs | 2 +- src/Dodge/Item/Weapon/Grenade.hs | 4 +- src/Dodge/Prop/Moving.hs | 2 +- src/Dodge/Update.hs | 2 +- src/Dodge/WallCreatureCollisions.hs | 4 +- src/Dodge/WorldEvent/Explosion.hs | 2 +- 8 files changed, 83 insertions(+), 172 deletions(-) diff --git a/src/Dodge/Base/Collide.hs b/src/Dodge/Base/Collide.hs index 34993a05d..4aafd17a6 100644 --- a/src/Dodge/Base/Collide.hs +++ b/src/Dodge/Base/Collide.hs @@ -1,19 +1,22 @@ {-# LANGUAGE TupleSections #-} -{- | Basic collision detection for a moving point -} +{- | Basic collision detection for a moving point. + - Conventions: input is typically a stream of walls. + - Collide returns an endpoint and maybe a collided with + - object (wall). + - Reflect maybe gives a slightly pushed out point from a collision and a + - relection velocity. + - Overlap returns a stream of walls. + - A point will typically be moving. + - A ball refers to a moving circle, i.e. a point with a radius. + - -} module Dodge.Base.Collide - ( hasLOS - , collidePointWallsWall + ( collidePoint , collidePointWallsFilterStream - , reflectPointWallsDamp - , reflectCircWallsDamp - , hasButtonLOS - , reflectPointWalls + , collidePointTestFilter + , bounceBall + , bouncePoint , ssfold , collidePointUpToIndirectMinDist - , canSeeIndirect - , isWalkable - , canSee - , hasLOSIndirect , wlIsOpaque , wlIsSeeThrough , wallsOnCirc @@ -21,14 +24,9 @@ module Dodge.Base.Collide , wallsOnLineHit , collideCircWallsStream , collideCircWalls - , collideCircWallsList --- , collideCircWalls' , circOnSomeWall - , collidePointWalls , collidePointWallsNorm , collidePointWalls' --- , collidePointWallsL - , collidePointWallsFilt , overlapCircWalls , overlapCircWallsClosest , collideCircCrsPoint @@ -42,6 +40,13 @@ module Dodge.Base.Collide , nearestCrInTri , nearestCrInFront , allVisibleWalls + + , hasLOS + , hasLOSIndirect + , hasButtonLOS + , canSee + , canSeeIndirect + , isWalkable ) where import Dodge.Data import Dodge.Zone @@ -60,22 +65,20 @@ import Data.Monoid import Streaming import qualified Streaming.Prelude as S --import qualified Data.Map.Lazy as M -- note the use of Lazy, the idea being interoperation with Streaming +-- +collidePoint :: Point2 -> Point2 + -> Stream (Of Wall) Identity () + -> (Point2, Maybe Wall) +{-# INLINE collidePoint #-} +collidePoint sp ep = runIdentity + . S.fold_ findPoint (ep, Nothing) id + where + findPoint (p,mwl) wl = maybe (p,mwl) (,Just wl) . uncurry (intersectSegSeg sp p) . _wlLine $ wl -hasLOS :: Point2 -> Point2 -> World -> Bool -{-# INLINE hasLOS #-} -hasLOS p1 p2 = not - . collidePointTestFilter (const True) p1 p2 - . wallsAlongLine p1 p2 - -hasButtonLOS :: Point2 -> Point2 -> World -> Bool -{-# INLINE hasButtonLOS #-} -hasButtonLOS p1 p2 = not - . collidePointTestFilter (not . _wlTouchThrough) p1 p2 - . wallsAlongLine p1 p2 - -reflectCircWallsDamp :: Float -> Point2 -> Point2 -> Float -> Stream (Of Wall) Identity () +bounceBall :: Float -> Point2 -> Point2 -> Float + -> Stream (Of Wall) Identity () -> Maybe (Point2,Point2) -reflectCircWallsDamp x sp ep r w = do +bounceBall x sp ep r w = do wl <- mwl return (p +.+ normalizeV (vNormal (uncurry (-.-) (_wlLine wl))) , reflVelWallDamp x wl (ep -.- sp) @@ -83,8 +86,8 @@ reflectCircWallsDamp x sp ep r w = do where (p, mwl) = collideCircWallsStream sp ep r w -reflectPointWallsDamp :: (Wall -> Bool) -> Float -> Point2 -> Point2 -> World -> Maybe (Point2,Point2) -reflectPointWallsDamp t x sp ep w = do +bouncePoint :: (Wall -> Bool) -> Float -> Point2 -> Point2 -> World -> Maybe (Point2,Point2) +bouncePoint t x sp ep w = do wl <- mwl return (p +.+ normalizeV (vNormal (uncurry (-.-) (_wlLine wl))) , reflVelWallDamp x wl (ep -.- sp) @@ -92,47 +95,6 @@ reflectPointWallsDamp t x sp ep w = do where (p, mwl) = collidePointWallsFilterStream t sp ep w --- | Looks for first collision of a point with walls. --- If found, gives point and wall. --- (This can probably be improved, eg by folding over the walls and on finding a --- wall moving the end point to the collision point, but the returns in speed --- are probably minimal) -collidePointWallsWall :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Wall) -collidePointWallsWall p1 p2 - = safeMinimumOn (dist p1 . fst) - . IM.mapMaybe ( \wl -> uncurry (intersectSegSeg p1 p2) (_wlLine wl) <&> ( , wl ) ) - --- | looks for first collision of a point with walls --- if found, gives point and reflection velocity -reflectPointWalls :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2) -reflectPointWalls p1 p2 - = safeMinimumOn (dist p1 . fst) - . IM.mapMaybe - (( \(x,y) -> - fmap ( (, reflectIn (x -.- y) (p2 -.- p1)) - . (+.+ errorNormalizeV 39 (vNormal (x -.- y))) - ) - (intersectSegSeg p1 p2 x y) - ) - . _wlLine) ----- | Looks for first collision of a point with walls. ----- If found, gives point and reflection velocity, reflection damped in normal. ---reflectPointWallsDamped --- :: Float -- ^ Damping factor, probably should be in (0,1) --- -> Point2 --- -> Point2 --- -> IM.IntMap Wall --- -> Maybe (Point2,Point2) ---reflectPointWallsDamped dfact p1 p2 ws --- = safeMinimumOn (dist p1 . fst) --- $ IM.mapMaybe --- (( \(x,y) -> fmap ((, reflectInParam dfact (x -.- y) (p2 -.- p1)) --- . (+.+ errorNormalizeV 40 (vNormal (x -.- y)))) --- (intersectSegSeg p1 p2 x y)) --- . _wlLine --- ) ws --- | Test if a point collides with walls - -- this COULD be written in terms of collidePointWallsFilterStream, TODO test -- whether this is actually faster collidePointTestFilter :: (Wall -> Bool) -> Point2 -> Point2 -> Stream (Of Wall) Identity () -> Bool @@ -141,12 +103,9 @@ collidePointTestFilter t sp ep = runIdentity . S.filter t collidePointWallsFilterStream :: (Wall -> Bool) -> Point2 -> Point2 -> World -> (Point2, Maybe Wall) -collidePointWallsFilterStream t sp ep = runIdentity - . S.fold_ findPoint (ep, Nothing) id +collidePointWallsFilterStream t sp ep = collidePoint sp ep . S.filter t . wallsAlongLine sp ep - where - findPoint (p,mwl) wl = maybe (p,mwl) (,Just wl) . uncurry (intersectSegSeg sp p) . _wlLine $ wl --visibleWallWalls' :: Point2 -> Point2 -> World -> M.Map Float Wall --visibleWallWalls' sp ep = L.purely S.fold L.map . visibleWallWalls sp ep @@ -210,27 +169,6 @@ ssfold :: Foldable t => (a -> Bool) -> (a -> b -> a) -> a -> t b -> a {-# INLINABLE ssfold #-} ssfold p f a0 xs = foldr (\x g a -> if p a then a else g (f a x)) id xs a0 -hasLOSIndirect :: Point2 -> Point2 -> World -> Bool -hasLOSIndirect p1 p2 = not - . collidePointTestFilter wlIsOpaque p1 p2 - . wallsAlongLine p1 p2 - -isWalkable :: Point2 -> Point2 -> World -> Bool -isWalkable p1 p2 = not - . collidePointTestFilter (not . (^?! wlPathable)) p1 p2 - . wallsAlongLine p1 p2 - -canSee :: Int -> Int -> World -> Bool -canSee i j w = hasLOS p1 p2 w - where - p1 = _crPos (_creatures w IM.! i) - p2 = _crPos (_creatures w IM.! j) - -canSeeIndirect :: Int -> Int -> World -> Bool -canSeeIndirect i j w = hasLOSIndirect ipos jpos w - where - ipos = _crPos (_creatures w IM.! i) - jpos = _crPos (_creatures w IM.! j) wallsOnLineHit :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap (Point2, Wall) wallsOnLineHit p1 p2 = IM.mapMaybe f @@ -255,67 +193,12 @@ collidePointAnyWallsReflect p1 p2 Just ip -> Just (ip +.+ normalizeV (vNormal (x -.- y)), reflectInParam 0.5 (x -.- y) (p2 -.- p1)) Nothing -> Nothing --- | Looks for collision of a point with walls. --- If found, gives collision point --- If not found, returns point -collidePointWalls :: Point2 -> Point2 -> IM.IntMap Wall -> Point2 -{-# INLINE collidePointWalls #-} -collidePointWalls p1 p2 = foldr findPoint p2 . fmap _wlLine - where - findPoint (x,y) p = fromMaybe p $ intersectSegSeg p1 p x y collidePointWalls' :: (Foldable t, Functor t) => Point2 -> Point2 -> t Wall -> Point2 {-# INLINE collidePointWalls' #-} collidePointWalls' p1 p2 = foldl' findPoint p2 . fmap _wlLine where findPoint p = fromMaybe p . uncurry (intersectSegSeg p1 p) ---collidePointWallsL :: Point2 -> Point2 -> L.Fold Wall Point2 ---collidePointWallsL p1 p2 = L.Fold findPoint p2 id --- where --- findPoint p = fromMaybe p . uncurry (intersectSegSeg p1 p) . _wlLine - -collidePointWallsFilt :: (Wall -> Bool) -> Point2 -> Point2 -> IM.IntMap Wall -> Point2 -{-# INLINE collidePointWallsFilt #-} -collidePointWallsFilt t p1 p2 = collidePointWalls' p1 p2 . IM.filter t - --- | Looks for first collision of a circle with walls. --- If found, gives point and reflection velocity, reflection damped in normal. --- note that the "intersection" point is the center of the circle flush against the wall ---collideCircWalls' :: Point2 -> Point2 -> Float -> IM.IntMap Wall -> Maybe (Point2,Point2) ---collideCircWalls' p1 p2 rad = either (const Nothing) Just . foldr findPoint (Left p2) --- where --- findPoint wl eip = maybe eip Right $ doReflection (getp eip) $ shiftByRad $ _wlLine wl --- getp (Left p) = p --- getp (Right (p,_)) = p --- doReflection p (x,y) = case intersectSegSeg p1 p x y of --- Nothing -> Nothing --- Just ip -> Just (ip +.+ normalizeV (vNormal (x -.- y)), reflectInParam 0.5 (x -.- y) (p2 -.- p1)) --- shiftByRad (a,b) = --- (g $ a +.+ rad *.* normalizeV (a -.-b) --- ,g $ b +.+ rad *.* normalizeV (b -.-a) --- ) --- where --- g = ((rad *.* normalizeV (vNormal $ a -.- b)) +.+) --- | Looks for first collision of a circle with walls. --- If found, gives point and reflection velocity, reflection damped in normal. -collideCircWallsList :: Point2 -> Point2 -> Float -> [Wall] -> Maybe (Point2,Point2) -collideCircWallsList p1 p2 rad - = safeMinimumOn (dist p1 . fst) - . mapMaybe - (( \(x:y:_) -> fmap - ((, reflectInParam 0.5 (x -.- y) (p2 -.- p1)) - . (+.+ normalizeV (vNormal (x -.- y))) - ) - (intersectSegSeg p1 p2 x y) - ) - . shiftByRad . _wlLine - ) - where - shiftByRad (a,b) = map ((rad *.* normalizeV (vNormal $ a -.- b)) +.+) - [a +.+ rad *.* normalizeV (a -.-b) - ,b +.+ rad *.* normalizeV (b -.-a) - ] - overlapCircWalls :: Point2 -> Float -> Stream (Of Wall) Identity () -> Stream (Of (Point2,Wall)) Identity () overlapCircWalls p r = S.mapMaybe dointersect @@ -369,16 +252,6 @@ collideCircWalls p1 p2 rad -- unfortunately, doesn't allow for collisions when the circle spawns on the -- wall --- | Looks for first collision of a point with a list of lines. --- If found, gives point and normal of wall. ---collidePointLines :: Point2 -> Point2 -> [Wall'] -> Maybe (Point2,Point2) ---collidePointLines p1 p2 ws --- = safeMinimumOn f --- $ mapMaybe (( \(x,y) -> intersectSegSeg p1 p2 x y <&> ( , vNormal $ x -.- y ) ) --- . _wlLine') ws --- where --- f (a,_) = magV (p1 -.- a) --- -- | Looks for first collision of a point with walls. -- If found, gives point and normal of wall. @@ -487,3 +360,39 @@ nearestCrInFront p dir x pL = p +.+ rotateV (dir + pi*(3/8)) (V2 (x/2) 0) pR1 = pR +.+ rotateV dir (V2 (x/2) 0) pL1 = pL +.+ rotateV dir (V2 (x/2) 0) + +{- | More general collision tests follow -} + +hasLOS :: Point2 -> Point2 -> World -> Bool +{-# INLINE hasLOS #-} +hasLOS p1 p2 = not + . collidePointTestFilter (const True) p1 p2 + . wallsAlongLine p1 p2 + +hasButtonLOS :: Point2 -> Point2 -> World -> Bool +{-# INLINE hasButtonLOS #-} +hasButtonLOS p1 p2 = not + . collidePointTestFilter (not . _wlTouchThrough) p1 p2 + . wallsAlongLine p1 p2 + +hasLOSIndirect :: Point2 -> Point2 -> World -> Bool +hasLOSIndirect p1 p2 = not + . collidePointTestFilter wlIsOpaque p1 p2 + . wallsAlongLine p1 p2 + +isWalkable :: Point2 -> Point2 -> World -> Bool +isWalkable p1 p2 = not + . collidePointTestFilter (not . (^?! wlPathable)) p1 p2 + . wallsAlongLine p1 p2 + +canSee :: Int -> Int -> World -> Bool +canSee i j w = hasLOS p1 p2 w + where + p1 = _crPos (_creatures w IM.! i) + p2 = _crPos (_creatures w IM.! j) + +canSeeIndirect :: Int -> Int -> World -> Bool +canSeeIndirect i j w = hasLOSIndirect ipos jpos w + where + ipos = _crPos (_creatures w IM.! i) + jpos = _crPos (_creatures w IM.! j) diff --git a/src/Dodge/Creature/Action.hs b/src/Dodge/Creature/Action.hs index 32410cc43..757fa239a 100644 --- a/src/Dodge/Creature/Action.hs +++ b/src/Dodge/Creature/Action.hs @@ -172,7 +172,7 @@ blinkActionFail cr w = w cid = _crID cr p1 = mouseWorldPos w cpos = _crPos cr - p2 = reflectPointWallsDamp (const True) 1 cpos p1 w + p2 = bouncePoint (const True) 1 cpos p1 w r = 1.5 * _crRad cr p3 = maybe p1 (mvPointTowardAtSpeed r cpos . fst) p2 @@ -193,7 +193,7 @@ blinkAction cr w = w cid = _crID cr p1 = mouseWorldPos w cpos = _crPos cr - p2 = reflectPointWallsDamp (const True) 1 cpos p1 w + p2 = bouncePoint (const True) 1 cpos p1 w r = 1.5 * _crRad cr p3 = maybe p1 (mvPointTowardAtSpeed r cpos . fst) p2 diff --git a/src/Dodge/Item/Equipment/Booster.hs b/src/Dodge/Item/Equipment/Booster.hs index a73b5eaff..ec524646d 100644 --- a/src/Dodge/Item/Equipment/Booster.hs +++ b/src/Dodge/Item/Equipment/Booster.hs @@ -26,7 +26,7 @@ boostPoint x cr w = case mayp2 of cpos = _crPos cr r = 1.5 * _crRad cr p1 = cpos +.+ x *.* squashNormalizeV (mouseWorldPos w -.- cpos) - mayp2 = reflectPointWallsDamp (const True) 1 cpos p1 w + mayp2 = bouncePoint (const True) 1 cpos p1 w boostSelfL :: Float -- ^ boost amount diff --git a/src/Dodge/Item/Weapon/Grenade.hs b/src/Dodge/Item/Weapon/Grenade.hs index 89bdb56bb..39b2cea90 100644 --- a/src/Dodge/Item/Weapon/Grenade.hs +++ b/src/Dodge/Item/Weapon/Grenade.hs @@ -55,7 +55,7 @@ moveGrenade pj w -- this should maybe -- be wallsAlongLine -- or something vvv - | otherwise = case reflectCircWallsDamp 1 oldPos newPos 4 $ wallsNearPoint newPos w of + | otherwise = case bounceBall 1 oldPos newPos 4 $ wallsNearPoint newPos w of Nothing -> w & props . ix pID %~ normalUpdate Just (p,v) -> w & soundStart (Tap 0) p tapQuietS Nothing @@ -186,7 +186,7 @@ moveRemoteBomb itid time pID w -- this is hacky, should use a version of collidePointWalls' that collides -- circles and walls invShift x = x -.- 5 *.* normalizeV (_pjVel pj) - hitWl = reflectCircWallsDamp 1 oldPos newPos 4 $ wallsNearPoint newPos w + hitWl = bounceBall 1 oldPos newPos 4 $ wallsNearPoint newPos w finalPos = maybe newPos (invShift . fst) hitWl setV v = set (props . ix pID . pjVel) v updateV = maybe id (setV . snd) hitWl diff --git a/src/Dodge/Prop/Moving.hs b/src/Dodge/Prop/Moving.hs index 58b4bece5..c8cff953c 100644 --- a/src/Dodge/Prop/Moving.hs +++ b/src/Dodge/Prop/Moving.hs @@ -58,7 +58,7 @@ fallSmallBounce' w pr velz = _pjVelZ pr vel = _pjVel pr pos = _prPos pr - updateWithVel v = case reflectPointWallsDamp (const True) 0.5 pos (pos + v) w of + updateWithVel v = case bouncePoint (const True) 0.5 pos (pos + v) w of Nothing -> prPos +~ v Just (p,v') -> (prPos .~ p) . (pjVel .~ v') diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 6fb28ac33..f8340d168 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -349,7 +349,7 @@ updateCloud w c newPos2 = stripZ newPos -- the following only tests for the first collision with a wall --hitWl = collidePointAnyWallsReflect oldPos2 newPos2 $ wallsNearPoint newPos2 w - hitWl = reflectPointWallsDamp (const True) 1 oldPos2 newPos2 w + hitWl = bouncePoint (const True) 1 oldPos2 newPos2 w finalPos = addZ (min 74 npz) $ maybe newPos2 fst hitWl -- allowing clouds at/above height 75 causes graphical glitches 22.05.23 finalVel = addZ nvz $ maybe newVel2 snd hitWl diff --git a/src/Dodge/WallCreatureCollisions.hs b/src/Dodge/WallCreatureCollisions.hs index 2b88015db..011af3017 100644 --- a/src/Dodge/WallCreatureCollisions.hs +++ b/src/Dodge/WallCreatureCollisions.hs @@ -40,12 +40,14 @@ colCrWall w c --c' = c & crPos %~ pushOutFromWalls' rad (reverse ls) c' = c & crPos %~ pushOutFromCorners rad ls' . pushOutFromWalls rad ls' - . flip (collidePointWalls' p1) wls -- check push throughs + . fst . flip (collidePoint p1) wls' -- check push throughs +-- . flip (collidePointWalls' p1) wls -- check push throughs rad = _crRad c + wallBuffer p1 = _crOldPos c p2 = _crPos c ls = _wlLine <$> wls ls' = filter (uncurry $ isLHS p1) ls + wls' = S.filter (not . _wlWalkable) $ wallsNearPoint p2 w wls = runIdentity . S.toList_ . S.filter (not . _wlWalkable) $ wallsNearPoint p2 w --wallPoints = map fst ls diff --git a/src/Dodge/WorldEvent/Explosion.hs b/src/Dodge/WorldEvent/Explosion.hs index 8134b3716..c691f23e7 100644 --- a/src/Dodge/WorldEvent/Explosion.hs +++ b/src/Dodge/WorldEvent/Explosion.hs @@ -92,5 +92,5 @@ makeExplosionAt p w = w addFlames w' = foldl' (flip ($)) w' newFs --pushAgainstWalls q = maybe q (uncurry (+.+)) $ reflectPointWalls p q wls --pushAgainstWalls q = maybe q fst $ reflectPointWalls p q wls - pushAgainstWalls q = maybe q fst $ reflectPointWallsDamp (const True) 1 p q w + pushAgainstWalls q = maybe q fst $ bouncePoint (const True) 1 p q w -- wls = wallsNearPoint p w