Refactor cloud zoning

src/Dodge/Data.hs

@@ -191,10 +191,10 @@ data World = World
     , _creatureGroups   :: IM.IntMap CrGroupParams
     , _itemPositions    :: IM.IntMap ItemPos
     , _clouds           :: [Cloud]
-    , _clZoning         :: Zoning [] Cloud
+    --, _clZoning         :: Zoning [] Cloud
+    , _clZoning         :: IM.IntMap (IM.IntMap [Cloud]) --Zoning IM.IntMap Creature
     , _gusts            :: IM.IntMap Gust
     , _gsZoning         :: IM.IntMap (IM.IntMap IS.IntSet)
-    --, _gsZoning         :: Zoning IM.IntMap Gust
     , _props            :: IM.IntMap Prop
     , _projectiles      :: IM.IntMap Proj
     , _instantBullets   :: [Bullet]

src/Dodge/Default/World.hs

@@ -2,7 +2,7 @@ module Dodge.Default.World where
 import Dodge.Data
 import Dodge.Zone.Size
 import Dodge.Zone.Object
-import Geometry.Vector3D
+--import Geometry.Vector3D
 import Geometry.Zone
 import Geometry.Data
 import Geometry.Polygon
@@ -30,7 +30,7 @@ defaultWorld = World
     , _crZoning         = mempty --Zoning IM.empty crZoneSize zoneOfCreature
     , _creatureGroups   = IM.empty
     , _clouds           = mempty
-    , _clZoning         = Zoning IM.empty clZoneSize (zonePos (stripZ . _clPos))
+    , _clZoning         = mempty
     , _gusts            = IM.empty
     , _gsZoning         = mempty --Zoning IM.empty clZoneSize (zonePos _guPos)
     , _itemPositions    = IM.empty

src/Dodge/Update.hs

@@ -4,6 +4,7 @@ Module      : Dodge.Update
 Description : Simulation update
 -}
 module Dodge.Update ( updateUniverse ) where
+import Dodge.Zoning.Cloud
 import Dodge.Zoning.Creature
 import Dodge.WorldEffect
 import Dodge.Data
@@ -27,7 +28,7 @@ import Dodge.Distortion
 import Dodge.SoundLogic
 import Dodge.Update.WallDamage
 import Dodge.Base
-import Dodge.Zone
+--import Dodge.Zone
 import Dodge.Hammer
 import Dodge.WallCreatureCollisions
 import Dodge.Update.Camera
@@ -42,7 +43,7 @@ import Data.Maybe
 import qualified IntMapHelp as IM
 import qualified Data.Map.Strict as M
 import Control.Applicative
-import qualified Streaming.Prelude as S
+--import qualified Streaming.Prelude as S
 import SDL
 
 {- For most menus the only way to change the world is using event handling.  -}
@@ -116,9 +117,9 @@ doWorldEvents w = foldr doWorldEffect (w & worldEvents .~ []) (_worldEvents w)
 
 zoneClouds :: World -> World
 zoneClouds w = w 
-    & clZoning . znObjects .~ mempty
+    & clZoning .~ mempty
     & clZoning %~ \zn ->
-        foldl' (flip $ updateZoning (:)) zn (_clouds w)
+        foldl' (flip zoneCloud) zn (_clouds w)
     --runIdentity (S.fold_ (flip $ updateZoning (:)) (zn & znObjects .~ mempty) id (_clouds w))
 
 updateWorldSelect :: World -> World
@@ -407,7 +408,7 @@ updateCloud w c
     newVel@(V3 _ _ nvz) = (0.95 *.*.* springVels) +.+.+ V3 0 0 (0.001 * vertVel)
     newVel2 = stripZ newVel
     vertVel = _clAlt c - opz
-    springVels = runIdentity $ S.fold_ (clClSpringVel c) (_clVel c) id (clsNearPoint oldPos2 w)
+    springVels = foldl' (clClSpringVel c) (_clVel c) (clsNearPoint oldPos2 w)
     oldPos@(V3 _ _ opz) = _clPos c
     oldPos2 = stripZ oldPos
     newPos@(V3 _ _ npz) = oldPos +.+.+ newVel

src/Dodge/Zone.hs

@@ -6,12 +6,12 @@ module Dodge.Zone
     , nearSeg
     --, wlsNearPoint
     --, crsNearPoint
-    , clsNearPoint
+    --, clsNearPoint
     --, wlsNearSeg
     --, crsNearSeg
     --, wlsInsideCirc
     --, crsInsideCirc
-    , clZoneOfPoint
+    --, clZoneOfPoint
     --, crZoneOfPoint
     , wlZoneOfPoint
     , module Dodge.Zone.Size
@@ -74,9 +74,9 @@ aroundPoint f p w = streamFromZone zn $ zoneAroundPoint (_znSize zn) p
   where
     zn = f w
 
-clsNearPoint :: Point2 -> World -> StreamOf Cloud
+--clsNearPoint :: Point2 -> World -> StreamOf Cloud
-{-# INLINE clsNearPoint #-}
+--{-# INLINE clsNearPoint #-}
-clsNearPoint = nearPoint _clZoning
+--clsNearPoint = nearPoint _clZoning
 
 --wlsNearPoint :: Point2 -> World -> StreamOf Wall
 --{-# INLINE wlsNearPoint #-}
@@ -121,9 +121,9 @@ wlZoneOfPoint = zoneOfPoint wlZoneSize
 wlZoneSize :: Float
 wlZoneSize = 50
 
-clZoneOfPoint :: Point2 -> Int2
+--clZoneOfPoint :: Point2 -> Int2
-{-# INLINE clZoneOfPoint #-}
+--{-# INLINE clZoneOfPoint #-}
-clZoneOfPoint = zoneOfPoint clZoneSize
+--clZoneOfPoint = zoneOfPoint clZoneSize
 
 --crZoneOfPoint :: Point2 -> Int2
 --{-# INLINE crZoneOfPoint #-}

src/Dodge/Zoning/Base.hs

@@ -3,6 +3,7 @@ import Geometry
 import Geometry.Zone
 import qualified IntMapHelp as IM
 
+import qualified Data.IntSet as IS
 import Control.Lens
 import Data.Maybe
 
@@ -60,3 +61,10 @@ zoneMonoid :: Semigroup m => Int2 -> m -> IM.IntMap (IM.IntMap m) -> IM.IntMap (
 zoneMonoid (V2 x y) a = IM.insertWith f x $ IM.singleton y a
   where
     f _ = IM.insertWith (<>) y a
+
+deZoneIX :: Int -> IM.IntMap (IM.IntMap IS.IntSet) -> Int2 ->  IM.IntMap (IM.IntMap IS.IntSet)
+deZoneIX i im (V2 x y) = im & ix x . ix y %~ IS.delete i
+
+zoneOfPoint'' :: Float -> Point2 -> V2 Int
+{-# INLINE zoneOfPoint'' #-}
+zoneOfPoint'' s = fmap (divTo s)

src/Dodge/Zoning/Cloud.hs

@@ -0,0 +1,31 @@
+module Dodge.Zoning.Cloud
+    where
+import Geometry.Vector
+import Dodge.Zoning.Base
+import Dodge.Data
+import Geometry
+
+import Data.Foldable
+import Control.Lens
+import qualified IntMapHelp as IM
+
+clsNearPoint :: Point2 -> World -> [Cloud]
+clsNearPoint p w = zoneExtract (zoneOfPoint' clZoneSize p) (w ^. clZoning)
+
+clsNearSeg :: Point2 -> Point2 -> World -> [Cloud]
+clsNearSeg sp ep w = zonesExtract (w ^. clZoning) (zoneOfSeg' clZoneSize sp ep)
+
+clsNearRect :: Point2 -> Point2 -> World -> [Cloud]
+clsNearRect sp ep w = zonesExtract (w ^. clZoning) $ zoneOfRect' clZoneSize sp ep
+
+clsNearCirc :: Point2 -> Float -> World -> [Cloud]
+clsNearCirc p r = clsNearRect (p +.+ V2 r r) (p -.- V2 r r)
+
+clZoneSize :: Float
+clZoneSize = 20
+
+zoneOfCl :: Cloud -> Int2
+zoneOfCl = zoneOfPoint'' clZoneSize . xyV3 . _clPos
+
+zoneCloud :: Cloud -> IM.IntMap (IM.IntMap [Cloud]) -> IM.IntMap (IM.IntMap [Cloud])
+zoneCloud cl = zoneMonoid (zoneOfCl cl) [cl]

src/Dodge/Zoning/Wall.hs

@@ -56,6 +56,3 @@ zoneWall wl im = foldl' f im (zoneOfWl wl)
 
 deZoneWall :: Wall -> IM.IntMap (IM.IntMap IS.IntSet) -> IM.IntMap (IM.IntMap IS.IntSet)
 deZoneWall wl im = foldl' (deZoneIX (_wlID wl)) im (zoneOfWl wl)
-
-deZoneIX :: Int -> IM.IntMap (IM.IntMap IS.IntSet) -> Int2 ->  IM.IntMap (IM.IntMap IS.IntSet)
-deZoneIX i im (V2 x y) = im & ix x . ix y %~ IS.delete i