Make thingsHit use streaming

src/Dodge/Base/Collide.hs

@@ -13,8 +13,10 @@ module Dodge.Base.Collide
     ( collidePoint
     , collidePointWallsFilterStream
     , collidePointTestFilter
+    , overlapSegWalls
     , bounceBall
     , bouncePoint
+    , sortStreamOn
 --    , wallsOnCirc
 --    , wallsOnCirc'
     , wallsOnLineHit
@@ -95,8 +97,9 @@ collidePointWallsFilterStream t sp ep = collidePoint sp ep
     . wallsAlongLine 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 ()
+sortStreamOn :: 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
+{-# INLINE sortStreamOn #-}
+sortStreamOn f = S.each . runIdentity . L.purely S.fold_ L.map . S.map g
   where
     g x = (f x,x)
 
@@ -107,7 +110,7 @@ overlapSegWalls sp ep = S.mapMaybe $ \wl -> uncurry (intersectSegSeg sp ep) (_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)
+    . sortStreamOn (dist sp . fst)
     . overlapSegWalls sp ep
     . wallsAlongLine sp ep    )
 

src/Dodge/Data.hs

@@ -77,6 +77,7 @@ import qualified Data.IntMap.Strict as IM
 import qualified Data.Map.Strict as M
 import qualified Data.Text as T
 import SDL (Scancode, MouseButton)
+import Streaming
 type CRUpdate = Creature -> World -> (World -> World, Maybe Creature)
 type CRUpdate' = Creature -> World -> (World -> World, Creature)
 
@@ -688,7 +689,7 @@ data Particle
         , _ptCenter :: Point2
         }
 type HitEffect = Particle 
-    -> [(Point2, Either Creature Wall)] 
+    -> Stream (Of (Point2, Either Creature Wall)) Identity ()
     -> World 
     -> (World,Maybe Particle)
 

src/Dodge/Initialisation.hs

@@ -41,6 +41,6 @@ initialWorld = defaultWorld
     }
 
 testStringInit :: Configuration -> World -> [String]
-testStringInit _ w = [show $ _boundDist w]
+testStringInit _ _ = mempty
 --testStringInit = map (show . _drStatus) . IM.elems . _doors
 --testStringInit = const . const [] 

src/Dodge/Item/Weapon/LaserPath.hs

@@ -8,17 +8,19 @@ import Dodge.WorldEvent
 import Geometry
 
 --import Data.Maybe
-import Data.List
+--import Data.List
 import Data.Bifunctor
 import Data.Tuple
+import Streaming
+import qualified Streaming.Prelude as S
 
 -- not sure why we need to keep a list of seen walls, but seems to loop
 -- infinitely when removed
 -- this needs to be tested with both reflections and refractions
 reflectLaserAlong :: Float -> [Wall] -> Point2 -> Point2 -> World 
     -> (Maybe (Point2,Either Creature Wall),[Point2])
-reflectLaserAlong phasev seenWl sp ep w = case find (notseen seenWl) 
+reflectLaserAlong phasev seenWl sp ep w = case runIdentity . S.head_ . S.dropWhile (notseen seenWl) 
-        $ thingsHitExceptCrLongLine Nothing sp ep w of
+        $ thingsHitExceptCr Nothing sp ep w of
     Just (p,Right wl) 
         | _wlReflect wl -> second (p:) $ reflectLaserAlong phasev (wl:seenWl) p 
             (p +.+ 800 *.* unitVectorAtAngle (reflDirWall sp p wl)) w

src/Dodge/Particle/HitEffect/ExpireAndDamage.hs

@@ -5,15 +5,17 @@ import Dodge.Particle.Update
 import Geometry
 import LensHelp
 import qualified Data.IntMap.Strict as IM
+import Streaming
+import qualified Streaming.Prelude as S
 
 expireAndDamage :: (Particle -> Point2 -> [Damage])
     -> Particle
-    -> [(Point2, Either Creature Wall)] 
+    -> Stream (Of (Point2, Either Creature Wall)) Identity ()
     -> World
     -> (World, Maybe Particle)
-expireAndDamage fdm bt hitThings w = case hitThings of
+expireAndDamage fdm bt things w = case runIdentity $ S.head_ things of
-    [] -> (w, mvPt bt)
+    Nothing -> (w, mvPt bt)
-    (x:_) -> (doDamages fdm x bt w, destroyAt (fst x) bt)
+    Just x -> (doDamages fdm x bt w, destroyAt (fst x) bt)
 
 doDamages :: (Particle -> Point2 -> [Damage])
     -> (Point2, Either Creature Wall)

src/Dodge/Particle/HitEffect/Penetrate.hs

@@ -6,6 +6,8 @@ import Geometry
 --import LensHelp
 
 import Data.Bifunctor
+import Streaming
+import qualified Streaming.Prelude as S
 
 penetrate 
     :: ((Point2,Either Creature Wall) -> Particle -> Maybe Particle) 
@@ -13,11 +15,11 @@ penetrate
     -> (Particle -> Point2 -> [Damage]) -- | damages when penetrating
     -> (Particle -> Point2 -> [Damage]) -- | damages when not penetrating
     -> Particle
-    -> [(Point2, Either Creature Wall)] 
+    -> Stream (Of (Point2, Either Creature Wall)) Identity ()
     -> World
     -> (World, Maybe Particle)
-penetrate t pendam stopdam pt hitThings w = case hitThings of
+penetrate t pendam stopdam pt hitThings w = case runIdentity $ S.uncons hitThings of
-    [] -> (w, mvPt pt)
+    Nothing -> (w, mvPt pt)
-    (x:xs) -> case t x pt of
+    Just (x,xs) -> case t x pt of
         Nothing -> expireAndDamage stopdam pt hitThings w
         Just pt' -> first (doDamages pendam x pt) $ penetrate t pendam stopdam pt' xs w

src/Dodge/WorldEvent/SpawnParticle.hs

@@ -81,9 +81,9 @@ moveFlame :: Point2   -- ^ Rotation direction
     -> (World, Maybe Particle)
 moveFlame rotd w pt 
     | time <= 0 = (makeFlamerSmokeAt (addZ 20 ep) w, Nothing)
-    | otherwise = case thingsHitExceptCr (_ptCrIgnore pt) sp ep w of
+    | otherwise = case runIdentity . S.head_ $ thingsHitExceptCr (_ptCrIgnore pt) sp ep w of
-        ((_,Left _):_)      -> (doSound $ dodamage w             , mvPt' 0.7)
+        Just (_,Left _)     -> (doSound $ dodamage w             , mvPt' 0.7)
-        ((p,Right wl):_) -> (doSound $ dodamage w  , rfl wl p)
+        Just (p,Right wl)   -> (doSound $ dodamage w  , rfl wl p)
         _                   -> (ptFlicker pt $ doSound $ dodamage w    , mvPt' 0.98)
   where 
     time = _ptTimer pt
@@ -206,10 +206,10 @@ damageInArea :: (Creature -> Bool) -> (Wall -> Bool) -> Particle -> World -> Wor
 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
+    damcrs = foldl' (flip $ \cr -> fst . hiteff (S.yield (p,Left cr))) w $ IM.filter crt $ _creatures w
     damwls w' = runIdentity
         . S.fold_ 
-            (flip $ \wl -> fst . hiteff [(p,Right wl)]) 
+            (flip $ \wl -> fst . hiteff (S.yield (p,Right wl))) 
             w' 
             id
         . S.filter wlt

src/Dodge/WorldEvent/ThingsHit.hs

@@ -6,9 +6,7 @@ module Dodge.WorldEvent.ThingsHit
     ( thingsHit
     , wallsHit
     , thingHit
-    , thingsHitLongLine
     , thingsHitExceptCr
-    , thingsHitExceptCrLongLine
     )
     where
 import Dodge.Data
@@ -20,27 +18,31 @@ import qualified Data.IntMap.Strict as IM
 import Data.List
 import Data.Maybe
 import Data.Bifunctor
+import Streaming
+import qualified Streaming.Prelude as S
+
 {- List those objects that appear on a line.  -}
 thingsHit
     :: Point2    -- ^ Line start point
     -> Point2    -- ^ Line end point
     -> World 
-    -> [(Point2, Either Creature Wall)]
+    -> Stream (Of (Point2, Either Creature Wall)) Identity ()
 thingsHit sp ep w 
-    | sp == ep  = []
+    | sp == ep  = S.each []
-    | otherwise = sortOn (dist sp . fst) (crs ++ wls)
+    | otherwise = fmap (const ()) $ S.mergeOn (dist sp . fst) crs wls
   where 
-    crs = mapMaybe 
+    crs :: Stream (Of (Point2, Either Creature Wall)) Identity ()
-        (\cr -> (,Left cr) <$> listToMaybe (intersectCircSeg (_crPos cr) (_crRad cr) sp ep))
+    crs = sortStreamOn (dist sp . fst)
-        . IM.elems 
+        . S.mapMaybe 
+            (\cr -> (,Left cr) <$> listToMaybe (intersectCircSeg (_crPos cr) (_crRad cr) sp ep))
+        . S.each 
         $ _creatures w
-    wls = map (second Right) . IM.elems $ wallsOnLineHit sp ep 
+    wls :: Stream (Of (Point2, Either Creature Wall)) Identity ()
-        $ IM.unions [f b $ f a $ _znObjects $ _wallsZone w 
+    wls = S.map (second Right) 
-            | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
+        . sortStreamOn (dist sp . fst)
-    (x,y) = zoneOfPoint (0.5 *.* (sp +.+ ep))
+        . overlapSegWalls sp ep $ wallsAlongLine sp ep w
-    f i = fromMaybe IM.empty . IM.lookup i
 thingHit :: Point2 -> Point2 -> World -> Maybe (Point2, Either Creature Wall)
-thingHit sp ep = listToMaybe . thingsHit sp ep
+thingHit sp ep = runIdentity . S.head_ . thingsHit sp ep
 {- List objects that appear on a line.
 Can filter out a creature.  -}
 thingsHitExceptCr 
@@ -48,9 +50,9 @@ thingsHitExceptCr
     -> Point2    -- ^ Line start point
     -> Point2    -- ^ Line end point
     -> World 
-    -> [(Point2, Either Creature Wall)]
+    -> Stream (Of (Point2, Either Creature Wall)) Identity ()
 thingsHitExceptCr Nothing    sp ep = thingsHit sp ep
-thingsHitExceptCr (Just cid) sp ep = filter crNotCid . thingsHit sp ep
+thingsHitExceptCr (Just cid) sp ep = S.filter crNotCid . thingsHit sp ep
   where 
     crNotCid (_,Left cr) = _crID cr /= cid
     crNotCid _ = True
@@ -70,27 +72,3 @@ wallsHit sp ep w
        -- $ _walls w
     (x,y) = zoneOfPoint (0.5 *.* (sp +.+ ep))
     f i = fromMaybe IM.empty . IM.lookup i
-
-thingsHitExceptCrLongLine 
-    :: Maybe Int 
-    -> Point2 
-    -> Point2 
-    -> World 
-    -> [(Point2, Either Creature Wall)]
-thingsHitExceptCrLongLine Nothing    sp ep = thingsHitLongLine sp ep
-thingsHitExceptCrLongLine (Just cid) sp ep = filter crNotCid . thingsHitLongLine sp ep
-  where 
-    crNotCid (_,Left cr) = _crID cr /= cid
-    crNotCid _ = True
-
-thingsHitLongLine :: Point2 -> Point2 -> World -> [(Point2, Either Creature Wall)]
-thingsHitLongLine sp ep w 
-    | sp == ep  = []
-    | otherwise = sortOn (dist sp . fst) (crs ++ wls)
-  where
-    crs = mapMaybe 
-        (\cr -> (,Left cr) <$> listToMaybe (intersectCircSeg (_crPos cr) (_crRad cr) sp ep))
-        . IM.elems 
-        $ _creatures w
-    --   $ creaturesAlongLine sp ep w
-    wls = map (second Right) . IM.elems $ wallsOnLineHit sp ep $ _walls w