From 207d52a719e72251b32cfb48bdeb8324925c2dda Mon Sep 17 00:00:00 2001
From: justin <justin.g.kruger@gmail.com>
Date: Fri, 1 Jul 2022 16:05:39 +0100
Subject: [PATCH 01/20] Redo collision changes

---
 src/Dodge/Base/Collide.hs         | 245 ++++++++----------------------
 src/Dodge/Item/Weapon/Launcher.hs |   5 +-
 2 files changed, 67 insertions(+), 183 deletions(-)

diff --git a/src/Dodge/Base/Collide.hs b/src/Dodge/Base/Collide.hs
index 03f4237b5..af976a5d5 100644
--- a/src/Dodge/Base/Collide.hs
+++ b/src/Dodge/Base/Collide.hs
@@ -11,33 +11,22 @@
  - -}
 module Dodge.Base.Collide
     ( collidePoint
+    , collideSegCrs
     , collidePointWallsFilterStream
     , collidePointTestFilter
     , overlapSegWalls
+    , overlapSegCrs
+    , overlap1SegCrs
     , bounceBall
     , bouncePoint
     , sortStreamOn
     , minStreamOn
---    , wallsOnCirc
---    , wallsOnCirc'
-    , wallsOnLineHit
     , collideCircWallsStream
-    , collideCircWalls
     , circOnSomeWall
-    , collidePointWallsNorm
-    , collidePointWalls'
+    , circOnAnyCr
     , overlapCircWalls
     , overlapCircWallsClosest
-    , collideCircCrsPoint
-    , collideCircCreatures
-    , collidePointCreatures
-    , collidePointAnyWallsReflect
     , crsNearPoint
-    , crsOnLine
-    , crsOnThickLine
-    , nearestCrInRad
-    , nearestCrInTri
-    , nearestCrInFront
     , allVisibleWalls
 
     , hasLOS
@@ -51,103 +40,111 @@ import Dodge.Data
 import Dodge.Zone
 import Dodge.Base.Wall
 import Geometry
-import FoldableHelp
 
 import Data.Maybe
 import qualified Data.IntMap.Strict as IM
 import Control.Lens
 import Control.Monad
---import qualified FoldlHelp as L
-import Data.Monoid
 import StreamingHelp
 import qualified Streaming.Prelude as S
 
 collidePoint :: Point2 -> Point2 
-    -> Stream (Of Wall) Identity ()
+    -> StreamOf Wall
     -> (Point2, Maybe Wall)
 {-# INLINE collidePoint #-}
 collidePoint sp ep = runIdentity . S.fold_ findPoint (ep, Nothing) id
   where
     findPoint (p,mwl) wl = maybe (p,mwl) (,Just wl) . uncurry (intersectSegSeg sp p) . _wlLine $ wl
 
+overlap1SegCrs :: Point2 -> Point2 
+    -> StreamOf Creature
+    -> StreamOf (Point2, Creature)
+{-# INLINE overlap1SegCrs #-}
+overlap1SegCrs sp ep = S.mapMaybe 
+    (\cr -> (,cr) <$> listToMaybe (intersectCircSeg (_crPos cr) (_crRad cr) sp ep ))
+
+overlapSegCrs :: Point2 -> Point2 
+    -> StreamOf Creature
+    -> StreamOf ([Point2], Creature)
+{-# INLINE overlapSegCrs #-}
+overlapSegCrs sp ep = S.mapMaybe 
+    (\cr -> f cr $ intersectCircSeg (_crPos cr) (_crRad cr) sp ep )
+  where
+    f _  [] = Nothing
+    f cr ps = Just (ps,cr)
+
+collideSegCrs :: Point2 -> Point2 
+    -> StreamOf Creature
+    -> (Point2, Maybe Creature)
+{-# INLINE collideSegCrs #-}
+collideSegCrs sp ep = runIdentity . S.fold_ findPoint (ep, Nothing) id
+  where
+    findPoint (p,mcr) cr 
+        = maybe (p,mcr) (,Just cr) $ listToMaybe (intersectCircSeg (_crPos cr) (_crRad cr) sp p)
+
 doBounce :: Float -> Point2 -> Point2 -> (Point2, Maybe Wall) -> Maybe (Point2, Point2)
+{-# INLINE doBounce #-}
 doBounce x sp ep (p, mwl) = mwl <&> \wl ->
     ( p +.+ normalizeV (vNormal (uncurry (-.-) (_wlLine wl)))
     , reflVelWallDamp x wl (ep -.- sp)
     )
 
 bounceBall :: Float -> Point2 -> Point2 -> Float 
-    -> Stream (Of Wall) Identity ()
+    -> StreamOf Wall
     -> Maybe (Point2,Point2)
+{-# INLINE bounceBall #-}
 bounceBall x sp ep r = doBounce x sp ep . collideCircWallsStream sp ep r
 
 bouncePoint :: (Wall -> Bool) -> Float -> Point2 -> Point2 -> World -> Maybe (Point2,Point2)
+{-# INLINE bouncePoint #-}
 bouncePoint t x sp ep = doBounce x sp ep . collidePointWallsFilterStream t sp ep
 
 -- this COULD be written in terms of collidePointWallsFilterStream, TODO test
 -- whether this is actually faster
-collidePointTestFilter :: (Wall -> Bool) -> Point2 -> Point2 -> Stream (Of Wall) Identity () -> Bool
+collidePointTestFilter :: (Wall -> Bool) -> Point2 -> Point2 -> StreamOf Wall -> Bool
+{-# INLINE collidePointTestFilter #-}
 collidePointTestFilter t sp ep = runIdentity 
     . S.any_ (isJust . uncurry (intersectSegSeg sp ep) . _wlLine)
     . S.filter t
 
 collidePointWallsFilterStream :: (Wall -> Bool) -> Point2 -> Point2 -> World -> (Point2, Maybe Wall)
+{-# INLINE collidePointWallsFilterStream #-}
 collidePointWallsFilterStream t sp ep = collidePoint sp ep
     . S.filter t
     . wlsNearSeg sp ep
 
-overlapSegWalls :: Point2 -> Point2 -> Stream (Of Wall) Identity () 
-    -> Stream (Of (Point2,Wall)) Identity ()
+overlapSegWalls :: Point2 -> Point2 -> StreamOf Wall
+    -> StreamOf (Point2,Wall)
+{-# INLINE overlapSegWalls #-}
 overlapSegWalls sp ep = S.mapMaybe $ \wl -> uncurry (intersectSegSeg sp ep) (_wlLine wl) <&> (,wl)
 
-visibleWalls :: Point2 -> Point2 -> World -> Stream (Of (Point2,Wall)) Identity ()
+visibleWalls :: Point2 -> Point2 -> World -> StreamOf (Point2,Wall)
+{-# INLINE visibleWalls #-}
 visibleWalls sp ep = S.take 1 <=<  -- hlint, was using join and fmap
     ( S.span (not . wlIsOpaque . snd)
     . sortStreamOn (dist sp . fst)
     . overlapSegWalls sp ep
     . wlsNearSeg sp ep    )
 
-allVisibleWalls :: World -> Stream (Of (Point2,Wall)) Identity ()
+allVisibleWalls :: World -> StreamOf (Point2,Wall)
+{-# INLINE allVisibleWalls #-}
 allVisibleWalls w = concats $ S.subst (flip (visibleWalls vPos) w . (+.+ vPos)) $ S.each (nRays 20)
   where
     vPos = _cameraViewFrom w
-
     
-wallsOnLineHit :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap (Point2, Wall)
-wallsOnLineHit p1 p2 = IM.mapMaybe f
-  where
-    f wl = uncurry (intersectSegSeg p1 p2) (_wlLine wl) <&> (, wl)
-
--- | Looks for any collision of a circle with walls.
--- If found, gives point and reflection velocity, reflection damped in normal.
--- note that in this version the circle can overlap the wall
-collidePointAnyWallsReflect :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
-collidePointAnyWallsReflect p1 p2 
-    = getFirst
-    . foldMap (First . findPoint . _wlLine)
-  where 
-    findPoint (x,y) = case intersectSegSeg p1 p2 x y of
-        Just ip -> Just (ip +.+ normalizeV (vNormal (x -.- y)), reflectInParam 0.5 (x -.- y) (p2 -.- p1))
-        Nothing -> Nothing
-
-collidePointWalls' :: (Foldable t, Functor t) => Point2 -> Point2 -> t Wall -> Point2
-{-# INLINE collidePointWalls' #-}
-collidePointWalls' p1 p2 = foldl' findPoint p2 . fmap _wlLine
-  where
-    findPoint p = fromMaybe p . uncurry (intersectSegSeg p1 p)
-
-overlapCircWalls :: Point2 -> Float -> Stream (Of Wall) Identity () 
-    -> Stream (Of (Point2,Wall)) Identity ()
+overlapCircWalls :: Point2 -> Float -> StreamOf Wall
+    -> StreamOf (Point2,Wall)
+{-# INLINE overlapCircWalls #-}
 overlapCircWalls p r = S.mapMaybe dointersect
   where
     dointersect wl = f (_wlLine wl) <&> (,wl)
     f (a,b) = intersectSegSeg p (p -.- r *.* vNormal (normalizeV (a -.- b))) a b
 
--- note that this does not push the circle away from the wall at all
-collideCircWallsStream :: Point2 -> Point2 -> Float -> Stream (Of Wall) Identity ()
+-- | note that this does not push the circle away from the wall at all
+collideCircWallsStream :: Point2 -> Point2 -> Float -> StreamOf Wall
     -> (Point2, Maybe Wall)
-collideCircWallsStream sp ep rad = runIdentity
-    . S.fold_ findPoint (ep, Nothing) id
+{-# INLINE collideCircWallsStream #-}
+collideCircWallsStream sp ep rad = runIdentity . S.fold_ findPoint (ep, Nothing) id
   where
     findPoint (p,mwl) wl = maybe (p,mwl) (,Just wl) . uncurry (intersectSegSeg sp p) 
         . shiftbyrad
@@ -157,142 +154,24 @@ collideCircWallsStream sp ep rad = runIdentity
         ,b +.+ rad *.* normalizeV (b -.-a)
         )
       where
-        f = ((rad *.* normalizeV (vNormal $ a -.- b)) +.+)
+        f = (+.+) (rad *.* normalizeV (vNormal $ a -.- b))
 
-overlapCircWallsClosest :: Point2 -> Float -> Stream (Of Wall) Identity () -> Maybe (Point2,Wall)
+overlapCircWallsClosest :: Point2 -> Float -> StreamOf Wall -> Maybe (Point2,Wall)
+{-# INLINE overlapCircWallsClosest #-}
 overlapCircWallsClosest p r = minStreamOn (dist p . fst)
     . overlapCircWalls p r
 
--- | Looks for first collision of a circle with walls.
--- If found, gives point and reflection velocity, reflection damped in normal.
-collideCircWalls :: Point2 -> Point2 -> Float -> IM.IntMap Wall -> Maybe (Point2,Point2)
-collideCircWalls p1 p2 rad
-    = safeMinimumOn (dist p1 . fst) 
-    . IM.mapMaybe 
-        (( \(x:y:_) -> fmap 
-            ((, reflectInParam 0.5 (x -.- y) (p2 -.- p1)) 
-            . (+.+ normalizeV (vNormal (x -.- y)))
-            ) 
-            (intersectSegSeg p1 p2 x y)
-         ) 
-         . shiftByRad . _wlLine
-        )
-  where 
-    shiftByRad (a,b) = map ((rad *.* normalizeV (vNormal $ a -.- b)) +.+)
-        [a +.+ rad *.* normalizeV (a -.-b)
-        ,b +.+ rad *.* normalizeV (b -.-a)
-        ]
--- this shifts the wall out, and for outer corners extends the wall
--- not sure what this does for inner corners, hopefully won't cause a problem
--- the alternative would be to separately bounce off corner points...
--- unfortunately, doesn't allow for collisions when the circle spawns on the
--- wall
-
-
--- | Looks for first collision of a point with walls.
--- If found, gives point and normal of wall.
-collidePointWallsNorm :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
-collidePointWallsNorm p1 p2 ws 
-    = safeMinimumOn (dist p1 . fst)
-    $ IM.mapMaybe (( \(x,y) -> intersectSegSeg p1 p2 x y <&> ( , vNormal $ x -.- y ) ) 
-        . _wlLine) ws
--- | Returns the first creature, if any, that a point intersects with.
-collidePointCreatures :: Point2 -> Point2 -> IM.IntMap Creature -> Maybe Int
-collidePointCreatures p1 p2 = fmap fst 
-    . safeMinimumOn snd
-    . IM.toList 
-    . IM.mapMaybe (\x -> dist p1 <$> intersectCircSegFirst (_crPos x) (_crRad x) p1 p2) 
--- | As for 'collidePointCreatures', only increases the radius of creatures by a
---fixed amount, thus collides a moving circle with creaures.
-collideCircCreatures :: Point2 -> Point2 -> Float -> IM.IntMap Creature -> Maybe Int
-collideCircCreatures p1 p2 rad = collidePointCreatures p1 p2 . fmap (crRad +~ rad)
-
--- | Returns the first creature id, if any, that a point intersects with, gives point
---in creature on line.
-collidePointCrsPoint :: Point2 -> Point2 -> IM.IntMap Creature -> Maybe (Point2,Int)
-collidePointCrsPoint p1 p2 = fmap f 
-    . safeMinimumOn (dist p1 . snd)
-    . IM.toList 
-    . IM.mapMaybe (\x -> intersectCircSegFirst (_crPos x) (_crRad x) p1 p2) 
-  where 
-    f (cID,p) = (p,cID)
-{- | Finds the first creature hit on a line.
-Maybe evaluates the creature id and hit point. -}
-collideCircCrsPoint :: Point2 -> Point2 -> Float -> IM.IntMap Creature -> Maybe (Point2,Int)
-collideCircCrsPoint p1 p2 rad = collidePointCrsPoint p1 p2 . fmap (crRad +~ rad)
-
----- | Makes a creature not hittable.
---collidePointCrsWithoutPoint :: Int -> Point2 -> Point2 -> World -> Maybe (Point2,Int)
---collidePointCrsWithoutPoint cid p1 p2 w 
---    = fmap f 
---    . safeMinimumOn (snd . snd)
---    . IM.toList 
---    . IM.mapMaybe (\x -> collidePointCirc'' p1 p2 (_crRad x) (_crPos x)) 
---    . IM.delete cid 
---    $ _creatures w
---  where 
---    f (cID,(p,_)) = (p,cID)
 {- | Test if a circle collides with any wall. 
  - Note no check on whether the wall is walkable. -}
 circOnSomeWall :: Point2 -> Float -> World -> Bool
+{-# INLINE circOnSomeWall #-}
 circOnSomeWall p rad = runIdentity . S.any_ (uncurry (circOnSeg p rad) . _wlLine)
     . wlsNearPoint p
---    = any (\(x,y) -> circOnSeg x y p rad) 
---    . fmap _wlLine 
---    . IM.elems 
---    . wallsNearPoint p
 
-{- | Produce an unordered list of creatures on a line. -}
-crsOnLine :: Point2 -> Point2 -> World -> IM.IntMap Creature
-crsOnLine p1 p2
-    = IM.filter (\cr -> segOnCirc p1 p2 (_crPos cr) (_crRad cr))
-    . _creatures
-{- | Produce an unordered list of creatures on a wide line. -}
-crsOnThickLine :: Float -> Point2 -> Point2 -> World -> IM.IntMap Creature
-crsOnThickLine thickness p1 p2
-    = IM.filter (\cr -> segOnCirc p1 p2 (_crPos cr) (_crRad cr + thickness))
-    . _creatures
-{- | Find 'Maybe' the closest creature to a point, within a circle.
- -}
-nearestCrInRad :: Point2 -> Float -> World -> Maybe Creature
-nearestCrInRad p r
-    = safeMinimumOn (dist p . _crPos)
-    . IM.filter (\cr -> dist p (_crPos cr) < r) 
-    . _creatures
-{- | Find 'Maybe' the closest creature in front of a point in a right-angle-triangle shape.  -}
-nearestCrInTri 
-    :: Point2 
-    -> Float    -- ^ Direction (radians +ve anticlockwise from x-axis).
-    -> Float    -- ^ Distance. 
-    -> World -> Maybe Creature
-nearestCrInTri p dir x
-    = safeMinimumOn (dist p . _crPos)
-    . IM.filter (\cr -> pointInPolygon (_crPos cr) tri) 
-    . _creatures
- where 
-    tri = 
-        [p 
-        ,p +.+ rotateV (dir-pi/4) (V2 x 0)
-        ,p +.+ rotateV (dir+pi/4) (V2 x 0)
-        ]
-{- | Find 'Maybe' the closes creature in front of a point in a given direction for
-a given distance.
-The shapes within which creatures are searched are a triangle then rectangle.  -}
-nearestCrInFront 
-    :: Point2
-    -> Float    -- ^ Direction (radians +ve anticlockwise from x-axis).
-    -> Float    -- ^ Distance.
-    -> World -> Maybe Creature
-nearestCrInFront p dir x
-    = safeMinimumOn (dist p . _crPos)
-    . IM.filter (\cr -> pointInPolygon (_crPos cr) rec)
-    . _creatures
-  where 
-    rec = [p, pR, pR1, pL1, pL ]
-    pR  = p +.+ rotateV (dir - pi*(3/8)) (V2 (x/2) 0)
-    pL  = p +.+ rotateV (dir + pi*(3/8)) (V2 (x/2) 0)
-    pR1 = pR +.+ rotateV dir (V2 (x/2) 0)
-    pL1 = pL +.+ rotateV dir (V2 (x/2) 0)
+circOnAnyCr :: Point2 -> Float -> World -> Bool
+{-# INLINE circOnAnyCr #-}
+circOnAnyCr p r = runIdentity . S.any_ (\cr -> dist p (_crPos cr) < r + _crRad cr)
+    . crsNearPoint p
 
 {- | More general collision tests follow -}
 
@@ -309,22 +188,26 @@ hasButtonLOS p1 p2 = not
     . wlsNearSeg p1 p2
 
 hasLOSIndirect :: Point2 -> Point2 -> World -> Bool
+{-# INLINE hasLOSIndirect #-}
 hasLOSIndirect p1 p2 = not
     . collidePointTestFilter wlIsOpaque p1 p2
     . wlsNearSeg p1 p2
 
 isWalkable :: Point2 -> Point2 -> World -> Bool
+{-# INLINE isWalkable #-}
 isWalkable p1 p2 = not 
     . collidePointTestFilter (not . (^?! wlPathable)) p1 p2 
     . wlsNearSeg p1 p2
 
 canSee :: Int -> Int -> World -> Bool
+{-# INLINE canSee #-}
 canSee i j w = hasLOS p1 p2 w
   where 
     p1 = _crPos (_creatures w IM.! i)
     p2 = _crPos (_creatures w IM.! j)
 
 canSeeIndirect :: Int -> Int -> World -> Bool
+{-# INLINE canSeeIndirect #-}
 canSeeIndirect i j w = hasLOSIndirect ipos jpos w
   where 
     ipos = _crPos (_creatures w IM.! i)
diff --git a/src/Dodge/Item/Weapon/Launcher.hs b/src/Dodge/Item/Weapon/Launcher.hs
index 971624c7c..fd1a17562 100644
--- a/src/Dodge/Item/Weapon/Launcher.hs
+++ b/src/Dodge/Item/Weapon/Launcher.hs
@@ -28,6 +28,7 @@ import qualified IntMapHelp as IM
 import ShapePicture
 import Shape
 
+import qualified Streaming.Prelude as S
 --import qualified Data.Set as S
 import qualified Data.Map.Strict as M
 import qualified SDL
@@ -332,9 +333,9 @@ moveRemoteShell cid itid pj w
     doExplosion = explodeRemoteRocket itid i $ stopSoundFrom (ShellSound i) w
 
 anythingHitCirc :: Float -> Point2 -> Point2 -> World -> Bool
-anythingHitCirc rad sp ep w = isJust hitCr || isJust (sequence hitWl)
+anythingHitCirc rad sp ep w = hitCr || isJust (sequence hitWl)
   where
-    hitCr    = collideCircCrsPoint sp ep rad (_creatures w)
+    hitCr    = runIdentity $ S.any_ (const True) $ overlap1SegCrs sp ep $ crsNearSeg sp ep w
     hitWl    = collideCircWallsStream sp ep rad $ wlsNearPoint ep w
                                                     -- this should probably be wallsOnLine or something
     

From 9e9c449fe67252136b20aa7f326f68e69cb0c7bb Mon Sep 17 00:00:00 2001
From: justin <justin.g.kruger@gmail.com>
Date: Fri, 1 Jul 2022 16:23:05 +0100
Subject: [PATCH 02/20] Redo more complex selection positions--results in
 slowdown

---
 src/Dodge/Config/Data.hs         |   4 +-
 src/Dodge/Data.hs                |   5 +-
 src/Dodge/Default/World.hs       |   7 +-
 src/Dodge/Render/ShapePicture.hs | 126 +++++++++++++++++++------------
 src/Dodge/Update.hs              |  17 ++++-
 5 files changed, 102 insertions(+), 57 deletions(-)

diff --git a/src/Dodge/Config/Data.hs b/src/Dodge/Config/Data.hs
index 09cef2ffa..a3f216a0a 100644
--- a/src/Dodge/Config/Data.hs
+++ b/src/Dodge/Config/Data.hs
@@ -21,7 +21,7 @@ data Configuration = Configuration
     , _windowPosY           :: Int
     , _gameplay_rotate_to_wall :: Bool
     , _debug_view_clip_bounds :: RoomClipping
-    , _debug_booleans :: S.Set DebugBool  -- consider using Data.BitSet
+    , _debug_booleans       :: S.Set DebugBool  -- consider using Data.BitSet
     }
   deriving (Generic, Show)
 data DebugBool
@@ -44,6 +44,8 @@ data DebugBool
     | Show_far_wall_detect
     | Show_select
     | Inspect_wall
+    | Show_nodes_near_select
+    | Show_path_between
   deriving (Generic, Eq,Ord,Bounded, Enum, Show)
 data ResFactor = FullRes | HalfRes | QuarterRes
   deriving (Generic, Show, Eq, Ord, Enum, Bounded)
diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs
index b290260d7..cb82f08f7 100644
--- a/src/Dodge/Data.hs
+++ b/src/Dodge/Data.hs
@@ -172,7 +172,10 @@ data World = World
     , _genRooms             :: IM.IntMap Room
     , _deathDelay           :: Maybe Int
     , _testFloat            :: Float
-    , _wSelect              :: (Point2,Point2)
+    , _lLine               :: (Point2,Point2)
+    , _rLine               :: (Point2,Point2)
+    , _lSelect             :: Point2
+    , _rSelect             :: Point2
     }
 data WorldHammer
     = SubInvHam
diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs
index 41420c833..53746c236 100644
--- a/src/Dodge/Default/World.hs
+++ b/src/Dodge/Default/World.hs
@@ -4,6 +4,7 @@ import Dodge.Zone.Size
 import Dodge.Zone.Object
 import Dodge.Base
 import Geometry.Vector3D
+import Geometry.Zone
 --import Dodge.Config.KeyConfig
 --import Dodge.Menu
 --import Picture
@@ -18,6 +19,7 @@ import qualified Data.IntMap.Strict as IM
 import qualified Data.Map as M
 import qualified Data.Set as S
 import Data.Graph.Inductive.Graph hiding ((&))
+--import Data.Graph.Inductive.NodeMap
 --import qualified Data.Vector.Fusion.Stream.Monadic as VS
 defaultWorld :: World
 defaultWorld = World
@@ -111,7 +113,10 @@ defaultWorld = World
     , _testFloat = 0
     , _boundBox = square 100
     , _boundDist = (100,-100,100,-100)
-    , _wSelect      = (0,0)
+    , _lLine  = (0,0)
+    , _rLine  = (0,0)
+    , _lSelect   = 0
+    , _rSelect   = 0
     }
 defaultWorldHammers :: M.Map WorldHammer HammerPosition
 defaultWorldHammers = M.fromSet (const HammerUp) $ S.fromList [minBound.. maxBound]
diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs
index fe3045588..75b42a4da 100644
--- a/src/Dodge/Render/ShapePicture.hs
+++ b/src/Dodge/Render/ShapePicture.hs
@@ -16,6 +16,8 @@ import Dodge.Graph
 import Dodge.GameRoom
 import Dodge.Update.Camera
 import Dodge.Item.Draw
+import Dodge.Render.List
+import Dodge.Path
 --import Dodge.Zone
 import Geometry
 import Geometry.Zone
@@ -28,9 +30,12 @@ import Geometry.ConvexPoly
 --import Data.Foldable
 import qualified Data.IntMap.Strict as IM -- Lazy?
 import qualified Data.Map.Strict as M
+--import qualified Data.Set as Set
 import Control.Lens
 import Data.Maybe
 import qualified Streaming.Prelude as S
+import qualified Data.Graph.Inductive as FGL
+import qualified Data.Set as Set
 
 -- TODO only filter out shapes outside the range of the furthest shown light source
 worldSPic :: Configuration -> World -> SPic
@@ -76,34 +81,54 @@ extraPics cfig w = pictures (_decorations w)
 --    <> runIdentity (S.foldMap_ clDraw (_clouds w))
     <> concatMapPic clDraw (_clouds w      )
     <> concatMapPic ppDraw (_pressPlates w )
-    <> soundPics cfig w
     <> viewClipBounds cfig w
-    <> drawMousePosition cfig w
-    <> drawWallIDs cfig w
-    <> drawPathing cfig w
-    <> drawCrInfo cfig w
-    <> cfigdraw View_boundaries (const viewBoundaries)
-    <> cfigdraw Show_bound_box (const drawBoundingBox)
-    <> cfigdraw Show_wall_search_rays (const drawWallSearchRays)
-    <> cfigdraw Show_dda_test (const drawDDATest)
-    <> cfigdraw Show_far_wall_detect    (const drawFarWallDetect)
-    <> cfigdraw Show_select             (const drawWorldSelect)
-    <> cfigdraw Inspect_wall            (const drawInspectWalls)
-    <> cfigdraw Cr_awareness            (const drawCreatureDisplayTexts)
+    <> debugDraw cfig w
+
+debugDraw :: Configuration -> World -> Picture
+debugDraw cfig w = pic
+    <> setLayer FixedCoordLayer (listPicturesAt (0.5*halfWidth cfig) 0 cfig $ map text ts)
   where
-    cfigdraw boption draw
-        | debugOn boption cfig = draw cfig w
-        | otherwise = mempty
+    (ts, pic) = foldMap (f . debugDraw' cfig w) (_debug_booleans cfig)
+    f (Left s) = ([s],mempty)
+    f (Right pic') = (mempty,pic')
+
+debugDraw' :: Configuration -> World -> DebugBool -> Either String Picture
+debugDraw' cfig w bl = case bl of
+    Noclip      -> Left "Noclip"
+    Remove_LOS  -> Left "No line of sight"
+    Cull_more_lights    -> Left "Cull more lights"
+    Close_shape_culling -> Left "Close shape culling"
+    Bound_box_screen    -> Left "bound box screen, this should be moved"
+    Show_ms_frame           -> Right mempty
+    View_boundaries         -> Right $ viewBoundaries w
+    Show_bound_box          -> Right $ drawBoundingBox w
+    Show_wall_search_rays   -> Right $ drawWallSearchRays w
+    Show_dda_test           -> Right $ drawDDATest w
+    Show_far_wall_detect    -> Right $ drawFarWallDetect w
+    Show_select             -> Right $ drawWorldSelect w
+    Inspect_wall            -> Right $ drawInspectWalls w
+    Cr_awareness            -> Right $ drawCreatureDisplayTexts w
+    Show_sound              -> Right $ pictures $ M.map (soundPic cfig w) $ _playingSounds w
+    Cr_status               -> Right $ drawCrInfo cfig w
+    Mouse_position          -> Right $ drawMousePosition cfig w
+    Walls_info              -> Right $ drawWlIDs cfig w
+    Pathing                 -> Right $ drawPathing cfig w
+    Show_nodes_near_select  -> Right $ drawNodesNearSelect w
+    Show_path_between       -> Right $ drawPathBetween w
 
 drawCreatureDisplayTexts :: World -> Picture
 drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (_creatures w)
 
+drawPathBetween :: World -> Picture
+drawPathBetween _ = mempty
+drawNodesNearSelect :: World -> Picture
+drawNodesNearSelect _ = mempty
 drawInspectWalls :: World -> Picture
 drawInspectWalls w = foldMap (drawInspectWall w) 
     $ filter (isJust . uncurry (intersectSegSeg a b) . _wlLine)
     $ IM.elems $ _walls w
   where
-    (a,b) = _wSelect w
+    (a,b) = _lLine w
 
 drawInspectWall :: World -> Wall -> Picture
 drawInspectWall _ wl = setLayer DebugLayer $ 
@@ -117,10 +142,12 @@ drawInspectWall _ wl = setLayer DebugLayer $
 --    (a,b) = _wSelect w
 
 drawWorldSelect :: World -> Picture
-drawWorldSelect w = setLayer DebugLayer . color cyan 
-    $ line [a,b]
+drawWorldSelect w = setLayer DebugLayer
+    $  color cyan (line [a,b])
+    <> color magenta (line [c,d])
   where
-    (a,b) = _wSelect w
+    (a,b) = _lLine w
+    (c,d) = _rLine w
 
 drawFarWallDetect :: World -> Picture
 drawFarWallDetect w = setLayer DebugLayer 
@@ -196,11 +223,6 @@ mcSPic :: Machine -> SPic
 mcSPic bt = uncurryV translateSPf (_mcPos bt)
     $ rotateSP (_mcDir bt) (_mcDraw bt bt)
 
-soundPics :: Configuration -> World -> Picture
-soundPics cfig w
-    | debugOn Show_sound cfig = pictures $ M.map (soundPic cfig w) $ _playingSounds w
-    | otherwise = []
-
 soundPic :: Configuration -> World -> Sound -> Picture
 soundPic cfig w s = fixedSizePicClampArrow 50 50 thePic p cfig w
   where
@@ -215,23 +237,17 @@ soundPic cfig w s = fixedSizePicClampArrow 50 50 thePic p cfig w
     f x = 1 - 0.5 * (1 - x)
 
 drawMousePosition :: Configuration -> World -> Picture
-drawMousePosition cfig w
-    | not $ debugOn Mouse_position cfig = mempty
-    | otherwise
-        = setLayer FixedCoordLayer . winScale cfig
-            . uncurryV translate p
-            . scale 0.1 0.1
-            . text 
-            $ shortPoint2 mwp 
+drawMousePosition cfig w = setLayer FixedCoordLayer . winScale cfig
+    . uncurryV translate p
+    . scale 0.1 0.1
+    . text 
+    $ shortPoint2 mwp 
   where
     p = worldPosToScreen w mwp
     mwp = mouseWorldPos w
 
-drawWallIDs :: Configuration -> World -> Picture
-drawWallIDs cfig w 
-    | debugOn Walls_info cfig = setLayer FixedCoordLayer 
-        $ foldMap f (_walls w)
-    | otherwise = mempty
+drawWlIDs :: Configuration -> World -> Picture
+drawWlIDs cfig w = setLayer FixedCoordLayer $ foldMap f (_walls w)
   where
     f wl 
         | dist (_crPos $ you w) (fst (_wlLine wl)) > 200 = mempty  -- this should be improved with a better "on screen test"
@@ -243,16 +259,28 @@ drawWallIDs cfig w
       where
         p = worldPosToScreen w $ 0.5 *.* uncurry (+.+) (_wlLine wl)
 
+--edgeToPic :: [Point2] -> PathEdge -> Picture
+--edgeToPic poly pe
+--    | not (pointInPolygon sp poly) && not (pointInPolygon ep poly) = mempty
+--    | null $ _peObstacles pe 
+--                = anarrow green
+--    | hasobstacle BlockObstacle  
+--                = anarrow red
+--    | hasobstacle AutoDoorObstacle = anarrow yellow
+--    | otherwise = anarrow cyan
+--  where
+--    hasobstacle = (`Set.member` _peObstacles pe)
+--    anarrow col = color col $ arrow sp ep
+--    sp = _peStart pe
+--    ep = _peEnd pe
+
 drawPathing :: Configuration -> World -> Picture
-drawPathing cfig w
-    | debugOn Pathing cfig 
-        = setLayer DebugLayer $ 
-        (color green . pictures . map (thickLine 5 . tflat2) $ graphToEdges gr)
-        <> concatMap dispInc (graphToIncidence gr)
-    | otherwise = []
-  where
-    dispInc (p,n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n
-    gr = _pathGraph w
+drawPathing cfig w = setLayer DebugLayer mempty
+--    $  foldMap (edgeToPic (screenPolygon cfig w) . (^?! _3)) (FGL.labEdges gr)
+--    <> concatMap dispInc (graphToIncidence gr)
+--  where
+--    dispInc (p,n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n
+--    gr = _pathGraph w
 
 crDisplayInfo :: Configuration -> World -> Creature -> Maybe (Point2,[String])
 crDisplayInfo cfig w cr 
@@ -274,11 +302,9 @@ crDisplayInfo cfig w cr
     crOnScreen = pointOnScreen cfig w $ _crPos cr
 
 drawCrInfo :: Configuration -> World -> Picture
-drawCrInfo cfig w
-    | debugOn Cr_status cfig = setLayer FixedCoordLayer 
+drawCrInfo cfig w = setLayer FixedCoordLayer 
         $ renderInfoListsAt (2*hw - 400) 0 cfig w
         $ mapMaybe (crDisplayInfo cfig w) $ IM.elems $ _creatures w
-    | otherwise = mempty
   where
     hw = halfWidth cfig
 
diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs
index af3ccbf32..869dfc33e 100644
--- a/src/Dodge/Update.hs
+++ b/src/Dodge/Update.hs
@@ -103,10 +103,19 @@ zoneClouds w = w & clZoning %~ \zn ->
     --runIdentity (S.fold_ (flip $ updateZoning (:)) (zn & znObjects .~ mempty) id (_clouds w))
 
 updateWorldSelect :: World -> World
-updateWorldSelect w = case w ^? mouseButtons . ix ButtonLeft of
-    Nothing     -> w
-    Just False  -> w & wSelect . _1 .~ mouseWorldPos w
-    Just True   -> w & wSelect . _2 .~ mouseWorldPos w
+updateWorldSelect w = f . g $ case (w ^? mouseButtons . ix ButtonLeft, w ^? mouseButtons . ix ButtonRight) of
+    (Nothing   ,Nothing)  -> w
+    (Just False,Nothing)  -> w & lLine . _1 .~ mwp
+    (Just True ,Nothing)  -> w & lLine . _2 .~ mwp
+    (Nothing   ,_)        -> w
+    (Just False,_)        -> w & rLine . _1 .~ mwp
+    (Just True ,_)        -> w & rLine . _2 .~ mwp
+  where
+    mwp = mouseWorldPos w
+    f   | ButtonLeft `M.member` _mouseButtons w = lSelect .~ mwp
+        | otherwise = id
+    g   | ButtonRight `M.member` _mouseButtons w = rSelect .~ mwp
+        | otherwise = id
 
 mcChooseUpdate :: Machine -> Machine -> World -> World
 mcChooseUpdate mc mc'

From 597cef6bd4a3a09f4800bafc837894790132d024 Mon Sep 17 00:00:00 2001
From: justin <justin.g.kruger@gmail.com>
Date: Fri, 1 Jul 2022 18:33:44 +0100
Subject: [PATCH 03/20] Stop drawing debug info (restores speed)

---
 src/Dodge/Render/ShapePicture.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs
index 75b42a4da..0bbc205b5 100644
--- a/src/Dodge/Render/ShapePicture.hs
+++ b/src/Dodge/Render/ShapePicture.hs
@@ -82,7 +82,7 @@ extraPics cfig w = pictures (_decorations w)
     <> concatMapPic clDraw (_clouds w      )
     <> concatMapPic ppDraw (_pressPlates w )
     <> viewClipBounds cfig w
-    <> debugDraw cfig w
+--    <> debugDraw cfig w
 
 debugDraw :: Configuration -> World -> Picture
 debugDraw cfig w = pic

From 516cc6d29e465f9fd11ee1ae2f363a5e6c81cb24 Mon Sep 17 00:00:00 2001
From: justin <justin.g.kruger@gmail.com>
Date: Fri, 1 Jul 2022 18:42:21 +0100
Subject: [PATCH 04/20] Readd PathGraph data

---
 src/Dodge/Data/PathGraph.hs | 28 ++++++++++++++++++++++++++++
 1 file changed, 28 insertions(+)
 create mode 100644 src/Dodge/Data/PathGraph.hs

diff --git a/src/Dodge/Data/PathGraph.hs b/src/Dodge/Data/PathGraph.hs
new file mode 100644
index 000000000..d6f751844
--- /dev/null
+++ b/src/Dodge/Data/PathGraph.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE StrictData #-}
+module Dodge.Data.PathGraph where
+import Geometry.Data
+import Control.Lens
+import Data.Graph.Inductive
+import qualified Data.Set as Set
+import Data.Map.Strict (Map)
+data PathGraph = PathGraph
+    { _pgGraph      :: Gr Point2 PathEdge
+    , _pgNodeMap    :: Map Point2 Int
+    , _pgNodeCount  :: Int
+    , _pgEdgeMap    :: Map (V2 Point2) (Int,Int,PathEdge)
+    }
+data PathEdge = PathEdge
+    {_peStart :: Point2
+    ,_peEnd   :: Point2
+    ,_peObstacles :: Set.Set EdgeObstacle
+    }
+  deriving (Eq,Ord,Show)
+data EdgeObstacle
+    = BlockObstacle
+    | DoorObstacle
+    | AutoDoorObstacle
+    | WallObstacle
+  deriving (Eq,Ord,Show,Bounded,Enum)
+
+makeLenses ''PathGraph

From 4d1f1547bca8935be5352600db15c2cf18ccf9b6 Mon Sep 17 00:00:00 2001
From: justin <justin.g.kruger@gmail.com>
Date: Fri, 1 Jul 2022 18:48:33 +0100
Subject: [PATCH 05/20] Redo PathFrom name change

---
 src/Dodge/Data/Room.hs     |  6 +++---
 src/Dodge/PlacementSpot.hs | 16 ++++++++--------
 src/Dodge/Room/Pillar.hs   |  6 +++---
 src/Dodge/Room/Tanks.hs    |  4 ++--
 4 files changed, 16 insertions(+), 16 deletions(-)

diff --git a/src/Dodge/Data/Room.hs b/src/Dodge/Data/Room.hs
index 3eb0c3da3..fa0296f62 100644
--- a/src/Dodge/Data/Room.hs
+++ b/src/Dodge/Data/Room.hs
@@ -61,12 +61,12 @@ data RPLinkStatus
     | UnusedLink  { _rplsType :: S.Set RoomLinkType }
     | NotLink
   deriving (Eq,Ord,Show)
-data PathEdge = PathFromEdge CardinalPoint Int
+data PathFromEdge = PathFromEdge CardinalPoint Int
   deriving (Eq,Ord,Show)
 
 data RoomPosType 
-    = RoomPosOnPath {_onPathEdges :: S.Set PathEdge}
-    | RoomPosOffPath {_offPathEdges :: S.Set PathEdge}
+    = RoomPosOnPath {_onPathFromEdges :: S.Set PathFromEdge}
+    | RoomPosOffPath {_offPathFromEdges :: S.Set PathFromEdge}
     | RoomPosExLink
     | RoomPosLab Int
   deriving (Eq,Ord,Show)
diff --git a/src/Dodge/PlacementSpot.hs b/src/Dodge/PlacementSpot.hs
index f6ecd3d19..3446d9194 100644
--- a/src/Dodge/PlacementSpot.hs
+++ b/src/Dodge/PlacementSpot.hs
@@ -3,8 +3,8 @@ module Dodge.PlacementSpot
     ( atFstLnkOut
     , rpIsOnPath
     , rpIsOffPath
-    , rpOffPathEdge
-    , rpOnPathEdge
+    , rpOffPathFromEdge
+    , rpOnPathFromEdge
     , useUnusedLnk
     , psRandRanges
     , useRoomPosCond
@@ -82,16 +82,16 @@ rpIsOffPath = any f . _rpType
   where
     f RoomPosOffPath {} = True
     f _ = False
-rpOffPathEdge :: PathEdge -> RoomPos -> Bool
-rpOffPathEdge pe = any f . _rpType
+rpOffPathFromEdge :: PathFromEdge -> RoomPos -> Bool
+rpOffPathFromEdge pe = any f . _rpType
   where
-    f rt = maybe False (pe `elem`) (rt ^? offPathEdges) 
+    f rt = maybe False (pe `elem`) (rt ^? offPathFromEdges) 
 
 -- test whether a roomPos is on the path with a given from edge value
-rpOnPathEdge :: PathEdge -> RoomPos -> Bool
-rpOnPathEdge pe = any f . _rpType
+rpOnPathFromEdge :: PathFromEdge -> RoomPos -> Bool
+rpOnPathFromEdge pe = any f . _rpType
   where
-    f rt = maybe False (pe `elem`) (rt ^? onPathEdges) 
+    f rt = maybe False (pe `elem`) (rt ^? onPathFromEdges) 
 
 resetPLUse :: PlacementSpot -> PlacementSpot
 resetPLUse (PSPos f g fallback) = PSPos f' g fallback
diff --git a/src/Dodge/Room/Pillar.hs b/src/Dodge/Room/Pillar.hs
index dfbaecd44..dc93bb1cb 100644
--- a/src/Dodge/Room/Pillar.hs
+++ b/src/Dodge/Room/Pillar.hs
@@ -24,8 +24,8 @@ blockPillar w' h' = ps0jPushPS (aline tl tr)
     $ ps0jPushPS (aline br bl)
     $ sps0 (aline bl tl)
   where
-    w = w' - 9
-    h = h' - 9
+    w = w' - 10
+    h = h' - 10
     tl = V2 (-w) h
     tr = V2 w h
     br = V2 w (-h)
@@ -70,7 +70,7 @@ roomPillarsSquare = do
   where
     makepill edge = sps (rprBool $ \rp _ -> t edge rp) smallPillar
     t edge rp = any (f edge) (_rpType rp) && _rpPlacementUse rp == 0
-    f edge rpt = maybe False (PathFromEdge edge 0 `S.member`) (rpt ^? offPathEdges)
+    f edge rpt = maybe False (PathFromEdge edge 0 `S.member`) (rpt ^? offPathFromEdges)
 
 roomPillarsPassage :: RandomGen g => State g Room
 roomPillarsPassage = do
diff --git a/src/Dodge/Room/Tanks.hs b/src/Dodge/Room/Tanks.hs
index f5855ab75..864a85bcc 100644
--- a/src/Dodge/Room/Tanks.hs
+++ b/src/Dodge/Room/Tanks.hs
@@ -42,7 +42,7 @@ randEdgeTank = do
                 <>  horPipe 80 0 (70 *.* cardVec edge))))
                     -- 70 is a guess, the true value depends on the distance to the wall
         & plSpot .~ rprBool (\rp _ -> _rpPlacementUse rp == 0
-                && rpOffPathEdge (PathFromEdge edge 0) rp)
+                && rpOffPathFromEdge (PathFromEdge edge 0) rp)
 
 randEdgeTanks :: RandomGen g => Int -> State g [Placement]
 randEdgeTanks i = do
@@ -54,7 +54,7 @@ randEdgeTanks i = do
                 <>  horPipe 80 0 (70 *.* cardVec edge))))
                     -- 70 is a guess, the true value depends on the distance to the wall
         & plSpot .~ rprBool (\rp _ -> _rpPlacementUse rp == 0
-                && rpOffPathEdge (PathFromEdge edge 0) rp)
+                && rpOffPathFromEdge (PathFromEdge edge 0) rp)
 
 tanksPipesRoom :: RandomGen g => State g Room
 tanksPipesRoom = do

From fc5d1348d958d249e9f25e8c7ea505088dfbce75 Mon Sep 17 00:00:00 2001
From: justin <justin.g.kruger@gmail.com>
Date: Fri, 1 Jul 2022 18:54:02 +0100
Subject: [PATCH 06/20] Reremove files

---
 src/Dodge/Debug.hs      | 66 -----------------------------------------
 src/Dodge/Debug/Flag.hs |  3 --
 2 files changed, 69 deletions(-)
 delete mode 100644 src/Dodge/Debug.hs
 delete mode 100644 src/Dodge/Debug/Flag.hs

diff --git a/src/Dodge/Debug.hs b/src/Dodge/Debug.hs
deleted file mode 100644
index 37c62bc36..000000000
--- a/src/Dodge/Debug.hs
+++ /dev/null
@@ -1,66 +0,0 @@
-module Dodge.Debug where
-import Dodge.Data
-import Dodge.Zone
-import Dodge.Base
-import Geometry.Zone
-import Geometry.Data
-import Geometry
-import Picture
-import qualified IntMapHelp as IM
-import qualified Data.IntSet as IS
-
-import qualified Streaming.Prelude as S
-import Control.Lens
-
-drawCircleAtFor :: Point2 -> Int -> World -> World
-drawCircleAtFor p t = drawCircleAtForCol p t white
-
-drawCircleAtForCol :: Point2 -> Int -> Color -> World -> World
-drawCircleAtForCol p t col w = w & props %~
-    IM.insert k Projectile 
-        { _prPos = p
-        , _pjStartPos = p
-        , _pjVel = V2 0 0
-        , _prDraw = \_ -> (,) mempty $ setDepth 20 $ uncurryV translate p $ color col $ circleSolid 20
-        , _pjID = k
-        , _pjUpdate = \_ -> pjTimerF t k
-        }
-  where
-    k = IM.newKey $ _props w
-
-drawLineForCol :: [Point2] -> Int -> Color -> World -> World
-drawLineForCol ps t col w = w & props %~
-    IM.insert k Projectile 
-        { _prPos = head ps
-        , _pjStartPos = head ps
-        , _pjVel = V2 0 0
-        , _prDraw = \_ -> (,) mempty $ setDepth 20 $ color col $ thickLine 5 ps
-        , _pjID = k
-        , _pjUpdate = \_ -> pjTimerF t k
-        }
-  where
-    k = IM.newKey $ _props w
-
-pjTimerF :: Int -> Int -> World -> World
-pjTimerF 0    i = props %~ IM.delete i
-pjTimerF time i = props . ix i . pjUpdate .~ (\_ -> pjTimerF (time - 1) i)
-
-drawDDA :: IM.IntMap IS.IntSet -> Picture
-drawDDA = setLayer BloomLayer . color (withAlpha 0.5 green) . IM.foldlWithKey' f blank
-  where
-    f pic x' ys' = concatMapPic (\y -> polygon (reverse $ rectNSWE (y+50) y x (x+50))) ys `appendPic` pic
-      where
-        x = 50 * fromIntegral x'
-        ys = map ((50 *) . fromIntegral) $ IS.toList ys'
-
-debugWallZoningPic :: World -> Picture
-debugWallZoningPic w = setLayer BloomLayer $ zonesPic `appendPic` wallsPic
-  where
-    --wallsPic = setDepth 25 . color yellow . concatMapPic (drawTheWall . _wlLine) $ IM.elems theWalls
-    wallsPic = setDepth 25 . color yellow . runIdentity . S.foldMap_ (drawTheWall . _wlLine) 
-        $ wlsNearSeg sp ep w
-    drawTheWall (a,b) = thickLine 20 [a,b]
-    zonesPic = setDepth 20 $ drawDDA zones
-    zones = ddaExt wlZoneSize sp ep
-    sp = _crPos $ you w
-    ep = mouseWorldPos w
diff --git a/src/Dodge/Debug/Flag.hs b/src/Dodge/Debug/Flag.hs
deleted file mode 100644
index 68acc80a3..000000000
--- a/src/Dodge/Debug/Flag.hs
+++ /dev/null
@@ -1,3 +0,0 @@
-module Dodge.Debug.Flag
-    where
-

From ca40f315c0dff0d353c636af38300912fe92c1a4 Mon Sep 17 00:00:00 2001
From: justin <justin.g.kruger@gmail.com>
Date: Fri, 1 Jul 2022 18:58:21 +0100
Subject: [PATCH 07/20] Readd block obstruction field

---
 src/Dodge/Data.hs                      | 2 +-
 src/Dodge/Default/Block.hs             | 1 +
 src/Dodge/Placement/PlaceSpot/Block.hs | 1 +
 3 files changed, 3 insertions(+), 1 deletion(-)

diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs
index cb82f08f7..c2fd5ede5 100644
--- a/src/Dodge/Data.hs
+++ b/src/Dodge/Data.hs
@@ -357,7 +357,6 @@ data Creature = Creature
     , _crMvDir          :: Float
     , _crTwist          :: Float
     , _crID             :: Int
-    --, _crPict           :: Creature -> Configuration -> World -> SPic
     , _crPict           :: Creature -> SPic
     , _crSkin           :: CreatureSkin
     , _crUpdate         :: Creature -> World -> World
@@ -945,6 +944,7 @@ data Block = Block
     , _blHP         :: Int
     , _blShadows    :: [Int]   -- a list of blocks/walls? that are not shown when this block exists
     , _blFootprint  :: [Point2]
+    , _blObstructs  :: [(Point2,Point2)]
     , _blPos        :: Point2
     , _blDir        :: Float
     , _blDraw       :: Block -> SPic
diff --git a/src/Dodge/Default/Block.hs b/src/Dodge/Default/Block.hs
index 8d5941d77..c7813c4c8 100644
--- a/src/Dodge/Default/Block.hs
+++ b/src/Dodge/Default/Block.hs
@@ -14,6 +14,7 @@ defaultBlock = Block
     , _blDir       = 0
     , _blDraw      = const mempty
     , _blDeath     = makeBlockDebris
+    , _blObstructs = []
     }
 defaultDirtBlock :: Block
 defaultDirtBlock = defaultBlock & blHP .~ 50
diff --git a/src/Dodge/Placement/PlaceSpot/Block.hs b/src/Dodge/Placement/PlaceSpot/Block.hs
index 671fcd3a1..1aa411e7a 100644
--- a/src/Dodge/Placement/PlaceSpot/Block.hs
+++ b/src/Dodge/Placement/PlaceSpot/Block.hs
@@ -88,6 +88,7 @@ placeLineBlock basePane blockWidth depth a b gw = ( 0
         , _blHP = 1000, _blShadows = shadowsAt i
         , _blDir = 0    -- THIS IS NOT SENSIBLE. TODO rethink block positioning
         , _blFootprint = cornersAt p -- TODO check winding (clockwise, anticlockwise)
+        , _blObstructs = []
         , _blPos = p, _blDraw = const mempty , _blDeath = makeBlockDebris}
     insertBlocks = flip (foldr insertBlock) $ zip is blockCenPs
     ksAtI i = map ( + (wlid + i*4) ) [0,1,2,3]

From 9c7c5e1133904d50a730e9ee1d359ee660a04f84 Mon Sep 17 00:00:00 2001
From: justin <justin.g.kruger@gmail.com>
Date: Fri, 1 Jul 2022 19:05:46 +0100
Subject: [PATCH 08/20] Zone creatures (casues slowdown)

---
 src/Dodge/Update/UsingInput.hs    | 2 +-
 src/Dodge/WorldEvent/ThingsHit.hs | 9 +++------
 2 files changed, 4 insertions(+), 7 deletions(-)

diff --git a/src/Dodge/Update/UsingInput.hs b/src/Dodge/Update/UsingInput.hs
index 89d4b1866..fe3639f4d 100644
--- a/src/Dodge/Update/UsingInput.hs
+++ b/src/Dodge/Update/UsingInput.hs
@@ -33,7 +33,7 @@ updatePressedButtons subinv pkeys w = case subinv of
         | otherwise -> updatePressedButtons' pkeys w
     CombineInventory mi
         | pkeys ^? ix ButtonLeft == Just False
-                -> (maybeexitcombine $ maybe id doCombine mi w) & hammers . ix SubInvHam .~ HammerDown
+                -> maybeexitcombine (maybe id doCombine mi w) & hammers . ix SubInvHam .~ HammerDown
     DisplayTerminal tmid
         | pkeys ^? ix ButtonLeft == Just False && inTermFocus w 
                 -> doTerminalEffectLB (w ^?! terminals . ix tmid) w
diff --git a/src/Dodge/WorldEvent/ThingsHit.hs b/src/Dodge/WorldEvent/ThingsHit.hs
index 18214e99e..882938247 100644
--- a/src/Dodge/WorldEvent/ThingsHit.hs
+++ b/src/Dodge/WorldEvent/ThingsHit.hs
@@ -1,10 +1,9 @@
-{-# LANGUAGE TupleSections #-}
+--{-# LANGUAGE TupleSections #-}
 {- |
 Find which objects lie upon a line.
  -}
 module Dodge.WorldEvent.ThingsHit
     ( thingsHit
---    , wallsHit
     , thingHit
     , thingsHitExceptCr
     )
@@ -14,7 +13,7 @@ import Dodge.Base
 import Dodge.Zone
 import Geometry
 
-import Data.Maybe
+--import Data.Maybe
 import Data.Bifunctor
 import StreamingHelp
 import qualified Streaming.Prelude as S
@@ -33,9 +32,7 @@ crsHit :: Point2 -> Point2 -> World -> StreamOf (Point2, Creature)
 crsHit sp ep
     | sp == ep  = const mempty
     | otherwise = sortStreamOn (dist sp . fst)
-        . S.mapMaybe 
-            (\cr -> (, cr) <$> listToMaybe (intersectCircSeg (_crPos cr) (_crRad cr) sp ep))
---        . S.each . _creatures
+        . overlap1SegCrs sp ep
         . crsNearSeg sp ep
 
 thingHit :: Point2 -> Point2 -> World -> Maybe (Point2, Either Creature Wall)

From 749f206af0ac47fa6fafa7877c97f75b41325385 Mon Sep 17 00:00:00 2001
From: justin <justin.g.kruger@gmail.com>
Date: Fri, 1 Jul 2022 19:57:49 +0100
Subject: [PATCH 09/20] Redo cloud zoning as in master

---
 src/Dodge/Update.hs | 6 ++++--
 1 file changed, 4 insertions(+), 2 deletions(-)

diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs
index 869dfc33e..276676dad 100644
--- a/src/Dodge/Update.hs
+++ b/src/Dodge/Update.hs
@@ -98,8 +98,10 @@ functionalUpdate cfig w = checkEndGame
     $ updateCloseObjects w
 
 zoneClouds :: World -> World
-zoneClouds w = w & clZoning %~ \zn ->
-    foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty) (_clouds w)
+zoneClouds w = w 
+    & clZoning . znObjects .~ mempty
+    & clZoning %~ \zn ->
+        foldl' (flip $ updateZoning (:)) zn (_clouds w)
     --runIdentity (S.fold_ (flip $ updateZoning (:)) (zn & znObjects .~ mempty) id (_clouds w))
 
 updateWorldSelect :: World -> World

From 0524f3bd2e410a4332b08329aee99aeb65589a40 Mon Sep 17 00:00:00 2001
From: justin <justin.g.kruger@gmail.com>
Date: Fri, 1 Jul 2022 20:03:37 +0100
Subject: [PATCH 10/20] Redo zoning functions/inlining

---
 src/Dodge/Zone.hs | 45 +++++++++++++++++++++++----------------------
 1 file changed, 23 insertions(+), 22 deletions(-)

diff --git a/src/Dodge/Zone.hs b/src/Dodge/Zone.hs
index aa7ade821..3384cfbc7 100644
--- a/src/Dodge/Zone.hs
+++ b/src/Dodge/Zone.hs
@@ -9,8 +9,6 @@ module Dodge.Zone
     , crsNearSeg
     , wlsInsideCirc
     , crsInsideCirc
-    , lookLookups
-    , zoneNearPointIP
     , clZoneOfPoint
     , crZoneOfPoint
     , wlZoneOfPoint
@@ -30,31 +28,25 @@ import Geometry.Zone
 import qualified Streaming.Prelude as S
 import StreamingHelp
 import Data.Maybe
-import qualified Data.IntMap.Strict as IM
 import Control.Lens
 
 extractFromZone :: Zoning t a -> Int2 -> Maybe (t a)
+{-# INLINE extractFromZone #-}
 extractFromZone zn (V2 x y) = zn ^? znObjects . ix x . ix y
 
 streamFromZone :: Foldable t => Zoning t a -> StreamOf Int2 -> StreamOf a
+{-# INLINE streamFromZone #-}
 streamFromZone zn = S.concat . S.mapMaybe (extractFromZone zn)
 
-
-zoneNearPointIP :: Point2 -> [(Int,Int)]
-zoneNearPointIP p = [(a,b) | a <- [x-1..x+1] , b <- [y-1..y+1] ]
-  where
-    V2 x y = wlZoneOfPoint p
-
 zoneAroundPoint :: Float -> Point2 -> StreamOf Int2
+{-# INLINE zoneAroundPoint #-}
 zoneAroundPoint s p = S.each [V2 a b | a <- [x-1..x+1] , b <- [y-1..y+1] ]
   where
     V2 x y = zoneOfPoint s p
 
---zoneOfBounds :: Float -> (Float,Float,Float,Float) -> Stream (Of Int2) Identity ()
---zoneOfBounds x (n,s,e,w) = ddaSqStream x (V2 n e) (V2 s w)
-
 -- this is ugly, might be better with zoneOfBounds or somesuch
 zoneOfSight :: Float -> World -> Stream (Of (V2 Int)) Identity () --(Int,Int)]
+{-# INLINE zoneOfSight #-}
 zoneOfSight x' w = S.each
     [V2 a b 
         | a <- [minimum xs .. maximum xs]
@@ -67,15 +59,6 @@ zoneOfSight x' w = S.each
       where
         f = floor . (/ s)
 
-lookLookup :: Int -> Int -> IM.IntMap (IM.IntMap a) -> Maybe a
-lookLookup i j z = case IM.lookup i z of
-    Just z' -> IM.lookup j z'
-    Nothing -> Nothing
-
-lookLookups :: [(Int,Int)] -> IM.IntMap (IM.IntMap a) -> [a]
-lookLookups xs z = mapMaybe (flip (uncurry lookLookup) z) xs
-
-
 nearPoint :: (Foldable t,Monoid (t a)) 
     => (World -> Zoning t a) -> Point2 -> World -> StreamOf a
 {-# INLINE nearPoint #-}
@@ -83,42 +66,60 @@ nearPoint f p w = S.each . fromMaybe mempty $ extractFromZone zn (zoneOfPoint (_
   where
     zn = f w
 
+aroundPoint :: Foldable t => (World -> Zoning t a) -> Point2 -> World -> StreamOf a
+{-# INLINE aroundPoint #-}
+aroundPoint f p w = streamFromZone zn $ zoneAroundPoint (_znSize zn) p
+  where
+    zn = f w
+
 clsNearPoint :: Point2 -> World -> StreamOf Cloud
+{-# INLINE clsNearPoint #-}
 clsNearPoint = nearPoint _clZoning
 
 wlsNearPoint :: Point2 -> World -> StreamOf Wall
+{-# INLINE wlsNearPoint #-}
 wlsNearPoint = nearPoint _wlZoning
 
 crsNearPoint :: Point2 -> World -> StreamOf Creature
+{-# INLINE crsNearPoint #-}
 crsNearPoint = nearPoint _crZoning
 
 nearSeg :: Foldable t => (World -> Zoning t a) -> Point2 -> Point2 -> World -> StreamOf a
+{-# INLINE nearSeg #-}
 nearSeg f p r w = streamFromZone zn $ zoneOfSeg (_znSize zn) p r
   where
-    zn = (f w)
+    zn = f w
 
 wlsNearSeg :: Point2 -> Point2 -> World -> Stream (Of Wall) Identity ()
+{-# INLINE wlsNearSeg #-}
 wlsNearSeg = nearSeg _wlZoning
 
 crsNearSeg :: Point2 -> Point2 -> World -> StreamOf Creature
+{-# INLINE crsNearSeg #-}
 crsNearSeg = nearSeg _crZoning
 
 insideCirc :: Foldable t => (World -> Zoning t a) -> Point2 -> Float -> World -> StreamOf a
+{-# INLINE insideCirc #-}
 insideCirc f p r w = streamFromZone zn $ zoneInsideCirc (_znSize zn) p r
   where
     zn = f w
 
 wlsInsideCirc :: Point2 -> Float -> World -> Stream (Of Wall) Identity ()
+{-# INLINE wlsInsideCirc #-}
 wlsInsideCirc = insideCirc _wlZoning
 
 crsInsideCirc :: Point2 -> Float -> World -> StreamOf Creature
+{-# INLINE crsInsideCirc #-}
 crsInsideCirc = insideCirc _crZoning
 
 wlZoneOfPoint :: Point2 -> Int2
+{-# INLINE wlZoneOfPoint #-}
 wlZoneOfPoint = zoneOfPoint wlZoneSize
 
 clZoneOfPoint :: Point2 -> Int2
+{-# INLINE clZoneOfPoint #-}
 clZoneOfPoint = zoneOfPoint clZoneSize
 
 crZoneOfPoint :: Point2 -> Int2
+{-# INLINE crZoneOfPoint #-}
 crZoneOfPoint = zoneOfPoint crZoneSize

From 12f409fff38fdc27d12b09969335c136ba09babf Mon Sep 17 00:00:00 2001
From: justin <justin.g.kruger@gmail.com>
Date: Fri, 1 Jul 2022 20:04:35 +0100
Subject: [PATCH 11/20] Finish redoing zoning functions (add exports)

---
 src/Dodge/Zone.hs | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/src/Dodge/Zone.hs b/src/Dodge/Zone.hs
index 3384cfbc7..78ffd3fed 100644
--- a/src/Dodge/Zone.hs
+++ b/src/Dodge/Zone.hs
@@ -1,7 +1,9 @@
 module Dodge.Zone
     ( zoneOfSight
     , zoneAroundPoint
+    , aroundPoint
     , nearPoint
+    , nearSeg
     , wlsNearPoint
     , crsNearPoint
     , clsNearPoint

From 3eb26e86a8251bb5a3f1b7e54f9cd84a318d81fd Mon Sep 17 00:00:00 2001
From: justin <justin.g.kruger@gmail.com>
Date: Fri, 1 Jul 2022 20:06:25 +0100
Subject: [PATCH 12/20] Redo zone size/update

---
 src/Dodge/Zone/Size.hs   |  3 +++
 src/Dodge/Zone/Update.hs | 15 ++++-----------
 2 files changed, 7 insertions(+), 11 deletions(-)

diff --git a/src/Dodge/Zone/Size.hs b/src/Dodge/Zone/Size.hs
index 16fda43e3..1b4c1351a 100644
--- a/src/Dodge/Zone/Size.hs
+++ b/src/Dodge/Zone/Size.hs
@@ -1,5 +1,8 @@
 module Dodge.Zone.Size where
 
+pnZoneSize :: Float
+pnZoneSize = 100
+
 wlZoneSize :: Float
 wlZoneSize = 50
 
diff --git a/src/Dodge/Zone/Update.hs b/src/Dodge/Zone/Update.hs
index 1bbfa09be..c3fdba974 100644
--- a/src/Dodge/Zone/Update.hs
+++ b/src/Dodge/Zone/Update.hs
@@ -1,4 +1,6 @@
-module Dodge.Zone.Update where
+module Dodge.Zone.Update 
+    ( updateZoning
+    ) where
 import Dodge.Data.Zoning
 import StreamingHelp
 import qualified Streaming.Prelude as S
@@ -7,20 +9,11 @@ import Geometry
 import LensHelp
 
 updateZoning :: Monoid (t a) => (a -> t a -> t a) -> a -> Zoning t a -> Zoning t a
+{-# INLINE updateZoning #-}
 updateZoning 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

From e0b63468fcced1a0ec245d89adfe8717ad09cc00 Mon Sep 17 00:00:00 2001
From: justin <justin.g.kruger@gmail.com>
Date: Fri, 1 Jul 2022 20:11:10 +0100
Subject: [PATCH 13/20] Redo Geometry.Zone (restrict exports, inlining)

---
 src/FoldableHelp.hs  |   1 -
 src/Geometry/Zone.hs | 208 +++----------------------------------------
 2 files changed, 10 insertions(+), 199 deletions(-)

diff --git a/src/FoldableHelp.hs b/src/FoldableHelp.hs
index 4ad1da0ae..e5dff9d2d 100644
--- a/src/FoldableHelp.hs
+++ b/src/FoldableHelp.hs
@@ -15,7 +15,6 @@ import Data.Foldable
 
 import qualified Control.Foldl as L
 
-
 -- TODO check up whether and how it is necessary to specialise this
 -- | A version of 'minimum' where the comparison is done on some extracted value.
 --   Returns Nothing if the list is empty.
diff --git a/src/Geometry/Zone.hs b/src/Geometry/Zone.hs
index 1c4a24705..68f40aa71 100644
--- a/src/Geometry/Zone.hs
+++ b/src/Geometry/Zone.hs
@@ -1,11 +1,6 @@
 --{-# LANGUAGE TupleSections #-}
 module Geometry.Zone
-    ( ddaExt
-    , ddaExt'
-    , ddaSq
-    , ddaSqStream
-    , ddaStream
-    , ddaStreamX
+    ( ddaStreamX
     , ddaStreamY
     , xIntercepts
     , yIntercepts
@@ -19,60 +14,13 @@ import Geometry.Vector
 
 import StreamingHelp
 import qualified Streaming.Prelude as S
-import Data.Foldable
-import qualified Data.IntMap.Strict as IM
-import qualified Data.IntSet as IS
---import Control.Monad
-
---foldl2'
---    :: (b -> a -> a -> b) 
---    -> b 
---    -> [a]
---    -> b
---foldl2' f s (t:ts) = fst $ foldl' g (s, t) ts
---  where
---    g (r,x) y = (f r x y,y)
---foldl2' _ s _ = s
-
---sortArguments 
---    :: Ord a 
---    => (a -> a -> b)
---    -> a -> a -> b
---sortArguments f x y
---    | x < y = f x y
---    | otherwise = f y x
---sortArgumentsReverse
---    :: Ord a 
---    => (a -> a -> [b])
---    -> a -> a -> [b]
---sortArgumentsReverse f x y
---    | x < y = f x y
---    | otherwise = reverse $ f y x
---
---intervalBounds
---    :: Float    -- ^ interval threshold
---    -> Float    -- ^ First endpoint
---    -> Float    -- ^ Second endpoint
---    -> [Float]
---intervalBounds = sortArgumentsReverse . f
---  where 
---    f r a b 
---        | x > b = [a]
---        | otherwise = (a : [x,x+r..b])
---      where
---        x = floorTo r a + r
-
---floorTo :: Float -> Float -> Float
---floorTo r x = r * (fromIntegral ((floor $ x / r) :: Int))
-
---ceilingTo :: Float -> Float -> Float
---ceilingTo r x = r * (fromIntegral ((ceiling $ x / r) :: Int))
 
 divTo :: Float -> Float -> Int
 {-# INLINE divTo #-}
 divTo s = floor . (/s)
 
 modTo :: Float -> Float -> Float
+{-# INLINE modTo #-}
 modTo s x = x - s * fromIntegral (divTo s x)
 
 --remTo :: Float -> Float -> Float
@@ -82,75 +30,13 @@ modTo s x = x - s * fromIntegral (divTo s x)
 --{-# INLINE quotTo #-}
 --quotTo s = truncate . (/s)
 
-
---flipV :: Point2 -> Point2
---{-# INLINE flipV #-}
---flipV (V2 a b) = V2 b a
-
---applyInverted 
---    :: (Point2 -> Point2 -> [Point2])
---    -> Point2 -> Point2 -> [Point2]
---applyInverted f sp@(V2 sx sy) ep@(V2 ex ey)
---    | abs (sx-ex) > abs (sy-ey) = f sp ep
---    | otherwise = map flipV $ f (flipV sp) (flipV ep)
-
 zoneOfPoint :: Float -> Point2 -> V2 Int
 {-# INLINE zoneOfPoint #-}
 zoneOfPoint s = fmap (divTo s)
 
---increasingInterval :: Int -> Int -> [Int]
---increasingInterval x y
---    | y > x = [x .. y]
---    | otherwise = [y .. x]
-
--- | Determines a "square" zone of points for a line
-ddaSq :: Float -> V2 Float -> V2 Float -> IM.IntMap IS.IntSet
-ddaSq s (V2 sx sy) (V2 ex ey) = IM.fromSet (const ys) xs
-  where
-    maxMin a b | a >= b = (a,b)
-        | otherwise = (b,a)
-    (maxx,minx) = maxMin (divTo s sx) (divTo s ex)
-    (maxy,miny) = maxMin (divTo s sy) (divTo s ey)
-    xs = IS.fromDistinctAscList [minx-1..maxx+1]
-    ys = IS.fromDistinctAscList [miny-1..maxy+1]
-
---ddaSqStream :: Monad m => Float -> V2 Float -> V2 Float -> Stream (Of (V2 Int)) m ()
---ddaSqStream s (V2 sx sy) (V2 ex ey) = S.each [V2 x y | x <- [minx..maxx], y <- [miny..maxy]]
---  where
---    maxMin a b | a >= b = (a,b)
---        | otherwise = (b,a)
---    (maxx,minx) = maxMin (divTo s sx) (divTo s ex)
---    (maxy,miny) = maxMin (divTo s sy) (divTo s ey)
-
--- | Determines which horizontal and vertical lines on a grid are crossed by a
--- line. For each adds the x-y index of the square to the right or above the
--- crossed grid line. Also adds the index of the square containing the start
--- point.
-ddaExt' :: Float -> V2 Float -> V2 Float -> IM.IntMap IS.IntSet
-ddaExt' s sp@(V2 sx sy) ep@(V2 ex ey) 
-    | x1 <= x2 = addsp . addys . IM.fromDistinctAscList $ zip [x1 .. x2] 
-                    $ map (IS.singleton . divTo s) [x1y,x1y+ydx..]
-    | otherwise = ddaExt' s ep sp
-  where
-    addsp im = let V2 x y = zoneOfPoint s sp
-        in insertXY im (x,y)
-    x1 = divTo s sx
-    x2 = divTo s ex
-    x1y = fx' sp ep $ s * fromIntegral x1
-    ydx = s * ydx' sp ep
-    addys m = add2s m ypairs 
-    y1 = divTo s sy
-    y2 = divTo s ey
-    y1x = fy' sp ep $ s * fromIntegral y1
-    y2x = fy' sp ep $ s * fromIntegral y2
-    xdy = s * xdy' sp ep
-    ypairs 
-        | y1 <= y2  = zip (map (divTo s) [y1x,y1x+xdy..])
-                         [y1 .. y2] 
-        | otherwise = zip (map (divTo s) [y2x,y2x+xdy..])
-                         [y2-1 .. y1-1] 
-ddaSqStream :: Float -> Point2 -> Point2 -> Stream (Of (V2 Int)) Identity ()
-ddaSqStream s sp ep = S.each [V2 x y | x <- makeInterval sx ex, y <- makeInterval sy ey]
+zoneOfRect :: Float -> Point2 -> Point2 -> Stream (Of (V2 Int)) Identity ()
+{-# INLINE zoneOfRect #-}
+zoneOfRect s sp ep = S.each [V2 x y | x <- makeInterval sx ex, y <- makeInterval sy ey]
   where
     V2 sx sy = zoneOfPoint s sp
     V2 ex ey = zoneOfPoint s ep
@@ -161,13 +47,12 @@ makeInterval x y
     | 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)
+{-# INLINE zoneInsideCirc #-}
+zoneInsideCirc x p r = zoneOfRect 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)
+{-# INLINE zoneOfSeg #-}
+zoneOfSeg s sp ep = S.map (zoneOfPoint s)
     $  S.yield sp
     <> xIntercepts s sp ep
     <> yIntercepts s sp ep
@@ -193,80 +78,7 @@ xIntercepts s (V2 sx sy) (V2 ex ey)
         | otherwise = s + sx - modTo s sx
 
 yIntercepts :: Float -> Point2 -> Point2 -> Stream (Of Point2) Identity ()
+{-# INLINE yIntercepts #-}
 yIntercepts s sp ep = S.map f $ xIntercepts s (f sp) (f ep)
   where
     f (V2 x y) = V2 y x
-
-
--- | Determines which horizontal and vertical lines on a grid are crossed by a
--- line. For each adds the x-y index of the square to the right or above the
--- crossed grid line. Also adds the index of the square containing the start
--- point.
--- Not correct, eg ddaExt 10 (V2 40 50) (V2 0 0)
-ddaExt :: Float -> V2 Float -> V2 Float -> IM.IntMap IS.IntSet
-ddaExt s sp@(V2 sx sy) ep@(V2 ex ey) 
-    | x1 <= x2 = addsp . addys . IM.fromDistinctAscList $ zip [x1 .. x2] 
-                    $ map (IS.singleton . divTo s) [x1y,x1y+ydx..]
-    | otherwise = addsp . addys . IM.fromDistinctAscList $ zip [x2-1 .. x1-1]
-                    $ map (IS.singleton . divTo s) [x2y,x2y+ydx..]
-  where
-    addsp im = let V2 x y = zoneOfPoint s sp
-        in insertXY im (x,y)
-    x1 = divTo s sx
-    x2 = divTo s ex
-    x1y = fx' sp ep $ s * fromIntegral x1
-    x2y = fx' sp ep $ s * fromIntegral x2
-    ydx = s * ydx' sp ep
-    addys m = add2s m ypairs 
-    y1 = divTo s sy
-    y2 = divTo s ey
-    y1x = fy' sp ep $ s * fromIntegral y1
-    y2x = fy' sp ep $ s * fromIntegral y2
-    xdy = s * xdy' sp ep
-    ypairs 
-        | y1 <= y2  = zip (map (divTo s) [y1x,y1x+xdy..])
-                         [y1 .. y2] 
-        | otherwise = zip (map (divTo s) [y2x,y2x+xdy..])
-                         [y2-1 .. y1-1] 
-
-ydx' :: Point2 -> Point2 -> Float
-{-# INLINE ydx' #-}
-ydx' (V2 sx sy) (V2 ex ey)
-    | sx == ex = 0
-    | otherwise = (ey - sy) / (ex - sx)
-fx' :: Point2 -> Point2 -> Float -> Float
-{-# INLINE fx' #-}
-fx' sp@(V2 sx sy) ep@(V2 _ ey) x
-    | sy == ey = sy
-    | otherwise = sy + ydx' sp ep * (x - sx)
-
-xdy' :: Point2 -> Point2 -> Float
-{-# INLINE xdy' #-}
-xdy' (V2 sx sy) (V2 ex ey)
-    | sy == ey = 0
-    | otherwise = (ex - sx) / (ey - sy)
-fy' :: Point2 -> Point2 -> Float -> Float
-{-# INLINE fy' #-}
-fy' sp@(V2 sx sy) ep@(V2 ex _) y
-    | sx == ex = sx
-    | otherwise = sx + xdy' sp ep * (y - sy)
-
-add2s :: IM.IntMap IS.IntSet -> [(Int,Int)] -> IM.IntMap IS.IntSet
-{-# INLINE add2s #-}
-add2s = foldl' 
-    (\m (k,x) -> IM.insertWith (\_ old -> IS.insert x old) k (IS.singleton x) m)
-
-insertXY :: IM.IntMap IS.IntSet -> (Int,Int) -> IM.IntMap IS.IntSet
-{-# INLINE insertXY #-}
-insertXY m (k,x) = IM.insertWith (\_ old -> IS.insert x old) k (IS.singleton x) m
-
---addV2s :: IM.IntMap IS.IntSet -> [V2 Int] -> IM.IntMap IS.IntSet
---{-# INLINE addV2s #-}
---addV2s imis = foldl' 
---    (\m (V2 k x) -> IM.insertWith (\_ old -> IS.insert x old) k (IS.singleton x) m)
---    imis
-
---pairsToIntMapSet :: [V2 Int] -> IM.IntMap IS.IntSet
---pairsToIntMapSet = foldl' 
---    (\m (V2 k x) -> IM.insertWith (\_ old -> IS.insert x old) k (IS.singleton x) m)
---    IM.empty

From e9e72594c030c5ac73ac9b8dbb81c1cf0c362f37 Mon Sep 17 00:00:00 2001
From: justin <justin.g.kruger@gmail.com>
Date: Fri, 1 Jul 2022 20:15:04 +0100
Subject: [PATCH 14/20] Resplit Picture

---
 src/Picture.hs           | 372 +-------------------------------------
 src/Picture/Base.hs      | 373 +++++++++++++++++++++++++++++++++++++++
 src/Picture/Composite.hs |  16 ++
 3 files changed, 395 insertions(+), 366 deletions(-)
 create mode 100644 src/Picture/Base.hs
 create mode 100644 src/Picture/Composite.hs

diff --git a/src/Picture.hs b/src/Picture.hs
index d216ec0b4..8f0f26bac 100644
--- a/src/Picture.hs
+++ b/src/Picture.hs
@@ -1,373 +1,13 @@
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE BangPatterns  #-}
+--{-# LANGUAGE TupleSections #-}
+--{-# LANGUAGE BangPatterns  #-}
 module Picture
     ( module Picture.Data
+    , module Picture.Base
+    , module Picture.Composite
     , module Color
-    , blank
-    , polygon
-    , polygonWire
-    , polygonZ
-    , polygonCol
-    , poly3
-    , poly3Col
-    , bezierQuad
-    , arc
-    , arcSolid
-    , thickArc
-    , thickCircle
-    , thickLine
-    , lineThick
-    , thickLineCol
-    , circleSolid
-    , circleSolidCol
-    , circle
-    , line
-    , lineCol
-    , text
-    , centerText
-    , stackText
-    , pictures
-    , concatMapPic
-    , appendPic
-    , tranRot
-    , translate
-    , translate3
-    , rotate
-    , scale
-    , color
-    , zeroZ
-    , setDepth
-    , addDepth
-    , setLayer
-    , mirroryz
-    , mirrorxz
     )
   where
-import Geometry
 import Picture.Data
+import Picture.Base
+import Picture.Composite
 import Color
-
-blank :: Picture
-{-# INLINE blank #-}
-blank = []
-
-polygonWire :: [Point2] -> Picture
-{-# INLINE polygonWire #-}
-polygonWire ps = line (ps ++ [head ps])
-
--- | Expects clockwise input.
-polygon :: [Point2] -> Picture
-{-# INLINE polygon #-}
-polygon = map f . polyToTris
-  where
-    f (V2 x y) = Verx (V3 x y 0) black [] BottomLayer polyNum
-
-polygonZ :: [Point2] -> Float -> Picture
-{-# INLINE polygonZ #-}
-polygonZ ps z = map (f . zeroZ) $ polyToTris ps
-  where
-    f pos = Verx pos black [z] BottomLayer polyzNum
-
-polygonCol :: [(Point2,RGBA)] -> Picture
-{-# INLINE polygonCol #-}
-polygonCol = polyToTris . map f
-  where
-    f (V2 x y,col) = Verx (V3 x y 0) col [] BottomLayer polyNum
-
-poly3 :: [Point3] -> Picture
-{-# INLINE poly3 #-}
-poly3 = poly3Col . map (, black)
-
-poly3Col :: [(Point3,RGBA)] -> Picture
-{-# INLINE poly3Col #-}
-poly3Col = map f . polyToTris
-  where
-    f (pos,col) = Verx pos col [] BottomLayer polyNum
-
--- note that much of work computing the width of the bezier curve is done here
-bezierQuad :: Color -> Color -> Float -> Float -> Point2 -> Point2 -> Point2 -> Picture
-bezierQuad cola colc ra rc a b c 
-    | a == b && b == c = blank
-    | a == b || b == c = bezierQuad cola colc ra rc a (0.5 *.* (a +.+ c)) c
-    | otherwise = bzhelp
-        [(aIn, cola, V2 (fa aIn) (fc aIn) , V2 1        0         )
-        ,(aIn, cola, V2 (fa aIn) (fc aIn) , V2 1        0         )
-        ,(cIn, colc, V2 (fa cIn) (fc cIn) , V2 0        1         )
-        ,( aX, cola, V2 1        0        , V2 (fa' aX) (fc' aX)  )
-        ,( cX, colc, V2 0        1        , V2 (fa' cX) (fc' cX)  )
-        ,( bX, colb, V2 0        0        , V2 (fa' bX) (fc' bX)  )
-        ,( bX, colb, V2 0        0        , V2 (fa' bX) (fc' bX)  )
-        ]
-  where 
-    colb = mixColors 0.5 0.5 cola colc
-    b2a | isLHS a b c = a -.- b
-        | otherwise   = b -.- a
-    aRadVec = 0.5 * ra *.* normalizeV (vNormal b2a)
-    aX  = a -.- aRadVec
-    aIn = a +.+ aRadVec
-    b2c | isLHS a b c = b -.- c
-        | otherwise   = c -.- b
-    cRadVec = 0.5 * rc *.* normalizeV (vNormal b2c)
-    cX  = c -.- cRadVec
-    cIn = c +.+ cRadVec
-    bRadVec = 0.25 * (ra + rc) *.* normalizeV (a +.+ b -.- 2 *.* c)
-    bX  = b +.+ bRadVec
-    bIn = b -.- bRadVec
-    fa = extrapolate aX cX bX 
-    fc = extrapolate cX aX bX
-    fa' = extrapolate aIn cIn bIn
-    fc' = extrapolate cIn aIn bIn
-
-bzhelp :: [(Point2, Point4, Point2, Point2)] -> Picture
-bzhelp = map f
-  where
-    f (V2 x y,col,V2 a b,V2 c d) = Verx (V3 x y 0) col [a,b,c,d] BottomLayer bezNum
-
--- given a one and two zeros of a linear function over x and y,
--- determine the function
--- so if f(ox,oy) = 1 and f(ax,ay) = f(bx,by) = 0, determines f
-extrapolate :: Point2 -> Point2 -> Point2 -> Point2 -> Float
-extrapolate (V2 ox oy) (V2 ax ay) (V2 bx by) (V2 x y) = 
-    (       x * ( ay - by )
-        +   y * ( bx - ax )
-        +   (ax * by - bx * ay)
-    ) 
-    / 
-    (       ox * ( ay - by )
-        +   ax * ( by - oy )
-        +   bx * ( oy - ay )
-    )
-
-color :: RGBA -> Picture -> Picture
-{-# INLINE color #-}
-color c = map $ overCol (const c)
-
-translateH :: Float -> Float -> Point3 -> Point3
-{-# INLINE translateH #-}
-translateH !a !b (V3 x y z) = V3 (x+a) (y+b) z
-
-translate :: Float -> Float -> Picture -> Picture
-{-# INLINE translate #-}
-translate x = map . overPos . translateH x
-
-translate3 :: Point3 -> Picture -> Picture
-{-# INLINE translate3 #-}
-translate3 = map . overPos . (+.+.+)
-
-tranRot :: V2 Float -> Float -> Picture -> Picture
-{-# INLINE tranRot #-}
-tranRot (V2 x y) r = map $ overPos (translateH x y . rotate3 r)
-
-setDepth :: Float -> Picture -> Picture
-{-# INLINE setDepth #-}
---setDepth d = map $ second $ overPos (\(x,y,_) -> (x,y,d))
-setDepth d = map $ overPos (\(V3 x y _) -> V3 x y d)
-
-addDepth :: Float -> Picture -> Picture
-{-# INLINE addDepth #-}
---addDepth d = map $ second $ overPos (\(x,y,z) -> (x,y,z+d))
-addDepth d = map $ overPos (\(V3 x y z) -> V3 x y (z+d))
-
--- TODO change the Int here to a dedicated type
-setLayer :: Layer -> Picture -> Picture
-{-# INLINE setLayer #-}
-setLayer i = map f
-  where
-    f v = v {_vxLayer = i}
-
-scale3 :: Float -> Float -> Point3 -> Point3
-{-# INLINE scale3 #-}
-scale3 a b (V3 x y z) = V3 (x*a) (y*b) z
-
-scale :: Float -> Float -> Picture -> Picture
-{-# INLINE scale #-}
-scale x = map . overPos . scale3 x
-
-rotate :: Float -> Picture -> Picture
-{-# INLINE rotate #-}
-rotate = map . overPos . rotate3
-
-concatMapPic :: Foldable t => (a -> Picture) -> t a -> Picture
-{-# INLINE concatMapPic #-}
-concatMapPic = concatMap
-
-appendPic :: Picture -> Picture -> Picture
-{-# INLINE appendPic #-}
-appendPic = (++)
-
-pictures :: Foldable t => t Picture -> Picture
-{-# INLINABLE pictures #-}
-pictures = concat
-
-makeArc :: Float -> Point2 -> [Point2]
-{-# INLINE makeArc #-}
-makeArc rad (V2 a b) = map (`rotateV` V2 0 rad) angles
-  where 
-    angles = [a,a+step.. b]
-    step = pi * 0.2
-
-circleSolid :: Float -> Picture
-{-# INLINE circleSolid #-}
-circleSolid = circleSolidCol white white
-
-circleSolidCol :: Color -> Color -> Float -> Picture
-{-# INLINE circleSolidCol #-}
-circleSolidCol colC colE r = map f
-    [(V3 (-r)   r  0, colC)
-    ,(V3 (-r) (-r) 0, colE)
-    ,(V3   r  (-r) 0, black)
-    ]
-  where
-    f (pos,col) = Verx pos col [] BottomLayer ellNum
-
-circle :: Float -> Picture
-{-# INLINE circle #-}
-circle rad = thickArc 0 (2*pi) rad 1
-
-centerText :: String -> Picture
-{-# INLINE centerText #-}
-centerText s = translate (50 * (negate . fromIntegral $ length s - 1)) 0 $ text s
-
-stackText :: [String] -> Picture
-{-# INLINE stackText #-}
-stackText = mconcat . zipWith (\y s -> translate 0 y $ centerText s) [0,100..]
-
-text :: String -> Picture
-{-# INLINE text #-}
-text = map f . stringToList
-  where
-    f (pos,col,V2 a b) = Verx pos col [a,b] BottomLayer textNum
-
-line :: [Point2] -> Picture
-{-# INLINE line #-}
-line = thickLine 1
-
-lineCol :: [(Point2,RGBA)] -> Picture
-{-# INLINE lineCol #-}
-lineCol = thickLineCol 1
-
-lineThick :: Float -> [Point2] -> Picture
-{-# INLINE lineThick #-}
-lineThick t = pictures . f
-  where 
-    f (x:y:ys) 
-      | x == y      = f (x:ys)
-      | otherwise   = polygon [x +.+ n x y, x -.- n x y, y -.- n x y, y +.+ n x y] : f (y:ys)
-    f _             = []
-    n a b = (t*0.5) *.* errorNormalizeV 42 (vNormal (a -.- b))
-
-thickLine :: Float -> [Point2] -> Picture
-{-# INLINE thickLine #-}
-thickLine t = pictures . f
-  where 
-    f (x:y:ys)
-      | x == y      = f (x:ys)
-      | otherwise   = polygon [x +.+ n, x -.- n, y -.- n, y +.+ n] : f (y:ys)
-      where
-        n = (t*0.5) *.* errorNormalizeV 42 (vNormal (x -.- y))
-    f _             = []
-
-thickLineCol :: Float -> [(Point2,RGBA)] -> Picture
-{-# INLINE thickLineCol #-}
-thickLineCol t = pictures . f
-  where 
-    f ((x,c):(y,c'):ys) 
-      | x == y      = f ((x,c):ys)
-      | otherwise   = polygonCol 
-        [(x +.+ n x y,c)
-        ,(x -.- n x y,c)
-        ,(y -.- n x y,c')
-        ,(y +.+ n x y,c')
-        ] : f ((y,c'):ys)
-    f _             = []
-    n a b = (t*0.5) *.* squashNormalizeV (vNormal (a -.- b))
-
-thickCircle :: Float -> Float -> Picture
-{-# INLINE thickCircle #-}
-thickCircle = thickArc 0 (2*pi)
-
-arcSolid
-    :: Float -- ^ Start angle
-    -> Float -- ^ End angle
-    -> Float -- ^ Radius
-    -> Picture
-{-# INLINE arcSolid #-}
-arcSolid startA endA rad = polygon $ V2 0 0 : makeArc rad (V2 startA endA)
-
-arc
-    :: Float -- ^ Start angle
-    -> Float -- ^ End angle
-    -> Float -- ^ Radius
-    -> Picture
-arc startA endA rad = thickArc startA endA rad 1
-{-# INLINE arc #-}
-
-thickArc :: Float -> Float -> Float -> Float -> Picture
-{-# INLINE thickArc #-}
-thickArc startA endA rad wdth
-    | endA - startA > (pi/ 2) = pictures 
-        [ thickArc (startA + pi/2) endA rad wdth
-        , thickArcHelp startA (startA + pi/2) r w
-        ]
-    | otherwise = thickArcHelp startA endA r w
-  where
-    r = rad + 0.5 * wdth
-    w = 1 - wdth / r
-
-thickArcHelp :: Float -> Float -> Float -> Float -> Picture
-{-# INLINE thickArcHelp #-}
-thickArcHelp startA endA rad wdth = map f
-    [  (V3 0 0 0,black,V3 0 0 wdth)
-    ,(V3 xa ya 0,black,V3 1 0 wdth)
-    ,(V3 xb yb 0,black,V3 1 1 wdth)
-    ,  (V3 0 0 0,black,V3 0 0 wdth)
-    ,(V3 xb yb 0,black,V3 1 1 wdth)
-    ,(V3 xc yc 0,black,V3 0 1 wdth)
-    ]
-  where
-    (V2 xa ya) = rotateV startA (V2 rad 0)
-    (V2 xb yb) = rotateV (0.5 * (startA + endA)) (V2 (rad * sqrt 2) 0)
-    --(V2 xb yb) = rotateV (0.5 * (startA + endA)) (V2 (rad * 2) 0)
-    (V2 xc yc) = rotateV endA (V2 rad 0)
-    f (pos,col,V3 a b c) = Verx pos col [a,b,c] BottomLayer arcNum
-
-
--- Currently the lens version is much slower
-overPos :: (Point3 -> Point3) -> Verx -> Verx
-{-# INLINE overPos #-}
---overPos = over vxPos
-overPos f vx = vx {_vxPos = f (_vxPos vx)}
-
-overCol :: (Point4 -> Point4) -> Verx -> Verx
-{-# INLINE overCol #-}
-overCol f vx = vx {_vxCol = f (_vxCol vx)}
-
--- no premature optimisation, consider changing to use texture arrays
-stringToList :: String -> [(Point3,Point4,Point2)]
-{-# INLINE stringToList #-}
-stringToList = concatMap (uncurry charToTuple) . zip [0,0.9*dimText ..]
-  where
-    dimText = 100
-
-charToTuple :: Float -> Char -> [(Point3,Point4,Point2)]
-{-# INLINE charToTuple #-}
-charToTuple x c = 
-    [(V3 (x-50) (-100) 0, white,V2 offset     1)
-    ,(V3 (x-50)   100  0, white,V2 offset     0)
-    ,(V3 (x+50)   100  0, white,V2 (offset+1) 0)
-    ,(V3 (x-50) (-100) 0, white,V2  offset    1)
-    ,(V3 (x+50) (-100) 0, white,V2 (offset+1) 1)
-    ,(V3 (x+50)   100  0, white,V2 (offset+1) 0)
-    ]
-  where 
-    offset = fromIntegral (fromEnum c) - 32
-
-mirrorxz :: Picture -> Picture
-mirrorxz = map (overPos flipy)
-  where
-    flipy (V3 x y z) = V3 x (negate y) z
-
-mirroryz :: Picture -> Picture
-mirroryz = map (overPos flipx)
-  where
-    flipx (V3 x y z) = V3 (negate x) y z
diff --git a/src/Picture/Base.hs b/src/Picture/Base.hs
new file mode 100644
index 000000000..b04e5719a
--- /dev/null
+++ b/src/Picture/Base.hs
@@ -0,0 +1,373 @@
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE BangPatterns  #-}
+module Picture.Base
+    ( module Picture.Data
+    , module Color
+    , blank
+    , polygon
+    , polygonWire
+    , polygonZ
+    , polygonCol
+    , poly3
+    , poly3Col
+    , bezierQuad
+    , arc
+    , arcSolid
+    , thickArc
+    , thickCircle
+    , thickLine
+    , lineThick
+    , thickLineCol
+    , circleSolid
+    , circleSolidCol
+    , circle
+    , line
+    , lineCol
+    , text
+    , centerText
+    , stackText
+    , pictures
+    , concatMapPic
+    , appendPic
+    , tranRot
+    , translate
+    , translate3
+    , rotate
+    , scale
+    , color
+    , zeroZ
+    , setDepth
+    , addDepth
+    , setLayer
+    , mirroryz
+    , mirrorxz
+    )
+  where
+import Geometry
+import Picture.Data
+import Color
+
+blank :: Picture
+{-# INLINE blank #-}
+blank = []
+
+polygonWire :: [Point2] -> Picture
+{-# INLINE polygonWire #-}
+polygonWire ps = line (ps ++ [head ps])
+
+-- | Expects clockwise input.
+polygon :: [Point2] -> Picture
+{-# INLINE polygon #-}
+polygon = map f . polyToTris
+  where
+    f (V2 x y) = Verx (V3 x y 0) black [] BottomLayer polyNum
+
+polygonZ :: [Point2] -> Float -> Picture
+{-# INLINE polygonZ #-}
+polygonZ ps z = map (f . zeroZ) $ polyToTris ps
+  where
+    f pos = Verx pos black [z] BottomLayer polyzNum
+
+polygonCol :: [(Point2,RGBA)] -> Picture
+{-# INLINE polygonCol #-}
+polygonCol = polyToTris . map f
+  where
+    f (V2 x y,col) = Verx (V3 x y 0) col [] BottomLayer polyNum
+
+poly3 :: [Point3] -> Picture
+{-# INLINE poly3 #-}
+poly3 = poly3Col . map (, black)
+
+poly3Col :: [(Point3,RGBA)] -> Picture
+{-# INLINE poly3Col #-}
+poly3Col = map f . polyToTris
+  where
+    f (pos,col) = Verx pos col [] BottomLayer polyNum
+
+-- note that much of work computing the width of the bezier curve is done here
+bezierQuad :: Color -> Color -> Float -> Float -> Point2 -> Point2 -> Point2 -> Picture
+bezierQuad cola colc ra rc a b c 
+    | a == b && b == c = blank
+    | a == b || b == c = bezierQuad cola colc ra rc a (0.5 *.* (a +.+ c)) c
+    | otherwise = bzhelp
+        [(aIn, cola, V2 (fa aIn) (fc aIn) , V2 1        0         )
+        ,(aIn, cola, V2 (fa aIn) (fc aIn) , V2 1        0         )
+        ,(cIn, colc, V2 (fa cIn) (fc cIn) , V2 0        1         )
+        ,( aX, cola, V2 1        0        , V2 (fa' aX) (fc' aX)  )
+        ,( cX, colc, V2 0        1        , V2 (fa' cX) (fc' cX)  )
+        ,( bX, colb, V2 0        0        , V2 (fa' bX) (fc' bX)  )
+        ,( bX, colb, V2 0        0        , V2 (fa' bX) (fc' bX)  )
+        ]
+  where 
+    colb = mixColors 0.5 0.5 cola colc
+    b2a | isLHS a b c = a -.- b
+        | otherwise   = b -.- a
+    aRadVec = 0.5 * ra *.* normalizeV (vNormal b2a)
+    aX  = a -.- aRadVec
+    aIn = a +.+ aRadVec
+    b2c | isLHS a b c = b -.- c
+        | otherwise   = c -.- b
+    cRadVec = 0.5 * rc *.* normalizeV (vNormal b2c)
+    cX  = c -.- cRadVec
+    cIn = c +.+ cRadVec
+    bRadVec = 0.25 * (ra + rc) *.* normalizeV (a +.+ b -.- 2 *.* c)
+    bX  = b +.+ bRadVec
+    bIn = b -.- bRadVec
+    fa = extrapolate aX cX bX 
+    fc = extrapolate cX aX bX
+    fa' = extrapolate aIn cIn bIn
+    fc' = extrapolate cIn aIn bIn
+
+bzhelp :: [(Point2, Point4, Point2, Point2)] -> Picture
+bzhelp = map f
+  where
+    f (V2 x y,col,V2 a b,V2 c d) = Verx (V3 x y 0) col [a,b,c,d] BottomLayer bezNum
+
+-- given a one and two zeros of a linear function over x and y,
+-- determine the function
+-- so if f(ox,oy) = 1 and f(ax,ay) = f(bx,by) = 0, determines f
+extrapolate :: Point2 -> Point2 -> Point2 -> Point2 -> Float
+extrapolate (V2 ox oy) (V2 ax ay) (V2 bx by) (V2 x y) = 
+    (       x * ( ay - by )
+        +   y * ( bx - ax )
+        +   (ax * by - bx * ay)
+    ) 
+    / 
+    (       ox * ( ay - by )
+        +   ax * ( by - oy )
+        +   bx * ( oy - ay )
+    )
+
+color :: RGBA -> Picture -> Picture
+{-# INLINE color #-}
+color c = map $ overCol (const c)
+
+translateH :: Float -> Float -> Point3 -> Point3
+{-# INLINE translateH #-}
+translateH !a !b (V3 x y z) = V3 (x+a) (y+b) z
+
+translate :: Float -> Float -> Picture -> Picture
+{-# INLINE translate #-}
+translate x = map . overPos . translateH x
+
+translate3 :: Point3 -> Picture -> Picture
+{-# INLINE translate3 #-}
+translate3 = map . overPos . (+.+.+)
+
+tranRot :: V2 Float -> Float -> Picture -> Picture
+{-# INLINE tranRot #-}
+tranRot (V2 x y) r = map $ overPos (translateH x y . rotate3 r)
+
+setDepth :: Float -> Picture -> Picture
+{-# INLINE setDepth #-}
+--setDepth d = map $ second $ overPos (\(x,y,_) -> (x,y,d))
+setDepth d = map $ overPos (\(V3 x y _) -> V3 x y d)
+
+addDepth :: Float -> Picture -> Picture
+{-# INLINE addDepth #-}
+--addDepth d = map $ second $ overPos (\(x,y,z) -> (x,y,z+d))
+addDepth d = map $ overPos (\(V3 x y z) -> V3 x y (z+d))
+
+-- TODO change the Int here to a dedicated type
+setLayer :: Layer -> Picture -> Picture
+{-# INLINE setLayer #-}
+setLayer i = map f
+  where
+    f v = v {_vxLayer = i}
+
+scale3 :: Float -> Float -> Point3 -> Point3
+{-# INLINE scale3 #-}
+scale3 a b (V3 x y z) = V3 (x*a) (y*b) z
+
+scale :: Float -> Float -> Picture -> Picture
+{-# INLINE scale #-}
+scale x = map . overPos . scale3 x
+
+rotate :: Float -> Picture -> Picture
+{-# INLINE rotate #-}
+rotate = map . overPos . rotate3
+
+concatMapPic :: Foldable t => (a -> Picture) -> t a -> Picture
+{-# INLINE concatMapPic #-}
+concatMapPic = concatMap
+
+appendPic :: Picture -> Picture -> Picture
+{-# INLINE appendPic #-}
+appendPic = (++)
+
+pictures :: Foldable t => t Picture -> Picture
+{-# INLINABLE pictures #-}
+pictures = concat
+
+makeArc :: Float -> Point2 -> [Point2]
+{-# INLINE makeArc #-}
+makeArc rad (V2 a b) = map (`rotateV` V2 0 rad) angles
+  where 
+    angles = [a,a+step.. b]
+    step = pi * 0.2
+
+circleSolid :: Float -> Picture
+{-# INLINE circleSolid #-}
+circleSolid = circleSolidCol white white
+
+circleSolidCol :: Color -> Color -> Float -> Picture
+{-# INLINE circleSolidCol #-}
+circleSolidCol colC colE r = map f
+    [(V3 (-r)   r  0, colC)
+    ,(V3 (-r) (-r) 0, colE)
+    ,(V3   r  (-r) 0, black)
+    ]
+  where
+    f (pos,col) = Verx pos col [] BottomLayer ellNum
+
+circle :: Float -> Picture
+{-# INLINE circle #-}
+circle rad = thickArc 0 (2*pi) rad 1
+
+centerText :: String -> Picture
+{-# INLINE centerText #-}
+centerText s = translate (50 * (negate . fromIntegral $ length s - 1)) 0 $ text s
+
+stackText :: [String] -> Picture
+{-# INLINE stackText #-}
+stackText = mconcat . zipWith (\y s -> translate 0 y $ centerText s) [0,100..]
+
+text :: String -> Picture
+{-# INLINE text #-}
+text = map f . stringToList
+  where
+    f (pos,col,V2 a b) = Verx pos col [a,b] BottomLayer textNum
+
+line :: [Point2] -> Picture
+{-# INLINE line #-}
+line = thickLine 1
+
+lineCol :: [(Point2,RGBA)] -> Picture
+{-# INLINE lineCol #-}
+lineCol = thickLineCol 1
+
+lineThick :: Float -> [Point2] -> Picture
+{-# INLINE lineThick #-}
+lineThick t = pictures . f
+  where 
+    f (x:y:ys) 
+      | x == y      = f (x:ys)
+      | otherwise   = polygon [x +.+ n x y, x -.- n x y, y -.- n x y, y +.+ n x y] : f (y:ys)
+    f _             = []
+    n a b = (t*0.5) *.* errorNormalizeV 42 (vNormal (a -.- b))
+
+thickLine :: Float -> [Point2] -> Picture
+{-# INLINE thickLine #-}
+thickLine t = pictures . f
+  where 
+    f (x:y:ys)
+      | x == y      = f (x:ys)
+      | otherwise   = polygon [x +.+ n, x -.- n, y -.- n, y +.+ n] : f (y:ys)
+      where
+        n = (t*0.5) *.* errorNormalizeV 42 (vNormal (x -.- y))
+    f _             = []
+
+thickLineCol :: Float -> [(Point2,RGBA)] -> Picture
+{-# INLINE thickLineCol #-}
+thickLineCol t = pictures . f
+  where 
+    f ((x,c):(y,c'):ys) 
+      | x == y      = f ((x,c):ys)
+      | otherwise   = polygonCol 
+        [(x +.+ n x y,c)
+        ,(x -.- n x y,c)
+        ,(y -.- n x y,c')
+        ,(y +.+ n x y,c')
+        ] : f ((y,c'):ys)
+    f _             = []
+    n a b = (t*0.5) *.* squashNormalizeV (vNormal (a -.- b))
+
+thickCircle :: Float -> Float -> Picture
+{-# INLINE thickCircle #-}
+thickCircle = thickArc 0 (2*pi)
+
+arcSolid
+    :: Float -- ^ Start angle
+    -> Float -- ^ End angle
+    -> Float -- ^ Radius
+    -> Picture
+{-# INLINE arcSolid #-}
+arcSolid startA endA rad = polygon $ V2 0 0 : makeArc rad (V2 startA endA)
+
+arc
+    :: Float -- ^ Start angle
+    -> Float -- ^ End angle
+    -> Float -- ^ Radius
+    -> Picture
+arc startA endA rad = thickArc startA endA rad 1
+{-# INLINE arc #-}
+
+thickArc :: Float -> Float -> Float -> Float -> Picture
+{-# INLINE thickArc #-}
+thickArc startA endA rad wdth
+    | endA - startA > (pi/ 2) = pictures 
+        [ thickArc (startA + pi/2) endA rad wdth
+        , thickArcHelp startA (startA + pi/2) r w
+        ]
+    | otherwise = thickArcHelp startA endA r w
+  where
+    r = rad + 0.5 * wdth
+    w = 1 - wdth / r
+
+thickArcHelp :: Float -> Float -> Float -> Float -> Picture
+{-# INLINE thickArcHelp #-}
+thickArcHelp startA endA rad wdth = map f
+    [  (V3 0 0 0,black,V3 0 0 wdth)
+    ,(V3 xa ya 0,black,V3 1 0 wdth)
+    ,(V3 xb yb 0,black,V3 1 1 wdth)
+    ,  (V3 0 0 0,black,V3 0 0 wdth)
+    ,(V3 xb yb 0,black,V3 1 1 wdth)
+    ,(V3 xc yc 0,black,V3 0 1 wdth)
+    ]
+  where
+    (V2 xa ya) = rotateV startA (V2 rad 0)
+    (V2 xb yb) = rotateV (0.5 * (startA + endA)) (V2 (rad * sqrt 2) 0)
+    --(V2 xb yb) = rotateV (0.5 * (startA + endA)) (V2 (rad * 2) 0)
+    (V2 xc yc) = rotateV endA (V2 rad 0)
+    f (pos,col,V3 a b c) = Verx pos col [a,b,c] BottomLayer arcNum
+
+
+-- Currently the lens version is much slower
+overPos :: (Point3 -> Point3) -> Verx -> Verx
+{-# INLINE overPos #-}
+--overPos = over vxPos
+overPos f vx = vx {_vxPos = f (_vxPos vx)}
+
+overCol :: (Point4 -> Point4) -> Verx -> Verx
+{-# INLINE overCol #-}
+overCol f vx = vx {_vxCol = f (_vxCol vx)}
+
+-- no premature optimisation, consider changing to use texture arrays
+stringToList :: String -> [(Point3,Point4,Point2)]
+{-# INLINE stringToList #-}
+stringToList = concatMap (uncurry charToTuple) . zip [0,0.9*dimText ..]
+  where
+    dimText = 100
+
+charToTuple :: Float -> Char -> [(Point3,Point4,Point2)]
+{-# INLINE charToTuple #-}
+charToTuple x c = 
+    [(V3 (x-50) (-100) 0, white,V2 offset     1)
+    ,(V3 (x-50)   100  0, white,V2 offset     0)
+    ,(V3 (x+50)   100  0, white,V2 (offset+1) 0)
+    ,(V3 (x-50) (-100) 0, white,V2  offset    1)
+    ,(V3 (x+50) (-100) 0, white,V2 (offset+1) 1)
+    ,(V3 (x+50)   100  0, white,V2 (offset+1) 0)
+    ]
+  where 
+    offset = fromIntegral (fromEnum c) - 32
+
+mirrorxz :: Picture -> Picture
+mirrorxz = map (overPos flipy)
+  where
+    flipy (V3 x y z) = V3 x (negate y) z
+
+mirroryz :: Picture -> Picture
+mirroryz = map (overPos flipx)
+  where
+    flipx (V3 x y z) = V3 (negate x) y z
diff --git a/src/Picture/Composite.hs b/src/Picture/Composite.hs
new file mode 100644
index 000000000..b007742fb
--- /dev/null
+++ b/src/Picture/Composite.hs
@@ -0,0 +1,16 @@
+module Picture.Composite where
+import Picture.Data
+import Picture.Base
+import Geometry
+--import Color
+
+arrowPath :: [Point2] -> Picture
+arrowPath xs = mconcat $ zipWith arrow xs $ tail xs
+
+arrow :: Point2 -> Point2 -> Picture
+arrow a b = line [a,b]
+    <> line [b +.+ n -.- v,b]
+    <> line [b -.- n -.- v,b]
+  where
+    v = 5 *.* normalizeV (b -.- a)
+    n = vNormal v

From f6084f37ed93c640f7b4352658c863df328c336e Mon Sep 17 00:00:00 2001
From: justin <justin.g.kruger@gmail.com>
Date: Fri, 1 Jul 2022 21:47:49 +0100
Subject: [PATCH 15/20] Reallow different line block sizes

---
 src/Dodge/Data.hs                      |  2 +-
 src/Dodge/Placement/Instance/Wall.hs   | 11 ++--
 src/Dodge/Placement/PlaceSpot.hs       |  4 +-
 src/Dodge/Placement/PlaceSpot/Block.hs | 71 ++++++++++----------------
 src/Dodge/Room/Pillar.hs               |  4 +-
 5 files changed, 38 insertions(+), 54 deletions(-)

diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs
index c2fd5ede5..f3c6c590b 100644
--- a/src/Dodge/Data.hs
+++ b/src/Dodge/Data.hs
@@ -1406,7 +1406,7 @@ data PSType = PutCrit {_unPutCrit :: Creature}
     | PutMod Modification
     | PutTrigger (World -> Bool)
     | PutLineBlock {_putWall :: Wall , _putWidth :: Float
-        , _putDepth :: Float, _putStartPoint :: Point2, _putEndPoint :: Point2}
+        , _putStartPoint :: Point2, _putEndPoint :: Point2}
     | PutWall { _pwPoly :: [Point2] , _pwWall :: Wall }
     | PutSlideDr Door Wall Float Point2 Point2
     | PutDoor Color (World -> Bool) [(Point2,Point2)]
diff --git a/src/Dodge/Placement/Instance/Wall.hs b/src/Dodge/Placement/Instance/Wall.hs
index 69fe1c1e2..500dd0f37 100644
--- a/src/Dodge/Placement/Instance/Wall.hs
+++ b/src/Dodge/Placement/Instance/Wall.hs
@@ -35,23 +35,22 @@ singleBlock a =
     ]
 {-
 Places a line of blocks between two points.
-Width 9, also extends out from each point by 9.
  -}
 blockLine :: Point2 -> Point2 -> Placement
-blockLine a b = sps0 $ PutLineBlock baseBlockPane 9 9 a b
+blockLine a b = sps0 $ PutLineBlock baseBlockPane 9 a b
 
 {-
 Places an breakable window between two points.
 Width 8, also extends out from each point by 8.
  -}
 windowLine :: Point2 -> Point2 -> Placement
-windowLine a b = sps0 $ PutLineBlock defaultWindow 8 8 a b
+windowLine a b = sps0 $ PutLineBlock defaultWindow 8 a b
 {-
 Places an unbreakable window between two points.
 Width 7, also extends out from each point by 7.
  -}
 crystalLine :: Point2 -> Point2 -> Placement
-crystalLine a b = sps0 $ PutLineBlock defaultCrystalWall 7 7 a b
+crystalLine a b = sps0 $ PutLineBlock defaultCrystalWall 7 a b
 --crystalLine a b = sps0 $ PutWall ps defaultCrystalWall
 --  where
 --    ps = 
@@ -77,7 +76,7 @@ wallLine a b = sps0 $ PutWall ps defaultWall
     up   = vNormal left
 
 windowLineType :: Point2 -> Point2 -> PSType
-windowLineType = PutLineBlock defaultWindow 8 8
+windowLineType = PutLineBlock defaultWindow 8
 
 baseBlockPane :: Wall
 baseBlockPane = defaultWall
@@ -124,7 +123,7 @@ putBlockRect' w h = ps0jPushPS (aline tl tr)
     tr = V2 w h
     br = V2 w (-h)
     bl = V2 (-w) (-h)
-    aline = PutLineBlock baseBlockPane 9 9
+    aline = PutLineBlock baseBlockPane 9
 
 putBlockRect :: Float -> Float -> Float -> Float -> [Placement]
 putBlockRect a x b y =
diff --git a/src/Dodge/Placement/PlaceSpot.hs b/src/Dodge/Placement/PlaceSpot.hs
index 5663cb04f..c65e3220d 100644
--- a/src/Dodge/Placement/PlaceSpot.hs
+++ b/src/Dodge/Placement/PlaceSpot.hs
@@ -99,9 +99,9 @@ placeSpotID ps pt w = case pt of
     PutCoord    cp          -> plNewID   coordinates (doShift cp) w
     PutSlideDr  wl dr off  a   b 
                             -> plSlideDoor wl dr off (doShift a) (doShift b) w
-    PutBlock    bl wl  ps'  -> placeBlock (map doShift ps') (bl & blPos %~ doShift & blDir .~ rot)
+    PutBlock    bl wl  ps'  -> plBlock (map doShift ps') (bl & blPos %~ doShift & blDir .~ rot)
                                     wl w
-    PutLineBlock wl wdth dpth a b -> placeLineBlock wl wdth dpth (doShift a) (doShift b) w
+    PutLineBlock wl wdth a b     -> plLineBlock wl wdth (doShift a) (doShift b) w
     PutWall     qs  wl      -> (0,placeWallPoly (map doShift qs) wl w)
     PutNothing              -> (0,w)
     PutID i                 -> (i, w)
diff --git a/src/Dodge/Placement/PlaceSpot/Block.hs b/src/Dodge/Placement/PlaceSpot/Block.hs
index 1aa411e7a..644fb0845 100644
--- a/src/Dodge/Placement/PlaceSpot/Block.hs
+++ b/src/Dodge/Placement/PlaceSpot/Block.hs
@@ -1,7 +1,7 @@
 {- | Creation, update and destruction of destructible walls.  -}
 module Dodge.Placement.PlaceSpot.Block 
-    ( placeBlock
-    , placeLineBlock
+    ( plBlock
+    , plLineBlock
     )
     where
 import Dodge.Data
@@ -17,63 +17,45 @@ import Control.Lens
 import Data.List
 import qualified Data.IntSet as IS
 
-addBlock 
+plBlock 
     :: [Point2]     -- ^ Block polygon
-    -> Wall         -- ^ Base Pane
     -> Block
+    -> Wall         -- ^ Base Pane
     -> World 
-    -> World
-addBlock (p:ps) wl bl w = w
-    & wlZoning . znObjects %~ flip (IM.foldl' $ flip wallInZone) panes
-    & walls  %~ IM.union panes
-    & blocks %~ IM.insert blid bl 
-        {_blID = blid,_blWallIDs = IS.fromList is, _blShadows=[]
-            , _blFootprint = p:ps
-            }
+    -> (Int,World)
+plBlock [] _ _ _ = error "Trying to add a block with incomplete polygon"
+plBlock (p:ps) bl wl w = (,) blid $ w
+    & flip (foldr insertWall) wls
+    & blocks . at blid ?~ bl 
+        { _blID = blid
+        , _blWallIDs = IS.fromList is
+        , _blShadows = []
+        , _blFootprint = p:ps
+        }
   where 
     blid = IM.newKey $ _blocks w
     lns = zip (p:ps) (ps ++ [p])
     i = IM.newKey $ _walls w
     is = [i.. i + length lns-1]
-    panes = IM.fromList $ zipWith 
-        (\j (a,b) -> (,) j wl 
-            { _wlLine = (a,b)
-            , _wlID = j
-            , _wlStructure = BlockPart blid
-            }
-        ) is lns
-    wallInZone wl'
-        | uncurry dist (_wlLine wl') <= 2*wlZoneSize 
-            = insertIMInZone x y wlid wl'
-        | otherwise = flip (foldl' $ flip (\(a,b) -> insertIMInZone a b wlid wl')) ips
-      where 
-        V2 x y = wlZoneOfPoint $ uncurry midPoint (_wlLine wl)
-        wlid  = _wlID wl
-        ips = map (unv2 . wlZoneOfPoint) $ uncurry (divideLine (2*wlZoneSize)) (_wlLine wl)
-        unv2 (V2 x' y') = (x',y')
-addBlock _ _ _ _ = error "Trying to add a block with incomplete polygon"
+    wls = zipWith 
+        (\j ln -> wl & wlLine .~ ln & wlID .~ j & wlStructure .~ BlockPart blid) 
+        is 
+        lns 
         
-placeBlock :: [Point2] -> Block -> Wall -> World -> (Int,World)
-placeBlock poly bl wl w 
-    = (0, foldr (uncurry removePathsCrossing) wWithBlock pairs)
-  where 
-    pairs = loopPairs poly
-    wWithBlock = addBlock poly wl bl w
-
 {- | Splits a line into many four cornered blocks. -}
-placeLineBlock 
+plLineBlock 
     :: Wall     -- ^ Base pane
-    -> Float    -- ^ Block width
-    -> Float    -- ^ Block depth
+    -> Float
     -> Point2   -- ^ Start point (symmetric)
     -> Point2   -- ^ End point (symmetric)
     -> World 
     -> (Int, World)
-placeLineBlock basePane blockWidth depth a b gw = ( 0 
-    , removePathsCrossing a b (foldr insertWall (insertBlocks gw) listWalls)
+plLineBlock basePane blwidth a b gw = ( 0 
+    , foldr insertWall (insertBlocks gw) listWalls
     )
   where 
-    psOnLine = divideLineOddNumPoints blockWidth a b
+    depth = blwidth
+    psOnLine = divideLineOddNumPoints blwidth a b
     halfBlockWidth = dist a b / fromIntegral (length psOnLine - 1)
     blockCenPs = snd $ evenOddSplit psOnLine
     numBlocks = length blockCenPs
@@ -108,4 +90,7 @@ placeLineBlock basePane blockWidth depth a b gw = ( 0
         ,_wlDraw = visStatus
         }
     listWalls = concat $ zipWith makeWallAt blockCenPs is
-    insertWall wl = over walls $ IM.insert (_wlID wl) wl
+
+insertWall :: Wall -> World -> World
+insertWall wl = (walls . at (_wlID wl) ?~ wl)
+--    . uncurry (addObstacleCrossing' BlockObstacle) (_wlLine wl)
diff --git a/src/Dodge/Room/Pillar.hs b/src/Dodge/Room/Pillar.hs
index dc93bb1cb..62558e503 100644
--- a/src/Dodge/Room/Pillar.hs
+++ b/src/Dodge/Room/Pillar.hs
@@ -30,7 +30,7 @@ blockPillar w' h' = ps0jPushPS (aline tl tr)
     tr = V2 w h
     br = V2 w (-h)
     bl = V2 (-w) (-h)
-    aline = PutLineBlock baseBlockPane 9 9
+    aline = PutLineBlock baseBlockPane 9
 
 smallPillar :: PSType
 smallPillar = PutBlock defaultBlock baseBlockPane $ reverse $ square 5
@@ -41,7 +41,7 @@ crossPillar w' h' = ps0jPushPS (aline (V2 (-w) 0) (V2 w 0))
   where
     w = w' - 9
     h = h' - 9
-    aline = PutLineBlock baseBlockPane 9 9
+    aline = PutLineBlock baseBlockPane 9
 
 roomPillarsSquare :: RandomGen g => State g Room
 roomPillarsSquare = do

From 66fe1abc6f96bbbc3a8571ffda9cb6613691615e Mon Sep 17 00:00:00 2001
From: justin <justin.g.kruger@gmail.com>
Date: Fri, 1 Jul 2022 23:17:41 +0100
Subject: [PATCH 16/20] Add PathEdge data to pathfinding graph

---
 src/Dodge/Data.hs           |  4 +++-
 src/Dodge/Data/PathGraph.hs |  1 +
 src/Dodge/Layout.hs         |  2 +-
 src/Dodge/Path.hs           | 45 +++++++++++++++++++++++++------------
 4 files changed, 36 insertions(+), 16 deletions(-)

diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs
index f3c6c590b..5505dedd1 100644
--- a/src/Dodge/Data.hs
+++ b/src/Dodge/Data.hs
@@ -32,8 +32,10 @@ module Dodge.Data
     , module Dodge.Data.ItemAmount
     , module Dodge.RoomCluster.Data
     , module Dodge.Data.Room
+    , module Dodge.Data.PathGraph
     ) where
 import Dodge.Data.Room
+import Dodge.Data.PathGraph
 import Dodge.Data.Zoning
 import Dodge.Data.ForegroundShape
 import Dodge.Data.LoadAction
@@ -146,7 +148,7 @@ data World = World
     , _shapes               :: IM.IntMap ForegroundShape
     , _corpses              :: IM.IntMap Corpse
     , _clickMousePos        :: Point2
-    , _pathGraph            :: Gr Point2 Float
+    , _pathGraph            :: Gr Point2 PathEdge
     , _pathGraphP           :: S.Set (Point2,Point2)
     , _phZoning             :: Zoning [] (Int,Point2)
     , _hud                  :: HUD
diff --git a/src/Dodge/Data/PathGraph.hs b/src/Dodge/Data/PathGraph.hs
index d6f751844..e6984fc53 100644
--- a/src/Dodge/Data/PathGraph.hs
+++ b/src/Dodge/Data/PathGraph.hs
@@ -15,6 +15,7 @@ data PathGraph = PathGraph
 data PathEdge = PathEdge
     {_peStart :: Point2
     ,_peEnd   :: Point2
+    ,_peDist  :: Float
     ,_peObstacles :: Set.Set EdgeObstacle
     }
   deriving (Eq,Ord,Show)
diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs
index 235f1d797..3c49ee669 100644
--- a/src/Dodge/Layout.hs
+++ b/src/Dodge/Layout.hs
@@ -45,7 +45,7 @@ generateLevelFromRoomList gr' w = initWallZoning
         , _pathGraphP   = pairPath
         }
   where
-    path = pairsToGraph dist pairPath
+    path = pairsToGraph pairPath
     pairPath = foldMap _rmPath rs
     rs = map doRoomShift $ IM.elems rs'
     rs'= mapM shuffleRoomPos gr' & evalState $ _randGen w
diff --git a/src/Dodge/Path.hs b/src/Dodge/Path.hs
index ffa337bf5..315d6d09d 100644
--- a/src/Dodge/Path.hs
+++ b/src/Dodge/Path.hs
@@ -17,6 +17,9 @@ import Data.List
 --import qualified Data.IntMap.Strict as IM
 import Data.Graph.Inductive hiding ((&))
 import qualified Data.Set as Set
+import qualified Data.Map.Strict as M
+import Data.Map.Strict (Map)
+import StreamingHelp
 import qualified Streaming.Prelude as S
 --import Data.Graph.Inductive.PatriciaTree
 --import Data.Graph.Inductive.Graph hiding ((&))
@@ -25,7 +28,7 @@ makePathBetween :: Point2 -> Point2 -> World -> Maybe [Int]
 makePathBetween a b w = do -- join $ sp <$> a' <*> b' <*> return (_pathGraph w)
     na <- walkableNodeNear a
     nb <- walkableNodeNear b
-    sp na nb (_pathGraph w)
+    sp na nb (second _peDist (_pathGraph w))
   where
     --nodesNear p = concat $ lookLookups (zoneNearPointIP p) (_pathPoints w)
     nodesNear p = runIdentity . S.toList_ $ nearPoint _phZoning p w
@@ -83,19 +86,33 @@ 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) -> Set.Set (a,a) -> Gr a b
-pairsToGraph f pairs = 
-    let nodes' = Set.map fst pairs `Set.union` Set.map snd pairs
-        pairs' = Set.map (\(x,y)->(x,y,f x y)) pairs
-    in undir $ run_ Data.Graph.Inductive.empty $ insMapNodesM (Set.toList nodes') >> insMapEdgesM (Set.toList pairs')
+pairsToGraph :: Set.Set (Point2,Point2) -> Gr Point2 PathEdge
+pairsToGraph pairs = addEdges nodemap gr $ S.each pairs
+  where
+    (nodemap,_,gr) = addNodes $ S.map fst (S.each pairs) <> S.map snd (S.each pairs)
+--    let nodes' = Set.map fst pairs `Set.union` Set.map snd pairs
+--        pairs' = Set.map (\(x,y)->(x,y,f x y)) pairs
+--    in undir $ run_ Data.Graph.Inductive.empty $ insMapNodesM (Set.toList nodes') >> insMapEdgesM (Set.toList pairs')
+
+addNodes :: StreamOf Point2 -> (Map Point2 Int,Int,Gr Point2 PathEdge)
+addNodes = runIdentity . S.fold_ f (mempty,0,Data.Graph.Inductive.empty) id
+  where
+    f (nodemap,i,gr) p = case nodemap M.!? p of
+        Just _  -> (nodemap,i,gr)
+        Nothing -> (nodemap & at p ?~i ,i+1, insNode (i,p) gr)
+addEdges :: Map Point2 Int -> Gr Point2 PathEdge -> StreamOf (Point2,Point2) -> Gr Point2 PathEdge
+addEdges nodemap gr = runIdentity . S.fold_ f gr id
+  where
+    f gr' (a,b) = insEdge (g a,g b,PathEdge a b (dist a b) mempty) gr'
+    g a = nodemap M.! a
 
 removePathsCrossing :: Point2 -> Point2 -> World -> World
 removePathsCrossing a b w = w
-    & pathGraph  .~ newGraph 
-    & pathGraphP .~ pg'
-    & phZoning   %~ \zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
-        (labNodes newGraph)
-  where 
-    pg' = Set.filter (isNothing . uncurry (intersectSegSeg a b)) $ _pathGraphP w
-   -- insertPoint pp@(_,p) = insertInZoneWith (wlZoneOfPoint p) (++) [pp]
-    newGraph = pairsToGraph dist pg'
+--    & pathGraph  .~ newGraph 
+--    & pathGraphP .~ pg'
+--    & phZoning   %~ \zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
+--        (labNodes newGraph)
+--  where 
+--    pg' = Set.filter (isNothing . uncurry (intersectSegSeg a b)) $ _pathGraphP w
+--   -- insertPoint pp@(_,p) = insertInZoneWith (wlZoneOfPoint p) (++) [pp]
+--    newGraph = pairsToGraph pg'

From 8dc7682327b882e5f69ecc998a7c8e8796787811 Mon Sep 17 00:00:00 2001
From: justin <justin.g.kruger@gmail.com>
Date: Sat, 2 Jul 2022 11:59:05 +0100
Subject: [PATCH 17/20] Readd some debug drawing (debugDraw itself still
 commented out)

---
 src/Dodge/Data.hs                |  2 +-
 src/Dodge/Default/World.hs       |  2 +-
 src/Dodge/Layout.hs              |  6 ++++
 src/Dodge/Path.hs                |  7 +++-
 src/Dodge/Render/ShapePicture.hs | 60 ++++++++++++++++++++------------
 5 files changed, 52 insertions(+), 25 deletions(-)

diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs
index 5505dedd1..fe195d2b3 100644
--- a/src/Dodge/Data.hs
+++ b/src/Dodge/Data.hs
@@ -150,7 +150,7 @@ data World = World
     , _clickMousePos        :: Point2
     , _pathGraph            :: Gr Point2 PathEdge
     , _pathGraphP           :: S.Set (Point2,Point2)
-    , _phZoning             :: Zoning [] (Int,Point2)
+    , _pnZoning             :: Zoning [] (Int,Point2)
     , _hud                  :: HUD
     , _lightSources         :: IM.IntMap LightSource
     , _tempLightSources     :: [TempLightSource]
diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs
index 53746c236..8370650d2 100644
--- a/src/Dodge/Default/World.hs
+++ b/src/Dodge/Default/World.hs
@@ -76,7 +76,7 @@ defaultWorld = World
     , _clickMousePos = V2 0 0
     , _pathGraph = Data.Graph.Inductive.Graph.empty
     , _pathGraphP   = mempty
-    , _phZoning     = Zoning mempty wlZoneSize (zonePos snd)
+    , _pnZoning     = Zoning mempty wlZoneSize (zonePos snd)
     , _hud = HUD
         { _hudElement = DisplayInventory NoSubInventory
         , _carteCenter = V2 0 0
diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs
index 3c49ee669..b5c3bb45b 100644
--- a/src/Dodge/Layout.hs
+++ b/src/Dodge/Layout.hs
@@ -5,6 +5,7 @@ module Dodge.Layout
 import Data.Tile
 import Dodge.Data
 import Dodge.Path
+import Dodge.Zone.Update
 import Dodge.ShiftPoint
 import Dodge.Placement.PlaceSpot
 --import Dodge.LevelGen.Data
@@ -21,6 +22,7 @@ import qualified IntMapHelp as IM
 import Tile
 import RandomHelp
 
+import Data.Graph.Inductive (labNodes,labEdges)
 import Data.List (nubBy)
 import Data.Traversable
 import Control.Lens
@@ -44,6 +46,10 @@ generateLevelFromRoomList gr' w = initWallZoning
         , _pathGraph    = path
         , _pathGraphP   = pairPath
         }
+        & pnZoning   %~ (\zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
+            (labNodes path))
+--        & peZoning   %~ (\zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
+--            (labEdges (_pgGraph path)))
   where
     path = pairsToGraph pairPath
     pairPath = foldMap _rmPath rs
diff --git a/src/Dodge/Path.hs b/src/Dodge/Path.hs
index 315d6d09d..ceceb5712 100644
--- a/src/Dodge/Path.hs
+++ b/src/Dodge/Path.hs
@@ -1,9 +1,11 @@
+--{-# LANGUAGE TupleSections #-}
 module Dodge.Path 
     ( pointTowardsImpulse
     , makePathBetween
     , makePathBetweenPs
     , removePathsCrossing
     , pairsToGraph
+    , getNodePos
     ) where
 import Dodge.Data
 import Dodge.Base.Collide
@@ -24,6 +26,9 @@ import qualified Streaming.Prelude as S
 --import Data.Graph.Inductive.PatriciaTree
 --import Data.Graph.Inductive.Graph hiding ((&))
 
+getNodePos :: Int -> World -> Maybe Point2
+getNodePos i w = _pathGraph w `lab` i
+
 makePathBetween :: Point2 -> Point2 -> World -> Maybe [Int]
 makePathBetween a b w = do -- join $ sp <$> a' <*> b' <*> return (_pathGraph w)
     na <- walkableNodeNear a
@@ -31,7 +36,7 @@ makePathBetween a b w = do -- join $ sp <$> a' <*> b' <*> return (_pathGraph w)
     sp na nb (second _peDist (_pathGraph w))
   where
     --nodesNear p = concat $ lookLookups (zoneNearPointIP p) (_pathPoints w)
-    nodesNear p = runIdentity . S.toList_ $ nearPoint _phZoning p w
+    nodesNear p = runIdentity . S.toList_ $ nearPoint _pnZoning p w
     walkableNodeNear p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear p
 
 --walkableNodeNear :: Point2 -> World -> Maybe Point2
diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs
index 0bbc205b5..53bc6574e 100644
--- a/src/Dodge/Render/ShapePicture.hs
+++ b/src/Dodge/Render/ShapePicture.hs
@@ -120,9 +120,25 @@ drawCreatureDisplayTexts :: World -> Picture
 drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (_creatures w)
 
 drawPathBetween :: World -> Picture
-drawPathBetween _ = mempty
+drawPathBetween w = setLayer DebugLayer
+    $  color yellow (foldMap (arrowPath . mapMaybe nodepos) nodelist)
+    <> foldMap (color green . arrow sp) (nodepos =<< nodelist ^? _Just . ix 0)
+    <> foldMap (color cyan . flip arrow ep) (nodepos =<< lastOf traverse =<< nodelist ^? _Just)
+  where
+    nodepos = (`getNodePos` w)
+    nodelist = makePathBetween sp ep w
+    sp = _lSelect w
+    ep = _rSelect w
+
 drawNodesNearSelect :: World -> Picture
-drawNodesNearSelect _ = mempty
+drawNodesNearSelect w = setLayer DebugLayer $
+     runIdentity (S.foldMap_ (drawZone pnZoneSize) (zoneAroundPoint pnZoneSize sp))
+--    <> color red (foldMap (drawCross . snd) $ nodesNearL sp w)
+    <> color green (drawCross sp)
+--    <> color cyan (foldMap (drawCross . snd) $ walkableNodeNear sp w)
+  where
+    sp = _lSelect w
+
 drawInspectWalls :: World -> Picture
 drawInspectWalls w = foldMap (drawInspectWall w) 
     $ filter (isJust . uncurry (intersectSegSeg a b) . _wlLine)
@@ -259,28 +275,28 @@ drawWlIDs cfig w = setLayer FixedCoordLayer $ foldMap f (_walls w)
       where
         p = worldPosToScreen w $ 0.5 *.* uncurry (+.+) (_wlLine wl)
 
---edgeToPic :: [Point2] -> PathEdge -> Picture
---edgeToPic poly pe
---    | not (pointInPolygon sp poly) && not (pointInPolygon ep poly) = mempty
---    | null $ _peObstacles pe 
---                = anarrow green
---    | hasobstacle BlockObstacle  
---                = anarrow red
---    | hasobstacle AutoDoorObstacle = anarrow yellow
---    | otherwise = anarrow cyan
---  where
---    hasobstacle = (`Set.member` _peObstacles pe)
---    anarrow col = color col $ arrow sp ep
---    sp = _peStart pe
---    ep = _peEnd pe
+edgeToPic :: [Point2] -> PathEdge -> Picture
+edgeToPic poly pe
+    | not (pointInPolygon sp poly) && not (pointInPolygon ep poly) = mempty
+    | null $ _peObstacles pe 
+                = anarrow green
+    | hasobstacle BlockObstacle  
+                = anarrow red
+    | hasobstacle AutoDoorObstacle = anarrow yellow
+    | otherwise = anarrow cyan
+  where
+    hasobstacle = (`Set.member` _peObstacles pe)
+    anarrow col = color col $ arrow sp ep
+    sp = _peStart pe
+    ep = _peEnd pe
 
 drawPathing :: Configuration -> World -> Picture
-drawPathing cfig w = setLayer DebugLayer mempty
---    $  foldMap (edgeToPic (screenPolygon cfig w) . (^?! _3)) (FGL.labEdges gr)
---    <> concatMap dispInc (graphToIncidence gr)
---  where
---    dispInc (p,n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n
---    gr = _pathGraph w
+drawPathing cfig w = setLayer DebugLayer
+    $  foldMap (edgeToPic (screenPolygon cfig w) . (^?! _3)) (FGL.labEdges gr)
+    <> concatMap dispInc (graphToIncidence gr)
+  where
+    dispInc (p,n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n
+    gr = _pathGraph w
 
 crDisplayInfo :: Configuration -> World -> Creature -> Maybe (Point2,[String])
 crDisplayInfo cfig w cr 

From 75a98a572f784bd451b0e8b2e48898af255beb36 Mon Sep 17 00:00:00 2001
From: justin <justin.g.kruger@gmail.com>
Date: Sat, 2 Jul 2022 12:14:31 +0100
Subject: [PATCH 18/20] Correct walkableNodeNear

---
 src/Dodge/Path.hs                | 17 +++++++++++------
 src/Dodge/Render/ShapePicture.hs |  4 ++--
 2 files changed, 13 insertions(+), 8 deletions(-)

diff --git a/src/Dodge/Path.hs b/src/Dodge/Path.hs
index ceceb5712..246fcecf7 100644
--- a/src/Dodge/Path.hs
+++ b/src/Dodge/Path.hs
@@ -6,6 +6,7 @@ module Dodge.Path
     , removePathsCrossing
     , pairsToGraph
     , getNodePos
+    , walkableNodeNear
     ) where
 import Dodge.Data
 import Dodge.Base.Collide
@@ -31,16 +32,20 @@ getNodePos i w = _pathGraph w `lab` i
 
 makePathBetween :: Point2 -> Point2 -> World -> Maybe [Int]
 makePathBetween a b w = do -- join $ sp <$> a' <*> b' <*> return (_pathGraph w)
-    na <- walkableNodeNear a
-    nb <- walkableNodeNear b
+    na <- walkableNodeNear w a
+    nb <- walkableNodeNear w b
     sp na nb (second _peDist (_pathGraph w))
   where
     --nodesNear p = concat $ lookLookups (zoneNearPointIP p) (_pathPoints w)
-    nodesNear p = runIdentity . S.toList_ $ nearPoint _pnZoning p w
-    walkableNodeNear p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear p
+--    nodesNear p = runIdentity . S.toList_ $ nearPoint _pnZoning p w
+--    walkableNodeNear p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear p
 
---walkableNodeNear :: Point2 -> World -> Maybe Point2
---walkableNodeNear p w = insideCirc
+walkableNodeNear :: World -> Point2 -> Maybe Int
+{-# INLINE walkableNodeNear #-}
+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
 
 makePathBetweenPs :: Point2 -> Point2 -> World -> Maybe [Point2]
 makePathBetweenPs a b w = mapMaybe (lab $ _pathGraph w) <$> makePathBetween a b w
diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs
index 53bc6574e..2a404da3c 100644
--- a/src/Dodge/Render/ShapePicture.hs
+++ b/src/Dodge/Render/ShapePicture.hs
@@ -122,8 +122,8 @@ drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (_creatures w)
 drawPathBetween :: World -> Picture
 drawPathBetween w = setLayer DebugLayer
     $  color yellow (foldMap (arrowPath . mapMaybe nodepos) nodelist)
-    <> foldMap (color green . arrow sp) (nodepos =<< nodelist ^? _Just . ix 0)
-    <> foldMap (color cyan . flip arrow ep) (nodepos =<< lastOf traverse =<< nodelist ^? _Just)
+    <> foldMap (color green . arrow sp) (nodepos =<< walkableNodeNear w sp)
+    <> foldMap (color cyan . flip arrow ep) (nodepos =<< walkableNodeNear w ep)
   where
     nodepos = (`getNodePos` w)
     nodelist = makePathBetween sp ep w

From 3952ec6315890cb316995054579e0c96717824f5 Mon Sep 17 00:00:00 2001
From: justin <justin.g.kruger@gmail.com>
Date: Sat, 2 Jul 2022 15:31:27 +0100
Subject: [PATCH 19/20] Store paths crossing block walls in block

---
 src/Dodge/Data.hs                      |  2 ++
 src/Dodge/Data/PathGraph.hs            |  1 +
 src/Dodge/Default/Block.hs             |  1 +
 src/Dodge/Default/World.hs             |  1 +
 src/Dodge/Layout.hs                    |  6 +++---
 src/Dodge/Path.hs                      | 28 +++++++++++++++++++++-----
 src/Dodge/Placement/PlaceSpot.hs       |  7 ++++---
 src/Dodge/Placement/PlaceSpot/Block.hs | 23 +++++++++++++++------
 8 files changed, 52 insertions(+), 17 deletions(-)

diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs
index fe195d2b3..214450261 100644
--- a/src/Dodge/Data.hs
+++ b/src/Dodge/Data.hs
@@ -151,6 +151,7 @@ data World = World
     , _pathGraph            :: Gr Point2 PathEdge
     , _pathGraphP           :: S.Set (Point2,Point2)
     , _pnZoning             :: Zoning [] (Int,Point2)
+    , _peZoning             :: Zoning [] (Int,Int,PathEdge)
     , _hud                  :: HUD
     , _lightSources         :: IM.IntMap LightSource
     , _tempLightSources     :: [TempLightSource]
@@ -951,6 +952,7 @@ data Block = Block
     , _blDir        :: Float
     , _blDraw       :: Block -> SPic
     , _blDeath      :: Block -> World -> World
+    , _blPaths      :: [(Int,Int,PathEdge)]
     }
 data TerminalStatus = TerminalOff | TerminalBusy | TerminalReady
   deriving (Eq,Ord,Show)
diff --git a/src/Dodge/Data/PathGraph.hs b/src/Dodge/Data/PathGraph.hs
index e6984fc53..7b8d6f4f4 100644
--- a/src/Dodge/Data/PathGraph.hs
+++ b/src/Dodge/Data/PathGraph.hs
@@ -27,3 +27,4 @@ data EdgeObstacle
   deriving (Eq,Ord,Show,Bounded,Enum)
 
 makeLenses ''PathGraph
+makeLenses ''PathEdge
diff --git a/src/Dodge/Default/Block.hs b/src/Dodge/Default/Block.hs
index c7813c4c8..8b15a8e21 100644
--- a/src/Dodge/Default/Block.hs
+++ b/src/Dodge/Default/Block.hs
@@ -15,6 +15,7 @@ defaultBlock = Block
     , _blDraw      = const mempty
     , _blDeath     = makeBlockDebris
     , _blObstructs = []
+    , _blPaths      = []
     }
 defaultDirtBlock :: Block
 defaultDirtBlock = defaultBlock & blHP .~ 50
diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs
index 8370650d2..350d04c12 100644
--- a/src/Dodge/Default/World.hs
+++ b/src/Dodge/Default/World.hs
@@ -77,6 +77,7 @@ defaultWorld = World
     , _pathGraph = Data.Graph.Inductive.Graph.empty
     , _pathGraphP   = mempty
     , _pnZoning     = Zoning mempty wlZoneSize (zonePos snd)
+    , _peZoning     = Zoning mempty wlZoneSize (\x (_,_,e) -> zoneOfSeg x (_peStart e) (_peEnd e))
     , _hud = HUD
         { _hudElement = DisplayInventory NoSubInventory
         , _carteCenter = V2 0 0
diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs
index b5c3bb45b..19cb0cc1d 100644
--- a/src/Dodge/Layout.hs
+++ b/src/Dodge/Layout.hs
@@ -48,10 +48,10 @@ generateLevelFromRoomList gr' w = initWallZoning
         }
         & pnZoning   %~ (\zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
             (labNodes path))
---        & peZoning   %~ (\zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
---            (labEdges (_pgGraph path)))
+        & peZoning   %~ (\zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
+            (labEdges path))
   where
-    path = pairsToGraph pairPath
+    (_,path) = pairsToGraph pairPath
     pairPath = foldMap _rmPath rs
     rs = map doRoomShift $ IM.elems rs'
     rs'= mapM shuffleRoomPos gr' & evalState $ _randGen w
diff --git a/src/Dodge/Path.hs b/src/Dodge/Path.hs
index 246fcecf7..d61c1d6ca 100644
--- a/src/Dodge/Path.hs
+++ b/src/Dodge/Path.hs
@@ -3,7 +3,8 @@ module Dodge.Path
     ( pointTowardsImpulse
     , makePathBetween
     , makePathBetweenPs
-    , removePathsCrossing
+--    , removePathsCrossing
+    , obstructPathsCrossing
     , pairsToGraph
     , getNodePos
     , walkableNodeNear
@@ -96,7 +97,7 @@ pointTowardsImpulse a b w = find (flip (isWalkable a) w) =<< makePathBetweenPs a
 --        [] -> return Nothing
 --        _  -> return $ Just $ ns !! i
 --
-pairsToGraph :: Set.Set (Point2,Point2) -> Gr Point2 PathEdge
+pairsToGraph :: Set.Set (Point2,Point2) -> (Map (V2 Point2) (Int,Int,PathEdge),Gr Point2 PathEdge)
 pairsToGraph pairs = addEdges nodemap gr $ S.each pairs
   where
     (nodemap,_,gr) = addNodes $ S.map fst (S.each pairs) <> S.map snd (S.each pairs)
@@ -110,12 +111,29 @@ addNodes = runIdentity . S.fold_ f (mempty,0,Data.Graph.Inductive.empty) id
     f (nodemap,i,gr) p = case nodemap M.!? p of
         Just _  -> (nodemap,i,gr)
         Nothing -> (nodemap & at p ?~i ,i+1, insNode (i,p) gr)
-addEdges :: Map Point2 Int -> Gr Point2 PathEdge -> StreamOf (Point2,Point2) -> Gr Point2 PathEdge
-addEdges nodemap gr = runIdentity . S.fold_ f gr id
+addEdges :: Map Point2 Int -> Gr Point2 PathEdge -> StreamOf (Point2,Point2) 
+    -> (Map (V2 Point2) (Int,Int,PathEdge) , Gr Point2 PathEdge)
+addEdges nodemap gr = runIdentity . S.fold_ f (mempty,gr) id
   where
-    f gr' (a,b) = insEdge (g a,g b,PathEdge a b (dist a b) mempty) gr'
+    f (edgemap,gr') (a,b) = (M.insert (V2 a b) theedge edgemap
+        , insEdge theedge gr'
+        )
+      where
+        theedge = (g a,g b,PathEdge a b (dist a b) mempty)
     g a = nodemap M.! a
 
+obstructPathsCrossing :: Point2 -> Point2 -> World -> ( World, [(Int,Int,PathEdge)])
+obstructPathsCrossing sp ep w = 
+    ( w & pathGraph %~ updateedges
+    , runIdentity $ S.toList_ edges
+    )
+  where
+    edges = S.filter edgecrosses $ nearSeg _peZoning sp ep w
+    edgecrosses (_,_,pe) = isJust $ intersectSegSeg sp ep (_peStart pe) (_peEnd pe)
+    updateedges gr = runIdentity $ S.fold_ updateedge gr id edges
+    updateedge gr (x,y,pe) 
+        = insEdge (x,y,pe & peObstacles . at BlockObstacle .~ Just ()) $ delEdge (x,y) gr
+
 removePathsCrossing :: Point2 -> Point2 -> World -> World
 removePathsCrossing a b w = w
 --    & pathGraph  .~ newGraph 
diff --git a/src/Dodge/Placement/PlaceSpot.hs b/src/Dodge/Placement/PlaceSpot.hs
index c65e3220d..109e2c9e5 100644
--- a/src/Dodge/Placement/PlaceSpot.hs
+++ b/src/Dodge/Placement/PlaceSpot.hs
@@ -120,9 +120,10 @@ evaluateRandPS rgen ps w = placeSpotID ps evaluatedType (set randGen g w)
     (evaluatedType, g) = runState rgen (_randGen w)
 
 placeWallPoly :: [Point2] -> Wall -> World -> World
-placeWallPoly ps wl = rmCrossPaths . over walls (placeWalls ps wl)
-  where
-    rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ loopPairs ps
+placeWallPoly ps wl = -- rmCrossPaths . 
+    over walls (placeWalls ps wl)
+--  where
+--    rmCrossPaths w = foldr (uncurry obstructPathsCrossing) w $ loopPairs ps
 
 placeWalls :: [Point2] -> Wall -> IM.IntMap Wall -> IM.IntMap Wall
 placeWalls qs wl wls = foldl' (addPane wl) wls pairs
diff --git a/src/Dodge/Placement/PlaceSpot/Block.hs b/src/Dodge/Placement/PlaceSpot/Block.hs
index 644fb0845..2a39b6964 100644
--- a/src/Dodge/Placement/PlaceSpot/Block.hs
+++ b/src/Dodge/Placement/PlaceSpot/Block.hs
@@ -25,13 +25,13 @@ plBlock
     -> (Int,World)
 plBlock [] _ _ _ = error "Trying to add a block with incomplete polygon"
 plBlock (p:ps) bl wl w = (,) blid $ w
-    & flip (foldr insertWall) wls
     & blocks . at blid ?~ bl 
         { _blID = blid
         , _blWallIDs = IS.fromList is
         , _blShadows = []
         , _blFootprint = p:ps
         }
+    & insertWalls blid wls
   where 
     blid = IM.newKey $ _blocks w
     lns = zip (p:ps) (ps ++ [p])
@@ -51,7 +51,8 @@ plLineBlock
     -> World 
     -> (Int, World)
 plLineBlock basePane blwidth a b gw = ( 0 
-    , foldr insertWall (insertBlocks gw) listWalls
+--    , foldr insertWall (insertBlocks gw) listWalls
+    , insertBlocks gw
     )
   where 
     depth = blwidth
@@ -65,13 +66,17 @@ plLineBlock basePane blwidth a b gw = ( 0
     linesAt p = loopPairs $ cornersAt p
     wlid = IM.newKey $ _walls gw
     blid = IM.newKey $ _blocks gw
-    insertBlock (i,p) = over blocks $ IM.insert (i+blid) Block 
+    insertBlock (i,p) = 
+        insertWalls (i + blid) (makeWallAt p i)
+        . (over blocks $ IM.insert (i+blid) Block 
         { _blID = i + blid, _blWallIDs = IS.fromList $ ksAtI i
         , _blHP = 1000, _blShadows = shadowsAt i
         , _blDir = 0    -- THIS IS NOT SENSIBLE. TODO rethink block positioning
         , _blFootprint = cornersAt p -- TODO check winding (clockwise, anticlockwise)
         , _blObstructs = []
+        , _blPaths = []
         , _blPos = p, _blDraw = const mempty , _blDeath = makeBlockDebris}
+        )
     insertBlocks = flip (foldr insertBlock) $ zip is blockCenPs
     ksAtI i = map ( + (wlid + i*4) ) [0,1,2,3]
     visibilityAt i 
@@ -91,6 +96,12 @@ plLineBlock basePane blwidth a b gw = ( 0
         }
     listWalls = concat $ zipWith makeWallAt blockCenPs is
 
-insertWall :: Wall -> World -> World
-insertWall wl = (walls . at (_wlID wl) ?~ wl)
---    . uncurry (addObstacleCrossing' BlockObstacle) (_wlLine wl)
+-- | Must be done after inserting the block
+insertWalls :: Int -> [Wall] -> World -> World
+insertWalls blid wls w = w' & blocks . ix blid . blPaths .~ concat paths
+  where
+    (w',paths) = mapAccumR (flip insertWall) w wls
+
+insertWall :: Wall -> World -> (World,[(Int,Int,PathEdge)])
+insertWall wl = uncurry obstructPathsCrossing (_wlLine wl)
+    . (walls . at (_wlID wl) ?~ wl)

From f2e8be35c19f13109a0aaf1e2bb2a5897e928152 Mon Sep 17 00:00:00 2001
From: justin <justin.g.kruger@gmail.com>
Date: Sat, 2 Jul 2022 15:50:50 +0100
Subject: [PATCH 20/20] Block destruction can update pathing

---
 src/Dodge/Block.hs | 15 +++++++++++++++
 1 file changed, 15 insertions(+)

diff --git a/src/Dodge/Block.hs b/src/Dodge/Block.hs
index aab3b607a..60d5fd3d7 100644
--- a/src/Dodge/Block.hs
+++ b/src/Dodge/Block.hs
@@ -1,5 +1,6 @@
 module Dodge.Block where
 import Dodge.Data
+import Dodge.Base.Collide
 import Dodge.Material
 --import Dodge.Block.Debris
 import Dodge.Zone
@@ -10,11 +11,14 @@ import RandomHelp
 import Geometry
 --import Geometry.ConvexPoly
 
+import Data.Foldable
 import Data.Function
 import Data.Maybe
 import qualified Data.IntSet as IS
 import qualified Data.IntMap.Strict as IM
 import Control.Lens
+import qualified Streaming.Prelude as S
+import qualified Data.Graph.Inductive as FGL
 
 splinterBlock :: Block -> World -> World
 splinterBlock bl w = foldr unshadowBlock w (_blShadows bl) -- foldr shiftTowardCen w (_blWallIDs bl)
@@ -45,6 +49,7 @@ destroyBlock bl w = w
     & flip (foldr unshadowBlock) (_blShadows bl)
     & _blDeath bl bl
     & deleteWallIDs wlids
+    & maybeClearPaths (_blPaths bl) -- must happen after the walls are deleted
     & blocks %~ IM.delete (_blID bl)
 --    & matDesSound (_blMaterial bl) pos
     & flip (foldr (wlDustAt awl)) (map (pos +.+) ps)
@@ -54,6 +59,16 @@ destroyBlock bl w = w
     pos = fst . _wlLine $ _walls w IM.! IS.findMin wlids
     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 ps w = foldl' maybeClearPath w ps
+
+maybeClearPath :: World -> (Int,Int,PathEdge) -> World
+maybeClearPath w (x,y,pe) 
+    | runIdentity . S.any_ (const True) $ overlapSegWalls (_peStart pe) (_peEnd pe) $ wlsNearSeg (_peStart pe) (_peEnd pe) w
+        = w
+    | otherwise = w & pathGraph %~ (FGL.insEdge (x,y,pe & peObstacles .~ mempty)) . FGL.delEdge (x,y) 
+
 destroyDoor :: Door -> World -> World
 destroyDoor dr w = w
     & _drDeath dr dr