Make pathedge zoning use sets, probably doesn't help

src/Dodge/Block.hs

@@ -1,5 +1,6 @@
 module Dodge.Block where
 
+import Data.Set (Set)
 import Dodge.Data.MountedObject
 import Control.Lens
 import Data.Foldable
@@ -64,7 +65,7 @@ destroyBlock bl w =
     ps = replicateM 25 (randInCirc 20) & evalState $ _randGen w
 
 -- this does not handle eg doors blocking the path as well
-maybeClearPaths :: [(Int, Int, PathEdge)] -> World -> World
+maybeClearPaths :: Set (Int, Int, PathEdge) -> World -> World
 maybeClearPaths ps w = foldl' maybeClearPath w ps
 
 maybeClearPath :: World -> (Int, Int, PathEdge) -> World

src/Dodge/Data/Block.hs

@@ -9,6 +9,7 @@ module Dodge.Data.Block (
     module Dodge.Data.PathGraph,
 ) where
 
+import Data.Set (Set)
 import Color
 import Control.Lens
 import Data.Aeson
@@ -30,7 +31,7 @@ data Block = Block
     , _blHeight :: Float
     , _blMaterial :: Material
     , _blDraw :: BlockDraw --Block -> SPic
-    , _blObstructs :: [(Int, Int, PathEdge)]
+    , _blObstructs :: Set (Int, Int, PathEdge)
     }
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 

src/Dodge/Data/CWorld.hs

@@ -48,6 +48,7 @@ module Dodge.Data.CWorld (
     module Dodge.Data.WorldEffect,
 ) where
 
+import Data.Set (Set)
 import Control.Lens
 import Data.Aeson
 import Data.Aeson.TH
@@ -176,7 +177,8 @@ data CWorld = CWorld
     , _corpses :: IM.IntMap Corpse
     , _pathGraph :: Gr Point2 PathEdge
     , _pnZoning :: IM.IntMap (IM.IntMap [(Int, Point2)]) --Zoning IM.IntMap Creature
-    , _peZoning :: IM.IntMap (IM.IntMap [(Int, Int, PathEdge)]) --Zoning IM.IntMap Creature
+    --, _peZoning :: IM.IntMap (IM.IntMap [(Int, Int, PathEdge)]) --Zoning IM.IntMap Creature
+    , _peZoning :: IM.IntMap (IM.IntMap (Set (Int, Int, PathEdge))) --Zoning IM.IntMap Creature
     , _hud :: HUD
     , _lightSources :: IM.IntMap LightSource
     , _tempLightSources :: [TempLightSource]

src/Dodge/Data/Door.hs

@@ -10,6 +10,7 @@ module Dodge.Data.Door (
     module Dodge.Data.WorldEffect,
 ) where
 
+import Data.Set (Set)
 import Control.Lens
 import Data.Aeson
 import Data.Aeson.TH
@@ -45,7 +46,7 @@ data Door = Door
     , _drPushedBy :: PushSource
     , _drPushes :: Maybe Int
     , _drMounts :: [MountedObject]
-    , _drObstructs :: [(Int, Int, PathEdge)]
+    , _drObstructs :: Set (Int, Int, PathEdge)
     , _drObstacleType :: EdgeObstacle
     }
     --deriving (Eq, Ord, Show, Read) --Generic, Flat)

src/Dodge/Data/PathGraph.hs

@@ -30,6 +30,13 @@ data PathGraph = PathGraph
     }
     deriving (Eq, Show, Read) --, Generic)
 
+data PathEdgeNodes = PathEdgeNodes
+    { _penStart :: Int
+    , _penEnd :: Int
+    , _penPathEdge :: PathEdge
+    }
+    deriving (Eq, Ord, Show, Read) --Generic, Flat)
+
 data PathEdge = PathEdge
     { _peStart :: Point2
     , _peEnd :: Point2
@@ -54,7 +61,9 @@ data EdgeObstacle
 
 makeLenses ''PathGraph
 makeLenses ''PathEdge
+makeLenses ''PathEdgeNodes
 deriveJSON defaultOptions ''EdgeObstacle
 deriveJSON defaultOptions ''PathEdge
+deriveJSON defaultOptions ''PathEdgeNodes
 deriveJSON defaultOptions ''Gr
 deriveJSON defaultOptions ''PathGraph

src/Dodge/Default/Block.hs

@@ -14,7 +14,7 @@ defaultBlock = Block
     , _blDraw      = BlockDrawMempty
     , _blHeight     = 100
     , _blMaterial   = Stone
-    , _blObstructs = []
+    , _blObstructs = mempty
     }
 defaultDirtBlock :: Block
 defaultDirtBlock = defaultBlock & blHP .~ 50

src/Dodge/Humanoid.hs

@@ -188,11 +188,7 @@ defaultImpulsive ::
     World ->
     World
 defaultImpulsive
-    --xs cr = id
-    -- updateRandGen -- . stateUpdate (const id) cr
     = fmap (fmap updateRandGen) . stateUpdate . impulsiveAIBefore . chainCreatureUpdates
-    --xs cr = updateRandGen . stateUpdate (const id) cr
-    --xs cr = stateUpdate (const id) cr
   where
     updateRandGen w =
         let (_, g) = randomR (0, 1 :: Int) (_randGen w)

src/Dodge/Path.hs

@@ -12,6 +12,8 @@ module Dodge.Path (
     fusePairs,
 ) where
 
+import Data.Set (Set)
+import qualified Data.Set as Set
 import Control.Lens
 import Data.Foldable
 import Data.Graph.Inductive hiding ((&))
@@ -19,8 +21,6 @@ import Data.List
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
 import Data.Maybe
-import Data.Set (Set)
-import qualified Data.Set as Set
 import Dodge.Base.Collide
 import Dodge.Data.World
 import Dodge.Zoning.Base
@@ -131,13 +131,13 @@ addEdges nodemap gr = foldl' f (mempty, gr)
         theedge = (g a, g b, PathEdge a b (dist a b) mempty)
     g a = nodemap M.! a
 
-obstructPathsCrossing :: EdgeObstacle -> Point2 -> Point2 -> World -> (World, [(Int, Int, PathEdge)])
+obstructPathsCrossing :: EdgeObstacle -> Point2 -> Point2 -> World -> (World, Set (Int, Int, PathEdge))
 obstructPathsCrossing obstacletype sp' ep w =
     ( w & cWorld . pathGraph %~ updateedges
     , es
     )
   where
-    es = filter edgecrosses $ pesNearSeg sp' ep w
+    es = Set.filter edgecrosses $ pesNearSeg sp' ep w
     edgecrosses (_, _, pe) = isJust $ intersectSegSeg sp' ep (_peStart pe) (_peEnd pe)
     updateedges gr = foldl' updateedge gr es
     updateedge gr (x, y, pe) =

src/Dodge/Placement/PlaceSpot/Block.hs

@@ -4,6 +4,8 @@ module Dodge.Placement.PlaceSpot.Block (
     plLineBlock,
 ) where
 
+import Data.Set (Set)
+import qualified Data.Set as Set
 import Control.Lens
 import qualified Data.IntSet as IS
 import Data.List
@@ -85,7 +87,7 @@ plLineBlock basePane blwidth a b gw =
                         , _blShadows = shadowsAt i
                         , _blDir = 0 -- THIS IS NOT SENSIBLE. TODO rethink block positioning
                         , _blFootprint = cornersAt p -- TODO check winding (clockwise, anticlockwise)
-                        , _blObstructs = []
+                        , _blObstructs = mempty
                         , _blMaterial = _wlMaterial basePane
                         , _blHeight = 100
                         , _blPos = p
@@ -113,11 +115,11 @@ plLineBlock basePane blwidth a b gw =
 
 -- | Must be done after inserting the block
 insertWalls :: Int -> [Wall] -> World -> World
-insertWalls blid wls w = w' & cWorld . blocks . ix blid . blObstructs .~ concat paths
+insertWalls blid wls w = w' & cWorld . blocks . ix blid . blObstructs .~ Set.unions paths
   where
     (w', paths) = mapAccumR (flip insertWall) w wls
 
-insertWall :: Wall -> World -> (World, [(Int, Int, PathEdge)])
+insertWall :: Wall -> World -> (World, Set (Int, Int, PathEdge))
 insertWall wl =
     uncurry (obstructPathsCrossing BlockObstacle) (_wlLine wl)
         . (cWorld . walls . at (_wlID wl) ?~ wl)

src/Dodge/Placement/PlaceSpot/TriggerDoor.hs

@@ -4,6 +4,7 @@ module Dodge.Placement.PlaceSpot.TriggerDoor (
     maybeClearDoorPaths,
 ) where
 
+import Data.Set (Set)
 import qualified Data.Graph.Inductive as FGL
 import qualified Data.IntSet as IS
 import Data.List
@@ -60,11 +61,11 @@ addDoorWall eo drid wl w (wlid, wlps) =
                     , _wlID = wlid
                     , _wlStructure = DoorPart drid
                     }
-        & cWorld . doors . ix drid . drObstructs .++~ es
+        & cWorld . doors . ix drid . drObstructs <>~ es
   where
     (w', es) = uncurry (obstructPathsCrossing eo) wlps w
 
-maybeClearDoorPaths :: EdgeObstacle -> [(Int, Int, PathEdge)] -> World -> World
+maybeClearDoorPaths :: EdgeObstacle -> Set (Int, Int, PathEdge) -> World -> World
 maybeClearDoorPaths eo es w = foldl' (maybeClearDoorPath eo) w es
 
 maybeClearDoorPath :: EdgeObstacle -> World -> (Int, Int, PathEdge) -> World

src/Dodge/Render/ShapePicture.hs

@@ -188,9 +188,9 @@ drawCollisionTest cfig w =
     <> foldMap (drawCross . fst) (crHit a b w) 
     <> foldMap (drawCross . _crPos) (crsNearSeg a b w) 
 --    <> foldMap (drawZoneCol green crZoneSize) (zoneOfSeg' crZoneSize a b)
-    <> foldMap (drawZoneCol green crZoneSize . zoneOfPoint' crZoneSize) (xIntercepts' crZoneSize a b)
+    <> foldMap (drawZoneCol green crZoneSize . zoneOfPoint crZoneSize) (xIntercepts crZoneSize a b)
-    <> foldMap (drawZoneCol yellow crZoneSize . zoneOfPoint' crZoneSize) (yIntercepts' crZoneSize a b)
+    <> foldMap (drawZoneCol yellow crZoneSize . zoneOfPoint crZoneSize) (yIntercepts' crZoneSize a b)
-    <> foldMap (drawLabCrossCol cfig w blue) (xIntercepts' crZoneSize a b)
+    <> foldMap (drawLabCrossCol cfig w blue) (xIntercepts crZoneSize a b)
   where
     (a, b) = _lrLine w
 
@@ -290,7 +290,7 @@ drawDDATest w =
     cvf = w ^. cWorld . cwCam . cwcViewFrom
     mwp = mouseWorldPos w
     --ps = ddaStreamX 50 cvf mwp
-    ps = zoneOfSeg' 50 cvf mwp
+    ps = zoneOfSeg 50 cvf mwp
 
 --ps' = ddaStreamY 50 (_cameraViewFrom (_cWorld w)) (mouseWorldPos w)
 --qs = xIntercepts 50 (_cameraViewFrom (_cWorld w)) (mouseWorldPos w)

src/Dodge/Zoning/Base.hs

@@ -13,8 +13,8 @@ zoneOfCirc zsize p r = zoneOfRect' zsize (p +.+ V2 r r) (p -.- V2 r r)
 zoneOfRect' :: Float -> Point2 -> Point2 -> [Int2]
 zoneOfRect' s sp ep = [V2 x y | x <- makeIntInterval sx ex, y <- makeIntInterval sy ey]
   where
-    V2 sx sy = zoneOfPoint' s sp
+    V2 sx sy = zoneOfPoint s sp
-    V2 ex ey = zoneOfPoint' s ep
+    V2 ex ey = zoneOfPoint s ep
 
 makeIntInterval :: Int -> Int -> [Int]
 makeIntInterval x y
@@ -25,12 +25,12 @@ makeInt2Interval :: Int2 -> Int2 -> [Int2]
 makeInt2Interval (V2 x1 y1) (V2 x2 y2) =
     [V2 x y | x <- makeIntInterval x1 x2, y <- makeIntInterval y1 y2]
 
-zoneOfPoint' :: Float -> Point2 -> Int2
+zoneOfPoint :: Float -> Point2 -> Int2
-zoneOfPoint' = fmap . divTo
+zoneOfPoint = fmap . divTo
 
-zoneOfSeg' :: Float -> Point2 -> Point2 -> [Int2]
+zoneOfSeg :: Float -> Point2 -> Point2 -> [Int2]
-{-# INLINE zoneOfSeg' #-}
+{-# INLINE zoneOfSeg #-}
-zoneOfSeg' s sp ep = map (zoneOfPoint' s) (sp : xIntercepts' s sp ep ++ yIntercepts' s sp ep)
+zoneOfSeg s sp ep = map (zoneOfPoint s) (sp : xIntercepts s sp ep ++ yIntercepts' s sp ep)
 
 zoneExtract :: Monoid m => Int2 -> IM.IntMap (IM.IntMap m) -> m
 zoneExtract (V2 x y) = fromMaybe mempty . (^? ix x . ix y)
@@ -39,9 +39,9 @@ zonesExtract :: Monoid m => IM.IntMap (IM.IntMap m) -> [Int2] -> m
 {-# INLINE zonesExtract #-}
 zonesExtract = foldMap . flip zoneExtract
 
-xIntercepts' :: Float -> Point2 -> Point2 -> [Point2]
+xIntercepts :: Float -> Point2 -> Point2 -> [Point2]
-{-# INLINE xIntercepts' #-}
+{-# INLINE xIntercepts #-}
-xIntercepts' s (V2 sx sy) (V2 ex ey)
+xIntercepts s (V2 sx sy) (V2 ex ey)
     | xdx == 0 = []
     | otherwise = zipWith V2 [halfstep + sx', halfstep + sx' + xdx * s .. ex] ([sy', sy' + ydx * s .. ey] ++ repeat ey)
   where
@@ -57,12 +57,12 @@ xIntercepts' s (V2 sx sy) (V2 ex ey)
 
 yIntercepts' :: Float -> Point2 -> Point2 -> [Point2]
 {-# INLINE yIntercepts' #-}
-yIntercepts' s sp ep = map f $ xIntercepts' s (f sp) (f ep)
+yIntercepts' s sp ep = map f $ xIntercepts s (f sp) (f ep)
   where
     f (V2 x y) = V2 y x
 
 zoneMonoid :: Semigroup m => Int2 -> m -> IM.IntMap (IM.IntMap m) -> IM.IntMap (IM.IntMap m)
-zoneMonoid (V2 x y) a = IM.insertWith f x $ IM.singleton y a
+zoneMonoid (V2 x y) a = IM.insertWith f x $! IM.singleton y a
   where
     f _ = IM.insertWith (<>) y a
 
@@ -76,4 +76,4 @@ 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
+    V2 x y = zoneOfPoint s p

src/Dodge/Zoning/Cloud.hs

@@ -8,10 +8,10 @@ import Geometry
 import qualified IntMapHelp as IM
 
 clsNearPoint :: Point2 -> World -> [Cloud]
-clsNearPoint p w = zoneExtract (zoneOfPoint' clZoneSize p) (w ^. cWorld . clZoning)
+clsNearPoint p w = zoneExtract (zoneOfPoint clZoneSize p) (w ^. cWorld . clZoning)
 
 clsNearSeg :: Point2 -> Point2 -> World -> [Cloud]
-clsNearSeg sp ep w = zonesExtract (w ^. cWorld . clZoning) (zoneOfSeg' clZoneSize sp ep)
+clsNearSeg sp ep w = zonesExtract (w ^. cWorld . clZoning) (zoneOfSeg clZoneSize sp ep)
 
 clsNearRect :: Point2 -> Point2 -> World -> [Cloud]
 clsNearRect sp ep w = zonesExtract (w ^. cWorld . clZoning) $ zoneOfRect' clZoneSize sp ep

src/Dodge/Zoning/Creature.hs

@@ -10,7 +10,7 @@ import Geometry
 import qualified IntMapHelp as IM
 
 crIXsNearPoint :: Point2 -> World -> IS.IntSet
-crIXsNearPoint p w = zoneExtract (zoneOfPoint' crZoneSize p) (w ^. cWorld . crZoning)
+crIXsNearPoint p w = zoneExtract (zoneOfPoint crZoneSize p) (w ^. cWorld . crZoning)
 
 crsNearPoint :: Point2 -> World -> [Creature]
 crsNearPoint p w = mapMaybe (\cid -> w ^? cWorld . creatures . ix cid) . IS.toList $ crIXsNearPoint p w
@@ -22,7 +22,7 @@ crsNearSeg sp ep w =
     $ crixsNearSeg sp ep w
 
 crixsNearSeg :: Point2 -> Point2 -> World -> IS.IntSet
-crixsNearSeg sp ep w = zonesExtract (w ^. cWorld . crZoning) (zoneOfSeg' crZoneSize sp ep)
+crixsNearSeg sp ep w = zonesExtract (w ^. cWorld . crZoning) (zoneOfSeg crZoneSize sp ep)
 
 crIXsNearCirc :: Point2 -> Float -> World -> IS.IntSet
 crIXsNearCirc p r = crsNearRect (p +.+ V2 r r) (p -.- V2 r r)

src/Dodge/Zoning/Pathing.hs

@@ -6,12 +6,14 @@ import Dodge.Data.World
 import Dodge.Zoning.Base
 import Geometry
 import qualified IntMapHelp as IM
+import Data.Set (Set)
+import qualified Data.Set as Set
 
 pnsNearPoint :: Point2 -> World -> [(Int, Point2)]
-pnsNearPoint p w = zoneExtract (zoneOfPoint' pnZoneSize p) (w ^. cWorld . pnZoning)
+pnsNearPoint p w = zoneExtract (zoneOfPoint pnZoneSize p) (w ^. cWorld . pnZoning)
 
 pnsNearSeg :: Point2 -> Point2 -> World -> [(Int, Point2)]
-pnsNearSeg sp ep w = zonesExtract (w ^. cWorld . pnZoning) (zoneOfSeg' pnZoneSize sp ep)
+pnsNearSeg sp ep w = zonesExtract (w ^. cWorld . pnZoning) (zoneOfSeg pnZoneSize sp ep)
 
 pnsNearRect :: Point2 -> Point2 -> World -> [(Int, Point2)]
 pnsNearRect sp ep w = zonesExtract (w ^. cWorld . pnZoning) $ zoneOfRect' pnZoneSize sp ep
@@ -28,25 +30,25 @@ 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 :: Point2 -> World -> Set (Int, Int, PathEdge)
-pesNearPoint p w = zoneExtract (zoneOfPoint' peZoneSize p) (w ^. cWorld . peZoning)
+pesNearPoint p w = zoneExtract (zoneOfPoint peZoneSize p) (w ^. cWorld . peZoning)
 
-pesNearSeg :: Point2 -> Point2 -> World -> [(Int, Int, PathEdge)]
+pesNearSeg :: Point2 -> Point2 -> World -> Set (Int, Int, PathEdge)
-pesNearSeg sp ep w = zonesExtract (w ^. cWorld . peZoning) (zoneOfSeg' peZoneSize sp ep)
+pesNearSeg sp ep w = zonesExtract (w ^. cWorld . peZoning) (zoneOfSeg peZoneSize sp ep)
 
-pesNearRect :: Point2 -> Point2 -> World -> [(Int, Int, PathEdge)]
+pesNearRect :: Point2 -> Point2 -> World -> Set (Int, Int, PathEdge)
 pesNearRect sp ep w = zonesExtract (w ^. cWorld . peZoning) $ zoneOfRect' peZoneSize sp ep
 
-pesNearCirc :: Point2 -> Float -> World -> [(Int, Int, PathEdge)]
+pesNearCirc :: Point2 -> Float -> World -> Set (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)
+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 :: (Int, Int, PathEdge) -> IM.IntMap (IM.IntMap (Set (Int, Int, PathEdge))) -> IM.IntMap (IM.IntMap (Set (Int, Int, PathEdge)))
 zonePe pe im = foldl' f im (zoneOfPe pe)
   where
-    f im' i2 = zoneMonoid i2 [pe] im'
+    f im' i2 = zoneMonoid i2 (Set.singleton pe) im'

src/Dodge/Zoning/Wall.hs

@@ -10,11 +10,11 @@ import Geometry
 import qualified IntMapHelp as IM
 
 wlIXsNearPoint :: Point2 -> World -> IS.IntSet
-wlIXsNearPoint p w = zoneExtract (zoneOfPoint' wlZoneSize p) (w ^. cWorld . wlZoning)
+wlIXsNearPoint p w = zoneExtract (zoneOfPoint wlZoneSize p) (w ^. cWorld . wlZoning)
 
 wlIXsNearSeg :: Point2 -> Point2 -> World -> IS.IntSet
 {-# INLINE wlIXsNearSeg #-}
-wlIXsNearSeg sp ep w = zonesExtract (w ^. cWorld . wlZoning) (zoneOfSeg' wlZoneSize sp ep)
+wlIXsNearSeg sp ep w = zonesExtract (w ^. cWorld . wlZoning) (zoneOfSeg wlZoneSize sp ep)
 
 wlIXsNearRect :: Point2 -> Point2 -> World -> IS.IntSet
 wlIXsNearRect sp ep w = zonesExtract (w ^. cWorld . wlZoning) $ zoneOfRect' wlZoneSize sp ep
@@ -41,7 +41,7 @@ wlZoneSize :: Float
 wlZoneSize = 50
 
 zoneOfWl :: Wall -> [Int2]
-zoneOfWl = uncurry (zoneOfSeg' wlZoneSize) . _wlLine
+zoneOfWl = uncurry (zoneOfSeg wlZoneSize) . _wlLine
 
 --minCrIXOn :: Ord a => (Creature -> a) -> IS.IntSet -> World -> Maybe Creature
 --minCrIXOn f is w = fmap fst $ IS.foldl' g Nothing is