Make zoning more universal

src/Dodge/Base.hs

@@ -15,7 +15,6 @@ module Dodge.Base
     , module Dodge.Base.CardinalPoint
     , module Dodge.Base.Wall
     ) where
-import Dodge.Data
 import Dodge.Base.WinScale
 import Dodge.Base.Wall
 import Dodge.Base.Arithmetic
@@ -37,11 +36,6 @@ import Control.Lens
 --import qualified Data.IntSet as IS
 --import qualified Data.Set as S
 
-
-allWalls :: World -> IM.IntMap Wall
-allWalls = IM.unions . concatMap IM.elems . IM.elems . _znObjects . _wallsZone
-
-
 {- | Expands a line out to a given thickness. -}
 lineGeom :: Float -> Point2 -> Point2 -> [Point2]
 lineGeom t x y

src/Dodge/Block.hs

@@ -30,7 +30,7 @@ unshadowBlock :: Int -> World -> World
 unshadowBlock wlid w = case w ^? walls . ix wlid of
     Just wl -> w
         & walls . ix wlid . wlDraw .~ True
-        & wallsZone . znObjects . ix x . ix y . ix wlid . wlDraw .~ True
+        & wlZoning . znObjects . ix x . ix y . ix wlid . wlDraw .~ True
       where
         V2 x y = wlZoneOfPoint $ uncurry midPoint (_wlLine wl)
     Nothing -> w

src/Dodge/Data.hs

@@ -14,6 +14,7 @@ module Dodge.Data
     , module Dodge.Data.LoadAction
     , module Dodge.Data.ForegroundShape
     , module Dodge.Data.Wall
+    , module Dodge.Data.Zoning
     , module Dodge.Data.Bounds
     , module Dodge.Combine.Data
     , module Dodge.Distortion.Data
@@ -33,6 +34,7 @@ module Dodge.Data
     , module Dodge.Data.Room
     ) where
 import Dodge.Data.Room
+import Dodge.Data.Zoning
 import Dodge.Data.ForegroundShape
 import Dodge.Data.LoadAction
 import Dodge.Data.Material
@@ -104,13 +106,13 @@ data World = World
     , _boundBox             :: [Point2]
     , _boundDist            :: (Float,Float,Float,Float) -- NSEW, S and W negative
     , _creatures            :: IM.IntMap Creature
-    , _creaturesZone        :: Zoning (IM.IntMap Creature)
+    , _crZoning             :: Zoning IM.IntMap Creature
     , _creatureGroups       :: IM.IntMap CrGroupParams
     , _itemPositions        :: IM.IntMap ItemPos
     , _clouds               :: [Cloud]
-    , _cloudsZone           :: Zoning [Cloud]
+    , _clZoning             :: Zoning [] Cloud
     , _gusts                :: IM.IntMap Gust
-    , _gustsZone            :: Zoning (IM.IntMap Gust)
+    , _gsZoning             :: Zoning IM.IntMap Gust
     , _props                :: IM.IntMap Prop
     , _instantParticles     :: [Particle]
     , _particles            :: [Particle]
@@ -125,7 +127,7 @@ data World = World
     , _blocks               :: IM.IntMap Block
     , _coordinates          :: IM.IntMap Point2
     , _triggers             :: IM.IntMap (World -> Bool)
-    , _wallsZone            :: Zoning (IM.IntMap Wall)
+    , _wlZoning             :: Zoning IM.IntMap Wall
     , _floorItems           :: IM.IntMap FloorItem
     , _floorTiles           :: [(Point3,Point3)]
     , _randGen              :: StdGen
@@ -145,7 +147,7 @@ data World = World
     , _clickMousePos        :: Point2
     , _pathGraph            :: Gr Point2 Float
     , _pathGraphP           :: S.Set (Point2,Point2)
-    , _pathPoints           :: Zoning [(Int,Point2)]
+    , _phZoning             :: Zoning [] (Int,Point2)
     , _hud                  :: HUD
     , _lightSources         :: IM.IntMap LightSource
     , _tempLightSources     :: [TempLightSource]
@@ -1327,9 +1329,6 @@ data Goal
     | SentinelAt Point2 Float
   deriving (Show)
 
-newtype Zoning a = Zoning
-    { _znObjects :: IM.IntMap (IM.IntMap a)
-    }
 data DamageEffect
     = PushDamage 
         { _dePush :: Float 
@@ -1515,7 +1514,6 @@ makeLenses ''Block
 makeLenses ''Terminal
 makeLenses ''Machine
 makeLenses ''MachineType
-makeLenses ''Zoning
 makeLenses ''ItemDimension
 makeLenses ''Vocalization
 makeLenses ''Universe

src/Dodge/Data/Zoning.hs

@@ -0,0 +1,15 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE StrictData #-}
+module Dodge.Data.Zoning where
+import Geometry.Data
+import Control.Lens
+import qualified Data.IntMap.Strict as IM
+import StreamingHelp
+
+data Zoning t a = Zoning
+    { _znObjects    :: IM.IntMap (IM.IntMap (t a))
+    , _znSize       :: Float
+    , _znFunc       :: Float -> a -> StreamOf Int2
+    }
+
+makeLenses ''Zoning

src/Dodge/Default/World.hs

@@ -1,6 +1,9 @@
 module Dodge.Default.World where
 import Dodge.Data
+import Dodge.Zone.Size
+import Dodge.Zone.Object
 import Dodge.Base
+import Geometry.Vector3D
 --import Dodge.Config.KeyConfig
 --import Dodge.Menu
 --import Picture
@@ -28,14 +31,14 @@ defaultWorld = World
     , _defaultZoom = 1
     , _cameraViewFrom = V2 0 0
     , _viewDistance = 1000
-    , _modifications = IM.empty
+    , _modifications    = IM.empty
-    , _creatures = IM.empty
+    , _creatures        = IM.empty
-    , _creaturesZone = Zoning IM.empty
+    , _crZoning         = Zoning IM.empty crZoneSize zoneOfCreature
-    , _creatureGroups = IM.empty
+    , _creatureGroups   = IM.empty
     , _clouds = []
-    , _cloudsZone = Zoning IM.empty
+    , _clZoning         = Zoning IM.empty clZoneSize (zonePos (stripZ . _clPos))
     , _gusts = IM.empty
-    , _gustsZone = Zoning IM.empty
+    , _gsZoning         = Zoning IM.empty clZoneSize (zonePos _guPos)
     , _itemPositions = IM.empty
     , _props = IM.empty
     , _instantParticles = []
@@ -50,7 +53,7 @@ defaultWorld = World
     , _doors = IM.empty
     , _coordinates  = IM.empty
     , _triggers     = IM.empty
-    , _wallsZone = Zoning IM.empty
+    , _wlZoning     = Zoning IM.empty wlZoneSize zoneOfWall
     , _floorItems = IM.empty
     , _floorTiles = []
     , _randGen = mkStdGen 2
@@ -70,8 +73,8 @@ defaultWorld = World
 --    , _menuLayers = []
     , _clickMousePos = V2 0 0
     , _pathGraph = Data.Graph.Inductive.Graph.empty
-    , _pathGraphP = mempty
+    , _pathGraphP   = mempty
-    , _pathPoints = Zoning IM.empty
+    , _phZoning     = Zoning mempty wlZoneSize (zonePos snd)
     , _hud = HUD
         { _hudElement = DisplayInventory NoSubInventory
         , _carteCenter = V2 0 0

src/Dodge/Layout.hs

@@ -140,7 +140,7 @@ setupWorldBounds w = w & worldBounds %~
 --polyhedrasToEdges = concatMap tflat4 . concatMap polyToEdges
 
 initWallZoning :: World -> World
-initWallZoning w = foldl' (flip insertWallInZones) (w & wallsZone . znObjects .~ IM.empty) (_walls w)
+initWallZoning w = foldl' (flip insertWallInZones) (w & wlZoning . znObjects .~ IM.empty) (_walls w)
 
 --makePath :: Tree Room -> [(Point2,Point2)]
 --makePath = concatMap _rmPath . flatten

src/Dodge/Path.hs

@@ -28,7 +28,7 @@ makePathBetween a b w = do -- join $ sp <$> a' <*> b' <*> return (_pathGraph w)
     sp na nb (_pathGraph w)
   where
     --nodesNear p = concat $ lookLookups (zoneNearPointIP p) (_pathPoints w)
-    nodesNear p = runIdentity . S.toList_ $ nearPoint wlZoneSize _pathPoints p w
+    nodesNear p = runIdentity . S.toList_ $ nearPoint _phZoning p w
     walkableNodeNear p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear p
 
 --walkableNodeNear :: Point2 -> World -> Maybe Point2
@@ -93,7 +93,8 @@ removePathsCrossing :: Point2 -> Point2 -> World -> World
 removePathsCrossing a b w = w
     & pathGraph  .~ newGraph 
     & pathGraphP .~ pg'
-    & pathPoints .~ foldl' insertpoint (Zoning mempty) (labNodes newGraph)
+    & phZoning   %~ \zn -> foldl' (flip $ insertInZoning (:)) (zn & znObjects .~ mempty)
+        (labNodes newGraph)
   where 
     pg' = Set.filter (isNothing . uncurry (intersectSegSeg a b)) $ _pathGraphP w
     insertpoint zn (i,p) = insertInZoneWith (wlZoneOfPoint p) (++) [(i,p)] zn

src/Dodge/Placement/PlaceSpot/Block.hs

@@ -24,7 +24,7 @@ addBlock
     -> World 
     -> World
 addBlock (p:ps) wl bl w = w
-    & wallsZone . znObjects %~ flip (IM.foldl' $ flip wallInZone) panes
+    & wlZoning . znObjects %~ flip (IM.foldl' $ flip wallInZone) panes
     & walls  %~ IM.union panes
     & blocks %~ IM.insert blid bl 
         {_blID = blid,_blWallIDs = IS.fromList is, _blShadows=[]

src/Dodge/Render/ShapePicture.hs

@@ -108,7 +108,7 @@ drawInspectWall :: World -> Wall -> Picture
 drawInspectWall _ wl = setLayer DebugLayer $ 
         color rose (thickLine 3 [a,b])
     <> foldMap (drawZone wlZoneSize)
-        (runIdentity $ S.toList_ $ zoneOfWall wl)
+        (runIdentity $ S.toList_ $ zoneOfWall wlZoneSize wl)  -- this won't work if wlZoneSize is not consistent
   where
     (a,b) = _wlLine wl 
 --    $ line [a,b]

src/Dodge/Render/Walls.hs

@@ -26,7 +26,7 @@ wallsToDraw w
         <*> L.prefilter wlSeeThroughDraw (L.premap f L.list)
         <*> L.premap getWallSPic L.mconcat
         ) (S.concat $ S.mapMaybe g $ zoneOfSight wlZoneSize w)
-    g (V2 i j) = w ^? wallsZone . znObjects . ix i . ix j
+    g (V2 i j) = w ^? wlZoning . znObjects . ix i . ix j
     
 wlOpaqueDraw :: Wall -> Bool
 wlOpaqueDraw wl = wlIsOpaque wl && _wlDraw wl

src/Dodge/Update.hs

@@ -97,11 +97,12 @@ functionalUpdate cfig w = checkEndGame
     $ updateCloseObjects w
 
 zoneClouds :: World -> World
-zoneClouds w = w & set cloudsZone (foldl' (flip cloudInZone) (Zoning mempty) (_clouds w))
+zoneClouds w = w & clZoning %~ \zn ->
-  where
+    foldl' (flip $ insertInZoning (:)) (zn & znObjects .~ mempty) (_clouds w)
-    cloudInZone cl = insertInZoneWith p (++) [cl]
+--  where
-      where 
+--    cloudInZone cl = insertInZoneWith p (++) [cl]
-        p = clZoneOfPoint $ stripZ $ _clPos cl
+--      where 
+--        p = clZoneOfPoint $ stripZ $ _clPos cl
 
 updateWorldSelect :: World -> World
 updateWorldSelect w = case w ^? mouseButtons . ix ButtonLeft of
@@ -148,17 +149,19 @@ doRewind w = case _maybeWorld w of
     Nothing' -> w  & timeFlow .~ NormalTimeFlow
 
 zoneCreatures :: World -> World
-zoneCreatures w = w 
+zoneCreatures w = w & crZoning %~ \zn ->
-    & creaturesZone . znObjects .~
+    foldl' (flip $ insertInZoning (\cr -> IM.insert (_crID cr) cr)) 
-        IM.foldl' zoneCreature IM.empty (_creatures w)
+        (zn & znObjects .~ mempty) (_creatures w)
---        runIdentity (S.fold_ zoneCreature IM.empty id (S.each $ _creatures w))
+--        . znObjects .~
-
+--        IM.foldl' zoneCreature IM.empty (_creatures w)
-zoneCreature :: IM.IntMap (IM.IntMap (IM.IntMap Creature)) 
+----        runIdentity (S.fold_ zoneCreature IM.empty id (S.each $ _creatures w))
-    -> Creature
+--
-    -> IM.IntMap (IM.IntMap (IM.IntMap Creature)) 
+--zoneCreature :: IM.IntMap (IM.IntMap (IM.IntMap Creature)) 
-zoneCreature m cr = runIdentity $ S.fold_ doinsert m id (zoneOfCreature cr)
+--    -> Creature
-  where
+--    -> IM.IntMap (IM.IntMap (IM.IntMap Creature)) 
-    doinsert m' (V2 x y) = insertIMInZone x y (_crID cr) cr m'
+--zoneCreature m cr = runIdentity $ S.fold_ doinsert m id (zoneOfCreature cr)
+--  where
+--    doinsert m' (V2 x y) = insertIMInZone x y (_crID cr) cr m'
 
 --        IM.foldl' (flip creatureInZone) IM.empty (_creatures w)
 --  where

src/Dodge/Wall/Zone.hs

@@ -5,20 +5,19 @@ import Geometry
 import Dodge.Zone
 import Dodge.Base
 
+import qualified Data.IntMap.Strict as IM
 import Control.Lens
 --import Data.Foldable
 --import Streaming
 import qualified Streaming.Prelude as S
 
 insertWallInZones :: Wall -> World -> World
-insertWallInZones wl = wallsZone . znObjects
+insertWallInZones wl = wlZoning %~ insertInZoning (IM.insert (_wlID wl)) wl
-    %~ (runIdentity . (\wlzns -> S.fold_ doinsert wlzns id (zoneOfWall wl)))
+--insertWallInZones wl = wlZoning . znObjects
-  where
+--    %~ (runIdentity . (\wlzns -> S.fold_ doinsert wlzns id (zoneOfWall wl)))
-    doinsert wlzns (V2 x y) = insertIMInZone x y (_wlID wl) wl wlzns
+--  where
+--    doinsert wlzns (V2 x y) = insertIMInZone x y (_wlID wl) wl wlzns
 
 deleteWallFromZones :: Wall -> World -> World
-deleteWallFromZones wl = wallsZone . znObjects 
+deleteWallFromZones wl = wlZoning %~ insertInZoning (const $ IM.delete (_wlID wl)) wl
-    %~ (runIdentity . (\wlzns -> S.fold_ dodelete wlzns id (zoneOfWall wl)))
-  where
-    dodelete wlzns (V2 x y) = deleteIMInZone x y (_wlID wl) wlzns
 --    %~ flip (foldl' (flip $ \(a,b) -> deleteIMInZone a b (_wlID wl))) (zoneOfWall wl)

src/Dodge/Zone.hs

@@ -1,9 +1,5 @@
 module Dodge.Zone
-    ( insertInZoneWith
+    ( zoneOfSight
-    , zoneOfSeg
-    , zoneOfCreature
-    , zoneOfWall
-    , zoneOfSight
     , zoneAroundPoint
     , nearPoint
     , wlsNearPoint
@@ -19,8 +15,12 @@ module Dodge.Zone
     , crZoneOfPoint
     , wlZoneOfPoint
     , module Dodge.Zone.Size
+    , module Dodge.Zone.Object
+    , module Dodge.Zone.Update
     )
     where
+import Dodge.Zone.Object
+import Dodge.Zone.Update
 import Dodge.Zone.Size
 import Dodge.Data
 --import Dodge.Base.Window
@@ -33,33 +33,12 @@ import Data.Maybe
 import qualified Data.IntMap.Strict as IM
 import Control.Lens
 
-extractFromZone :: Zoning a -> Int2 -> Maybe a
+extractFromZone :: Zoning t a -> Int2 -> Maybe (t a)
 extractFromZone zn (V2 x y) = zn ^? znObjects . ix x . ix y
 
-streamFromZone :: Foldable t => Zoning (t a) -> StreamOf Int2 -> StreamOf a
+streamFromZone :: Foldable t => Zoning t a -> StreamOf Int2 -> StreamOf a
 streamFromZone zn = S.concat . S.mapMaybe (extractFromZone zn)
 
-insertInZoneWith
-    :: Int2
-    -> (a -> a -> a) -- ^ Combining function
-    -> a            -- ^ Value to insert
-    -> Zoning a 
-    -> Zoning a
-insertInZoneWith (V2 x y) fun obj = over znObjects $ IM.insertWith f x $ IM.singleton y obj
-  where
-    f _ = IM.insertWith fun y obj
-
-zoneOfSeg :: Float -> Point2 -> Point2 -> StreamOf Int2
-zoneOfSeg = ddaStream
-
-zoneInsideCirc :: Float -> Point2 -> Float -> StreamOf Int2
-zoneInsideCirc x p r = ddaSqStream x (p +.+ V2 r r) (p -.- V2 r r)
-
-zoneOfWall :: Wall -> Stream (Of (V2 Int)) Identity ()
-zoneOfWall = uncurry (zoneOfSeg wlZoneSize) . _wlLine
-
-zoneOfCreature :: Creature -> StreamOf Int2
-zoneOfCreature cr = zoneInsideCirc crZoneSize (_crPos cr) (_crRad cr)
 
 zoneNearPointIP :: Point2 -> [(Int,Int)]
 zoneNearPointIP p = [(a,b) | a <- [x-1..x+1] , b <- [y-1..y+1] ]
@@ -98,36 +77,42 @@ lookLookups xs z = mapMaybe (flip (uncurry lookLookup) z) xs
 
 
 nearPoint :: (Foldable t,Monoid (t a)) 
-    => Float -> (World -> Zoning (t a)) -> Point2 -> World -> StreamOf a
+    => (World -> Zoning t a) -> Point2 -> World -> StreamOf a
 {-# INLINE nearPoint #-}
-nearPoint s f p w = S.each . fromMaybe mempty $ extractFromZone (f w) (zoneOfPoint s p)
+nearPoint f p w = S.each . fromMaybe mempty $ extractFromZone zn (zoneOfPoint (_znSize zn) p)
+  where
+    zn = f w
 
 clsNearPoint :: Point2 -> World -> StreamOf Cloud
-clsNearPoint = nearPoint clZoneSize _cloudsZone
+clsNearPoint = nearPoint _clZoning
 
 wlsNearPoint :: Point2 -> World -> StreamOf Wall
-wlsNearPoint = nearPoint wlZoneSize _wallsZone
+wlsNearPoint = nearPoint _wlZoning
 
 crsNearPoint :: Point2 -> World -> StreamOf Creature
-crsNearPoint = nearPoint crZoneSize _creaturesZone
+crsNearPoint = nearPoint _crZoning
 
-nearSeg :: Foldable t => Float -> (World -> Zoning (t a)) -> Point2 -> Point2 -> World -> StreamOf a
+nearSeg :: Foldable t => (World -> Zoning t a) -> Point2 -> Point2 -> World -> StreamOf a
-nearSeg s f p r w = streamFromZone (f w) $ zoneOfSeg s p r
+nearSeg f p r w = streamFromZone zn $ zoneOfSeg (_znSize zn) p r
+  where
+    zn = (f w)
 
 wlsNearSeg :: Point2 -> Point2 -> World -> Stream (Of Wall) Identity ()
-wlsNearSeg = nearSeg wlZoneSize _wallsZone
+wlsNearSeg = nearSeg _wlZoning
 
 crsNearSeg :: Point2 -> Point2 -> World -> StreamOf Creature
-crsNearSeg = nearSeg crZoneSize _creaturesZone
+crsNearSeg = nearSeg _crZoning
 
-insideCirc :: Foldable t => Float -> (World -> Zoning (t a)) -> Point2 -> Float -> World -> StreamOf a
+insideCirc :: Foldable t => (World -> Zoning t a) -> Point2 -> Float -> World -> StreamOf a
-insideCirc s f p r w = streamFromZone (f w) $ zoneInsideCirc s p r
+insideCirc f p r w = streamFromZone zn $ zoneInsideCirc (_znSize zn) p r
+  where
+    zn = f w
 
 wlsInsideCirc :: Point2 -> Float -> World -> Stream (Of Wall) Identity ()
-wlsInsideCirc = insideCirc wlZoneSize _wallsZone
+wlsInsideCirc = insideCirc _wlZoning
 
 crsInsideCirc :: Point2 -> Float -> World -> StreamOf Creature
-crsInsideCirc = insideCirc crZoneSize _creaturesZone
+crsInsideCirc = insideCirc _crZoning
 
 wlZoneOfPoint :: Point2 -> Int2
 wlZoneOfPoint = zoneOfPoint wlZoneSize

src/Dodge/Zone/Object.hs

@@ -0,0 +1,16 @@
+module Dodge.Zone.Object where
+import Dodge.Data
+import Geometry.Zone
+import Geometry.Data
+import Geometry.Vector3D
+import StreamingHelp
+import qualified Streaming.Prelude as S
+
+zoneOfCreature :: Float -> Creature -> StreamOf Int2
+zoneOfCreature x cr = zoneInsideCirc x (_crPos cr) (_crRad cr)
+
+zoneOfWall :: Float -> Wall -> StreamOf Int2
+zoneOfWall x = uncurry (zoneOfSeg x) . _wlLine
+
+zonePos :: (a -> Point2) -> Float -> a -> StreamOf Int2
+zonePos f x = S.yield . zoneOfPoint x . f

src/Dodge/Zone/Update.hs

@@ -0,0 +1,32 @@
+module Dodge.Zone.Update where
+import Dodge.Data.Zoning
+import StreamingHelp
+import qualified Streaming.Prelude as S
+import qualified Data.IntMap.Strict as IM
+import Geometry
+import LensHelp
+
+insertInZoning :: Monoid (t a) => (a -> t a -> t a) -> a -> Zoning t a -> Zoning t a
+insertInZoning f obj zn = runIdentity (S.fold_ doinsert zn id (_znFunc zn (_znSize zn) obj))
+  where
+    doinsert znobs vxy = insertInZoneWith vxy (\_ -> f obj) (f obj mempty) znobs
+
+--alterInZone :: (a -> Maybe (t a) -> Maybe (t a)) -> a -> Zoning 
+
+updateInZoning' :: Applicative t => (t a -> t a -> t a) -> a -> Zoning t a -> Zoning t a
+updateInZoning' f obj zn = runIdentity (S.fold_ doinsert zn id (_znFunc zn (_znSize zn) obj))
+  where
+    doinsert znobs vxy = insertInZoneWith vxy f (pure obj) znobs
+
+imInsert :: (a -> Int) -> a -> IM.IntMap a -> IM.IntMap a
+imInsert getID x = IM.insert (getID x) x
+
+insertInZoneWith
+    :: Int2
+    -> (t a -> t a -> t a) -- ^ Combining function
+    -> t a            -- ^ Value to insert
+    -> Zoning t a 
+    -> Zoning t a
+insertInZoneWith (V2 x y) fun obj = over znObjects $ IM.insertWith f x $ IM.singleton y obj
+  where
+    f _ = IM.insertWith fun y obj

src/Geometry/Zone.hs

@@ -11,10 +11,13 @@ module Geometry.Zone
     , yIntercepts
     , divTo
     , zoneOfPoint
+    , zoneOfSeg
+    , zoneInsideCirc
     ) where
 import Geometry.Data
+import Geometry.Vector
 
-import Streaming
+import StreamingHelp
 import qualified Streaming.Prelude as S
 import Data.Foldable
 import qualified Data.IntMap.Strict as IM
@@ -157,6 +160,12 @@ makeInterval x y
     | x < y = [x-1..y+1]
     | otherwise = [y-1..x+1]
 
+zoneInsideCirc :: Float -> Point2 -> Float -> StreamOf Int2
+zoneInsideCirc x p r = ddaSqStream x (p +.+ V2 r r) (p -.- V2 r r)
+
+zoneOfSeg :: Float -> Point2 -> Point2 -> StreamOf Int2
+zoneOfSeg = ddaStream
+
 ddaStream :: Float -> Point2 -> Point2 -> Stream (Of (V2 Int)) Identity ()
 ddaStream s sp ep = S.map (zoneOfPoint s)
     $  S.yield sp