Refactor more collisions to use streaming

src/Dodge/Base/Collide.hs

@@ -22,7 +22,7 @@ module Dodge.Base.Collide
     , collidePointWalls
     , collidePointWallsNorm
     , collidePointWalls'
-    , collidePointWallsL
+--    , collidePointWallsL
     , collidePointWallsFilt
     , overlapCircWallsReturnWall
     , collideCircCrsPoint
@@ -48,6 +48,8 @@ import qualified Data.IntMap.Strict as IM
 import Control.Lens
 import qualified FoldlHelp as L
 import Data.Monoid
+import Streaming
+import qualified Streaming.Prelude as S
 
 hasLOS :: Point2 -> Point2 -> World -> Bool
 {-# INLINE hasLOS #-}
@@ -119,11 +121,11 @@ reflectPointWalls p1 p2
 pointHitsWalls :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
 pointHitsWalls p1 p2 
     = any $ isJust . uncurry (intersectSegSeg p1 p2) . _wlLine
--- | Test if there something blocking a walk
+
-collidePointWalkable :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
+collidePointTestFilter :: (Wall -> Bool) -> Point2 -> Point2 -> Stream (Of Wall) Identity () -> Bool
-collidePointWalkable p1 p2 ws 
+collidePointTestFilter t sp ep = runIdentity 
-    = any (isJust . uncurry (intersectSegSeg p1 p2) . _wlLine) 
+    . S.any_ (isJust . uncurry (intersectSegSeg sp ep) . _wlLine)
-    $ IM.filter (not . fromMaybe True . (^? wlPathable)) ws
+    . S.filter t
 
 --furthestPointWalkable :: Point2 -> Point2 -> IM.IntMap Wall -> Point2
 --furthestPointWalkable p1 p2 ws 
@@ -228,10 +230,9 @@ hasLOSIndirect p1 p2 w = case collidePointIndirect' p1 p2 $ wallsAlongLine p1 p2
     Nothing -> True
 
 isWalkable :: Point2 -> Point2 -> World -> Bool
-isWalkable p1 p2 w = not 
+isWalkable p1 p2 = not 
-    $ collidePointWalkable p1 p2 
+    . collidePointTestFilter (not . (^?! wlPathable)) p1 p2 
-    $ _walls w
+    . wallsAlongLineStream p1 p2
---    $ wallsAlongLine p1 p2 w
 
 canSee :: Int -> Int -> World -> Bool
 canSee i j w = hasLOS p1 p2 w
@@ -377,10 +378,10 @@ 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 :: Point2 -> Point2 -> L.Fold Wall Point2
-collidePointWallsL p1 p2 = L.Fold findPoint p2 id
+--collidePointWallsL p1 p2 = L.Fold findPoint p2 id
-  where
+--  where
-    findPoint p = fromMaybe p . uncurry (intersectSegSeg p1 p) . _wlLine
+--    findPoint p = fromMaybe p . uncurry (intersectSegSeg p1 p) . _wlLine
 
 collidePointWallsFilt :: (Wall -> Bool) -> Point2 -> Point2 -> IM.IntMap Wall -> Point2
 {-# INLINE collidePointWallsFilt #-}

src/Dodge/CullBox.hs

@@ -16,7 +16,7 @@ cullBox :: Configuration -> World -> [Point2]
 cullBox cfig w' 
     | debugOn Bound_box_screen cfig = screenPolygon cfig w'
     | otherwise = let (n,s,e,w) = f $ farWallDistDirection (_cameraCenter w') w'
-            in map ((+.+ _cameraCenter w') . rotateV (_cameraRot w') ) $ rectNSWE n ( s) ( w) e
+            in map ((+.+ _cameraCenter w') . rotateV (_cameraRot w') ) $ rectNSWE n s w e
   where
     f (Just a,Just b,Just c,Just d) = (max 0 a,min 0 b,max 0 c,min 0 d)
     f _ = (0,0,0,0)

src/Dodge/Update/Camera.hs

@@ -232,8 +232,9 @@ farWallDistDirection p w = runIdentity $ L.purely S.fold_ ((,,,)
     )
     $ S.map f vps
   where
-    f q = rotateV (negate $ _cameraRot w) 
+    f q = runIdentity (S.fold_ findPoint q (rotateV (negate $ _cameraRot w) . (-.- p)) (wls q))
-        $ runIdentity (L.purely S.fold_ (collidePointWallsL p q) (S.filter wlIsOpaque $ wallsAlongLineStream p q w)) -.- p
+    wls q = S.filter wlIsOpaque $ wallsAlongLineStream p q w
+    findPoint q = fromMaybe q . uncurry (intersectSegSeg p q) . _wlLine
     vps = streamViewpoints p w