Commit before complicating zoning

src/Dodge/Base.hs

@@ -62,16 +62,6 @@ wedgeGeom t x y
   where 
     n a b = (t*0.5) *.* errorNormalizeV 4200 (vNormal (a -.- b))
 
-insertInZoneWith 
-    :: Int          -- ^ First Key
-    -> Int          -- ^ Second Key
-    -> (a -> a -> a) -- ^ Combining function
-    -> a            -- ^ Value to insert
-    -> IM.IntMap (IM.IntMap a) 
-    -> IM.IntMap (IM.IntMap a)
-insertInZoneWith x y fun obj = IM.insertWith f x $ IM.singleton y obj
-  where
-    f _ = IM.insertWith fun y obj
 {- | I believe this overwrites the value if it already exists, but not sure. -}
 insertIMInZone 
     :: Int      -- ^ First key

src/Dodge/Data.hs

@@ -7,6 +7,7 @@ circular imports are probably not a good idea.
 {-# LANGUAGE StrictData #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
 module Dodge.Data 
     ( module Dodge.Data
     , module Dodge.Data.Material
@@ -103,13 +104,13 @@ data World = World
     , _boundBox             :: [Point2]
     , _boundDist            :: (Float,Float,Float,Float) -- NSEW, S and W negative
     , _creatures            :: IM.IntMap Creature
-    , _creaturesZone        :: Zone (IM.IntMap Creature)
+    , _creaturesZone        :: Zoning (IM.IntMap Creature)
     , _creatureGroups       :: IM.IntMap CrGroupParams
     , _itemPositions        :: IM.IntMap ItemPos
     , _clouds               :: [Cloud]
-    , _cloudsZone           :: Zone [Cloud]
+    , _cloudsZone           :: Zoning [Cloud]
     , _gusts                :: IM.IntMap Gust
-    , _gustsZone            :: Zone (IM.IntMap Gust)
+    , _gustsZone            :: Zoning (IM.IntMap Gust)
     , _props                :: IM.IntMap Prop
     , _instantParticles     :: [Particle]
     , _particles            :: [Particle]
@@ -124,7 +125,7 @@ data World = World
     , _blocks               :: IM.IntMap Block
     , _coordinates          :: IM.IntMap Point2
     , _triggers             :: IM.IntMap (World -> Bool)
-    , _wallsZone            :: Zone (IM.IntMap Wall)
+    , _wallsZone            :: Zoning (IM.IntMap Wall)
     , _floorItems           :: IM.IntMap FloorItem
     , _floorTiles           :: [(Point3,Point3)]
     , _randGen              :: StdGen
@@ -144,7 +145,7 @@ data World = World
     , _clickMousePos        :: Point2
     , _pathGraph            :: Gr Point2 Float
     , _pathGraphP           :: S.Set (Point2,Point2)
-    , _pathPoints           :: IM.IntMap (IM.IntMap [(Int,Point2)])
+    , _pathPoints           :: Zoning [(Int,Point2)]
     , _hud                  :: HUD
     , _lightSources         :: IM.IntMap LightSource
     , _tempLightSources     :: [TempLightSource]
@@ -1326,7 +1327,7 @@ data Goal
     | SentinelAt Point2 Float
   deriving (Show)
 
-newtype Zone a = Zone
+newtype Zoning a = Zoning
     { _znObjects :: IM.IntMap (IM.IntMap a)
     }
 data DamageEffect
@@ -1514,7 +1515,7 @@ makeLenses ''Block
 makeLenses ''Terminal
 makeLenses ''Machine
 makeLenses ''MachineType
-makeLenses ''Zone
+makeLenses ''Zoning
 makeLenses ''ItemDimension
 makeLenses ''Vocalization
 makeLenses ''Universe

src/Dodge/Default/World.hs

@@ -30,12 +30,12 @@ defaultWorld = World
     , _viewDistance = 1000
     , _modifications = IM.empty
     , _creatures = IM.empty
-    , _creaturesZone = Zone IM.empty
+    , _creaturesZone = Zoning IM.empty
     , _creatureGroups = IM.empty
     , _clouds = []
-    , _cloudsZone = Zone IM.empty
+    , _cloudsZone = Zoning IM.empty
     , _gusts = IM.empty
-    , _gustsZone = Zone IM.empty
+    , _gustsZone = Zoning IM.empty
     , _itemPositions = IM.empty
     , _props = IM.empty
     , _instantParticles = []
@@ -50,7 +50,7 @@ defaultWorld = World
     , _doors = IM.empty
     , _coordinates  = IM.empty
     , _triggers     = IM.empty
-    , _wallsZone = Zone IM.empty
+    , _wallsZone = Zoning IM.empty
     , _floorItems = IM.empty
     , _floorTiles = []
     , _randGen = mkStdGen 2
@@ -71,7 +71,7 @@ defaultWorld = World
     , _clickMousePos = V2 0 0
     , _pathGraph = Data.Graph.Inductive.Graph.empty
     , _pathGraphP = mempty
-    , _pathPoints = IM.empty
+    , _pathPoints = Zoning IM.empty
     , _hud = HUD
         { _hudElement = DisplayInventory NoSubInventory
         , _carteCenter = V2 0 0

src/Dodge/Path.hs

@@ -9,15 +9,15 @@ import Dodge.Data
 import Dodge.Base.Collide
 import Dodge.Zone
 import Geometry.Data
-import Dodge.Base
 import Geometry
 
 import Control.Lens
 import Data.Maybe
 import Data.List
-import qualified Data.IntMap.Strict as IM
+--import qualified Data.IntMap.Strict as IM
 import Data.Graph.Inductive hiding ((&))
-import qualified Data.Set as S
+import qualified Data.Set as Set
+import qualified Streaming.Prelude as S
 --import Data.Graph.Inductive.PatriciaTree
 --import Data.Graph.Inductive.Graph hiding ((&))
 
@@ -27,9 +27,13 @@ makePathBetween a b w = do -- join $ sp <$> a' <*> b' <*> return (_pathGraph w)
     nb <- walkableNodeNear b
     sp na nb (_pathGraph w)
   where
-    nodesNear p = concat $ lookLookups (zoneNearPointIP p) (_pathPoints w)
+    --nodesNear p = concat $ lookLookups (zoneNearPointIP p) (_pathPoints w)
+    nodesNear p = runIdentity . S.toList_ $ nearPoint wlZoneSize _pathPoints p w
     walkableNodeNear p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear p
 
+--walkableNodeNear :: Point2 -> World -> Maybe Point2
+--walkableNodeNear p w = insideCirc
+
 makePathBetweenPs :: Point2 -> Point2 -> World -> Maybe [Point2]
 makePathBetweenPs a b w = mapMaybe (lab $ _pathGraph w) <$> makePathBetween a b w
 
@@ -79,18 +83,19 @@ pointTowardsImpulse a b w = find (flip (isWalkable a) w) =<< makePathBetweenPs a
 --        [] -> return Nothing
 --        _  -> return $ Just $ ns !! i
 --
-pairsToGraph :: (Ord a, Ord b) => (a -> a -> b) -> S.Set (a,a) -> Gr a b
+pairsToGraph :: (Ord a, Ord b) => (a -> a -> b) -> Set.Set (a,a) -> Gr a b
 pairsToGraph f pairs = 
-    let nodes' = S.map fst pairs `S.union` S.map snd pairs
+    let nodes' = Set.map fst pairs `Set.union` Set.map snd pairs
-        pairs' = S.map (\(x,y)->(x,y,f x y)) pairs
+        pairs' = Set.map (\(x,y)->(x,y,f x y)) pairs
-    in undir $ run_ Data.Graph.Inductive.empty $ insMapNodesM (S.toList nodes') >> insMapEdgesM (S.toList pairs')
+    in undir $ run_ Data.Graph.Inductive.empty $ insMapNodesM (Set.toList nodes') >> insMapEdgesM (Set.toList pairs')
 
 removePathsCrossing :: Point2 -> Point2 -> World -> World
 removePathsCrossing a b w = w
     & pathGraph  .~ newGraph 
     & pathGraphP .~ pg'
-    & pathPoints .~ foldr insertPoint IM.empty (labNodes newGraph)
+    & pathPoints .~ foldl' insertpoint (Zoning mempty) (labNodes newGraph)
   where 
-    pg' = S.filter (isNothing . uncurry (intersectSegSeg a b)) $ _pathGraphP w
+    pg' = Set.filter (isNothing . uncurry (intersectSegSeg a b)) $ _pathGraphP w
-    insertPoint pp@(_,p) = uncurryV insertInZoneWith (wlZoneOfPoint p) (++) [pp]
+    insertpoint zn (i,p) = insertInZoneWith (wlZoneOfPoint p) (++) [(i,p)] zn
+   -- insertPoint pp@(_,p) = insertInZoneWith (wlZoneOfPoint p) (++) [pp]
     newGraph = pairsToGraph dist pg'

src/Dodge/Update.hs

@@ -95,15 +95,13 @@ functionalUpdate cfig w = checkEndGame
     . updateRBList
     . updateBounds cfig  -- where should this go? next to update camera?
     $ updateCloseObjects w
-  where 
-    --updatedLightSources = mapMaybe (\b -> _tlsUpdate b w b) $ _tempLightSources w
 
 zoneClouds :: World -> World
-zoneClouds w = w & set (cloudsZone . znObjects) (foldl' (flip cloudInZone) IM.empty (_clouds w))
+zoneClouds w = w & set cloudsZone (foldl' (flip cloudInZone) (Zoning mempty) (_clouds w))
   where
-    cloudInZone cl = insertInZoneWith x y (++) [cl]
+    cloudInZone cl = insertInZoneWith p (++) [cl]
       where 
-        V2 x y = clZoneOfPoint $ stripZ $ _clPos cl
+        p = clZoneOfPoint $ stripZ $ _clPos cl
 
 updateWorldSelect :: World -> World
 updateWorldSelect w = case w ^? mouseButtons . ix ButtonLeft of

src/Dodge/Zone.hs

@@ -1,9 +1,11 @@
 module Dodge.Zone
-    ( zoneOfSeg
+    ( insertInZoneWith
+    , zoneOfSeg
     , zoneOfCreature
     , zoneOfWall
     , zoneOfSight
     , zoneAroundPoint
+    , nearPoint
     , wlsNearPoint
     , crsNearPoint
     , clsNearPoint
@@ -31,6 +33,22 @@ import Data.Maybe
 import qualified Data.IntMap.Strict as IM
 import Control.Lens
 
+extractFromZone :: Zoning a -> Int2 -> Maybe a
+extractFromZone zn (V2 x y) = zn ^? znObjects . ix x . ix y
+
+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
 
@@ -78,11 +96,10 @@ lookLookup i j z = case IM.lookup i z of
 lookLookups :: [(Int,Int)] -> IM.IntMap (IM.IntMap a) -> [a]
 lookLookups xs z = mapMaybe (flip (uncurry lookLookup) z) xs
 
-extractFromZone :: Zone a -> Int2 -> Maybe a
-extractFromZone zn (V2 x y) = zn ^? znObjects . ix x . ix y
 
 nearPoint :: (Foldable t,Monoid (t a)) 
-    => Float -> (World -> Zone (t a)) -> Point2 -> World -> StreamOf a
+    => Float -> (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)
 
 clsNearPoint :: Point2 -> World -> StreamOf Cloud
@@ -94,9 +111,8 @@ wlsNearPoint = nearPoint wlZoneSize _wallsZone
 crsNearPoint :: Point2 -> World -> StreamOf Creature
 crsNearPoint = nearPoint crZoneSize _creaturesZone
 
-nearSeg :: Foldable t => Float -> (World -> Zone (t a)) -> Point2 -> Point2 -> World -> StreamOf a
+nearSeg :: Foldable t => Float -> (World -> Zoning (t a)) -> Point2 -> Point2 -> World -> StreamOf a
-nearSeg s f p r w = S.concat $ S.mapMaybe (extractFromZone (f w)) 
+nearSeg s f p r w = streamFromZone (f w) $ zoneOfSeg s p r
-    $ zoneOfSeg s p r
 
 wlsNearSeg :: Point2 -> Point2 -> World -> Stream (Of Wall) Identity ()
 wlsNearSeg = nearSeg wlZoneSize _wallsZone
@@ -104,9 +120,8 @@ wlsNearSeg = nearSeg wlZoneSize _wallsZone
 crsNearSeg :: Point2 -> Point2 -> World -> StreamOf Creature
 crsNearSeg = nearSeg crZoneSize _creaturesZone
 
-insideCirc :: Foldable t => Float -> (World -> Zone (t a)) -> Point2 -> Float -> World -> StreamOf a
+insideCirc :: Foldable t => Float -> (World -> Zoning (t a)) -> Point2 -> Float -> World -> StreamOf a
-insideCirc s f p r w = S.concat $ S.mapMaybe (extractFromZone (f w)) 
+insideCirc s f p r w = streamFromZone (f w) $ zoneInsideCirc s p r
-    $ zoneInsideCirc s p r
 
 wlsInsideCirc :: Point2 -> Float -> World -> Stream (Of Wall) Identity ()
 wlsInsideCirc = insideCirc wlZoneSize _wallsZone