Redo collision changes

src/Dodge/Base/Collide.hs

@@ -11,33 +11,22 @@
  - -}
 module Dodge.Base.Collide
     ( collidePoint
+    , collideSegCrs
     , collidePointWallsFilterStream
     , collidePointTestFilter
     , overlapSegWalls
+    , overlapSegCrs
+    , overlap1SegCrs
     , bounceBall
     , bouncePoint
     , sortStreamOn
     , minStreamOn
---    , wallsOnCirc
---    , wallsOnCirc'
-    , wallsOnLineHit
     , collideCircWallsStream
-    , collideCircWalls
     , circOnSomeWall
-    , collidePointWallsNorm
+    , circOnAnyCr
-    , collidePointWalls'
     , overlapCircWalls
     , overlapCircWallsClosest
-    , collideCircCrsPoint
-    , collideCircCreatures
-    , collidePointCreatures
-    , collidePointAnyWallsReflect
     , crsNearPoint
-    , crsOnLine
-    , crsOnThickLine
-    , nearestCrInRad
-    , nearestCrInTri
-    , nearestCrInFront
     , allVisibleWalls
 
     , hasLOS
@@ -51,103 +40,111 @@ import Dodge.Data
 import Dodge.Zone
 import Dodge.Base.Wall
 import Geometry
-import FoldableHelp
 
 import Data.Maybe
 import qualified Data.IntMap.Strict as IM
 import Control.Lens
 import Control.Monad
---import qualified FoldlHelp as L
-import Data.Monoid
 import StreamingHelp
 import qualified Streaming.Prelude as S
 
 collidePoint :: Point2 -> Point2 
-    -> Stream (Of Wall) Identity ()
+    -> StreamOf Wall
     -> (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
 
+overlap1SegCrs :: Point2 -> Point2 
+    -> StreamOf Creature
+    -> StreamOf (Point2, Creature)
+{-# INLINE overlap1SegCrs #-}
+overlap1SegCrs sp ep = S.mapMaybe 
+    (\cr -> (,cr) <$> listToMaybe (intersectCircSeg (_crPos cr) (_crRad cr) sp ep ))
+
+overlapSegCrs :: Point2 -> Point2 
+    -> StreamOf Creature
+    -> StreamOf ([Point2], Creature)
+{-# INLINE overlapSegCrs #-}
+overlapSegCrs sp ep = S.mapMaybe 
+    (\cr -> f cr $ intersectCircSeg (_crPos cr) (_crRad cr) sp ep )
+  where
+    f _  [] = Nothing
+    f cr ps = Just (ps,cr)
+
+collideSegCrs :: Point2 -> Point2 
+    -> StreamOf Creature
+    -> (Point2, Maybe Creature)
+{-# INLINE collideSegCrs #-}
+collideSegCrs sp ep = runIdentity . S.fold_ findPoint (ep, Nothing) id
+  where
+    findPoint (p,mcr) cr 
+        = maybe (p,mcr) (,Just cr) $ listToMaybe (intersectCircSeg (_crPos cr) (_crRad cr) sp p)
+
 doBounce :: Float -> Point2 -> Point2 -> (Point2, Maybe Wall) -> Maybe (Point2, Point2)
+{-# INLINE doBounce #-}
 doBounce x sp ep (p, mwl) = mwl <&> \wl ->
     ( p +.+ normalizeV (vNormal (uncurry (-.-) (_wlLine wl)))
     , reflVelWallDamp x wl (ep -.- sp)
     )
 
 bounceBall :: Float -> Point2 -> Point2 -> Float 
-    -> Stream (Of Wall) Identity ()
+    -> StreamOf Wall
     -> Maybe (Point2,Point2)
+{-# INLINE bounceBall #-}
 bounceBall x sp ep r = doBounce x sp ep . collideCircWallsStream sp ep r
 
 bouncePoint :: (Wall -> Bool) -> Float -> Point2 -> Point2 -> World -> Maybe (Point2,Point2)
+{-# INLINE bouncePoint #-}
 bouncePoint t x sp ep = doBounce x sp ep . collidePointWallsFilterStream t sp ep
 
 -- 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
+collidePointTestFilter :: (Wall -> Bool) -> Point2 -> Point2 -> StreamOf Wall -> Bool
+{-# INLINE collidePointTestFilter #-}
 collidePointTestFilter t sp ep = runIdentity 
     . S.any_ (isJust . uncurry (intersectSegSeg sp ep) . _wlLine)
     . S.filter t
 
 collidePointWallsFilterStream :: (Wall -> Bool) -> Point2 -> Point2 -> World -> (Point2, Maybe Wall)
+{-# INLINE collidePointWallsFilterStream #-}
 collidePointWallsFilterStream t sp ep = collidePoint sp ep
     . S.filter t
     . wlsNearSeg sp ep
 
-overlapSegWalls :: Point2 -> Point2 -> Stream (Of Wall) Identity () 
+overlapSegWalls :: Point2 -> Point2 -> StreamOf Wall
-    -> Stream (Of (Point2,Wall)) Identity ()
+    -> StreamOf (Point2,Wall)
+{-# INLINE overlapSegWalls #-}
 overlapSegWalls sp ep = S.mapMaybe $ \wl -> uncurry (intersectSegSeg sp ep) (_wlLine wl) <&> (,wl)
 
-visibleWalls :: Point2 -> Point2 -> World -> Stream (Of (Point2,Wall)) Identity ()
+visibleWalls :: Point2 -> Point2 -> World -> StreamOf (Point2,Wall)
+{-# INLINE visibleWalls #-}
 visibleWalls sp ep = S.take 1 <=<  -- hlint, was using join and fmap
     ( S.span (not . wlIsOpaque . snd)
     . sortStreamOn (dist sp . fst)
     . overlapSegWalls sp ep
     . wlsNearSeg sp ep    )
 
-allVisibleWalls :: World -> Stream (Of (Point2,Wall)) Identity ()
+allVisibleWalls :: World -> StreamOf (Point2,Wall)
+{-# INLINE allVisibleWalls #-}
 allVisibleWalls w = concats $ S.subst (flip (visibleWalls vPos) w . (+.+ vPos)) $ S.each (nRays 20)
   where
     vPos = _cameraViewFrom w
     
-    
+overlapCircWalls :: Point2 -> Float -> StreamOf Wall
-wallsOnLineHit :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap (Point2, Wall)
+    -> StreamOf (Point2,Wall)
-wallsOnLineHit p1 p2 = IM.mapMaybe f
+{-# INLINE overlapCircWalls #-}
-  where
-    f wl = uncurry (intersectSegSeg p1 p2) (_wlLine wl) <&> (, wl)
-
--- | Looks for any collision of a circle with walls.
--- If found, gives point and reflection velocity, reflection damped in normal.
--- note that in this version the circle can overlap the wall
-collidePointAnyWallsReflect :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
-collidePointAnyWallsReflect p1 p2 
-    = getFirst
-    . foldMap (First . findPoint . _wlLine)
-  where 
-    findPoint (x,y) = case intersectSegSeg p1 p2 x y of
-        Just ip -> Just (ip +.+ normalizeV (vNormal (x -.- y)), reflectInParam 0.5 (x -.- y) (p2 -.- p1))
-        Nothing -> Nothing
-
-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)
-
-overlapCircWalls :: Point2 -> Float -> Stream (Of Wall) Identity () 
-    -> Stream (Of (Point2,Wall)) Identity ()
 overlapCircWalls p r = S.mapMaybe dointersect
   where
     dointersect wl = f (_wlLine wl) <&> (,wl)
     f (a,b) = intersectSegSeg p (p -.- r *.* vNormal (normalizeV (a -.- b))) a b
 
--- note that this does not push the circle away from the wall at all
+-- | note that this does not push the circle away from the wall at all
-collideCircWallsStream :: Point2 -> Point2 -> Float -> Stream (Of Wall) Identity ()
+collideCircWallsStream :: Point2 -> Point2 -> Float -> StreamOf Wall
     -> (Point2, Maybe Wall)
-collideCircWallsStream sp ep rad = runIdentity
+{-# INLINE collideCircWallsStream #-}
-    . S.fold_ findPoint (ep, Nothing) id
+collideCircWallsStream sp ep rad = runIdentity . S.fold_ findPoint (ep, Nothing) id
   where
     findPoint (p,mwl) wl = maybe (p,mwl) (,Just wl) . uncurry (intersectSegSeg sp p) 
         . shiftbyrad
@@ -157,142 +154,24 @@ collideCircWallsStream sp ep rad = runIdentity
         ,b +.+ rad *.* normalizeV (b -.-a)
         )
       where
-        f = ((rad *.* normalizeV (vNormal $ a -.- b)) +.+)
+        f = (+.+) (rad *.* normalizeV (vNormal $ a -.- b))
 
-overlapCircWallsClosest :: Point2 -> Float -> Stream (Of Wall) Identity () -> Maybe (Point2,Wall)
+overlapCircWallsClosest :: Point2 -> Float -> StreamOf Wall -> Maybe (Point2,Wall)
+{-# INLINE overlapCircWallsClosest #-}
 overlapCircWallsClosest p r = minStreamOn (dist p . fst)
     . overlapCircWalls p r
 
--- | Looks for first collision of a circle with walls.
--- If found, gives point and reflection velocity, reflection damped in normal.
-collideCircWalls :: Point2 -> Point2 -> Float -> IM.IntMap Wall -> Maybe (Point2,Point2)
-collideCircWalls p1 p2 rad
-    = safeMinimumOn (dist p1 . fst) 
-    . IM.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)
-        ]
--- this shifts the wall out, and for outer corners extends the wall
--- not sure what this does for inner corners, hopefully won't cause a problem
--- the alternative would be to separately bounce off corner points...
--- unfortunately, doesn't allow for collisions when the circle spawns on the
--- wall
-
-
--- | Looks for first collision of a point with walls.
--- If found, gives point and normal of wall.
-collidePointWallsNorm :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
-collidePointWallsNorm p1 p2 ws 
-    = safeMinimumOn (dist p1 . fst)
-    $ IM.mapMaybe (( \(x,y) -> intersectSegSeg p1 p2 x y <&> ( , vNormal $ x -.- y ) ) 
-        . _wlLine) ws
--- | Returns the first creature, if any, that a point intersects with.
-collidePointCreatures :: Point2 -> Point2 -> IM.IntMap Creature -> Maybe Int
-collidePointCreatures p1 p2 = fmap fst 
-    . safeMinimumOn snd
-    . IM.toList 
-    . IM.mapMaybe (\x -> dist p1 <$> intersectCircSegFirst (_crPos x) (_crRad x) p1 p2) 
--- | As for 'collidePointCreatures', only increases the radius of creatures by a
---fixed amount, thus collides a moving circle with creaures.
-collideCircCreatures :: Point2 -> Point2 -> Float -> IM.IntMap Creature -> Maybe Int
-collideCircCreatures p1 p2 rad = collidePointCreatures p1 p2 . fmap (crRad +~ rad)
-
--- | Returns the first creature id, if any, that a point intersects with, gives point
---in creature on line.
-collidePointCrsPoint :: Point2 -> Point2 -> IM.IntMap Creature -> Maybe (Point2,Int)
-collidePointCrsPoint p1 p2 = fmap f 
-    . safeMinimumOn (dist p1 . snd)
-    . IM.toList 
-    . IM.mapMaybe (\x -> intersectCircSegFirst (_crPos x) (_crRad x) p1 p2) 
-  where 
-    f (cID,p) = (p,cID)
-{- | Finds the first creature hit on a line.
-Maybe evaluates the creature id and hit point. -}
-collideCircCrsPoint :: Point2 -> Point2 -> Float -> IM.IntMap Creature -> Maybe (Point2,Int)
-collideCircCrsPoint p1 p2 rad = collidePointCrsPoint p1 p2 . fmap (crRad +~ rad)
-
----- | Makes a creature not hittable.
---collidePointCrsWithoutPoint :: Int -> Point2 -> Point2 -> World -> Maybe (Point2,Int)
---collidePointCrsWithoutPoint cid p1 p2 w 
---    = fmap f 
---    . safeMinimumOn (snd . snd)
---    . IM.toList 
---    . IM.mapMaybe (\x -> collidePointCirc'' p1 p2 (_crRad x) (_crPos x)) 
---    . IM.delete cid 
---    $ _creatures w
---  where 
---    f (cID,(p,_)) = (p,cID)
 {- | Test if a circle collides with any wall. 
  - Note no check on whether the wall is walkable. -}
 circOnSomeWall :: Point2 -> Float -> World -> Bool
+{-# INLINE circOnSomeWall #-}
 circOnSomeWall p rad = runIdentity . S.any_ (uncurry (circOnSeg p rad) . _wlLine)
     . wlsNearPoint p
---    = any (\(x,y) -> circOnSeg x y p rad) 
---    . fmap _wlLine 
---    . IM.elems 
---    . wallsNearPoint p
 
-{- | Produce an unordered list of creatures on a line. -}
+circOnAnyCr :: Point2 -> Float -> World -> Bool
-crsOnLine :: Point2 -> Point2 -> World -> IM.IntMap Creature
+{-# INLINE circOnAnyCr #-}
-crsOnLine p1 p2
+circOnAnyCr p r = runIdentity . S.any_ (\cr -> dist p (_crPos cr) < r + _crRad cr)
-    = IM.filter (\cr -> segOnCirc p1 p2 (_crPos cr) (_crRad cr))
+    . crsNearPoint p
-    . _creatures
-{- | Produce an unordered list of creatures on a wide line. -}
-crsOnThickLine :: Float -> Point2 -> Point2 -> World -> IM.IntMap Creature
-crsOnThickLine thickness p1 p2
-    = IM.filter (\cr -> segOnCirc p1 p2 (_crPos cr) (_crRad cr + thickness))
-    . _creatures
-{- | Find 'Maybe' the closest creature to a point, within a circle.
- -}
-nearestCrInRad :: Point2 -> Float -> World -> Maybe Creature
-nearestCrInRad p r
-    = safeMinimumOn (dist p . _crPos)
-    . IM.filter (\cr -> dist p (_crPos cr) < r) 
-    . _creatures
-{- | Find 'Maybe' the closest creature in front of a point in a right-angle-triangle shape.  -}
-nearestCrInTri 
-    :: Point2 
-    -> Float    -- ^ Direction (radians +ve anticlockwise from x-axis).
-    -> Float    -- ^ Distance. 
-    -> World -> Maybe Creature
-nearestCrInTri p dir x
-    = safeMinimumOn (dist p . _crPos)
-    . IM.filter (\cr -> pointInPolygon (_crPos cr) tri) 
-    . _creatures
- where 
-    tri = 
-        [p 
-        ,p +.+ rotateV (dir-pi/4) (V2 x 0)
-        ,p +.+ rotateV (dir+pi/4) (V2 x 0)
-        ]
-{- | Find 'Maybe' the closes creature in front of a point in a given direction for
-a given distance.
-The shapes within which creatures are searched are a triangle then rectangle.  -}
-nearestCrInFront 
-    :: Point2
-    -> Float    -- ^ Direction (radians +ve anticlockwise from x-axis).
-    -> Float    -- ^ Distance.
-    -> World -> Maybe Creature
-nearestCrInFront p dir x
-    = safeMinimumOn (dist p . _crPos)
-    . IM.filter (\cr -> pointInPolygon (_crPos cr) rec)
-    . _creatures
-  where 
-    rec = [p, pR, pR1, pL1, pL ]
-    pR  = p +.+ rotateV (dir - pi*(3/8)) (V2 (x/2) 0)
-    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 -}
 
@@ -309,22 +188,26 @@ hasButtonLOS p1 p2 = not
     . wlsNearSeg p1 p2
 
 hasLOSIndirect :: Point2 -> Point2 -> World -> Bool
+{-# INLINE hasLOSIndirect #-}
 hasLOSIndirect p1 p2 = not
     . collidePointTestFilter wlIsOpaque p1 p2
     . wlsNearSeg p1 p2
 
 isWalkable :: Point2 -> Point2 -> World -> Bool
+{-# INLINE isWalkable #-}
 isWalkable p1 p2 = not 
     . collidePointTestFilter (not . (^?! wlPathable)) p1 p2 
     . wlsNearSeg p1 p2
 
 canSee :: Int -> Int -> World -> Bool
+{-# INLINE canSee #-}
 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
+{-# INLINE canSeeIndirect #-}
 canSeeIndirect i j w = hasLOSIndirect ipos jpos w
   where 
     ipos = _crPos (_creatures w IM.! i)

src/Dodge/Item/Weapon/Launcher.hs

@@ -28,6 +28,7 @@ import qualified IntMapHelp as IM
 import ShapePicture
 import Shape
 
+import qualified Streaming.Prelude as S
 --import qualified Data.Set as S
 import qualified Data.Map.Strict as M
 import qualified SDL
@@ -332,9 +333,9 @@ moveRemoteShell cid itid pj w
     doExplosion = explodeRemoteRocket itid i $ stopSoundFrom (ShellSound i) w
 
 anythingHitCirc :: Float -> Point2 -> Point2 -> World -> Bool
-anythingHitCirc rad sp ep w = isJust hitCr || isJust (sequence hitWl)
+anythingHitCirc rad sp ep w = hitCr || isJust (sequence hitWl)
   where
-    hitCr    = collideCircCrsPoint sp ep rad (_creatures w)
+    hitCr    = runIdentity $ S.any_ (const True) $ overlap1SegCrs sp ep $ crsNearSeg sp ep w
     hitWl    = collideCircWallsStream sp ep rad $ wlsNearPoint ep w
                                                     -- this should probably be wallsOnLine or something