diff --git a/src/Dodge/Base/Collide.hs b/src/Dodge/Base/Collide.hs index c59205130..419e51421 100644 --- a/src/Dodge/Base/Collide.hs +++ b/src/Dodge/Base/Collide.hs @@ -18,6 +18,7 @@ module Dodge.Base.Collide , wallsOnCirc , wallsOnCirc' , wallsOnLineHit + , collideCircWallsStream , collideCircWalls , collideCircWallsList -- , collideCircWalls' @@ -320,6 +321,21 @@ overlapCircWalls p r = S.mapMaybe dointersect dointersect wl = f (_wlLine wl) <&> (,wl) f (a,b) = intersectSegSeg p (p -.- r *.* vNormal (normalizeV (a -.- b))) a b +collideCircWallsStream :: Point2 -> Point2 -> Float -> Stream (Of Wall) Identity () + -> (Point2, Maybe Wall) +collideCircWallsStream sp ep rad = runIdentity + . S.fold_ findPoint (ep, Nothing) id + where + findPoint (p,mwl) wl = maybe (p,mwl) (,Just wl) . uncurry (intersectSegSeg sp p) + . shiftbyrad + . _wlLine $ wl + shiftbyrad (a,b) = bimap f f + (a +.+ rad *.* normalizeV (a -.-b) + ,b +.+ rad *.* normalizeV (b -.-a) + ) + where + 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))) diff --git a/src/Dodge/Item/Weapon/Launcher.hs b/src/Dodge/Item/Weapon/Launcher.hs index 11c4e6e72..956c7a2a0 100644 --- a/src/Dodge/Item/Weapon/Launcher.hs +++ b/src/Dodge/Item/Weapon/Launcher.hs @@ -33,7 +33,6 @@ import qualified Data.Map.Strict as M import qualified SDL import Data.Maybe import Control.Lens -import Control.Applicative launcher :: Item launcher = defaultWeapon @@ -333,10 +332,10 @@ moveRemoteShell cid itid pj w doExplosion = explodeRemoteRocket itid i $ stopSoundFrom (ShellSound i) w anythingHitCirc :: Float -> Point2 -> Point2 -> World -> Bool -anythingHitCirc rad sp ep w = isJust $ hitCr <|> hitWl +anythingHitCirc rad sp ep w = isJust hitCr || isJust (sequence hitWl) where - hitCr = fst <$> collideCircCrsPoint sp ep rad (_creatures w) - hitWl = fst <$> collideCircWallsList sp ep rad (wallsNearPoint' ep w) + hitCr = collideCircCrsPoint sp ep rad (_creatures w) + hitWl = collideCircWallsStream sp ep rad $ wallsNearPoint ep w -- this should probably be wallsOnLine or something explodeRemoteRocket diff --git a/src/Dodge/WorldEvent/SpawnParticle.hs b/src/Dodge/WorldEvent/SpawnParticle.hs index b38dd8582..618771a97 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 qualified Streaming.Prelude as S aFlameParticle :: Int -- ^ Timer -> Point2 -- ^ Position @@ -206,7 +207,13 @@ 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' $ filter wlt $ wallsNearPoint' p w + damwls w' = runIdentity + . S.fold_ + (flip $ \wl -> fst . hiteff [(p,Right wl)]) + w' + id + . S.filter wlt + $ wallsNearPoint p w' hiteff = _ptHitEff pt pt -- | At writing the radius is half the size of the effect area diff --git a/src/Dodge/Zone.hs b/src/Dodge/Zone.hs index 9eb94655f..e2593455f 100644 --- a/src/Dodge/Zone.hs +++ b/src/Dodge/Zone.hs @@ -93,6 +93,7 @@ zoneOfLineIntMap :: Point2 -> Point2 -> IM.IntMap IS.IntSet --zoneOfLineIntMap = ddaExt zoneSize zoneOfLineIntMap = ddaSq zoneSize +zoneOfCirc :: Monad m => Point2 -> Float -> Stream (Of (V2 Int)) m () zoneOfCirc p = S.map (uncurry V2) . S.each . zoneOfCircle p zoneOfCircle :: Point2 -> Float -> [(Int,Int)] @@ -164,21 +165,7 @@ cloudsNearPoint p w = f (IM.lookup x (_znObjects $ _cloudsZone w) >>= IM.lookup f Nothing = [] f (Just l) = l --- possible BUG, was associated with thingsHitLongLine --- assumes _wallsZone is correct level generation --- there is certainly a problem somewhere here: it may be in the zoning, or --- within this function ---wallsAlongLine :: Point2 -> Point2 -> World -> IM.IntMap Wall -----{-# INLINE wallsAlongLine #-} ---wallsAlongLine a b w = --- IM.foldlWithKey' g IM.empty kps --- where --- g m x s = IM.union (IM.unions (IM.restrictKeys (f x $ _znObjects $ _wallsZone w) s)) m --- kps = zoneOfLineIntMap a b --- f i m = case IM.lookup i m of --- Just val -> val --- _ -> IM.empty - +-- TODO check whether/when nubbing of walls is necessary wallsAlongLine :: Point2 -> Point2 -> World -> Stream (Of Wall) Identity () wallsAlongLine sp ep w = S.concat $ S.mapMaybe f $ zoneOfLineStream sp ep where