diff --git a/src/Dodge/Base/Collide.hs b/src/Dodge/Base/Collide.hs index df01e24c9..36ffbe8d9 100644 --- a/src/Dodge/Base/Collide.hs +++ b/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 -{-# INLINE collidePointWallsFilt' #-} -collidePointWallsFilt' t p1 p2 = collidePointWalls p1 p2 . IM.filter t +collidePointWallsL :: Point2 -> Point2 -> L.Fold Wall Point2 +collidePointWallsL p1 p2 = L.Fold findPoint p2 id + 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. diff --git a/src/Dodge/Update/Camera.hs b/src/Dodge/Update/Camera.hs index d472e294f..3b88153ef 100644 --- a/src/Dodge/Update/Camera.hs +++ b/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 diff --git a/src/Dodge/WorldEvent/Explosion.hs b/src/Dodge/WorldEvent/Explosion.hs index ae38ae931..8c98a13ab 100644 --- a/src/Dodge/WorldEvent/Explosion.hs +++ b/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 diff --git a/src/Dodge/WorldEvent/SpawnParticle.hs b/src/Dodge/WorldEvent/SpawnParticle.hs index 24521e396..d2404c009 100644 --- a/src/Dodge/WorldEvent/SpawnParticle.hs +++ b/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 - damwls w' = foldr (\wl -> fst . hiteff [(p,Right wl)]) w' $ IM.filter wlt $ wallsNearPoint p w + 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' $ 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 diff --git a/src/Dodge/Zone.hs b/src/Dodge/Zone.hs index 2de0c461e..079ef8c8f 100644 --- a/src/Dodge/Zone.hs +++ b/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 diff --git a/src/Geometry/Zone.hs b/src/Geometry/Zone.hs index 1299d1185..b99a47f62 100644 --- a/src/Geometry/Zone.hs +++ b/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