Start using streaming as the way to consume foldable objects

src/Dodge/Base/Collide.hs

@@ -19,10 +19,11 @@ module Dodge.Base.Collide
     , collideCircWalls
 --    , collideCircWalls'
     , circOnSomeWall
---    , collidePointWalls
+    , collidePointWalls
     , collidePointWallsNorm
     , collidePointWalls'
-    , collidePointWallsFilt'
+    , collidePointWallsL
+    , collidePointWallsFilt
     , overlapCircWallsReturnWall
     , collideCircCrsPoint
     , collideCircCreatures
@@ -370,15 +371,20 @@ collidePointWalls :: Point2 -> Point2 -> IM.IntMap Wall -> Point2
 collidePointWalls p1 p2 = foldr findPoint p2 . fmap _wlLine
   where
     findPoint (x,y) p = fromMaybe p $ intersectSegSeg p1 p x y
-collidePointWalls' :: Point2 -> Point2 -> IM.IntMap Wall -> Point2
+collidePointWalls' :: (Foldable t, Functor t) => Point2 -> Point2 -> t Wall -> Point2
 {-# INLINE collidePointWalls' #-}
 collidePointWalls' p1 p2 = foldl' findPoint p2 . fmap _wlLine
   where
     findPoint p = fromMaybe p . uncurry (intersectSegSeg p1 p)
 
-collidePointWallsFilt' :: (Wall -> Bool) -> Point2 -> Point2 -> IM.IntMap Wall -> Point2
+collidePointWallsL :: Point2 -> Point2 -> L.Fold Wall Point2
-{-# INLINE collidePointWallsFilt' #-}
+collidePointWallsL p1 p2 = L.Fold findPoint p2 id
-collidePointWallsFilt' t p1 p2 = collidePointWalls p1 p2 . IM.filter t
+  where
+    findPoint p = fromMaybe p . uncurry (intersectSegSeg p1 p) . _wlLine
+
+collidePointWallsFilt :: (Wall -> Bool) -> Point2 -> Point2 -> IM.IntMap Wall -> Point2
+{-# INLINE collidePointWallsFilt #-}
+collidePointWallsFilt t p1 p2 = collidePointWalls' p1 p2 . IM.filter t
 
 -- | Looks for first collision of a circle with walls.
 -- If found, gives point and reflection velocity, reflection damped in normal.

src/Dodge/Update/Camera.hs

@@ -27,7 +27,8 @@ import qualified Data.IntMap.Strict as IM
 import qualified SDL
 --import Data.Monoid
 --import Data.Semigroup
---import qualified Control.Foldl as L
+import qualified Control.Foldl as L
+import qualified Streaming.Prelude as S
 {- Update the screen camera rotation and position, including any in rold scope/remote camera modifiers; 
 update where your avatar's view is from.  -}
 updateCamera :: Configuration -> World -> World
@@ -213,7 +214,9 @@ farWallDistDirection p w = foldl' (flip (m . f)) (0,0,0,0) vps
   where
     --f q = g $ rotateV (negate $ _cameraRot w) $ collidePointWallsFilt' wlIsOpaque p q wos -.- p
     f q = g $ rotateV (negate $ _cameraRot w) 
-        $ collidePointWallsFilt' wlIsOpaque p q (wallsAlongLine p q w) -.- p
+--        $ collidePointWallsFilt wlIsOpaque p q (wallsAlongLine p q w) -.- p
+        -- $ L.purely S.fold_ (collidePointWallsL p q) (wallsAlongLineStream p q w) -.- p
+        $ runIdentity (L.purely S.fold_ (collidePointWallsL p q) (wallsAlongLineStream p q w)) -.- p
     g (V2 x y) = (y, negate y, x, negate x)
     m (a,b,c,d) (x,y,z,w') = (max a x, max b y, max c z, max d w')
     vps = concatMap _grViewpoints grs ++ extendedViewPoints p grs

src/Dodge/WorldEvent/Explosion.hs

@@ -31,7 +31,7 @@ makePoisonExplosionAt
     -> World
 makePoisonExplosionAt p w 
     = soundMultiFrom [Explosion 0,Explosion 1] p bangS Nothing
-    $ foldr (makeGasCloud p) w 
+    $ foldl' (flip $ makeGasCloud p) w 
     $ replicateM 25 (randInCirc 2) & evalState $ _randGen w
 -- just change the number after replicateM to get more or less clouds
 -- suggested change: use random positions, offset from p, rather than velocities
@@ -89,7 +89,7 @@ makeExplosionAt p w = w
     times = randomRs (15,20) $ _randGen w
     mF q z v size time = makeFlamelet q z v Nothing size time
     newFs = zipWith5 mF fPs zs (fmap (3 *.*) fVs') sizes times
-    addFlames w' = foldr ($) w' newFs
+    addFlames w' = foldl' (flip ($)) w' newFs
     --pushAgainstWalls q = maybe q (uncurry (+.+)) $ reflectPointWalls p q wls
     pushAgainstWalls q = maybe q fst $ reflectPointWalls p q wls
     wls = wallsNearPoint p w

src/Dodge/WorldEvent/SpawnParticle.hs

@@ -23,6 +23,7 @@ import Geometry
 import qualified IntMapHelp as IM
 import LensHelp
 
+import Data.Foldable
 import Data.Tuple
 aFlameParticle 
     :: Int      -- ^ Timer
@@ -82,7 +83,7 @@ moveFlame rotd w pt
     | otherwise = case thingsHitExceptCr (_ptCrIgnore pt) sp ep w of
         ((_,Left _):_)      -> (doSound $ dodamage w             , mvPt' 0.7)
         ((p,Right wl):_) -> (doSound $ dodamage w  , rfl wl p)
-        _                   -> (ptFlicker pt . damwls $ doSound damcrs    , mvPt' 0.98)
+        _                   -> (ptFlicker pt $ doSound $ dodamage w    , mvPt' 0.98)
   where 
     time = _ptTimer pt
     doSound = soundContinue Flame (V2 x y) fireLoudS (Just 2)
@@ -95,14 +96,11 @@ moveFlame rotd w pt
         , _ptCrIgnore = Nothing
         , _ptVel = speed *.* vel    }
     dodamage = damageInArea closeCrs closeWls pt
-    damwls w' = foldr (\wl -> fst . hiteff [(ep,Right wl)]) w' $ IM.filter closeWls $ wallsNearPoint ep w
-    damcrs = foldr (\cr -> fst . hiteff [(ep,Left cr)]) w $ IM.filter closeCrs $ _creatures w
     closeWls wl = uncurry circOnSeg (_wlLine wl) ep 5
     closeCrs cr = dist ep (_crPos cr) 
                     < _crRad cr + 10 - min 9 (max 0 (fromIntegral time - 80))
                                 + 5 * angleCoeff (angleVV (ep -.- _crPos cr) rotd)
     angleCoeff x' = abs $ 1 - abs ( (x' * 2 - pi) / pi )
-    hiteff = _ptHitEff pt pt
     rfl wl p = Just $ pt 
         { _ptTimer = time - 1
         , _ptPos = pOut p
@@ -203,11 +201,12 @@ damageInRadius size pt = damageInArea isClose closeWls pt
     isClose cr = dist p (_crPos cr) < _crRad cr + size
 
 damageInArea :: (Creature -> Bool) -> (Wall -> Bool) -> Particle -> World -> World
+{-# INLINE damageInArea #-}
 damageInArea crt wlt pt w = damwls damcrs
   where
     p = _ptPos pt
-    damcrs = foldr (\cr -> fst . hiteff [(p,Left cr)]) w $ IM.filter crt $ _creatures w
+    damcrs = foldl' (flip $ \cr -> fst . hiteff [(p,Left cr)]) w $ IM.filter crt $ _creatures w
-    damwls w' = foldr (\wl -> fst . hiteff [(p,Right wl)]) w' $ IM.filter wlt $ wallsNearPoint p w
+    damwls w' = foldl' (flip $ \wl -> fst . hiteff [(p,Right wl)]) w' $ IM.filter wlt $ wallsNearPoint p w
     hiteff = _ptHitEff pt pt
 
 -- | At writing the radius is half the size of the effect area
@@ -234,7 +233,7 @@ makeGasCloud pos vel w = w
     (col, g) = runState (takeOne [green,yellow]) $ _randGen w
 {- Attach poison cloud damage to creatures near cloud.  -}
 cloudPoisonDamage :: Cloud -> World -> World
-cloudPoisonDamage c w = w & creatures %~ flip (foldr (IM.adjust doDam)) damagedCrs
+cloudPoisonDamage c w = w & creatures %~ flip (foldl' (flip $ IM.adjust doDam)) damagedCrs
   where 
     damagedCrs = IM.keys $ IM.filter f $ creaturesNearPoint clpos w
     f cr = dist3 (addZ 20 $ _crPos cr) (_clPos c) < _crRad cr + _clRad c + 10

src/Dodge/Zone.hs

@@ -3,6 +3,7 @@ module Dodge.Zone
     , zoneOfLineIntMap
     , wallsNearPoint
     , wallsAlongLine
+    , wallsAlongLineStream
     , zoneSize
     , zoneOfPoint
     , wallsAlongCirc
@@ -30,10 +31,14 @@ import Geometry
 import Geometry.Zone
 import qualified FoldlHelp as L
 
+import qualified Streaming.Prelude as S
+import Streaming
 import Data.Maybe
 import Data.List
+import Data.IntMap.Merge.Strict
 import qualified Data.IntMap.Strict as IM
 import qualified Data.IntSet as IS
+import Control.Lens
 
 --flattenZones ::  Zone (IM.IntMap a) -> IM.IntMap a
 --flattenZones = flattenIMIMIM . _znObjects
@@ -79,6 +84,9 @@ zoneOfLine (V2 aa ab) (V2 ba bb)
     f (x,y) = [(p,r) | p <-[x-1,x,x+1] , r<-[y-1,y,y+1]]
     --f (x,y) = [(p,r) | p <-[x-2..x+2] , r<-[y-2..y+2]]
 
+zoneOfLineStream :: Monad m => Point2 -> Point2 -> Stream (Of (Int,Int)) m ()
+zoneOfLineStream = ddaSqStream zoneSize
+
 zoneOfLineIntMap :: Point2 -> Point2 -> IM.IntMap IS.IntSet
 --{-# INLINE zoneOfLineIntMap #-}
 --zoneOfLineIntMap = ddaExt zoneSize
@@ -168,6 +176,20 @@ wallsAlongLine a b w =
         Just val -> val
         _        -> IM.empty
 
+restrictIMIM :: IM.IntMap (IM.IntMap a) -> IM.IntMap IS.IntSet -> IM.IntMap (IM.IntMap a)
+restrictIMIM = merge dropMissing dropMissing (zipWithMatched $ const IM.restrictKeys)
+
+wallsAlongLineStream :: Monad m => Point2 -> Point2 -> World -> Stream (Of Wall) m ()
+wallsAlongLineStream sp ep w = flip S.for S.each $ S.mapMaybe f $ zoneOfLineStream sp ep
+  where
+    f (i,j) = w ^? wallsZone . znObjects . ix i . ix j
+
+--wallsAlongLine :: Point2 -> Point2 -> World -> IM.IntMap Wall
+----{-# INLINE wallsAlongLine #-}
+--wallsAlongLine a b w = _walls w
+--  where 
+--    kps = zoneOfLineIntMap a b
+
 wallsAlongCirc :: Point2 -> Float -> World -> IM.IntMap Wall
 wallsAlongCirc p r w =  IM.unions [f y $ f x $ _znObjects $ _wallsZone w | (x,y) <- zoneOfCircle p r]
   where 

src/Geometry/Zone.hs

@@ -3,9 +3,12 @@ module Geometry.Zone
     ( ddaExt
     , ddaExt'
     , ddaSq
+    , ddaSqStream
     ) where
 import Geometry.Data
 
+import Streaming
+import qualified Streaming.Prelude as S
 import Data.Foldable
 import qualified Data.IntMap.Strict as IM
 import qualified Data.IntSet as IS
@@ -89,6 +92,14 @@ ddaSq s (V2 sx sy) (V2 ex ey) = IM.fromSet (const ys) xs
     xs = IS.fromDistinctAscList [minx-1..maxx+1]
     ys = IS.fromDistinctAscList [miny-1..maxy+1]
 
+ddaSqStream :: Monad m => Float -> V2 Float -> V2 Float -> Stream (Of (Int,Int)) m ()
+ddaSqStream s (V2 sx sy) (V2 ex ey) = S.each [(x,y) | x <- [minx..maxx], y <- [miny..maxy]]
+  where
+    maxMin a b | a >= b = (a,b)
+        | otherwise = (b,a)
+    (maxx,minx) = maxMin (divTo s sx) (divTo s ex)
+    (maxy,miny) = maxMin (divTo s sy) (divTo s ey)
+
 -- | Determines which horizontal and vertical lines on a grid are crossed by a
 -- line. For each adds the x-y index of the square to the right or above the
 -- crossed grid line. Also adds the index of the square containing the start