Cleanup and inline collisions

src/Dodge/Base/Collide.hs

@@ -11,24 +11,22 @@
  - -}
 module Dodge.Base.Collide
     ( collidePoint
+    , collideSegCrs
     , collidePointWallsFilterStream
     , collidePointTestFilter
     , overlapSegWalls
+    , overlapSegCrs
+    , overlap1SegCrs
     , bounceBall
     , bouncePoint
     , sortStreamOn
     , minStreamOn
     , collideCircWallsStream
     , circOnSomeWall
+    , circOnAnyCr
     , overlapCircWalls
     , overlapCircWallsClosest
-    , collideCircCrsPoint
     , crsNearPoint
-    , crsOnLine
-    , crsOnThickLine
-    , nearestCrInRad
-    , nearestCrInTri
-    , nearestCrInFront
     , allVisibleWalls
 
     , hasLOS
@@ -42,14 +40,11 @@ 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
 
@@ -61,7 +56,34 @@ 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)
@@ -70,28 +92,34 @@ doBounce x sp ep (p, mwl) = mwl <&> \wl ->
 bounceBall :: Float -> Point2 -> Point2 -> Float 
     -> 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 -> 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 -> StreamOf Wall
     -> StreamOf (Point2,Wall)
+{-# INLINE overlapSegWalls #-}
 overlapSegWalls sp ep = S.mapMaybe $ \wl -> uncurry (intersectSegSeg sp ep) (_wlLine wl) <&> (,wl)
 
 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)
@@ -99,22 +127,24 @@ visibleWalls sp ep = S.take 1 <=<  -- hlint, was using join and fmap
     . wlsNearSeg sp ep    )
 
 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
     -> StreamOf (Point2,Wall)
+{-# INLINE overlapCircWalls #-}
 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 -> 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
@@ -124,98 +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 -> StreamOf Wall -> Maybe (Point2,Wall)
+{-# INLINE overlapCircWallsClosest #-}
 overlapCircWallsClosest p r = minStreamOn (dist p . fst)
     . overlapCircWalls p r
 
--- | 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 -}
 
@@ -232,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
     

src/Dodge/WorldEvent/ThingsHit.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE TupleSections #-}
+--{-# LANGUAGE TupleSections #-}
 {- |
 Find which objects lie upon a line.
  -}
@@ -13,7 +13,7 @@ import Dodge.Base
 import Dodge.Zone
 import Geometry
 
-import Data.Maybe
+--import Data.Maybe
 import Data.Bifunctor
 import StreamingHelp
 import qualified Streaming.Prelude as S
@@ -32,9 +32,7 @@ crsHit :: Point2 -> Point2 -> World -> StreamOf (Point2, Creature)
 crsHit sp ep
     | sp == ep  = const mempty
     | otherwise = sortStreamOn (dist sp . fst)
-        . S.mapMaybe 
+        . overlap1SegCrs sp ep
-            (\cr -> (, cr) <$> listToMaybe (intersectCircSeg (_crPos cr) (_crRad cr) sp ep))
---        . S.each . _creatures
         . crsNearSeg sp ep
 
 thingHit :: Point2 -> Point2 -> World -> Maybe (Point2, Either Creature Wall)