Cleanup

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
+    ( collidePoint
-    , collidePointWallsWall
     , collidePointWallsFilterStream
-    , reflectPointWallsDamp
+    , collidePointTestFilter
-    , reflectCircWallsDamp
+    , bounceBall
-    , hasButtonLOS
+    , bouncePoint
-    , reflectPointWalls
     , 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
+bounceBall :: Float -> Point2 -> Point2 -> Float 
-{-# INLINE hasLOS #-}
+    -> Stream (Of Wall) Identity ()
-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 ()
     -> 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)
+bouncePoint :: (Wall -> Bool) -> Float -> Point2 -> Point2 -> World -> Maybe (Point2,Point2)
-reflectPointWallsDamp t x sp ep w = do
+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
+collidePointWallsFilterStream t sp ep = collidePoint sp ep
-    . S.fold_ findPoint (ep, Nothing) id
     . 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)

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
 

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

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

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')
 

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

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
 

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