Refactor path zoning

src/Dodge/Data.hs

@@ -236,8 +236,10 @@ data World = World
     , _corpses          :: IM.IntMap Corpse
     , _clickMousePos    :: Point2
     , _pathGraph        :: Gr Point2 PathEdge
-    , _pnZoning         :: Zoning [] (Int,Point2)
+    --, _pnZoning         :: Zoning [] (Int,Point2)
-    , _peZoning         :: Zoning [] (Int,Int,PathEdge)
+    --, _peZoning         :: Zoning [] (Int,Int,PathEdge)
+    , _pnZoning         :: IM.IntMap (IM.IntMap [(Int,Point2)]) --Zoning IM.IntMap Creature
+    , _peZoning         :: IM.IntMap (IM.IntMap [(Int,Int,PathEdge)]) --Zoning IM.IntMap Creature
     , _hud              :: HUD
     , _lightSources     :: IM.IntMap LightSource
     , _tempLightSources :: [TempLightSource]

src/Dodge/Default/World.hs

@@ -1,9 +1,5 @@
 module Dodge.Default.World where
 import Dodge.Data
-import Dodge.Zone.Size
-import Dodge.Zone.Object
---import Geometry.Vector3D
-import Geometry.Zone
 import Geometry.Data
 import Geometry.Polygon
 
@@ -76,8 +72,8 @@ defaultWorld = World
     , _clickMousePos = V2 0 0
     , _pathGraph = Data.Graph.Inductive.Graph.empty
 --    , _pathGraphP   = mempty
-    , _pnZoning     = Zoning mempty peZoneSize (zonePos snd)
+    , _pnZoning     = mempty
-    , _peZoning     = Zoning mempty peZoneSize (\x (_,_,e) -> zoneOfSeg x (_peStart e) (_peEnd e))
+    , _peZoning     = mempty
     , _hud = HUD
         { _hudElement = DisplayInventory NoSubInventory
         , _carteCenter = V2 0 0

src/Dodge/Layout.hs

@@ -2,10 +2,10 @@
 module Dodge.Layout 
     ( generateLevelFromRoomList
     ) where
+import Dodge.Zoning.Pathing
 import Data.Tile
 import Dodge.Data
 import Dodge.Path
-import Dodge.Zone.Update
 import Dodge.ShiftPoint
 import Dodge.Placement.PlaceSpot
 --import Dodge.LevelGen.Data
@@ -45,10 +45,8 @@ generateLevelFromRoomList gr' w = initWallZoning
         , _gameRooms    = gameRoomsFromRooms (IM.elems rs')
         , _pathGraph    = path
         }
-        & pnZoning   %~ (\zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
+        & pnZoning   .~ foldl' (flip $ zonePn) mempty (labNodes path)
-            (labNodes path))
+        & peZoning   .~ foldl' (flip $ zonePe) mempty (labEdges path)
-        & peZoning   %~ (\zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
-            (labEdges path))
   where
     (_,path) = pairsToGraph pairPath'
     pairPath = foldMap _rmPath rs

src/Dodge/Path.hs

@@ -11,9 +11,10 @@ module Dodge.Path
     , bfsNodePoints
     , fusePairs
     ) where
+import Dodge.Zoning.Pathing
+import Dodge.Zoning.Base
 import Dodge.Data
 import Dodge.Base.Collide
-import Dodge.Zone
 import Geometry.Data
 import Geometry
 
@@ -52,7 +53,7 @@ walkableNodeNear :: World -> Point2 -> Maybe Int
 walkableNodeNear w p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear
   where
     --nodesNear = runIdentity . S.toList_ $ nearPoint _pnZoning p w
-    nodesNear = runIdentity . S.toList_ $ aroundPoint _pnZoning p w
+    nodesNear = zonesExtract (w ^. pnZoning) $ zonesAroundPoint pnZoneSize p
 
 makePathBetweenPs :: Point2 -> Point2 -> World -> Maybe [Point2]
 makePathBetweenPs a b w = mapMaybe (lab $ _pathGraph w) <$> makePathBetween a b w
@@ -137,12 +138,12 @@ addEdges nodemap gr = runIdentity . S.fold_ f (mempty,gr) id
 obstructPathsCrossing :: EdgeObstacle -> Point2 -> Point2 -> World -> ( World, [(Int,Int,PathEdge)])
 obstructPathsCrossing obstacletype sp' ep w = 
     ( w & pathGraph %~ updateedges
-    , runIdentity $ S.toList_ es
+    , es
     )
   where
-    es = S.filter edgecrosses $ nearSeg _peZoning sp' ep w
+    es = filter edgecrosses $ pesNearSeg sp' ep w
     edgecrosses (_,_,pe) = isJust $ intersectSegSeg sp' ep (_peStart pe) (_peEnd pe)
-    updateedges gr = runIdentity $ S.fold_ updateedge gr id es
+    updateedges gr = foldl' updateedge gr es
     updateedge gr (x,y,pe) 
         = insEdge (x,y,pe & peObstacles . at obstacletype ?~ ()) $ delEdge (x,y) gr
 

src/Dodge/Render/ShapePicture.hs

@@ -1,7 +1,7 @@
 module Dodge.Render.ShapePicture
     ( worldSPic
     ) where
-import Dodge.Zoning.Wall
+import Dodge.Zoning
 import Dodge.Button.Draw
 import Dodge.LightSource.Draw
 import Dodge.Targeting.Draw

src/Dodge/Zone/Size.hs

@@ -1,10 +1,10 @@
 module Dodge.Zone.Size where
 
-pnZoneSize :: Float
+--pnZoneSize :: Float
-pnZoneSize = 100
+--pnZoneSize = 100
 
 clZoneSize :: Float
 clZoneSize = 20
 
-peZoneSize :: Float
+--peZoneSize :: Float
-peZoneSize = 50
+--peZoneSize = 50

src/Dodge/Zoning.hs

@@ -1,7 +1,9 @@
 module Dodge.Zoning 
     ( module Dodge.Zoning.Creature
     , module Dodge.Zoning.Wall
+    , module Dodge.Zoning.Pathing
     ) where
 import Dodge.Zoning.Creature
 import Dodge.Zoning.Wall
+import Dodge.Zoning.Pathing
 

src/Dodge/Zoning/Base.hs

@@ -65,6 +65,11 @@ zoneMonoid (V2 x y) a = IM.insertWith f x $ IM.singleton 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
+zoneOfPoint'' :: Float -> Point2 -> Int2
 {-# INLINE zoneOfPoint'' #-}
 zoneOfPoint'' s = fmap (divTo s)
+
+zonesAroundPoint :: Float -> Point2 -> [Int2]
+zonesAroundPoint s p = [V2 a b | a <- [x-1..x+1] , b <- [y-1..y+1] ]
+  where
+    V2 x y = zoneOfPoint' s p

src/Dodge/Zoning/Cloud.hs

@@ -5,7 +5,7 @@ import Dodge.Zoning.Base
 import Dodge.Data
 import Geometry
 
-import Data.Foldable
+--import Data.Foldable
 import Control.Lens
 import qualified IntMapHelp as IM
 

src/Dodge/Zoning/Pathing.hs

@@ -0,0 +1,56 @@
+module Dodge.Zoning.Pathing
+    where
+import Geometry.Vector
+import Dodge.Zoning.Base
+import Dodge.Data
+import Geometry
+
+import Data.Foldable
+import Control.Lens
+import qualified IntMapHelp as IM
+
+pnsNearPoint :: Point2 -> World -> [(Int,Point2)]
+pnsNearPoint p w = zoneExtract (zoneOfPoint' pnZoneSize p) (w ^. pnZoning)
+
+pnsNearSeg :: Point2 -> Point2 -> World -> [(Int,Point2)]
+pnsNearSeg sp ep w = zonesExtract (w ^. pnZoning) (zoneOfSeg' pnZoneSize sp ep)
+
+pnsNearRect :: Point2 -> Point2 -> World -> [(Int,Point2)]
+pnsNearRect sp ep w = zonesExtract (w ^. pnZoning) $ zoneOfRect' pnZoneSize sp ep
+
+pnsNearCirc :: Point2 -> Float -> World -> [(Int,Point2)]
+pnsNearCirc p r = pnsNearRect (p +.+ V2 r r) (p -.- V2 r r)
+
+pnZoneSize :: Float
+pnZoneSize = 50
+
+zoneOfPn :: (Int,Point2) -> Int2
+zoneOfPn = zoneOfPoint'' pnZoneSize . snd
+
+zonePn :: (Int,Point2) -> IM.IntMap (IM.IntMap [(Int,Point2)]) -> IM.IntMap (IM.IntMap [(Int,Point2)])
+zonePn pn = zoneMonoid (zoneOfPn pn) [pn]
+
+
+
+pesNearPoint :: Point2 -> World -> [(Int,Int,PathEdge)]
+pesNearPoint p w = zoneExtract (zoneOfPoint' peZoneSize p) (w ^. peZoning)
+
+pesNearSeg :: Point2 -> Point2 -> World -> [(Int,Int,PathEdge)]
+pesNearSeg sp ep w = zonesExtract (w ^. peZoning) (zoneOfSeg' peZoneSize sp ep)
+
+pesNearRect :: Point2 -> Point2 -> World -> [(Int,Int,PathEdge)]
+pesNearRect sp ep w = zonesExtract (w ^. peZoning) $ zoneOfRect' peZoneSize sp ep
+
+pesNearCirc :: Point2 -> Float -> World -> [(Int,Int,PathEdge)]
+pesNearCirc p r = pesNearRect (p +.+ V2 r r) (p -.- V2 r r)
+
+peZoneSize :: Float
+peZoneSize = 50
+
+zoneOfPe :: (Int,Int,PathEdge) -> [Int2]
+zoneOfPe (_,_,pe) = zoneOfSeg' peZoneSize (_peStart pe) (_peEnd pe)
+
+zonePe :: (Int,Int,PathEdge) -> IM.IntMap (IM.IntMap [(Int,Int,PathEdge)]) -> IM.IntMap (IM.IntMap [(Int,Int,PathEdge)])
+zonePe pe im = foldl' f im (zoneOfPe pe)
+  where
+    f im' i2 = zoneMonoid i2 [pe] im'