diff --git a/src/Dodge/Base/Collide.hs b/src/Dodge/Base/Collide.hs index 718acbdad..097d8cb5e 100644 --- a/src/Dodge/Base/Collide.hs +++ b/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 () -orderStreamOn f = S.each . runIdentity . L.purely S.fold_ L.map . S.map g +sortStreamOn :: Ord a => (b -> a) -> Stream (Of b) Identity () -> Stream (Of b) Identity () +{-# 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 ) diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 916d54e6d..a788622d2 100644 --- a/src/Dodge/Data.hs +++ b/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) diff --git a/src/Dodge/Initialisation.hs b/src/Dodge/Initialisation.hs index bc9c5530e..39e41c9e5 100644 --- a/src/Dodge/Initialisation.hs +++ b/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 [] diff --git a/src/Dodge/Item/Weapon/LaserPath.hs b/src/Dodge/Item/Weapon/LaserPath.hs index 3f79569f7..6ca136ebd 100644 --- a/src/Dodge/Item/Weapon/LaserPath.hs +++ b/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) - $ thingsHitExceptCrLongLine Nothing sp ep w of +reflectLaserAlong phasev seenWl sp ep w = case runIdentity . S.head_ . S.dropWhile (notseen seenWl) + $ 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 diff --git a/src/Dodge/Particle/HitEffect/ExpireAndDamage.hs b/src/Dodge/Particle/HitEffect/ExpireAndDamage.hs index bcab3b08e..841bb4505 100644 --- a/src/Dodge/Particle/HitEffect/ExpireAndDamage.hs +++ b/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 - [] -> (w, mvPt bt) - (x:_) -> (doDamages fdm x bt w, destroyAt (fst x) bt) +expireAndDamage fdm bt things w = case runIdentity $ S.head_ things of + Nothing -> (w, mvPt bt) + Just x -> (doDamages fdm x bt w, destroyAt (fst x) bt) doDamages :: (Particle -> Point2 -> [Damage]) -> (Point2, Either Creature Wall) diff --git a/src/Dodge/Particle/HitEffect/Penetrate.hs b/src/Dodge/Particle/HitEffect/Penetrate.hs index d5d94c50c..2810d8c0f 100644 --- a/src/Dodge/Particle/HitEffect/Penetrate.hs +++ b/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 - [] -> (w, mvPt pt) - (x:xs) -> case t x pt of +penetrate t pendam stopdam pt hitThings w = case runIdentity $ S.uncons hitThings of + Nothing -> (w, mvPt pt) + 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 diff --git a/src/Dodge/WorldEvent/SpawnParticle.hs b/src/Dodge/WorldEvent/SpawnParticle.hs index 618771a97..76052c8a1 100644 --- a/src/Dodge/WorldEvent/SpawnParticle.hs +++ b/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 - ((_,Left _):_) -> (doSound $ dodamage w , mvPt' 0.7) - ((p,Right wl):_) -> (doSound $ dodamage w , rfl wl p) + | otherwise = case runIdentity . S.head_ $ thingsHitExceptCr (_ptCrIgnore pt) sp ep w of + Just (_,Left _) -> (doSound $ dodamage w , mvPt' 0.7) + 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 diff --git a/src/Dodge/WorldEvent/ThingsHit.hs b/src/Dodge/WorldEvent/ThingsHit.hs index e577d192b..43a70c1ba 100644 --- a/src/Dodge/WorldEvent/ThingsHit.hs +++ b/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 = [] - | otherwise = sortOn (dist sp . fst) (crs ++ wls) + | sp == ep = S.each [] + | otherwise = fmap (const ()) $ S.mergeOn (dist sp . fst) crs wls where - crs = mapMaybe - (\cr -> (,Left cr) <$> listToMaybe (intersectCircSeg (_crPos cr) (_crRad cr) sp ep)) - . IM.elems + crs :: Stream (Of (Point2, Either Creature Wall)) Identity () + crs = sortStreamOn (dist sp . fst) + . 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 - $ IM.unions [f b $ f a $ _znObjects $ _wallsZone w - | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]] - (x,y) = zoneOfPoint (0.5 *.* (sp +.+ ep)) - f i = fromMaybe IM.empty . IM.lookup i + wls :: Stream (Of (Point2, Either Creature Wall)) Identity () + wls = S.map (second Right) + . sortStreamOn (dist sp . fst) + . overlapSegWalls sp ep $ wallsAlongLine sp ep w 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