Move wall collisions around

src/Dodge/Base.hs

@@ -13,9 +13,11 @@ module Dodge.Base
     , module Dodge.Base.Coordinate
     , module Dodge.Base.Collide
     , module Dodge.Base.CardinalPoint
+    , module Dodge.Base.Wall
     ) where
 import Dodge.Data
 import Dodge.Base.WinScale
+import Dodge.Base.Wall
 import Dodge.Base.Arithmetic
 import Dodge.Base.NewID
 import Dodge.Base.Coordinate

src/Dodge/Base/Collide.hs

@@ -16,7 +16,7 @@ module Dodge.Base.Collide
     , bounceBall
     , bouncePoint
     , ssfold
-    , collidePointUpToIndirectMinDist
+--    , collidePointUpToIndirectMinDist
     , wlIsOpaque
     , wlIsSeeThrough
     , wallsOnCirc
@@ -50,11 +50,10 @@ module Dodge.Base.Collide
     ) where
 import Dodge.Data
 import Dodge.Zone
-import Dodge.Wall.Reflect
+import Dodge.Base.Wall
 import Geometry
 import FoldableHelp
 
---import Data.List
 import Data.Maybe
 import Data.Function (on)
 import qualified Data.IntMap.Strict as IM
@@ -64,36 +63,28 @@ import qualified FoldlHelp as L
 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
+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
 
+doBounce :: Float -> Point2 -> Point2 -> (Point2, Maybe Wall) -> Maybe (Point2, Point2)
+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 ()
     -> Maybe (Point2,Point2)
-bounceBall x sp ep r w = do
-    wl <- mwl
-    return (p +.+ normalizeV (vNormal (uncurry (-.-) (_wlLine wl)))
-        , reflVelWallDamp x wl (ep -.- sp)
-        )
-  where
-    (p, mwl) = collideCircWallsStream sp ep r w
+bounceBall x sp ep r = doBounce x sp ep . collideCircWallsStream sp ep r
 
 bouncePoint :: (Wall -> Bool) -> Float -> Point2 -> Point2 -> World -> Maybe (Point2,Point2)
-bouncePoint t x sp ep w = do
-    wl <- mwl
-    return (p +.+ normalizeV (vNormal (uncurry (-.-) (_wlLine wl)))
-        , reflVelWallDamp x wl (ep -.- sp)
-        )
-  where
-    (p, mwl) = collidePointWallsFilterStream t sp ep w
+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
@@ -107,49 +98,28 @@ collidePointWallsFilterStream t sp ep = collidePoint sp ep
     . S.filter t
     . wallsAlongLine sp ep
 
---visibleWallWalls' :: Point2 -> Point2 -> World -> M.Map Float Wall
---visibleWallWalls' sp ep = L.purely S.fold L.map . visibleWallWalls sp ep
-
 --orderStreamOn :: Ord b => (a -> b) -> Stream (Of a) Identity () -> Identity (Of (M.Map b a) ())
 orderStreamOn :: Ord a => (b -> a) -> Stream (Of b) Identity () -> Stream (Of b) Identity ()
 orderStreamOn f = S.each . runIdentity . L.purely S.fold_ L.map . S.map g
   where
     g x = (f x,x)
 
+overlapSegWalls :: Point2 -> Point2 -> Stream (Of Wall) Identity () 
+    -> Stream (Of (Point2,Wall)) Identity ()
+overlapSegWalls sp ep = S.mapMaybe $ \wl -> uncurry (intersectSegSeg sp ep) (_wlLine wl) <&> (,wl)
+
 visibleWalls :: Point2 -> Point2 -> World -> Stream (Of (Point2,Wall)) Identity ()
 visibleWalls sp ep = S.take 1 <=<  -- hlint, was using join and fmap
     ( S.span (not . wlIsOpaque . snd)
     . orderStreamOn (dist sp . fst)
-    . S.mapMaybe f
+    . overlapSegWalls sp ep
     . wallsAlongLine sp ep    )
-  where
-    f wl = uncurry (intersectSegSeg sp ep) (_wlLine wl) <&> (,wl)
 
 allVisibleWalls :: World -> Stream (Of (Point2,Wall)) Identity ()
 allVisibleWalls w = concats $ S.subst (flip (visibleWalls vPos) w . (+.+ vPos)) $ S.each (nRays 20)
   where
     vPos = _cameraViewFrom w
 
-wlIsOpaque :: Wall -> Bool
-wlIsOpaque wl = case _wlOpacity wl of
-    Opaque -> True
-    _ -> False
-
-wlIsSeeThrough :: Wall -> Bool
-wlIsSeeThrough wl = case _wlOpacity wl of
-    SeeThrough -> True
-    _ -> False
-
---collidePointUpToIndirect
---    :: Point2   -- ^start point
---    -> Point2   -- ^end point
---    -> IM.IntMap Wall 
---    -> Point2
---{-# INLINE collidePointUpToIndirect #-}
---collidePointUpToIndirect p1 p2 = foldr f p2 . IM.filter wlIsOpaque
---  where
---    f wl x = fromMaybe x . uncurry (intersectSegSeg p1 x) $ _wlLine wl
-
 collidePointUpToIndirectMinDist
     :: Point2   -- ^start point
     -> Point2   -- ^end point

src/Dodge/Base/Wall.hs

@@ -1,7 +1,16 @@
-module Dodge.Wall.Reflect
-    where
-import Geometry
+module Dodge.Base.Wall where
 import Dodge.Data
+import Geometry
+
+wlIsOpaque :: Wall -> Bool
+wlIsOpaque wl = case _wlOpacity wl of
+    Opaque -> True
+    _ -> False
+
+wlIsSeeThrough :: Wall -> Bool
+wlIsSeeThrough wl = case _wlOpacity wl of
+    SeeThrough -> True
+    _ -> False
 
 reflDirWall :: Point2 -> Point2 -> Wall -> Float
 reflDirWall sp ep wl = argV (reflectIn (uncurry (-.-) (_wlLine wl)) (ep -.- sp))

src/Dodge/Item/Weapon/LaserPath.hs

@@ -2,15 +2,9 @@ module Dodge.Item.Weapon.LaserPath
     ( reflectLaserAlong
     ) where
 import Dodge.Data
-import Dodge.Wall.Reflect
+import Dodge.Base.Wall
 --import Dodge.Creature.HandPos
 import Dodge.WorldEvent
-import Dodge.Base.Collide
---import Dodge.Default
---import Dodge.Item.Weapon.InventoryDisplay
---import Dodge.Item.Weapon.TriggerType
---import Dodge.Item.Attachment
---import Dodge.Base
 import Geometry
 
 --import Data.Maybe

src/Dodge/Wall/DamageEffect.hs

@@ -2,7 +2,7 @@ module Dodge.Wall.DamageEffect where
 import Dodge.Data
 import Dodge.Particle.Spark
 import Dodge.Particle.Bullet.Spawn
-import Dodge.Wall.Reflect
+import Dodge.Base.Wall
 import Dodge.Wall.Dust
 import Dodge.Block
 import Geometry