diff --git a/src/Dodge/Base/Collide.hs b/src/Dodge/Base/Collide.hs index 36ffbe8d9..501353ab3 100644 --- a/src/Dodge/Base/Collide.hs +++ b/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 -collidePointWalkable p1 p2 ws - = any (isJust . uncurry (intersectSegSeg p1 p2) . _wlLine) - $ IM.filter (not . fromMaybe True . (^? wlPathable)) ws + +collidePointTestFilter :: (Wall -> Bool) -> Point2 -> Point2 -> Stream (Of Wall) Identity () -> Bool +collidePointTestFilter t sp ep = runIdentity + . S.any_ (isJust . uncurry (intersectSegSeg sp ep) . _wlLine) + . 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 - $ collidePointWalkable p1 p2 - $ _walls w --- $ wallsAlongLine p1 p2 w +isWalkable p1 p2 = not + . collidePointTestFilter (not . (^?! wlPathable)) p1 p2 + . wallsAlongLineStream p1 p2 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 p1 p2 = L.Fold findPoint p2 id - where - findPoint p = fromMaybe p . uncurry (intersectSegSeg p1 p) . _wlLine +--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 #-} diff --git a/src/Dodge/CullBox.hs b/src/Dodge/CullBox.hs index e41aee8d1..42a186ff9 100644 --- a/src/Dodge/CullBox.hs +++ b/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) diff --git a/src/Dodge/Update/Camera.hs b/src/Dodge/Update/Camera.hs index 04dfafd4a..a8f101580 100644 --- a/src/Dodge/Update/Camera.hs +++ b/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) - $ runIdentity (L.purely S.fold_ (collidePointWallsL p q) (S.filter wlIsOpaque $ wallsAlongLineStream p q w)) -.- p + f q = runIdentity (S.fold_ findPoint q (rotateV (negate $ _cameraRot w) . (-.- p)) (wls q)) + wls q = S.filter wlIsOpaque $ wallsAlongLineStream p q w + findPoint q = fromMaybe q . uncurry (intersectSegSeg p q) . _wlLine vps = streamViewpoints p w