Make zoning more universal

2022-06-28 19:04:31 +01:00
parent 4965934502
commit b1a7e1bf35
16 changed files with 152 additions and 97 deletions
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
-    , _creatures = IM.empty
-    , _creaturesZone = Zoning IM.empty
-    , _creatureGroups = IM.empty
+    , _modifications    = IM.empty
+    , _creatures        = IM.empty
+    , _crZoning         = Zoning IM.empty crZoneSize zoneOfCreature
+    , _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
-    , _pathPoints = Zoning IM.empty
+    , _pathGraphP   = mempty
+    , _phZoning     = Zoning mempty wlZoneSize (zonePos snd)
    , _hud = HUD
        { _hudElement = DisplayInventory NoSubInventory
        , _carteCenter = V2 0 0
@@ -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
@@ -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
@@ -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=[]
@@ -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]
@@ -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
@@ -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))
-  where
-    cloudInZone cl = insertInZoneWith p (++) [cl]
-      where 
-        p = clZoneOfPoint $ stripZ $ _clPos cl
+zoneClouds w = w & clZoning %~ \zn ->
+    foldl' (flip $ insertInZoning (:)) (zn & znObjects .~ mempty) (_clouds w)
+--  where
+--    cloudInZone cl = insertInZoneWith p (++) [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 
-    & creaturesZone . znObjects .~
-        IM.foldl' zoneCreature IM.empty (_creatures w)
--        runIdentity (S.fold_ zoneCreature IM.empty id (S.each $ _creatures w))
-
-zoneCreature :: IM.IntMap (IM.IntMap (IM.IntMap Creature)) 
-    -> Creature
-    -> IM.IntMap (IM.IntMap (IM.IntMap Creature)) 
-zoneCreature m cr = runIdentity $ S.fold_ doinsert m id (zoneOfCreature cr)
-  where
-    doinsert m' (V2 x y) = insertIMInZone x y (_crID cr) cr m'
+zoneCreatures w = w & crZoning %~ \zn ->
+    foldl' (flip $ insertInZoning (\cr -> IM.insert (_crID cr) cr)) 
+        (zn & znObjects .~ mempty) (_creatures w)
+--        . znObjects .~
+--        IM.foldl' zoneCreature IM.empty (_creatures w)
+----        runIdentity (S.fold_ zoneCreature IM.empty id (S.each $ _creatures w))
+--
+--zoneCreature :: IM.IntMap (IM.IntMap (IM.IntMap Creature)) 
+--    -> Creature
+--    -> IM.IntMap (IM.IntMap (IM.IntMap Creature)) 
+--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
@@ -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
-    %~ (runIdentity . (\wlzns -> S.fold_ doinsert wlzns id (zoneOfWall wl)))
-  where
-    doinsert wlzns (V2 x y) = insertIMInZone x y (_wlID wl) wl wlzns
+insertWallInZones wl = wlZoning %~ insertInZoning (IM.insert (_wlID wl)) wl
+--insertWallInZones wl = wlZoning . znObjects
+--    %~ (runIdentity . (\wlzns -> S.fold_ doinsert wlzns id (zoneOfWall wl)))
+--  where
+--    doinsert wlzns (V2 x y) = insertIMInZone x y (_wlID wl) wl wlzns

 deleteWallFromZones :: Wall -> World -> World
-deleteWallFromZones wl = wallsZone . znObjects 
-    %~ (runIdentity . (\wlzns -> S.fold_ dodelete wlzns id (zoneOfWall wl)))
-  where
-    dodelete wlzns (V2 x y) = deleteIMInZone x y (_wlID wl) wlzns
+deleteWallFromZones wl = wlZoning %~ insertInZoning (const $ IM.delete (_wlID wl)) wl
 --    %~ flip (foldl' (flip $ \(a,b) -> deleteIMInZone a b (_wlID wl))) (zoneOfWall wl)
@@ -1,9 +1,5 @@
 module Dodge.Zone
-    ( insertInZoneWith
-    , zoneOfSeg
-    , zoneOfCreature
-    , zoneOfWall
-    , zoneOfSight
+    ( 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 s f p r w = streamFromZone (f w) $ zoneOfSeg s p r
+nearSeg :: Foldable t => (World -> Zoning t a) -> Point2 -> Point2 -> World -> StreamOf a
+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 s f p r w = streamFromZone (f w) $ zoneInsideCirc s p r
+insideCirc :: Foldable t => (World -> Zoning t a) -> Point2 -> Float -> World -> StreamOf a
+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
@@ -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
@@ -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
@@ -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