More streaming refactoring

src/Dodge/Base/Collide.hs

@@ -16,8 +16,10 @@ module Dodge.Base.Collide
     , wlIsOpaque
     , wlIsSeeThrough
     , wallsOnCirc
+    , wallsOnCirc'
     , wallsOnLineHit
     , collideCircWalls
+    , collideCircWallsList
 --    , collideCircWalls'
     , circOnSomeWall
     , collidePointWalls
@@ -26,6 +28,7 @@ module Dodge.Base.Collide
 --    , collidePointWallsL
     , collidePointWallsFilt
     , overlapCircWallsReturnWall
+    , overlapCircWallsReturnWall'
     , collideCircCrsPoint
     , collideCircCreatures
     , collidePointCreatures
@@ -235,6 +238,11 @@ wallsOnCirc p r = IM.filter f
   where 
     f wl = uncurry circOnSeg (_wlLine wl) p r
 
+wallsOnCirc' :: Point2 -> Float -> [Wall] -> [Wall]
+wallsOnCirc' p r = filter f
+  where 
+    f wl = uncurry circOnSeg (_wlLine wl) p r
+
 -- | Looks for overlap of a circle with walls.
 -- If found, gives wall
 overlapCircWallsReturnWall :: Point2 -> Float -> IM.IntMap Wall -> Maybe Wall
@@ -243,6 +251,14 @@ overlapCircWallsReturnWall p rad
   where 
     f (a,b) = intersectSegSeg p (p -.- rad *.* vNormal (normalizeV (a -.- b))) a b
 
+-- | Looks for overlap of a circle with walls.
+-- If found, gives wall
+overlapCircWallsReturnWall' :: Point2 -> Float -> Stream (Of Wall) Identity () -> Maybe Wall
+overlapCircWallsReturnWall' p rad
+    = runIdentity . L.purely S.fold_ (safeMinimumOnMaybeL (fmap (dist p) . f . _wlLine))
+  where 
+    f (a,b) = intersectSegSeg p (p -.- rad *.* vNormal (normalizeV (a -.- b))) a b
+
 -- | 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
@@ -296,6 +312,25 @@ collidePointWallsFilt t p1 p2 = collidePointWalls' p1 p2 . IM.filter t
 --        )
 --      where
 --        g = ((rad *.* normalizeV (vNormal $ a -.- b)) +.+)
+-- | Looks for first collision of a circle with walls.
+-- If found, gives point and reflection velocity, reflection damped in normal.
+collideCircWallsList :: Point2 -> Point2 -> Float -> [Wall] -> Maybe (Point2,Point2)
+collideCircWallsList p1 p2 rad
+    = safeMinimumOn (dist p1 . fst) 
+    . 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)
+        ]
 
 -- | Looks for first collision of a circle with walls.
 -- If found, gives point and reflection velocity, reflection damped in normal.
@@ -379,11 +414,12 @@ collideCircCrsPoint p1 p2 rad = collidePointCrsPoint p1 p2 . fmap (crRad +~ rad)
 {- | Test if a circle collides with any wall. 
  - Note no check on whether the wall is walkable. -}
 circOnSomeWall :: Point2 -> Float -> World -> Bool
-circOnSomeWall p rad
+circOnSomeWall p rad = runIdentity . S.any_ (uncurry (circOnSeg' p rad) . _wlLine)
-    = any (\(x,y) -> circOnSeg x y p rad) 
-    . fmap _wlLine 
-    . IM.elems 
     . wallsNearPoint p
+--    = any (\(x,y) -> circOnSeg x y p rad) 
+--    . fmap _wlLine 
+--    . IM.elems 
+--    . wallsNearPoint p
 {- | Adds the distance to the creature radius, tests whether the center is in
 the circle of this size centered at the point -}
 crsNearPoint :: Float -> Point2 -> World -> Bool

src/Dodge/Beam.hs

@@ -114,10 +114,11 @@ defaultArcStep itparams w (ArcStep p dir _) = do
             . filter (\cr -> dist center (_crPos cr) < csize)
             . IM.elems
             $ _creatures w
-        wlsnearpoint = wallsNearPoint p w
+        wlsnearpoint = wallsNearPoint' p w
         mwl = listToMaybe
             . sortOn (dist p . fst)
-            . mapMaybe (\ q -> collidePointWallsWall p (center +.+ q) wlsnearpoint)
+            . mapMaybe (\ q -> sequence $ collidePointWallsFilterStream (const True) p (center +.+ q) w)
+                -- collidePointWallsWall and wlsnearpoint
             $ polyCirc 6 csize
         f (q,wl) = ArcStep q dir (Just $ Right wl)
         g cr   = ArcStep (_crPos cr +.+ csize *.* unitVectorAtAngle dir) dir (Just $ Left cr)

src/Dodge/Item/Weapon/Grenade.hs

@@ -52,7 +52,7 @@ moveGrenade pj w
     | _pjTimer pj <= 0 = w 
         & props %~ IM.delete pID 
         & _pjPayload pj (_prPos (_props w IM.! pID)) 
-    | otherwise = case collideCircWalls oldPos newPos 4 $ wallsNearPoint newPos w of
+    | otherwise = case collideCircWallsList oldPos newPos 4 $ wallsNearPoint' newPos w of
         Nothing -> w & props . ix pID %~ normalUpdate
         Just (p,v)  -> w
             & soundStart (Tap 0) p tapQuietS Nothing
@@ -182,7 +182,7 @@ moveRemoteBomb itid time pID w
     -- this is hacky, should use a version of collidePointWalls' that collides
     -- circles and walls
     invShift x = x -.- 5 *.* normalizeV (_pjVel pj)
-    hitWl  = collideCircWalls oldPos newPos 4 $ wallsNearPoint newPos w
+    hitWl  = collideCircWallsList oldPos newPos 4 $ wallsNearPoint' newPos w
     finalPos = maybe newPos (invShift . fst) hitWl
     setV v = set (props . ix pID . pjVel) v
     updateV = maybe id (setV . snd) hitWl

src/Dodge/Item/Weapon/Launcher.hs

@@ -336,7 +336,7 @@ anythingHitCirc :: Float -> Point2 -> Point2 -> World -> Bool
 anythingHitCirc rad sp ep w = isJust $ hitCr <|> hitWl
   where
     hitCr    = fst <$> collideCircCrsPoint sp ep rad (_creatures w)
-    hitWl    = fst <$> collideCircWalls sp ep rad (wallsNearPoint ep w) 
+    hitWl    = fst <$> collideCircWallsList sp ep rad (wallsNearPoint' ep w) 
                                                     -- this should probably be wallsOnLine or something
     
 explodeRemoteRocket 

src/Dodge/Update.hs

@@ -348,7 +348,8 @@ updateCloud w c
     newPos@(V3 _ _ npz) = oldPos +.+.+ newVel
     newPos2 = stripZ newPos
     -- the following only tests for the first collision with a wall
-    hitWl = collidePointAnyWallsReflect oldPos2 newPos2 $ wallsNearPoint newPos2 w
+    --hitWl = collidePointAnyWallsReflect oldPos2 newPos2 $ wallsNearPoint newPos2 w
+    hitWl = reflectPointWallsDamp (const True) 1 oldPos2 newPos2 w
     finalPos = addZ (min 74 npz) $ maybe newPos2 fst hitWl
         -- allowing clouds at/above height 75 causes graphical glitches 22.05.23
     finalVel = addZ nvz $ maybe newVel2 snd hitWl

src/Dodge/Update/Camera.hs

@@ -143,7 +143,7 @@ ifConfigWallRotate cfig w
 
 rotateToOverlappingWall :: World -> World
 rotateToOverlappingWall w = maybe w dowallrotate
-    $ overlapCircWallsReturnWall p (_crRad cr + 5) (IM.filter _wlRotateTo $ wallsNearPoint p w)
+    $ overlapCircWallsReturnWall' p (_crRad cr + 5) (S.filter _wlRotateTo $ wallsNearPoint p w)
   where
     dowallrotate wl' = rotateUsing $ (argV . uncurry (-.-) $ _wlLine wl') - _cameraRot w
     rotateUsing a

src/Dodge/WallCreatureCollisions.hs

@@ -18,6 +18,8 @@ import Data.Function
 import Control.Lens
 import qualified Data.IntMap.Strict as IM
 
+import qualified Streaming.Prelude as S
+
 colCrsWalls :: Configuration -> World -> World
 colCrsWalls cfig w = w & creatures %~ fmap (noclipCheck cfig w)
 
@@ -42,9 +44,9 @@ colCrWall w c
     rad = _crRad c + wallBuffer
     p1  = _crOldPos c
     p2  = _crPos c
-    ls  = IM.elems $ _wlLine <$> wls
+    ls  = _wlLine <$> wls
     ls' = filter (uncurry $ isLHS p1) ls
-    wls = IM.filter (not . _wlWalkable) $ wallsNearPoint p2 w
+    wls = runIdentity . S.toList_ . S.filter (not . _wlWalkable) $ wallsNearPoint p2 w
     --wallPoints = map fst ls
 
 -- the amount to push creatures out from walls, extra to their radius
@@ -81,9 +83,9 @@ pushOrCrush wls cr = case mapMaybe (pushOutFromWall (_crRad cr) cpos) wls of
 
 -- note the inclusion of endpoints in circOnSeg
 crOnWall :: Creature -> World -> Bool
-crOnWall cr = any (\(a,b) -> circOnSeg a b p r)
+crOnWall cr = runIdentity
-    . fmap _wlLine 
+    . S.any_ (uncurry (circOnSeg' p r) . _wlLine)
-    . IM.filter (not . _wlWalkable) 
+    . S.filter (not . _wlWalkable) 
     . wallsNearPoint p
   where
     p = _crPos cr

src/Dodge/WorldEvent/Explosion.hs

@@ -91,5 +91,6 @@ makeExplosionAt p w = w
     newFs = zipWith5 mF fPs zs (fmap (3 *.*) fVs') sizes times
     addFlames w' = foldl' (flip ($)) w' newFs
     --pushAgainstWalls q = maybe q (uncurry (+.+)) $ reflectPointWalls p q wls
-    pushAgainstWalls q = maybe q fst $ reflectPointWalls p q wls
+    --pushAgainstWalls q = maybe q fst $ reflectPointWalls p q wls
-    wls = wallsNearPoint p w
+    pushAgainstWalls q = maybe q fst $ reflectPointWallsDamp (const True) 1 p q w
+--    wls = wallsNearPoint p w

src/Dodge/WorldEvent/Shockwave.hs

@@ -12,6 +12,7 @@ import Geometry
 import Picture
 import LensHelp
 
+import Data.Foldable
 import qualified Data.IntMap.Strict as IM
 -- currently very effective against walls
 makeShockwaveAt 
@@ -62,9 +63,9 @@ mvShockwave is w pt
     tFraction = fromIntegral t / fromIntegral (_ptMaxTime pt)
     rad = r - (3/4) * r * tFraction
     doDams = over creatures (IM.map damCr) 
-        . flip (IM.foldl' (flip $ damageWall (Damage EXPLOSIVE 10000 p p p NoDamageEffect))) 
+        . flip (foldl' (flip $ damageWall (Damage EXPLOSIVE 10000 p p p NoDamageEffect))) 
         hitBlocks
-    hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w 
+    hitBlocks = wallsOnCirc' p rad $ wallsNearPoint' p w 
     damCr cr 
         | _crID cr `elem` is || dist (_crPos cr) p >= rad + _crRad cr  = cr
         | otherwise = cr & crState . csDamage .:~
@@ -104,7 +105,7 @@ moveInverseShockwave w pt
     t = _ptTimer pt
     rad = r - 0.1 * r * fromIntegral (10 - t)
     dams = over creatures (IM.map damCr) . flip (foldr (damageBlocksBy 1)) hitBlocks
-    hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w 
+    hitBlocks = wallsOnCirc' p rad $ wallsNearPoint' p w 
     damCr cr 
         | dist (_crPos cr) p >= rad + _crRad cr = cr
         | otherwise = cr & crState . csDamage .:~

src/Dodge/WorldEvent/SpawnParticle.hs

@@ -206,7 +206,7 @@ damageInArea crt wlt pt w = damwls damcrs
   where
     p = _ptPos pt
     damcrs = foldl' (flip $ \cr -> fst . hiteff [(p,Left cr)]) w $ IM.filter crt $ _creatures w
-    damwls w' = foldl' (flip $ \wl -> fst . hiteff [(p,Right wl)]) w' $ IM.filter wlt $ wallsNearPoint p w
+    damwls w' = foldl' (flip $ \wl -> fst . hiteff [(p,Right wl)]) w' $ filter wlt $ wallsNearPoint' p w
     hiteff = _ptHitEff pt pt
 
 -- | At writing the radius is half the size of the effect area

src/Dodge/Zone.hs

@@ -2,6 +2,7 @@ module Dodge.Zone
     ( crZoneOfPoint
     , zoneOfLineIntMap
     , wallsNearPoint
+    , wallsNearPoint'
     , wallsAlongLine
     , zoneSize
     , zoneOfPoint
@@ -187,13 +188,20 @@ wallsAlongCirc p r w =  IM.unions [f y $ f x $ _znObjects $ _wallsZone w | (x,y)
         Just val -> val
         _ -> IM.empty
 
-wallsNearPoint :: Point2 -> World -> IM.IntMap Wall
+wallsNearPoint' :: Point2 -> World -> [Wall]
-wallsNearPoint p w =  IM.unions [f b $ f a $ _znObjects $ _wallsZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
+wallsNearPoint' p = runIdentity . S.toList_ . wallsNearPoint p
+
+wallsNearPoint :: Point2 -> World -> Stream (Of Wall) Identity ()
+wallsNearPoint p w = S.concat $ S.mapMaybe f $ S.each [V2 a b | a <- [x-1,x,x+1], b <- [y-1,y,y+1]]
   where
     (x,y) = zoneOfPoint p
-    f i m = case IM.lookup i m of 
+    f (V2 i j) = w ^? wallsZone . znObjects . ix i . ix j
-        Just val -> val
+--    IM.unions [f b $ f a $ _znObjects $ _wallsZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
-        _ -> IM.empty
+--  where 
+--    (x,y) = zoneOfPoint p
+--    f i m = case IM.lookup i m of 
+--        Just val -> val
+--        _ -> IM.empty
 
 flattenIMIMIM :: IM.IntMap (IM.IntMap (IM.IntMap a)) -> IM.IntMap a
 flattenIMIMIM = IM.unions . fmap IM.unions

src/Geometry.hs

@@ -81,6 +81,16 @@ circOnSegNoEndpoints :: Point2 -> Point2 -> Point2 -> Float -> Bool
 circOnSegNoEndpoints !p1 !p2 !c !rad = intersectSegSegTest p1 p2 (c -.- thenormal) (c +.+ thenormal)
   where 
     thenormal = rad *.* vNormal (normalizeV $ p1 -.- p2)
+-- | Test whether a circle is on a segment by intersecting a normal and testing
+-- the distance to the endpoints of the segment.
+-- Perhaps a better order of arguments.
+circOnSeg' :: Point2 -> Float -> Point2 -> Point2 -> Bool
+{-# INLINE circOnSeg' #-}
+circOnSeg' !c !rad !p1 !p2 = magV (p1 -.- c) <= rad 
+    || magV (p2 -.- c) <= rad
+    || intersectSegSegTest p1 p2 (c -.- thenormal) (c +.+ thenormal)
+  where 
+    thenormal = rad *.* vNormal (normalizeV $ p1 -.- p2)
 
 -- | Test whether a circle is on a segment by intersecting a normal and testing
 -- the distance to the endpoints of the segment.