diff --git a/src/Dodge/Base/Collide.hs b/src/Dodge/Base/Collide.hs index d8bfd2e9d..db9e95c5c 100644 --- a/src/Dodge/Base/Collide.hs +++ b/src/Dodge/Base/Collide.hs @@ -17,6 +17,7 @@ module Dodge.Base.Collide , bounceBall , bouncePoint , sortStreamOn + , minStreamOn -- , wallsOnCirc -- , wallsOnCirc' , wallsOnLineHit @@ -53,13 +54,12 @@ import Geometry import FoldableHelp import Data.Maybe -import Data.Function (on) import qualified Data.IntMap.Strict as IM import Control.Lens import Control.Monad -import qualified FoldlHelp as L +--import qualified FoldlHelp as L import Data.Monoid -import Streaming +import StreamingHelp import qualified Streaming.Prelude as S collidePoint :: Point2 -> Point2 @@ -96,14 +96,6 @@ collidePointWallsFilterStream t sp ep = collidePoint sp ep . S.filter t . wallsAlongLine sp ep --- this hopefully also nub the stream in most cases ---orderStreamOn :: Ord b => (a -> b) -> Stream (Of a) Identity () -> Identity (Of (M.Map b a) ()) -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) - 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) @@ -168,8 +160,7 @@ collideCircWallsStream sp ep rad = runIdentity f = ((rad *.* normalizeV (vNormal $ a -.- b)) +.+) overlapCircWallsClosest :: Point2 -> Float -> Stream (Of Wall) Identity () -> Maybe (Point2,Wall) -overlapCircWallsClosest p r = runIdentity - . L.purely S.fold_ (L.minimumBy (compare `on` (dist p . fst))) +overlapCircWallsClosest p r = minStreamOn (dist p . fst) . overlapCircWalls p r -- | Looks for first collision of a circle with walls. @@ -250,10 +241,7 @@ circOnSomeWall p rad = runIdentity . S.any_ (uncurry (circOnSeg p rad) . _wlLine -- . 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 -} -anyCrNearPoint :: Float -> Point2 -> World -> Bool -anyCrNearPoint d p = any (\c -> dist (_crPos c) p < (d + _crRad c)) . _creatures + {- | Produce an unordered list of creatures on a line. -} crsOnLine :: Point2 -> Point2 -> World -> IM.IntMap Creature crsOnLine p1 p2 diff --git a/src/Dodge/Creature/ReaderUpdate.hs b/src/Dodge/Creature/ReaderUpdate.hs index 26ae68e1d..0e1d1e6c3 100644 --- a/src/Dodge/Creature/ReaderUpdate.hs +++ b/src/Dodge/Creature/ReaderUpdate.hs @@ -20,13 +20,14 @@ import Dodge.Creature.Volition import Dodge.Base import Dodge.Zone import Geometry -import FoldableHelp import qualified Data.IntMap.Strict as IM import Control.Lens import Control.Applicative import Data.Maybe import Data.Bifunctor +--import StreamingHelp +import qualified Streaming.Prelude as S overrideMeleeCloseTarget :: Creature -> Creature overrideMeleeCloseTarget cr = maybe cr (tryMeleeAttack cr) (_targetCr $ _crIntention cr) @@ -76,8 +77,7 @@ flockACC w cr = case cr ^? crIntention . targetCr . _Just of isFarACC cr' = _crGroup cr' == _crGroup cr && _crID cr' /= _crID cr && dist (_crPos cr') tpos > dist cpos tpos - nearACCs = IM.filter isFarACC $ creaturesNearPointI 5 cpos w - macr = safeMinimumOn (dist cpos . _crPos) nearACCs + macr = minStreamOn (dist cpos . _crPos) . S.filter isFarACC $ crsInsideCirc cpos 50 w in case macr of Nothing -> cr Just acr -> diff --git a/src/Dodge/Item/Weapon/ExtraEffect.hs b/src/Dodge/Item/Weapon/ExtraEffect.hs index e1ce36a4c..1c4c36ac7 100644 --- a/src/Dodge/Item/Weapon/ExtraEffect.hs +++ b/src/Dodge/Item/Weapon/ExtraEffect.hs @@ -28,7 +28,6 @@ import Picture import Geometry.Vector import Geometry.Data import LensHelp -import qualified FoldlHelp as L import Sound.Data import ShortShow @@ -36,7 +35,7 @@ import qualified Data.Map.Strict as M --import Data.Bifunctor import Data.Maybe --import qualified Control.Foldl as L ---import qualified Data.Set as S +import qualified Streaming.Prelude as S import qualified SDL autoEffect :: (Item -> Creature -> World -> World) -> Int -> SoundID -> Item -> Creature -> World -> World autoEffect eff t sid itm cr w @@ -129,9 +128,9 @@ targetRBCreatureUp it cr w t & tgActive .~ False ) where - newtarg = L.fold - (L.prefilter (canseepos . _crPos) $ L.minimumOn (dist mwp . _crPos)) - $ creaturesNearPointI 3 mwp w + newtarg = minStreamOn (dist mwp . _crPos) + . S.filter (canseepos . _crPos) + $ crsInsideCirc mwp 40 w canseepos p = hasLOS (_crPos cr) p w mwp = mouseWorldPos w updatePos t' = t' & tgPos .~ posFromMaybeID (_tgID t') diff --git a/src/Dodge/WorldEvent/SpawnParticle.hs b/src/Dodge/WorldEvent/SpawnParticle.hs index 0ee2a1340..0195c0994 100644 --- a/src/Dodge/WorldEvent/SpawnParticle.hs +++ b/src/Dodge/WorldEvent/SpawnParticle.hs @@ -25,6 +25,7 @@ import LensHelp import Data.Foldable import Data.Tuple +import StreamingHelp import qualified Streaming.Prelude as S aFlameParticle :: Int -- ^ Timer @@ -240,14 +241,13 @@ 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 - %~ dodamagesto damagedCrs +cloudPoisonDamage c w = w & dodamagesto (S.filter f $ crsNearPoint clpos w) where - dodamagesto :: StreamOf Creature -> IM.IntMap Creature -> IM.IntMap Creature - dodamagesto = undefined - damagedCrs = S.filter f $ crsNearPoint clpos w + dodamagesto :: StreamOf Creature -> World -> World + dodamagesto scrs mcrs = runIdentity $ S.fold_ (flip doDam) mcrs id scrs + doDam cr = creatures . ix (_crID cr) . crState . csDamage + .:~ Damage POISONDAM 1 clpos clpos clpos NoDamageEffect f cr = dist3 (addZ 20 $ _crPos cr) (_clPos c) < _crRad cr + _clRad c + 10 - doDam cr = cr & crState . csDamage .:~ Damage POISONDAM 1 clpos clpos clpos NoDamageEffect clpos = stripZ $ _clPos c incBall :: RandomGen g => Point2 -> State g Particle diff --git a/src/Dodge/Zone.hs b/src/Dodge/Zone.hs index a3b9e0d8a..9c13a599c 100644 --- a/src/Dodge/Zone.hs +++ b/src/Dodge/Zone.hs @@ -4,6 +4,7 @@ module Dodge.Zone , wallsAlongLine , crsNearSeg , wallsInsideCirc + , crsInsideCirc , lookLookups , zoneOfSeg , zoneNearPointIP @@ -15,10 +16,6 @@ module Dodge.Zone , flattenIMIMIM , wlZoneOfPoint , crsNearPoint - , creaturesNearPointI --- , creaturesNearPoint - , creatureNearPoint - , creatureNearPointI , creaturesAlongLine , module Dodge.Zone.Size ) @@ -31,7 +28,7 @@ import Geometry.Zone import qualified FoldlHelp as L import qualified Streaming.Prelude as S -import Streaming +import StreamingHelp import Data.Maybe import qualified Data.IntMap.Strict as IM import Control.Lens @@ -106,6 +103,11 @@ crsNearSeg sp ep w = S.concat $ S.mapMaybe f $ zoneOfSeg crZoneSize sp ep where f (V2 i j) = w ^? creaturesZone . znObjects . ix i . ix j +crsInsideCirc :: Point2 -> Float -> World -> StreamOf Creature +crsInsideCirc p r w = S.concat $ S.mapMaybe f $ zoneInsideCirc crZoneSize p r + where + f (V2 i j) = w ^? creaturesZone . znObjects . ix i . ix j + wallsInsideCirc :: Point2 -> Float -> World -> Stream (Of Wall) Identity () wallsInsideCirc p r w = S.concat $ S.mapMaybe f $ zoneInsideCirc wlZoneSize p r where @@ -130,9 +132,6 @@ crsNearPoint p = S.each . fromMaybe mempty . (^? creaturesZone . znObjects . ix where V2 x y = crZoneOfPoint p -creaturesNearPoint :: Point2 -> World -> IM.IntMap Creature -creaturesNearPoint = creaturesNearPointI 1 - creaturesNearPointI :: Int -> Point2 -> World -> IM.IntMap Creature creaturesNearPointI n p w = IM.unions [f b $ f a $ _znObjects $ _creaturesZone w | a<-[x-n..x+n] , b<-[y-n..y+n]] diff --git a/src/Geometry/Data.hs b/src/Geometry/Data.hs index f17937c65..adbfd63a1 100644 --- a/src/Geometry/Data.hs +++ b/src/Geometry/Data.hs @@ -8,8 +8,6 @@ module Geometry.Data import Linear.V2 import Linear.V3 import Linear.V4 -import Streaming -type StreamOf a = Stream (Of a) Identity () type Int2 = V2 Int type Point2 = V2 Float type Point3 = V3 Float diff --git a/src/StreamingHelp.hs b/src/StreamingHelp.hs new file mode 100644 index 000000000..21307acde --- /dev/null +++ b/src/StreamingHelp.hs @@ -0,0 +1,25 @@ +module StreamingHelp + ( minStreamOn + , sortStreamOn + , StreamOf + , module Streaming + ) where +import Streaming +import qualified Streaming.Prelude as S +import qualified Control.Foldl as L +import Data.Function (on) + +type StreamOf a = Stream (Of a) Identity () + +minStreamOn :: Ord a => (b -> a) -> StreamOf b -> Maybe b +{-# INLINE minStreamOn #-} +minStreamOn f = runIdentity + . L.purely S.fold_ (L.minimumBy (compare `on` f)) + +-- this hopefully also nub the stream in most cases +--orderStreamOn :: Ord b => (a -> b) -> Stream (Of a) Identity () -> Identity (Of (M.Map b a) ()) +sortStreamOn :: Ord a => (b -> a) -> StreamOf b -> 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)