From 84cb83080400dc7a563be9832b49a0406c08636c Mon Sep 17 00:00:00 2001
From: justin <justin.g.kruger@gmail.com>
Date: Wed, 29 Jun 2022 19:20:27 +0100
Subject: [PATCH 01/13] Add debugging for pathfinding

---
 src/Dodge/Config/Data.hs          |   3 +-
 src/Dodge/Data.hs                 |   5 +-
 src/Dodge/Default/World.hs        |   7 +-
 src/Dodge/Path.hs                 |  26 ++-
 src/Dodge/Render/ShapePicture.hs  | 107 +++++----
 src/Dodge/Update.hs               |  23 +-
 src/Dodge/Update/UsingInput.hs    |   2 +-
 src/Dodge/WorldEvent/ThingsHit.hs |   1 -
 src/Dodge/Zone.hs                 |   8 +-
 src/Dodge/Zone/Size.hs            |   3 +
 src/FoldableHelp.hs               |   1 -
 src/Picture.hs                    | 368 +----------------------------
 src/Picture/Base.hs               | 373 ++++++++++++++++++++++++++++++
 src/Picture/Composite.hs          |  16 ++
 14 files changed, 511 insertions(+), 432 deletions(-)
 create mode 100644 src/Picture/Base.hs
 create mode 100644 src/Picture/Composite.hs

diff --git a/src/Dodge/Config/Data.hs b/src/Dodge/Config/Data.hs
index 09cef2ffa..9bf40d033 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,7 @@ data DebugBool
     | Show_far_wall_detect
     | Show_select
     | Inspect_wall
+    | Show_nodes_near_select
   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..1cf614096 100644
--- a/src/Dodge/Default/World.hs
+++ b/src/Dodge/Default/World.hs
@@ -74,7 +74,7 @@ defaultWorld = World
     , _clickMousePos = V2 0 0
     , _pathGraph = Data.Graph.Inductive.Graph.empty
     , _pathGraphP   = mempty
-    , _phZoning     = Zoning mempty wlZoneSize (zonePos snd)
+    , _phZoning     = Zoning mempty phZoneSize (zonePos snd)
     , _hud = HUD
         { _hudElement = DisplayInventory NoSubInventory
         , _carteCenter = V2 0 0
@@ -111,7 +111,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/Path.hs b/src/Dodge/Path.hs
index ffa337bf5..dd1517f17 100644
--- a/src/Dodge/Path.hs
+++ b/src/Dodge/Path.hs
@@ -4,6 +4,9 @@ module Dodge.Path
     , makePathBetweenPs
     , removePathsCrossing
     , pairsToGraph
+    , walkableNodeNear
+    , nodesNearL
+    , getNodePos
     ) where
 import Dodge.Data
 import Dodge.Base.Collide
@@ -18,21 +21,28 @@ import Data.List
 import Data.Graph.Inductive hiding ((&))
 import qualified Data.Set as Set
 import qualified Streaming.Prelude as S
+import StreamingHelp
 --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
-    nb <- walkableNodeNear b
+    (na,_) <- walkableNodeNear a w
+    (nb,_) <- walkableNodeNear b w
     sp na nb (_pathGraph w)
-  where
-    --nodesNear p = concat $ lookLookups (zoneNearPointIP p) (_pathPoints w)
-    nodesNear p = runIdentity . S.toList_ $ nearPoint _phZoning p w
-    walkableNodeNear p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear p
 
---walkableNodeNear :: Point2 -> World -> Maybe Point2
---walkableNodeNear p w = insideCirc
+walkableNodeNear :: Point2 -> World -> Maybe (Int,Point2)
+walkableNodeNear p w = minStreamOn (dist p . snd) 
+    . S.filter (flip (isWalkable p) w . snd) $ nodesNear p w
+
+nodesNear :: Point2 -> World -> StreamOf (Int,Point2)
+nodesNear = aroundPoint _phZoning
+
+nodesNearL :: Point2 -> World -> [(Int,Point2)]
+nodesNearL p = runIdentity . S.toList_ . nodesNear p
 
 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 fe3045588..62bdc0c30 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
@@ -76,34 +78,61 @@ 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 w
+    Show_nodes_near_select  -> Right $ drawNodesNearSelect w
 
 drawCreatureDisplayTexts :: World -> Picture
 drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (_creatures w)
 
+drawNodesNearSelect :: World -> Picture
+drawNodesNearSelect w = setLayer DebugLayer $
+     runIdentity (S.foldMap_ (drawZone phZoneSize) (zoneAroundPoint phZoneSize sp))
+    <> color red (foldMap (drawCross . snd) $ nodesNearL sp w)
+    <> color green (drawCross sp)
+    <> color cyan (foldMap (drawCross . snd) $ walkableNodeNear sp w)
+    <> color yellow (foldMap (arrowPath . mapMaybe (`getNodePos` w)) (makePathBetween sp ep w))
+  where
+    sp = _lSelect w
+    ep = _rSelect w
+
+
 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 +146,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 +227,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 +241,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,13 +263,10 @@ drawWallIDs cfig w
       where
         p = worldPosToScreen w $ 0.5 *.* uncurry (+.+) (_wlLine wl)
 
-drawPathing :: Configuration -> World -> Picture
-drawPathing cfig w
-    | debugOn Pathing cfig 
-        = setLayer DebugLayer $ 
+drawPathing :: World -> Picture
+drawPathing w = 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
@@ -274,11 +291,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..276676dad 100644
--- a/src/Dodge/Update.hs
+++ b/src/Dodge/Update.hs
@@ -98,15 +98,26 @@ 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
-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'
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..80a2fae19 100644
--- a/src/Dodge/WorldEvent/ThingsHit.hs
+++ b/src/Dodge/WorldEvent/ThingsHit.hs
@@ -4,7 +4,6 @@ Find which objects lie upon a line.
  -}
 module Dodge.WorldEvent.ThingsHit
     ( thingsHit
---    , wallsHit
     , thingHit
     , thingsHitExceptCr
     )
diff --git a/src/Dodge/Zone.hs b/src/Dodge/Zone.hs
index aa7ade821..2d181352f 100644
--- a/src/Dodge/Zone.hs
+++ b/src/Dodge/Zone.hs
@@ -1,6 +1,7 @@
 module Dodge.Zone
     ( zoneOfSight
     , zoneAroundPoint
+    , aroundPoint
     , nearPoint
     , wlsNearPoint
     , crsNearPoint
@@ -83,6 +84,11 @@ 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
+aroundPoint f p w = streamFromZone zn $ zoneAroundPoint (_znSize zn) p
+  where
+    zn = f w
+
 clsNearPoint :: Point2 -> World -> StreamOf Cloud
 clsNearPoint = nearPoint _clZoning
 
@@ -95,7 +101,7 @@ crsNearPoint = nearPoint _crZoning
 nearSeg :: Foldable t => (World -> Zoning t a) -> Point2 -> Point2 -> World -> StreamOf a
 nearSeg f p r w = streamFromZone zn $ zoneOfSeg (_znSize zn) p r
   where
-    zn = (f w)
+    zn = f w
 
 wlsNearSeg :: Point2 -> Point2 -> World -> Stream (Of Wall) Identity ()
 wlsNearSeg = nearSeg _wlZoning
diff --git a/src/Dodge/Zone/Size.hs b/src/Dodge/Zone/Size.hs
index 16fda43e3..b7f238797 100644
--- a/src/Dodge/Zone/Size.hs
+++ b/src/Dodge/Zone/Size.hs
@@ -1,5 +1,8 @@
 module Dodge.Zone.Size where
 
+phZoneSize :: Float
+phZoneSize = 100
+
 wlZoneSize :: Float
 wlZoneSize = 50
 
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/Picture.hs b/src/Picture.hs
index d216ec0b4..b83a27345 100644
--- a/src/Picture.hs
+++ b/src/Picture.hs
@@ -2,372 +2,12 @@
 {-# 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 1abcf099e2644dfe6bb39076f9c7af9b300da6f6 Mon Sep 17 00:00:00 2001
From: justin <justin.g.kruger@gmail.com>
Date: Wed, 29 Jun 2022 23:17:45 +0100
Subject: [PATCH 02/13] Fix leaky path graph creation

---
 src/Dodge/Data.hs                      |  4 +-
 src/Dodge/Data/PathGraph.hs            | 12 ++++++
 src/Dodge/Default/World.hs             |  3 +-
 src/Dodge/Layout.hs                    |  2 +-
 src/Dodge/Path.hs                      | 57 +++++++++++++++++---------
 src/Dodge/Placement/PlaceSpot.hs       |  7 ++--
 src/Dodge/Placement/PlaceSpot/Block.hs |  6 ++-
 src/Dodge/Render/ShapePicture.hs       |  2 +-
 8 files changed, 65 insertions(+), 28 deletions(-)
 create mode 100644 src/Dodge/Data/PathGraph.hs

diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs
index cb82f08f7..a109594e2 100644
--- a/src/Dodge/Data.hs
+++ b/src/Dodge/Data.hs
@@ -10,6 +10,7 @@ circular imports are probably not a good idea.
 {-# LANGUAGE DerivingStrategies #-}
 module Dodge.Data 
     ( module Dodge.Data
+    , module Dodge.Data.PathGraph
     , module Dodge.Data.Material
     , module Dodge.Data.LoadAction
     , module Dodge.Data.ForegroundShape
@@ -34,6 +35,7 @@ module Dodge.Data
     , module Dodge.Data.Room
     ) 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            :: PathGraph
     , _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
new file mode 100644
index 000000000..5b318938e
--- /dev/null
+++ b/src/Dodge/Data/PathGraph.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE StrictData #-}
+module Dodge.Data.PathGraph where
+import Geometry.Data
+import Control.Lens
+import Data.Graph.Inductive
+data PathGraph = PathGraph
+    { _pgGraph      :: Gr Point2 Float
+    , _pgNodeMap    :: NodeMap Point2
+    }
+
+makeLenses ''PathGraph
diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs
index 1cf614096..fc237cf73 100644
--- a/src/Dodge/Default/World.hs
+++ b/src/Dodge/Default/World.hs
@@ -18,6 +18,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
@@ -72,7 +73,7 @@ defaultWorld = World
     --, _savedWorlds = M.empty
 --    , _menuLayers = []
     , _clickMousePos = V2 0 0
-    , _pathGraph = Data.Graph.Inductive.Graph.empty
+    , _pathGraph = PathGraph Data.Graph.Inductive.Graph.empty new
     , _pathGraphP   = mempty
     , _phZoning     = Zoning mempty phZoneSize (zonePos snd)
     , _hud = HUD
diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs
index 235f1d797..056f8df8a 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 dd1517f17..f1ee3529c 100644
--- a/src/Dodge/Path.hs
+++ b/src/Dodge/Path.hs
@@ -2,8 +2,9 @@ module Dodge.Path
     ( pointTowardsImpulse
     , makePathBetween
     , makePathBetweenPs
-    , removePathsCrossing
+--    , removePathsCrossing
     , pairsToGraph
+    , pairsToGraph''
     , walkableNodeNear
     , nodesNearL
     , getNodePos
@@ -26,26 +27,28 @@ import StreamingHelp
 --import Data.Graph.Inductive.Graph hiding ((&))
 
 getNodePos :: Int -> World -> Maybe Point2
-getNodePos i w = _pathGraph w `lab` i
+getNodePos i w = _pgGraph (_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 w
     (nb,_) <- walkableNodeNear b w
-    sp na nb (_pathGraph w)
+    sp na nb (_pgGraph $ _pathGraph w)
 
 walkableNodeNear :: Point2 -> World -> Maybe (Int,Point2)
+{-# INLINE walkableNodeNear #-}
 walkableNodeNear p w = minStreamOn (dist p . snd) 
     . S.filter (flip (isWalkable p) w . snd) $ nodesNear p w
 
 nodesNear :: Point2 -> World -> StreamOf (Int,Point2)
+{-# INLINE nodesNear #-}
 nodesNear = aroundPoint _phZoning
 
 nodesNearL :: Point2 -> World -> [(Int,Point2)]
 nodesNearL p = runIdentity . S.toList_ . nodesNear p
 
 makePathBetweenPs :: Point2 -> Point2 -> World -> Maybe [Point2]
-makePathBetweenPs a b w = mapMaybe (lab $ _pathGraph w) <$> makePathBetween a b w
+makePathBetweenPs a b w = mapMaybe (lab $ _pgGraph $ _pathGraph w) <$> makePathBetween a b w
 
 pointTowardsImpulse :: Point2 -> Point2 -> World -> Maybe Point2
 pointTowardsImpulse a b w = find (flip (isWalkable a) w) =<< makePathBetweenPs a b w
@@ -93,19 +96,35 @@ 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')
 
-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'
+pairsToGraph'' :: Set.Set (Point2,Point2) -> PathGraph
+pairsToGraph'' = uncurry PathGraph . pairsToGraph' dist
+
+pairsToGraph' :: Ord a => (a -> a -> b) -> Set.Set (a,a) -> (Gr a b, NodeMap a)
+pairsToGraph' f = runIdentity . S.fold_ g (Data.Graph.Inductive.empty,new) id . S.each
+  where
+    g grnm (x,y) = h' $ h x $ h y grnm
+      where
+        h' (gr,nm) = (insMapEdge nm (x,y,f x y) gr , nm)
+        h n (gr,nm) = (gr',nm')
+          where
+            (gr',nm',_) = insMapNode nm n gr
+
+pairsToGraph :: (Ord a, Ord b) => (a -> a -> b) -> Set.Set (a,a) -> Gr a b
+pairsToGraph f pairs = undir
+    $ run_ Data.Graph.Inductive.empty 
+    $ insMapNodesM (Set.toList nodes') >> insMapEdgesM (Set.toList pairs')
+  where
+    nodes' = Set.map fst pairs `Set.union` Set.map snd pairs
+    pairs' = Set.map (\(x,y)->(x,y,f x y)) pairs
+
+--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'
diff --git a/src/Dodge/Placement/PlaceSpot.hs b/src/Dodge/Placement/PlaceSpot.hs
index 5663cb04f..c793ceb37 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 = over walls (placeWalls ps wl)
+--placeWallPoly ps wl = rmCrossPaths . over walls (placeWalls ps wl)
+--  where
+--    rmCrossPaths w = foldr (uncurry removePathsCrossing) 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 671fcd3a1..abb72b7de 100644
--- a/src/Dodge/Placement/PlaceSpot/Block.hs
+++ b/src/Dodge/Placement/PlaceSpot/Block.hs
@@ -55,7 +55,8 @@ addBlock _ _ _ _ = error "Trying to add a block with incomplete polygon"
         
 placeBlock :: [Point2] -> Block -> Wall -> World -> (Int,World)
 placeBlock poly bl wl w 
-    = (0, foldr (uncurry removePathsCrossing) wWithBlock pairs)
+--    = (0, foldr (uncurry removePathsCrossing) wWithBlock pairs)
+    = (0, wWithBlock)
   where 
     pairs = loopPairs poly
     wWithBlock = addBlock poly wl bl w
@@ -70,7 +71,8 @@ placeLineBlock
     -> World 
     -> (Int, World)
 placeLineBlock basePane blockWidth depth a b gw = ( 0 
-    , removePathsCrossing a b (foldr insertWall (insertBlocks gw) listWalls)
+    , (foldr insertWall (insertBlocks gw) listWalls)
+--    , removePathsCrossing a b (foldr insertWall (insertBlocks gw) listWalls)
     )
   where 
     psOnLine = divideLineOddNumPoints blockWidth a b
diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs
index 62bdc0c30..8e2c7e2a0 100644
--- a/src/Dodge/Render/ShapePicture.hs
+++ b/src/Dodge/Render/ShapePicture.hs
@@ -269,7 +269,7 @@ drawPathing w = setLayer DebugLayer $
         <> concatMap dispInc (graphToIncidence gr)
   where
     dispInc (p,n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n
-    gr = _pathGraph w
+    gr = _pgGraph $ _pathGraph w
 
 crDisplayInfo :: Configuration -> World -> Creature -> Maybe (Point2,[String])
 crDisplayInfo cfig w cr 

From 3dfa6926cc183d7a3f19c8dfb1e34bfad927d74a Mon Sep 17 00:00:00 2001
From: justin <justin.g.kruger@gmail.com>
Date: Thu, 30 Jun 2022 16:41:12 +0100
Subject: [PATCH 03/13] Tweak pathfinding

---
 src/Dodge/Data.hs                      |  2 +-
 src/Dodge/Layout.hs                    |  4 +++
 src/Dodge/Path.hs                      | 41 +++++++++++++++++++-------
 src/Dodge/Placement/PlaceSpot.hs       |  8 ++---
 src/Dodge/Placement/PlaceSpot/Block.hs |  4 +--
 src/Dodge/Render/ShapePicture.hs       |  2 ++
 src/Dodge/Zone.hs                      |  1 +
 7 files changed, 44 insertions(+), 18 deletions(-)

diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs
index a109594e2..4fa281d75 100644
--- a/src/Dodge/Data.hs
+++ b/src/Dodge/Data.hs
@@ -76,7 +76,7 @@ import GHC.Generics
 import Control.Lens
 import Control.Monad.State
 import System.Random
-import Data.Graph.Inductive
+--import Data.Graph.Inductive
 import qualified Data.Set as S
 import qualified Data.IntSet as IS
 import qualified Data.IntMap.Strict as IM
diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs
index 056f8df8a..6170b0c68 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)
 import Data.List (nubBy)
 import Data.Traversable
 import Control.Lens
@@ -44,6 +46,8 @@ generateLevelFromRoomList gr' w = initWallZoning
         , _pathGraph    = path
         , _pathGraphP   = pairPath
         }
+        & phZoning   %~ \zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
+            (labNodes (_pgGraph path))
   where
     path = pairsToGraph'' pairPath
     pairPath = foldMap _rmPath rs
diff --git a/src/Dodge/Path.hs b/src/Dodge/Path.hs
index f1ee3529c..4aaaf870e 100644
--- a/src/Dodge/Path.hs
+++ b/src/Dodge/Path.hs
@@ -1,8 +1,9 @@
+{-# LANGUAGE TupleSections #-}
 module Dodge.Path 
     ( pointTowardsImpulse
     , makePathBetween
     , makePathBetweenPs
---    , removePathsCrossing
+    , removePathsCrossing
     , pairsToGraph
     , pairsToGraph''
     , walkableNodeNear
@@ -101,14 +102,15 @@ pairsToGraph'' :: Set.Set (Point2,Point2) -> PathGraph
 pairsToGraph'' = uncurry PathGraph . pairsToGraph' dist
 
 pairsToGraph' :: Ord a => (a -> a -> b) -> Set.Set (a,a) -> (Gr a b, NodeMap a)
-pairsToGraph' f = runIdentity . S.fold_ g (Data.Graph.Inductive.empty,new) id . S.each
+pairsToGraph' f pairset = ngr'
   where
-    g grnm (x,y) = h' $ h x $ h y grnm
-      where
-        h' (gr,nm) = (insMapEdge nm (x,y,f x y) gr , nm)
-        h n (gr,nm) = (gr',nm')
-          where
-            (gr',nm',_) = insMapNode nm n gr
+    nodeset = S.each . runIdentity $ S.fold_ getnode Set.empty id $ S.each pairset
+    getnode nodeset' (x,y) = Set.insert x $ Set.insert y nodeset'
+    ngr = runIdentity $ S.fold_ insertnode (Data.Graph.Inductive.empty,new) id nodeset
+    ngr' = runIdentity $ S.fold_ insertedge ngr id $ S.each pairset
+    insertedge (gr,nm) (x,y) = (insMapEdge nm (x,y,f x y) gr, nm)
+    insertnode (gr,nm) n = fstsnd $ insMapNode nm n gr
+    fstsnd (a,b,_) = (a,b)
 
 pairsToGraph :: (Ord a, Ord b) => (a -> a -> b) -> Set.Set (a,a) -> Gr a b
 pairsToGraph f pairs = undir
@@ -118,13 +120,30 @@ pairsToGraph f pairs = undir
     nodes' = Set.map fst pairs `Set.union` Set.map snd pairs
     pairs' = Set.map (\(x,y)->(x,y,f x y)) pairs
 
---removePathsCrossing :: Point2 -> Point2 -> World -> World
---removePathsCrossing a b w = w
+removePathsCrossing :: Point2 -> Point2 -> World -> World
+removePathsCrossing a b w = w
+--    & pathGraph . pgGraph %~ deleteEdges
+--    & pathGraphP %~ deletePairs
 --    & pathGraph  .~ newGraph 
 --    & pathGraphP .~ pg'
 --    & phZoning   %~ \zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
 --        (labNodes newGraph)
---  where 
+  where
+    thegr = _pgGraph (_pathGraph w)
+    ns = nearSeg _phZoning a b w
+    pairs = S.filter testEdge $ S.for ns (nodePairs thegr)
+    testEdge ((_,p),(_,q)) = isJust $ intersectSegSeg a b p q
+    deleteEdges gr = runIdentity $ S.fold_ deleteEdge gr id pairs
+    deleteEdge gr ((x,_),(y,_)) = delEdge (x,y) $ delEdge (y,x) gr
+--    deletePairs s = runIdentity $ S.fold_ deletePair s id pairs
+--    deletePair s (x,y) = Set.delete (x,y) $ Set.delete (y,x) s
+
+nodePairs :: Gr a b -> (Int,a) -> StreamOf ((Int,a),(Int,a))
+nodePairs gr (n,p) = S.mapMaybe (fmap ((n,p),) . nodeLabel gr) . S.each $ neighbors gr n
+
+nodeLabel :: Gr a b -> Int -> Maybe (Int, a)
+nodeLabel gr n = (n,) <$> lab gr n
+
 --    pg' = Set.filter (isNothing . uncurry (intersectSegSeg a b)) $ _pathGraphP w
 --   -- insertPoint pp@(_,p) = insertInZoneWith (wlZoneOfPoint p) (++) [pp]
 --    newGraph = pairsToGraph'' dist pg'
diff --git a/src/Dodge/Placement/PlaceSpot.hs b/src/Dodge/Placement/PlaceSpot.hs
index c793ceb37..e53035621 100644
--- a/src/Dodge/Placement/PlaceSpot.hs
+++ b/src/Dodge/Placement/PlaceSpot.hs
@@ -120,10 +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 = over walls (placeWalls ps wl)
---placeWallPoly ps wl = rmCrossPaths . over walls (placeWalls ps wl)
---  where
---    rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ loopPairs ps
+--placeWallPoly ps wl = over walls (placeWalls ps wl)
+placeWallPoly ps wl = rmCrossPaths . over walls (placeWalls ps wl)
+  where
+    rmCrossPaths w = foldr (uncurry removePathsCrossing) 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 abb72b7de..5d6850f50 100644
--- a/src/Dodge/Placement/PlaceSpot/Block.hs
+++ b/src/Dodge/Placement/PlaceSpot/Block.hs
@@ -55,8 +55,8 @@ addBlock _ _ _ _ = error "Trying to add a block with incomplete polygon"
         
 placeBlock :: [Point2] -> Block -> Wall -> World -> (Int,World)
 placeBlock poly bl wl w 
---    = (0, foldr (uncurry removePathsCrossing) wWithBlock pairs)
-    = (0, wWithBlock)
+    = (0, foldr (uncurry removePathsCrossing) wWithBlock pairs)
+--    = (0, wWithBlock)
   where 
     pairs = loopPairs poly
     wWithBlock = addBlock poly wl bl w
diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs
index 8e2c7e2a0..2b8901719 100644
--- a/src/Dodge/Render/ShapePicture.hs
+++ b/src/Dodge/Render/ShapePicture.hs
@@ -30,6 +30,7 @@ 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
@@ -266,6 +267,7 @@ drawWlIDs cfig w = setLayer FixedCoordLayer $ foldMap f (_walls w)
 drawPathing :: World -> Picture
 drawPathing w = setLayer DebugLayer $ 
         (color green . pictures . map (thickLine 5 . tflat2) $ graphToEdges gr)
+        --(color green . pictures . Set.map (thickLine 5 . tflat2) $ _pathGraphP w)
         <> concatMap dispInc (graphToIncidence gr)
   where
     dispInc (p,n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n
diff --git a/src/Dodge/Zone.hs b/src/Dodge/Zone.hs
index 2d181352f..ab6f325bc 100644
--- a/src/Dodge/Zone.hs
+++ b/src/Dodge/Zone.hs
@@ -3,6 +3,7 @@ module Dodge.Zone
     , zoneAroundPoint
     , aroundPoint
     , nearPoint
+    , nearSeg
     , wlsNearPoint
     , crsNearPoint
     , clsNearPoint

From 56b063544c4142ec700f3047114b4ad01d800bbe Mon Sep 17 00:00:00 2001
From: justin <justin.g.kruger@gmail.com>
Date: Thu, 30 Jun 2022 23:33:48 +0100
Subject: [PATCH 04/13] Add pathing infrastructure

---
 src/Dodge/Data.hs                      |  3 +-
 src/Dodge/Data/PathGraph.hs            | 19 +++++-
 src/Dodge/Data/Room.hs                 |  6 +-
 src/Dodge/Default/World.hs             |  6 +-
 src/Dodge/Floor.hs                     |  2 +-
 src/Dodge/Layout.hs                    |  8 ++-
 src/Dodge/Path.hs                      | 82 +++++++++++++++++++++-----
 src/Dodge/Placement/PlaceSpot/Block.hs |  2 +-
 src/Dodge/PlacementSpot.hs             | 16 ++---
 src/Dodge/Render/ShapePicture.hs       | 21 +++++--
 src/Dodge/Room/Pillar.hs               |  2 +-
 src/Dodge/Room/Tanks.hs                |  4 +-
 src/Dodge/Zone/Size.hs                 |  4 +-
 13 files changed, 130 insertions(+), 45 deletions(-)

diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs
index 4fa281d75..794f7dac5 100644
--- a/src/Dodge/Data.hs
+++ b/src/Dodge/Data.hs
@@ -150,7 +150,8 @@ data World = World
     , _clickMousePos        :: Point2
     , _pathGraph            :: PathGraph
     , _pathGraphP           :: S.Set (Point2,Point2)
-    , _phZoning             :: Zoning [] (Int,Point2)
+    , _pnZoning             :: Zoning [] (Int,Point2)
+    , _peZoning             :: Zoning [] (Int,Int,PathEdge)
     , _hud                  :: HUD
     , _lightSources         :: IM.IntMap LightSource
     , _tempLightSources     :: [TempLightSource]
diff --git a/src/Dodge/Data/PathGraph.hs b/src/Dodge/Data/PathGraph.hs
index 5b318938e..338fdba5c 100644
--- a/src/Dodge/Data/PathGraph.hs
+++ b/src/Dodge/Data/PathGraph.hs
@@ -4,9 +4,24 @@ 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 Float
-    , _pgNodeMap    :: NodeMap Point2
+    { _pgGraph      :: Gr Point2 PathEdge
+    , _pgNodeMap    :: Map Point2 Int
+    , _pgNodeCount  :: Int
+    , _pgEdgeMap    :: Map (V2 Point2) Int2
     }
+data PathEdge = PathEdge
+    {_peStart :: Point2
+    ,_peEnd   :: Point2
+    ,_peObstacles :: Set.Set EdgeObstacle
+    }
+  deriving (Eq,Ord,Show)
+data EdgeObstacle
+    = BlockObstacle
+    | DoorObstacle
+    | AutoDoorObstacle
+  deriving (Eq,Ord,Show,Bounded,Enum)
 
 makeLenses ''PathGraph
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/Default/World.hs b/src/Dodge/Default/World.hs
index fc237cf73..3a19d2ffa 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
@@ -73,9 +74,10 @@ defaultWorld = World
     --, _savedWorlds = M.empty
 --    , _menuLayers = []
     , _clickMousePos = V2 0 0
-    , _pathGraph = PathGraph Data.Graph.Inductive.Graph.empty new
+    , _pathGraph = PathGraph Data.Graph.Inductive.Graph.empty mempty 0 mempty
     , _pathGraphP   = mempty
-    , _phZoning     = Zoning mempty phZoneSize (zonePos snd)
+    , _pnZoning     = Zoning mempty pnZoneSize (zonePos snd)
+    , _peZoning     = Zoning mempty pnZoneSize (\x (_,_,PathEdge p q _) -> zoneOfSeg x p q)
     , _hud = HUD
         { _hudElement = DisplayInventory NoSubInventory
         , _carteCenter = V2 0 0
diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs
index 393c1a8c1..822e0ac31 100644
--- a/src/Dodge/Floor.hs
+++ b/src/Dodge/Floor.hs
@@ -41,9 +41,9 @@ initialAnoTree :: Annotation
 initialAnoTree = OnwardList 
         $ intersperse (AnTree corDoor)
     [ IntAnno $ AnTree . startRoom
+    , AnRoom $ roomCCrits 10
     , AnRoom $ return airlock0
     , AnRoom slowDoorRoom
---    , AnRoom $ roomCCrits 10
     , AnTree firstBreather
 --    , AnTree $ telRoomLev 1 >>= rToOnward "telRoomLev" . pure . cleatOnward
 --    ]
diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs
index 6170b0c68..5a94f2801 100644
--- a/src/Dodge/Layout.hs
+++ b/src/Dodge/Layout.hs
@@ -22,7 +22,7 @@ import qualified IntMapHelp as IM
 import Tile
 import RandomHelp
 
-import Data.Graph.Inductive (labNodes)
+import Data.Graph.Inductive (labNodes,labEdges)
 import Data.List (nubBy)
 import Data.Traversable
 import Control.Lens
@@ -46,8 +46,10 @@ generateLevelFromRoomList gr' w = initWallZoning
         , _pathGraph    = path
         , _pathGraphP   = pairPath
         }
-        & phZoning   %~ \zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
-            (labNodes (_pgGraph path))
+        & pnZoning   %~ (\zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
+            (labNodes (_pgGraph 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 4aaaf870e..4e7b2a4af 100644
--- a/src/Dodge/Path.hs
+++ b/src/Dodge/Path.hs
@@ -9,6 +9,7 @@ module Dodge.Path
     , walkableNodeNear
     , nodesNearL
     , getNodePos
+    , addObstacleCrossing'
     ) where
 import Dodge.Data
 import Dodge.Base.Collide
@@ -21,7 +22,10 @@ import Data.Maybe
 import Data.List
 --import qualified Data.IntMap.Strict as IM
 import Data.Graph.Inductive hiding ((&))
+import Data.Set (Set)
 import qualified Data.Set as Set
+import Data.Map (Map)
+import qualified Data.Map.Strict as M
 import qualified Streaming.Prelude as S
 import StreamingHelp
 --import Data.Graph.Inductive.PatriciaTree
@@ -34,7 +38,10 @@ makePathBetween :: Point2 -> Point2 -> World -> Maybe [Int]
 makePathBetween a b w = do -- join $ sp <$> a' <*> b' <*> return (_pathGraph w)
     (na,_) <- walkableNodeNear a w
     (nb,_) <- walkableNodeNear b w
-    sp na nb (_pgGraph $ _pathGraph w)
+    sp na nb (second pathDist $ _pgGraph $ _pathGraph w)
+
+pathDist :: PathEdge -> Float
+pathDist pe = dist (_peStart pe) (_peEnd pe)
 
 walkableNodeNear :: Point2 -> World -> Maybe (Int,Point2)
 {-# INLINE walkableNodeNear #-}
@@ -43,7 +50,7 @@ walkableNodeNear p w = minStreamOn (dist p . snd)
 
 nodesNear :: Point2 -> World -> StreamOf (Int,Point2)
 {-# INLINE nodesNear #-}
-nodesNear = aroundPoint _phZoning
+nodesNear = aroundPoint _pnZoning
 
 nodesNearL :: Point2 -> World -> [(Int,Point2)]
 nodesNearL p = runIdentity . S.toList_ . nodesNear p
@@ -99,18 +106,45 @@ pointTowardsImpulse a b w = find (flip (isWalkable a) w) =<< makePathBetweenPs a
 --
 
 pairsToGraph'' :: Set.Set (Point2,Point2) -> PathGraph
-pairsToGraph'' = uncurry PathGraph . pairsToGraph' dist
-
-pairsToGraph' :: Ord a => (a -> a -> b) -> Set.Set (a,a) -> (Gr a b, NodeMap a)
-pairsToGraph' f pairset = ngr'
+pairsToGraph'' pairset = PathGraph gr' nodemap ncount edgemap
   where
-    nodeset = S.each . runIdentity $ S.fold_ getnode Set.empty id $ S.each pairset
-    getnode nodeset' (x,y) = Set.insert x $ Set.insert y nodeset'
-    ngr = runIdentity $ S.fold_ insertnode (Data.Graph.Inductive.empty,new) id nodeset
-    ngr' = runIdentity $ S.fold_ insertedge ngr id $ S.each pairset
-    insertedge (gr,nm) (x,y) = (insMapEdge nm (x,y,f x y) gr, nm)
-    insertnode (gr,nm) n = fstsnd $ insMapNode nm n gr
-    fstsnd (a,b,_) = (a,b)
+    (gr,nodemap,ncount) = insertNodes pairset
+    (gr',edgemap) = insertEdges toPathEdge pairset gr nodemap
+    
+
+toPathEdge :: Point2 -> Point2 -> PathEdge
+toPathEdge sp' ep = PathEdge sp' ep mempty
+
+insertEdges :: (Point2 -> Point2 -> b) 
+    -> Set (Point2,Point2) -> Gr Point2 b -> Map Point2 Int -> (Gr Point2 b,Map (V2 Point2) Int2)
+insertEdges efunc pairset gr nm = runIdentity $ S.fold_ insertedge (gr,mempty) id $ (S.each pairset)
+  where
+    insertedge (gr',em) (a,b) = (insEdge (f a,f b,efunc a b) gr'
+        , M.insert (V2 a b) (V2 (f a) (f b)) em)
+    f a = nm M.! a
+
+insertNodes :: Set (Point2,Point2) -> (Gr Point2 b, Map Point2 Int, Int)
+insertNodes pairset = runIdentity $ S.fold_ insertnode (Data.Graph.Inductive.empty,mempty,0) id nodestream
+  where
+    nodestream :: StreamOf Point2
+    nodestream = S.each . runIdentity $ S.fold_ getnode Set.empty id $ S.each pairset
+    getnode strm (x,y) = Set.insert x $ Set.insert y strm
+    insertnode :: (Gr Point2 b,Map Point2 Int,Int) -> Point2 -> (Gr Point2 b,Map Point2 Int,Int)
+    insertnode (gr,nm,i) n = case M.lookup n nm of
+        Nothing -> (insNode (j,n) gr, M.insert n j nm, j)
+        Just _  -> (gr,nm,i)
+      where
+        j = i + 1
+--pairsToGraph' :: (Ord a) => (a -> a -> b) -> Set (a,a) -> (Gr a b, Map a Int, Map (V2 a) Int2)
+--pairsToGraph' f pairset = ngr'
+--  where
+--    nodeset = S.each . runIdentity $ S.fold_ getnode Set.empty id $ S.each pairset
+--    getnode nodeset' (x,y) = Set.insert x $ Set.insert y nodeset'
+--    ngr = runIdentity $ S.fold_ insertnode (Data.Graph.Inductive.empty,new) id nodeset
+--    ngr' = runIdentity $ S.fold_ insertedge ngr id $ S.each pairset
+--    insertedge (gr,nm) (x,y) = (insMapEdge nm (x,y,f x y) gr, nm)
+--    insertnode (gr,nm) n = fstsnd $ insMapNode nm n gr
+--    fstsnd (a,b,_) = (a,b)
 
 pairsToGraph :: (Ord a, Ord b) => (a -> a -> b) -> Set.Set (a,a) -> Gr a b
 pairsToGraph f pairs = undir
@@ -120,6 +154,26 @@ pairsToGraph f pairs = undir
     nodes' = Set.map fst pairs `Set.union` Set.map snd pairs
     pairs' = Set.map (\(x,y)->(x,y,f x y)) pairs
 
+--findEdgesCrossing :: Point2 -> Point2 -> Gr Point2 PathEdge -> 
+--
+addObstacleCrossing :: World -> EdgeObstacle -> Point2 -> Point2 
+    -> Gr Point2 PathEdge
+    -> Gr Point2 PathEdge
+addObstacleCrossing w eo a b gr = runIdentity $ S.fold_ updateedge gr id paths
+  where
+    updateedge gr' (xi,yi,PathEdge x y obs) = insEdge (xi,yi,PathEdge x y (Set.insert eo obs))
+        $ delEdge (xi,yi) gr'
+    paths = S.filter f $ nearSeg _peZoning a b w
+    f (_,_,PathEdge x y _) = isJust $ intersectSegSeg x y a b
+
+addObstacleCrossing' :: EdgeObstacle -> Point2 -> Point2 
+    -> World
+    -> World
+addObstacleCrossing' eo a b w = w & pathGraph . pgGraph %~ addObstacleCrossing w eo a b
+  where
+    paths = S.filter f $ nearSeg _peZoning a b w
+    f (_,_,PathEdge x y _) = isJust $ intersectSegSeg x y a b
+
 removePathsCrossing :: Point2 -> Point2 -> World -> World
 removePathsCrossing a b w = w
 --    & pathGraph . pgGraph %~ deleteEdges
@@ -130,7 +184,7 @@ removePathsCrossing a b w = w
 --        (labNodes newGraph)
   where
     thegr = _pgGraph (_pathGraph w)
-    ns = nearSeg _phZoning a b w
+    ns = nearSeg _pnZoning a b w
     pairs = S.filter testEdge $ S.for ns (nodePairs thegr)
     testEdge ((_,p),(_,q)) = isJust $ intersectSegSeg a b p q
     deleteEdges gr = runIdentity $ S.fold_ deleteEdge gr id pairs
diff --git a/src/Dodge/Placement/PlaceSpot/Block.hs b/src/Dodge/Placement/PlaceSpot/Block.hs
index 5d6850f50..927dbe0d4 100644
--- a/src/Dodge/Placement/PlaceSpot/Block.hs
+++ b/src/Dodge/Placement/PlaceSpot/Block.hs
@@ -55,7 +55,7 @@ addBlock _ _ _ _ = error "Trying to add a block with incomplete polygon"
         
 placeBlock :: [Point2] -> Block -> Wall -> World -> (Int,World)
 placeBlock poly bl wl w 
-    = (0, foldr (uncurry removePathsCrossing) wWithBlock pairs)
+    = (0, foldr (uncurry (addObstacleCrossing' BlockObstacle)) wWithBlock pairs)
 --    = (0, wWithBlock)
   where 
     pairs = loopPairs poly
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/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs
index 2b8901719..82e23718b 100644
--- a/src/Dodge/Render/ShapePicture.hs
+++ b/src/Dodge/Render/ShapePicture.hs
@@ -34,6 +34,7 @@ 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
 
 -- TODO only filter out shapes outside the range of the furthest shown light source
 worldSPic :: Configuration -> World -> SPic
@@ -110,7 +111,7 @@ debugDraw' cfig w bl = case bl of
     Cr_status               -> Right $ drawCrInfo cfig w
     Mouse_position          -> Right $ drawMousePosition cfig w
     Walls_info              -> Right $ drawWlIDs cfig w
-    Pathing                 -> Right $ drawPathing w
+    Pathing                 -> Right $ drawPathing cfig w
     Show_nodes_near_select  -> Right $ drawNodesNearSelect w
 
 drawCreatureDisplayTexts :: World -> Picture
@@ -118,7 +119,7 @@ drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (_creatures w)
 
 drawNodesNearSelect :: World -> Picture
 drawNodesNearSelect w = setLayer DebugLayer $
-     runIdentity (S.foldMap_ (drawZone phZoneSize) (zoneAroundPoint phZoneSize sp))
+     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)
@@ -264,9 +265,19 @@ drawWlIDs cfig w = setLayer FixedCoordLayer $ foldMap f (_walls w)
       where
         p = worldPosToScreen w $ 0.5 *.* uncurry (+.+) (_wlLine wl)
 
-drawPathing :: World -> Picture
-drawPathing w = setLayer DebugLayer $ 
-        (color green . pictures . map (thickLine 5 . tflat2) $ graphToEdges gr)
+edgeToPic :: [Point2] -> PathEdge -> Picture
+edgeToPic poly pe
+    | not (pointInPolygon sp poly) && not (pointInPolygon ep poly) = mempty
+    | null $ _peObstacles pe 
+                = color green $ arrow sp ep
+    | otherwise = color red   $ arrow sp ep
+  where
+    sp = _peStart pe
+    ep = _peEnd pe
+
+drawPathing :: Configuration -> World -> Picture
+drawPathing cfig w = setLayer DebugLayer $ 
+        (foldMap (edgeToPic (screenPolygon cfig w) . (^?! _3)) $ FGL.labEdges gr)
         --(color green . pictures . Set.map (thickLine 5 . tflat2) $ _pathGraphP w)
         <> concatMap dispInc (graphToIncidence gr)
   where
diff --git a/src/Dodge/Room/Pillar.hs b/src/Dodge/Room/Pillar.hs
index dfbaecd44..04c376569 100644
--- a/src/Dodge/Room/Pillar.hs
+++ b/src/Dodge/Room/Pillar.hs
@@ -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
diff --git a/src/Dodge/Zone/Size.hs b/src/Dodge/Zone/Size.hs
index b7f238797..1b4c1351a 100644
--- a/src/Dodge/Zone/Size.hs
+++ b/src/Dodge/Zone/Size.hs
@@ -1,7 +1,7 @@
 module Dodge.Zone.Size where
 
-phZoneSize :: Float
-phZoneSize = 100
+pnZoneSize :: Float
+pnZoneSize = 100
 
 wlZoneSize :: Float
 wlZoneSize = 50

From ed33b4ff2b3d81cb4a2b780cc0fe66e9ee9dd913 Mon Sep 17 00:00:00 2001
From: justin <justin.g.kruger@gmail.com>
Date: Thu, 30 Jun 2022 23:59:07 +0100
Subject: [PATCH 05/13] Make obstacles block pathing

---
 src/Dodge/Config/Data.hs               |  1 +
 src/Dodge/Data/PathGraph.hs            |  1 +
 src/Dodge/Default/World.hs             |  2 +-
 src/Dodge/Path.hs                      | 32 +++-----------------------
 src/Dodge/Placement/PlaceSpot.hs       |  2 +-
 src/Dodge/Placement/PlaceSpot/Block.hs |  4 ++--
 src/Dodge/Render/ShapePicture.hs       | 13 +++++++----
 7 files changed, 18 insertions(+), 37 deletions(-)

diff --git a/src/Dodge/Config/Data.hs b/src/Dodge/Config/Data.hs
index 9bf40d033..a3f216a0a 100644
--- a/src/Dodge/Config/Data.hs
+++ b/src/Dodge/Config/Data.hs
@@ -45,6 +45,7 @@ data DebugBool
     | 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/PathGraph.hs b/src/Dodge/Data/PathGraph.hs
index 338fdba5c..913282282 100644
--- a/src/Dodge/Data/PathGraph.hs
+++ b/src/Dodge/Data/PathGraph.hs
@@ -22,6 +22,7 @@ data EdgeObstacle
     = BlockObstacle
     | DoorObstacle
     | AutoDoorObstacle
+    | WallObstacle
   deriving (Eq,Ord,Show,Bounded,Enum)
 
 makeLenses ''PathGraph
diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs
index 3a19d2ffa..f86379694 100644
--- a/src/Dodge/Default/World.hs
+++ b/src/Dodge/Default/World.hs
@@ -19,7 +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 Data.Graph.Inductive.NodeMap
 --import qualified Data.Vector.Fusion.Stream.Monadic as VS
 defaultWorld :: World
 defaultWorld = World
diff --git a/src/Dodge/Path.hs b/src/Dodge/Path.hs
index 4e7b2a4af..da97ea03e 100644
--- a/src/Dodge/Path.hs
+++ b/src/Dodge/Path.hs
@@ -3,7 +3,6 @@ module Dodge.Path
     ( pointTowardsImpulse
     , makePathBetween
     , makePathBetweenPs
-    , removePathsCrossing
     , pairsToGraph
     , pairsToGraph''
     , walkableNodeNear
@@ -38,7 +37,9 @@ makePathBetween :: Point2 -> Point2 -> World -> Maybe [Int]
 makePathBetween a b w = do -- join $ sp <$> a' <*> b' <*> return (_pathGraph w)
     (na,_) <- walkableNodeNear a w
     (nb,_) <- walkableNodeNear b w
-    sp na nb (second pathDist $ _pgGraph $ _pathGraph w)
+    sp na nb (second pathDist $ efilter noobstacle $ _pgGraph $ _pathGraph w)
+  where
+    noobstacle (_,_,PathEdge _ _ s) = null s
 
 pathDist :: PathEdge -> Float
 pathDist pe = dist (_peStart pe) (_peEnd pe)
@@ -170,33 +171,6 @@ addObstacleCrossing' :: EdgeObstacle -> Point2 -> Point2
     -> World
     -> World
 addObstacleCrossing' eo a b w = w & pathGraph . pgGraph %~ addObstacleCrossing w eo a b
-  where
-    paths = S.filter f $ nearSeg _peZoning a b w
-    f (_,_,PathEdge x y _) = isJust $ intersectSegSeg x y a b
-
-removePathsCrossing :: Point2 -> Point2 -> World -> World
-removePathsCrossing a b w = w
---    & pathGraph . pgGraph %~ deleteEdges
---    & pathGraphP %~ deletePairs
---    & pathGraph  .~ newGraph 
---    & pathGraphP .~ pg'
---    & phZoning   %~ \zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
---        (labNodes newGraph)
-  where
-    thegr = _pgGraph (_pathGraph w)
-    ns = nearSeg _pnZoning a b w
-    pairs = S.filter testEdge $ S.for ns (nodePairs thegr)
-    testEdge ((_,p),(_,q)) = isJust $ intersectSegSeg a b p q
-    deleteEdges gr = runIdentity $ S.fold_ deleteEdge gr id pairs
-    deleteEdge gr ((x,_),(y,_)) = delEdge (x,y) $ delEdge (y,x) gr
---    deletePairs s = runIdentity $ S.fold_ deletePair s id pairs
---    deletePair s (x,y) = Set.delete (x,y) $ Set.delete (y,x) s
-
-nodePairs :: Gr a b -> (Int,a) -> StreamOf ((Int,a),(Int,a))
-nodePairs gr (n,p) = S.mapMaybe (fmap ((n,p),) . nodeLabel gr) . S.each $ neighbors gr n
-
-nodeLabel :: Gr a b -> Int -> Maybe (Int, a)
-nodeLabel gr n = (n,) <$> lab gr n
 
 --    pg' = Set.filter (isNothing . uncurry (intersectSegSeg a b)) $ _pathGraphP w
 --   -- insertPoint pp@(_,p) = insertInZoneWith (wlZoneOfPoint p) (++) [pp]
diff --git a/src/Dodge/Placement/PlaceSpot.hs b/src/Dodge/Placement/PlaceSpot.hs
index e53035621..9ad5bb90a 100644
--- a/src/Dodge/Placement/PlaceSpot.hs
+++ b/src/Dodge/Placement/PlaceSpot.hs
@@ -123,7 +123,7 @@ placeWallPoly :: [Point2] -> Wall -> World -> World
 --placeWallPoly ps wl = over walls (placeWalls ps wl)
 placeWallPoly ps wl = rmCrossPaths . over walls (placeWalls ps wl)
   where
-    rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ loopPairs ps
+    rmCrossPaths w = foldr (uncurry (addObstacleCrossing' WallObstacle)) 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 927dbe0d4..c44d8081e 100644
--- a/src/Dodge/Placement/PlaceSpot/Block.hs
+++ b/src/Dodge/Placement/PlaceSpot/Block.hs
@@ -71,8 +71,8 @@ placeLineBlock
     -> World 
     -> (Int, World)
 placeLineBlock basePane blockWidth depth a b gw = ( 0 
-    , (foldr insertWall (insertBlocks gw) listWalls)
---    , removePathsCrossing a b (foldr insertWall (insertBlocks gw) listWalls)
+--    , (foldr insertWall (insertBlocks gw) listWalls)
+    , addObstacleCrossing' BlockObstacle a b (foldr insertWall (insertBlocks gw) listWalls)
     )
   where 
     psOnLine = divideLineOddNumPoints blockWidth a b
diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs
index 82e23718b..580985db0 100644
--- a/src/Dodge/Render/ShapePicture.hs
+++ b/src/Dodge/Render/ShapePicture.hs
@@ -30,7 +30,7 @@ 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 qualified Data.Set as Set
 import Control.Lens
 import Data.Maybe
 import qualified Streaming.Prelude as S
@@ -113,21 +113,26 @@ debugDraw' cfig w bl = case bl of
     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 w = color yellow 
+    $ foldMap (arrowPath . mapMaybe (`getNodePos` w)) (makePathBetween sp ep w)
+  where
+    sp = _lSelect w
+    ep = _rSelect w
+
 drawNodesNearSelect :: World -> Picture
 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)
-    <> color yellow (foldMap (arrowPath . mapMaybe (`getNodePos` w)) (makePathBetween sp ep w))
   where
     sp = _lSelect w
-    ep = _rSelect w
-
 
 drawInspectWalls :: World -> Picture
 drawInspectWalls w = foldMap (drawInspectWall w) 

From 4e893931a8afbcc994e995036db0346e9ced352c Mon Sep 17 00:00:00 2001
From: justin <justin.g.kruger@gmail.com>
Date: Fri, 1 Jul 2022 08:38:38 +0100
Subject: [PATCH 06/13] Correctly set obstacle when creating block

---
 src/Dodge/Path.hs                      |  4 +--
 src/Dodge/Placement/PlaceSpot/Block.hs | 47 ++++++++------------------
 src/Dodge/Render/ShapePicture.hs       | 25 +++++++++-----
 src/Picture.hs                         |  4 +--
 4 files changed, 36 insertions(+), 44 deletions(-)

diff --git a/src/Dodge/Path.hs b/src/Dodge/Path.hs
index da97ea03e..ac59a61d0 100644
--- a/src/Dodge/Path.hs
+++ b/src/Dodge/Path.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TupleSections #-}
+--{-# LANGUAGE TupleSections #-}
 module Dodge.Path 
     ( pointTowardsImpulse
     , makePathBetween
@@ -118,7 +118,7 @@ toPathEdge sp' ep = PathEdge sp' ep mempty
 
 insertEdges :: (Point2 -> Point2 -> b) 
     -> Set (Point2,Point2) -> Gr Point2 b -> Map Point2 Int -> (Gr Point2 b,Map (V2 Point2) Int2)
-insertEdges efunc pairset gr nm = runIdentity $ S.fold_ insertedge (gr,mempty) id $ (S.each pairset)
+insertEdges efunc pairset gr nm = runIdentity $ S.fold_ insertedge (gr,mempty) id $ S.each pairset
   where
     insertedge (gr',em) (a,b) = (insEdge (f a,f b,efunc a b) gr'
         , M.insert (V2 a b) (V2 (f a) (f b)) em)
diff --git a/src/Dodge/Placement/PlaceSpot/Block.hs b/src/Dodge/Placement/PlaceSpot/Block.hs
index c44d8081e..2984294cc 100644
--- a/src/Dodge/Placement/PlaceSpot/Block.hs
+++ b/src/Dodge/Placement/PlaceSpot/Block.hs
@@ -9,23 +9,22 @@ import Dodge.Path
 import Dodge.Block.Debris
 --import Dodge.LevelGen.LevelStructure
 import Dodge.Base
-import Dodge.Zone
+--import Dodge.Zone
 import Geometry
 import qualified IntMapHelp as IM
 
 import Control.Lens
-import Data.List
 import qualified Data.IntSet as IS
 
-addBlock 
+placeBlock 
     :: [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
+    -> (Int,World)
+placeBlock [] _ _ _ = error "Trying to add a block with incomplete polygon"
+placeBlock (p:ps) bl wl w = (,) blid $ w
+    & flip (foldr insertWall) wls
     & blocks %~ IM.insert blid bl 
         {_blID = blid,_blWallIDs = IS.fromList is, _blShadows=[]
             , _blFootprint = p:ps
@@ -35,32 +34,14 @@ addBlock (p:ps) wl bl w = 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 
+    wls = zipWith 
+        (\j (a,b) -> 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"
+        ) is lns 
         
-placeBlock :: [Point2] -> Block -> Wall -> World -> (Int,World)
-placeBlock poly bl wl w 
-    = (0, foldr (uncurry (addObstacleCrossing' BlockObstacle)) wWithBlock pairs)
---    = (0, wWithBlock)
-  where 
-    pairs = loopPairs poly
-    wWithBlock = addBlock poly wl bl w
-
 {- | Splits a line into many four cornered blocks. -}
 placeLineBlock 
     :: Wall     -- ^ Base pane
@@ -71,8 +52,7 @@ placeLineBlock
     -> World 
     -> (Int, World)
 placeLineBlock basePane blockWidth depth a b gw = ( 0 
---    , (foldr insertWall (insertBlocks gw) listWalls)
-    , addObstacleCrossing' BlockObstacle a b (foldr insertWall (insertBlocks gw) listWalls)
+    , foldr insertWall (insertBlocks gw) listWalls
     )
   where 
     psOnLine = divideLineOddNumPoints blockWidth a b
@@ -109,4 +89,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/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs
index 580985db0..99c7e85c8 100644
--- a/src/Dodge/Render/ShapePicture.hs
+++ b/src/Dodge/Render/ShapePicture.hs
@@ -35,6 +35,7 @@ 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
@@ -119,9 +120,13 @@ drawCreatureDisplayTexts :: World -> Picture
 drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (_creatures w)
 
 drawPathBetween :: World -> Picture
-drawPathBetween w = color yellow 
-    $ foldMap (arrowPath . mapMaybe (`getNodePos` w)) (makePathBetween sp ep w)
+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
 
@@ -274,17 +279,21 @@ edgeToPic :: [Point2] -> PathEdge -> Picture
 edgeToPic poly pe
     | not (pointInPolygon sp poly) && not (pointInPolygon ep poly) = mempty
     | null $ _peObstacles pe 
-                = color green $ arrow sp ep
-    | otherwise = color red   $ arrow sp ep
+                = 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 $ 
-        (foldMap (edgeToPic (screenPolygon cfig w) . (^?! _3)) $ FGL.labEdges gr)
-        --(color green . pictures . Set.map (thickLine 5 . tflat2) $ _pathGraphP w)
-        <> concatMap dispInc (graphToIncidence gr)
+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 = _pgGraph $ _pathGraph w
diff --git a/src/Picture.hs b/src/Picture.hs
index b83a27345..8f0f26bac 100644
--- a/src/Picture.hs
+++ b/src/Picture.hs
@@ -1,5 +1,5 @@
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE BangPatterns  #-}
+--{-# LANGUAGE TupleSections #-}
+--{-# LANGUAGE BangPatterns  #-}
 module Picture
     ( module Picture.Data
     , module Picture.Base

From 870225b6b69327c2d571ce0301677f5213326cdb Mon Sep 17 00:00:00 2001
From: justin <justin.g.kruger@gmail.com>
Date: Fri, 1 Jul 2022 09:17:22 +0100
Subject: [PATCH 07/13] Commit before adjusting wall zoning

---
 src/Dodge/Data.hs                      |  4 +--
 src/Dodge/Data/PathGraph.hs            |  2 +-
 src/Dodge/Default/Block.hs             |  1 +
 src/Dodge/Path.hs                      |  5 ++--
 src/Dodge/Placement/Instance/Wall.hs   | 11 ++++---
 src/Dodge/Placement/PlaceSpot.hs       |  4 +--
 src/Dodge/Placement/PlaceSpot/Block.hs | 40 +++++++++++++-------------
 src/Dodge/Room/Pillar.hs               | 12 ++++----
 8 files changed, 40 insertions(+), 39 deletions(-)

diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs
index 794f7dac5..09cbdfde1 100644
--- a/src/Dodge/Data.hs
+++ b/src/Dodge/Data.hs
@@ -948,6 +948,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
@@ -1408,8 +1409,7 @@ data PSType = PutCrit {_unPutCrit :: Creature}
     | PutCoord Point2
     | PutMod Modification
     | PutTrigger (World -> Bool)
-    | PutLineBlock {_putWall :: Wall , _putWidth :: Float
-        , _putDepth :: Float, _putStartPoint :: Point2, _putEndPoint :: Point2}
+    | PutLineBlock {_putWall :: Wall , _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/Data/PathGraph.hs b/src/Dodge/Data/PathGraph.hs
index 913282282..d6f751844 100644
--- a/src/Dodge/Data/PathGraph.hs
+++ b/src/Dodge/Data/PathGraph.hs
@@ -10,7 +10,7 @@ data PathGraph = PathGraph
     { _pgGraph      :: Gr Point2 PathEdge
     , _pgNodeMap    :: Map Point2 Int
     , _pgNodeCount  :: Int
-    , _pgEdgeMap    :: Map (V2 Point2) Int2
+    , _pgEdgeMap    :: Map (V2 Point2) (Int,Int,PathEdge)
     }
 data PathEdge = PathEdge
     {_peStart :: Point2
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/Path.hs b/src/Dodge/Path.hs
index ac59a61d0..178151f82 100644
--- a/src/Dodge/Path.hs
+++ b/src/Dodge/Path.hs
@@ -117,11 +117,12 @@ toPathEdge :: Point2 -> Point2 -> PathEdge
 toPathEdge sp' ep = PathEdge sp' ep mempty
 
 insertEdges :: (Point2 -> Point2 -> b) 
-    -> Set (Point2,Point2) -> Gr Point2 b -> Map Point2 Int -> (Gr Point2 b,Map (V2 Point2) Int2)
+    -> Set (Point2,Point2) -> Gr Point2 b -> Map Point2 Int 
+    -> (Gr Point2 b, Map (V2 Point2) (Int,Int,b))
 insertEdges efunc pairset gr nm = runIdentity $ S.fold_ insertedge (gr,mempty) id $ S.each pairset
   where
     insertedge (gr',em) (a,b) = (insEdge (f a,f b,efunc a b) gr'
-        , M.insert (V2 a b) (V2 (f a) (f b)) em)
+        , M.insert (V2 a b) (f a,f b,efunc a b) em)
     f a = nm M.! a
 
 insertNodes :: Set (Point2,Point2) -> (Gr Point2 b, Map Point2 Int, Int)
diff --git a/src/Dodge/Placement/Instance/Wall.hs b/src/Dodge/Placement/Instance/Wall.hs
index 69fe1c1e2..328525219 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 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 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 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
 
 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
 
 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 9ad5bb90a..1c344a545 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 a b     -> plLineBlock wl (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 2984294cc..ef5522996 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
@@ -16,46 +16,45 @@ import qualified IntMapHelp as IM
 import Control.Lens
 import qualified Data.IntSet as IS
 
-placeBlock 
+plBlock 
     :: [Point2]     -- ^ Block polygon
     -> Block
     -> Wall         -- ^ Base Pane
     -> World 
     -> (Int,World)
-placeBlock [] _ _ _ = error "Trying to add a block with incomplete polygon"
-placeBlock (p:ps) bl wl w = (,) blid $ w
+plBlock [] _ _ _ = error "Trying to add a block with incomplete polygon"
+plBlock (p:ps) bl wl w = (,) blid $ w
     & flip (foldr insertWall) wls
-    & blocks %~ IM.insert blid bl 
-        {_blID = blid,_blWallIDs = IS.fromList is, _blShadows=[]
-            , _blFootprint = p:ps
-            }
+    & 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]
     wls = zipWith 
-        (\j (a,b) -> wl 
-            { _wlLine = (a,b)
-            , _wlID = j
-            , _wlStructure = BlockPart blid
-            }
-        ) is lns 
+        (\j ln -> wl & wlLine .~ ln & wlID .~ j & wlStructure .~ BlockPart blid) 
+        is 
+        lns 
         
 {- | Splits a line into many four cornered blocks. -}
-placeLineBlock 
+plLineBlock 
     :: Wall     -- ^ Base pane
-    -> Float    -- ^ Block width
-    -> Float    -- ^ Block depth
     -> Point2   -- ^ Start point (symmetric)
     -> Point2   -- ^ End point (symmetric)
     -> World 
     -> (Int, World)
-placeLineBlock basePane blockWidth depth a b gw = ( 0 
+plLineBlock basePane a b gw = ( 0 
     , foldr insertWall (insertBlocks gw) listWalls
     )
   where 
-    psOnLine = divideLineOddNumPoints blockWidth a b
+    blwidth = 10
+    depth = 10
+    psOnLine = divideLineOddNumPoints blwidth a b
     halfBlockWidth = dist a b / fromIntegral (length psOnLine - 1)
     blockCenPs = snd $ evenOddSplit psOnLine
     numBlocks = length blockCenPs
@@ -70,6 +69,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]
diff --git a/src/Dodge/Room/Pillar.hs b/src/Dodge/Room/Pillar.hs
index 04c376569..880e87e0d 100644
--- a/src/Dodge/Room/Pillar.hs
+++ b/src/Dodge/Room/Pillar.hs
@@ -24,13 +24,13 @@ 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)
     bl = V2 (-w) (-h)
-    aline = PutLineBlock baseBlockPane 9 9
+    aline = PutLineBlock baseBlockPane
 
 smallPillar :: PSType
 smallPillar = PutBlock defaultBlock baseBlockPane $ reverse $ square 5
@@ -39,9 +39,9 @@ crossPillar :: Float -> Float -> Placement
 crossPillar w' h' = ps0jPushPS (aline (V2 (-w) 0) (V2 w 0))
     $ sps0 (aline (V2 0 (-h)) (V2 0 h))
   where
-    w = w' - 9
-    h = h' - 9
-    aline = PutLineBlock baseBlockPane 9 9
+    w = w' - 10
+    h = h' - 10
+    aline = PutLineBlock baseBlockPane
 
 roomPillarsSquare :: RandomGen g => State g Room
 roomPillarsSquare = do

From e5f6afb5772007ac12570251c6fd1c5d0d2d0f25 Mon Sep 17 00:00:00 2001
From: justin <justin.g.kruger@gmail.com>
Date: Fri, 1 Jul 2022 11:19:29 +0100
Subject: [PATCH 08/13] Inline functions in Dodge.Zone

---
 src/Dodge/Base/Collide.hs | 101 +++---------------
 src/Dodge/Data.hs         |   1 -
 src/Dodge/Debug.hs        |  66 ------------
 src/Dodge/Debug/Flag.hs   |   3 -
 src/Dodge/Layout.hs       |   2 +-
 src/Dodge/Path.hs         |  36 ++-----
 src/Dodge/Zone.hs         |  38 ++++---
 src/Geometry/Zone.hs      | 208 ++------------------------------------
 8 files changed, 49 insertions(+), 406 deletions(-)
 delete mode 100644 src/Dodge/Debug.hs
 delete mode 100644 src/Dodge/Debug/Flag.hs

diff --git a/src/Dodge/Base/Collide.hs b/src/Dodge/Base/Collide.hs
index 03f4237b5..bb7ee50ee 100644
--- a/src/Dodge/Base/Collide.hs
+++ b/src/Dodge/Base/Collide.hs
@@ -18,20 +18,11 @@ module Dodge.Base.Collide
     , bouncePoint
     , sortStreamOn
     , minStreamOn
---    , wallsOnCirc
---    , wallsOnCirc'
-    , wallsOnLineHit
     , collideCircWallsStream
-    , collideCircWalls
     , circOnSomeWall
-    , collidePointWallsNorm
-    , collidePointWalls'
     , overlapCircWalls
     , overlapCircWallsClosest
     , collideCircCrsPoint
-    , collideCircCreatures
-    , collidePointCreatures
-    , collidePointAnyWallsReflect
     , crsNearPoint
     , crsOnLine
     , crsOnThickLine
@@ -58,12 +49,12 @@ import qualified Data.IntMap.Strict as IM
 import Control.Lens
 import Control.Monad
 --import qualified FoldlHelp as L
-import Data.Monoid
+--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
@@ -77,7 +68,7 @@ doBounce x sp ep (p, mwl) = mwl <&> \wl ->
     )
 
 bounceBall :: Float -> Point2 -> Point2 -> Float 
-    -> Stream (Of Wall) Identity ()
+    -> StreamOf Wall
     -> Maybe (Point2,Point2)
 bounceBall x sp ep r = doBounce x sp ep . collideCircWallsStream sp ep r
 
@@ -86,7 +77,7 @@ 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
 collidePointTestFilter t sp ep = runIdentity 
     . S.any_ (isJust . uncurry (intersectSegSeg sp ep) . _wlLine)
     . S.filter t
@@ -96,55 +87,31 @@ 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)
 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)
 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)
 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)
 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 ()
+collideCircWallsStream :: Point2 -> Point2 -> Float -> StreamOf Wall
     -> (Point2, Maybe Wall)
 collideCircWallsStream sp ep rad = runIdentity
     . S.fold_ findPoint (ep, Nothing) id
@@ -159,54 +126,10 @@ collideCircWallsStream sp ep rad = runIdentity
       where
         f = ((rad *.* normalizeV (vNormal $ a -.- b)) +.+)
 
-overlapCircWallsClosest :: Point2 -> Float -> Stream (Of Wall) Identity () -> Maybe (Point2,Wall)
+overlapCircWallsClosest :: Point2 -> Float -> StreamOf Wall -> Maybe (Point2,Wall)
 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)
diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs
index 09cbdfde1..1f7ad5b0a 100644
--- a/src/Dodge/Data.hs
+++ b/src/Dodge/Data.hs
@@ -360,7 +360,6 @@ data Creature = Creature
     , _crMvDir          :: Float
     , _crTwist          :: Float
     , _crID             :: Int
-    --, _crPict           :: Creature -> Configuration -> World -> SPic
     , _crPict           :: Creature -> SPic
     , _crSkin           :: CreatureSkin
     , _crUpdate         :: Creature -> World -> World
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
-
diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs
index 5a94f2801..a84ea6eb4 100644
--- a/src/Dodge/Layout.hs
+++ b/src/Dodge/Layout.hs
@@ -51,7 +51,7 @@ generateLevelFromRoomList gr' w = initWallZoning
         & peZoning   %~ (\zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
             (labEdges (_pgGraph 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 178151f82..46adda775 100644
--- a/src/Dodge/Path.hs
+++ b/src/Dodge/Path.hs
@@ -4,7 +4,6 @@ module Dodge.Path
     , makePathBetween
     , makePathBetweenPs
     , pairsToGraph
-    , pairsToGraph''
     , walkableNodeNear
     , nodesNearL
     , getNodePos
@@ -106,12 +105,11 @@ pointTowardsImpulse a b w = find (flip (isWalkable a) w) =<< makePathBetweenPs a
 --        _  -> return $ Just $ ns !! i
 --
 
-pairsToGraph'' :: Set.Set (Point2,Point2) -> PathGraph
-pairsToGraph'' pairset = PathGraph gr' nodemap ncount edgemap
+pairsToGraph :: Set.Set (Point2,Point2) -> PathGraph
+pairsToGraph pairset = PathGraph gr' nodemap ncount edgemap
   where
     (gr,nodemap,ncount) = insertNodes pairset
     (gr',edgemap) = insertEdges toPathEdge pairset gr nodemap
-    
 
 toPathEdge :: Point2 -> Point2 -> PathEdge
 toPathEdge sp' ep = PathEdge sp' ep mempty
@@ -137,27 +135,15 @@ insertNodes pairset = runIdentity $ S.fold_ insertnode (Data.Graph.Inductive.emp
         Just _  -> (gr,nm,i)
       where
         j = i + 1
---pairsToGraph' :: (Ord a) => (a -> a -> b) -> Set (a,a) -> (Gr a b, Map a Int, Map (V2 a) Int2)
---pairsToGraph' f pairset = ngr'
+
+--pairsToGraph :: (Ord a, Ord b) => (a -> a -> b) -> Set.Set (a,a) -> Gr a b
+--pairsToGraph f pairs = undir
+--    $ run_ Data.Graph.Inductive.empty 
+--    $ insMapNodesM (Set.toList nodes') >> insMapEdgesM (Set.toList pairs')
 --  where
---    nodeset = S.each . runIdentity $ S.fold_ getnode Set.empty id $ S.each pairset
---    getnode nodeset' (x,y) = Set.insert x $ Set.insert y nodeset'
---    ngr = runIdentity $ S.fold_ insertnode (Data.Graph.Inductive.empty,new) id nodeset
---    ngr' = runIdentity $ S.fold_ insertedge ngr id $ S.each pairset
---    insertedge (gr,nm) (x,y) = (insMapEdge nm (x,y,f x y) gr, nm)
---    insertnode (gr,nm) n = fstsnd $ insMapNode nm n gr
---    fstsnd (a,b,_) = (a,b)
+--    nodes' = Set.map fst pairs `Set.union` Set.map snd pairs
+--    pairs' = Set.map (\(x,y)->(x,y,f x y)) pairs
 
-pairsToGraph :: (Ord a, Ord b) => (a -> a -> b) -> Set.Set (a,a) -> Gr a b
-pairsToGraph f pairs = undir
-    $ run_ Data.Graph.Inductive.empty 
-    $ insMapNodesM (Set.toList nodes') >> insMapEdgesM (Set.toList pairs')
-  where
-    nodes' = Set.map fst pairs `Set.union` Set.map snd pairs
-    pairs' = Set.map (\(x,y)->(x,y,f x y)) pairs
-
---findEdgesCrossing :: Point2 -> Point2 -> Gr Point2 PathEdge -> 
---
 addObstacleCrossing :: World -> EdgeObstacle -> Point2 -> Point2 
     -> Gr Point2 PathEdge
     -> Gr Point2 PathEdge
@@ -172,7 +158,3 @@ addObstacleCrossing' :: EdgeObstacle -> Point2 -> Point2
     -> World
     -> World
 addObstacleCrossing' eo a b w = w & pathGraph . pgGraph %~ addObstacleCrossing w eo a b
-
---    pg' = Set.filter (isNothing . uncurry (intersectSegSeg a b)) $ _pathGraphP w
---   -- insertPoint pp@(_,p) = insertInZoneWith (wlZoneOfPoint p) (++) [pp]
---    newGraph = pairsToGraph'' dist pg'
diff --git a/src/Dodge/Zone.hs b/src/Dodge/Zone.hs
index ab6f325bc..78ffd3fed 100644
--- a/src/Dodge/Zone.hs
+++ b/src/Dodge/Zone.hs
@@ -11,8 +11,6 @@ module Dodge.Zone
     , crsNearSeg
     , wlsInsideCirc
     , crsInsideCirc
-    , lookLookups
-    , zoneNearPointIP
     , clZoneOfPoint
     , crZoneOfPoint
     , wlZoneOfPoint
@@ -32,31 +30,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]
@@ -69,15 +61,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 #-}
@@ -86,46 +69,59 @@ nearPoint f p w = S.each . fromMaybe mempty $ extractFromZone zn (zoneOfPoint (_
     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
 
 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
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 73e3353ba98fcb9511a33419c1609b0a8f1d5e79 Mon Sep 17 00:00:00 2001
From: justin <justin.g.kruger@gmail.com>
Date: Fri, 1 Jul 2022 12:13:45 +0100
Subject: [PATCH 09/13] Cleanup and inline collisions

---
 src/Dodge/Base/Collide.hs         | 146 +++++++++++-------------------
 src/Dodge/Item/Weapon/Launcher.hs |   5 +-
 src/Dodge/WorldEvent/ThingsHit.hs |   8 +-
 3 files changed, 59 insertions(+), 100 deletions(-)

diff --git a/src/Dodge/Base/Collide.hs b/src/Dodge/Base/Collide.hs
index bb7ee50ee..af976a5d5 100644
--- a/src/Dodge/Base/Collide.hs
+++ b/src/Dodge/Base/Collide.hs
@@ -11,24 +11,22 @@
  - -}
 module Dodge.Base.Collide
     ( collidePoint
+    , collideSegCrs
     , collidePointWallsFilterStream
     , collidePointTestFilter
     , overlapSegWalls
+    , overlapSegCrs
+    , overlap1SegCrs
     , bounceBall
     , bouncePoint
     , sortStreamOn
     , minStreamOn
     , collideCircWallsStream
     , circOnSomeWall
+    , circOnAnyCr
     , overlapCircWalls
     , overlapCircWallsClosest
-    , collideCircCrsPoint
     , crsNearPoint
-    , crsOnLine
-    , crsOnThickLine
-    , nearestCrInRad
-    , nearestCrInTri
-    , nearestCrInFront
     , allVisibleWalls
 
     , hasLOS
@@ -42,14 +40,11 @@ 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
 
@@ -61,7 +56,34 @@ 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)
@@ -70,28 +92,34 @@ doBounce x sp ep (p, mwl) = mwl <&> \wl ->
 bounceBall :: Float -> Point2 -> Point2 -> Float 
     -> 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 -> 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 -> StreamOf Wall
     -> StreamOf (Point2,Wall)
+{-# INLINE overlapSegWalls #-}
 overlapSegWalls sp ep = S.mapMaybe $ \wl -> uncurry (intersectSegSeg sp ep) (_wlLine wl) <&> (,wl)
 
 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)
@@ -99,22 +127,24 @@ visibleWalls sp ep = S.take 1 <=<  -- hlint, was using join and fmap
     . wlsNearSeg sp ep    )
 
 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
     
 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
+-- | 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
@@ -124,98 +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 -> StreamOf Wall -> Maybe (Point2,Wall)
+{-# INLINE overlapCircWallsClosest #-}
 overlapCircWallsClosest p r = minStreamOn (dist p . fst)
     . overlapCircWalls p r
 
--- | 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 -}
 
@@ -232,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
     
diff --git a/src/Dodge/WorldEvent/ThingsHit.hs b/src/Dodge/WorldEvent/ThingsHit.hs
index 80a2fae19..882938247 100644
--- a/src/Dodge/WorldEvent/ThingsHit.hs
+++ b/src/Dodge/WorldEvent/ThingsHit.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TupleSections #-}
+--{-# LANGUAGE TupleSections #-}
 {- |
 Find which objects lie upon a line.
  -}
@@ -13,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
@@ -32,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 c42c2115a38520d29e0644e3263af257d5006a10 Mon Sep 17 00:00:00 2001
From: justin <justin.g.kruger@gmail.com>
Date: Fri, 1 Jul 2022 12:34:31 +0100
Subject: [PATCH 10/13] Commit before attempting to stream room generation

---
 src/Dodge/Path.hs | 21 +++++++++++++--------
 1 file changed, 13 insertions(+), 8 deletions(-)

diff --git a/src/Dodge/Path.hs b/src/Dodge/Path.hs
index 46adda775..3e247db67 100644
--- a/src/Dodge/Path.hs
+++ b/src/Dodge/Path.hs
@@ -22,7 +22,7 @@ import Data.List
 import Data.Graph.Inductive hiding ((&))
 import Data.Set (Set)
 import qualified Data.Set as Set
-import Data.Map (Map)
+import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
 import qualified Streaming.Prelude as S
 import StreamingHelp
@@ -109,19 +109,24 @@ pairsToGraph :: Set.Set (Point2,Point2) -> PathGraph
 pairsToGraph pairset = PathGraph gr' nodemap ncount edgemap
   where
     (gr,nodemap,ncount) = insertNodes pairset
-    (gr',edgemap) = insertEdges toPathEdge pairset gr nodemap
+    (gr',edgemap) = insertEdges toPathEdge gr nodemap pairset
 
 toPathEdge :: Point2 -> Point2 -> PathEdge
 toPathEdge sp' ep = PathEdge sp' ep mempty
 
 insertEdges :: (Point2 -> Point2 -> b) 
-    -> Set (Point2,Point2) -> Gr Point2 b -> Map Point2 Int 
+    -> Gr Point2 b -> Map Point2 Int 
+    -> Set (Point2,Point2) 
     -> (Gr Point2 b, Map (V2 Point2) (Int,Int,b))
-insertEdges efunc pairset gr nm = runIdentity $ S.fold_ insertedge (gr,mempty) id $ S.each pairset
-  where
-    insertedge (gr',em) (a,b) = (insEdge (f a,f b,efunc a b) gr'
-        , M.insert (V2 a b) (f a,f b,efunc a b) em)
-    f a = nm M.! a
+insertEdges efunc gr nm = runIdentity . S.fold_ (insertEdge efunc nm) (gr,mempty) id . S.each
+
+insertEdge :: Ord a => (a -> a -> c) -> Map a Int -> (Gr b c,Map (V2 a) (Int,Int,c))
+    -> (a,a)
+    -> (Gr b c,Map (V2 a) (Int,Int,c))
+insertEdge efunc nm (gr',em) (a,b) = (insEdge (f a,f b,efunc a b) gr'
+    , M.insert (V2 a b) (f a,f b,efunc a b) em)
+  where 
+    f x = nm M.! x
 
 insertNodes :: Set (Point2,Point2) -> (Gr Point2 b, Map Point2 Int, Int)
 insertNodes pairset = runIdentity $ S.fold_ insertnode (Data.Graph.Inductive.empty,mempty,0) id nodestream

From 650b2387b806f8c1311e703abd546e5801ef5e12 Mon Sep 17 00:00:00 2001
From: justin <justin.g.kruger@gmail.com>
Date: Fri, 1 Jul 2022 12:58:47 +0100
Subject: [PATCH 11/13] Cleanup

---
 src/Dodge/Zone/Update.hs | 15 ++++-----------
 1 file changed, 4 insertions(+), 11 deletions(-)

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 c866c147b9ad5110b6ef23a0df824983bf36a165 Mon Sep 17 00:00:00 2001
From: justin <justin.g.kruger@gmail.com>
Date: Fri, 1 Jul 2022 21:28:30 +0100
Subject: [PATCH 12/13] Allow for lineBlocks to have different sizes

---
 src/Dodge/Data.hs                      |  3 ++-
 src/Dodge/Placement/Instance/Wall.hs   | 10 +++++-----
 src/Dodge/Placement/PlaceSpot.hs       |  2 +-
 src/Dodge/Placement/PlaceSpot/Block.hs |  6 +++---
 src/Dodge/Room/Pillar.hs               |  8 ++++----
 5 files changed, 15 insertions(+), 14 deletions(-)

diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs
index 1f7ad5b0a..016386bed 100644
--- a/src/Dodge/Data.hs
+++ b/src/Dodge/Data.hs
@@ -1408,7 +1408,8 @@ data PSType = PutCrit {_unPutCrit :: Creature}
     | PutCoord Point2
     | PutMod Modification
     | PutTrigger (World -> Bool)
-    | PutLineBlock {_putWall :: Wall , _putStartPoint :: Point2, _putEndPoint :: Point2}
+    | PutLineBlock {_putWall :: Wall , _putWidth :: Float
+        , _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 328525219..500dd0f37 100644
--- a/src/Dodge/Placement/Instance/Wall.hs
+++ b/src/Dodge/Placement/Instance/Wall.hs
@@ -37,20 +37,20 @@ singleBlock a =
 Places a line of blocks between two points.
  -}
 blockLine :: Point2 -> Point2 -> Placement
-blockLine a b = sps0 $ PutLineBlock baseBlockPane 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 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 a b
+crystalLine a b = sps0 $ PutLineBlock defaultCrystalWall 7 a b
 --crystalLine a b = sps0 $ PutWall ps defaultCrystalWall
 --  where
 --    ps = 
@@ -76,7 +76,7 @@ wallLine a b = sps0 $ PutWall ps defaultWall
     up   = vNormal left
 
 windowLineType :: Point2 -> Point2 -> PSType
-windowLineType = PutLineBlock defaultWindow
+windowLineType = PutLineBlock defaultWindow 8
 
 baseBlockPane :: Wall
 baseBlockPane = defaultWall
@@ -123,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
+    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 1c344a545..35bc7df05 100644
--- a/src/Dodge/Placement/PlaceSpot.hs
+++ b/src/Dodge/Placement/PlaceSpot.hs
@@ -101,7 +101,7 @@ placeSpotID ps pt w = case pt of
                             -> plSlideDoor wl dr off (doShift a) (doShift b) w
     PutBlock    bl wl  ps'  -> plBlock (map doShift ps') (bl & blPos %~ doShift & blDir .~ rot)
                                     wl w
-    PutLineBlock wl a b     -> plLineBlock wl (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 ef5522996..49a2e9ef8 100644
--- a/src/Dodge/Placement/PlaceSpot/Block.hs
+++ b/src/Dodge/Placement/PlaceSpot/Block.hs
@@ -44,16 +44,16 @@ plBlock (p:ps) bl wl w = (,) blid $ w
 {- | Splits a line into many four cornered blocks. -}
 plLineBlock 
     :: Wall     -- ^ Base pane
+    -> Float
     -> Point2   -- ^ Start point (symmetric)
     -> Point2   -- ^ End point (symmetric)
     -> World 
     -> (Int, World)
-plLineBlock basePane a b gw = ( 0 
+plLineBlock basePane blwidth a b gw = ( 0 
     , foldr insertWall (insertBlocks gw) listWalls
     )
   where 
-    blwidth = 10
-    depth = 10
+    depth = blwidth
     psOnLine = divideLineOddNumPoints blwidth a b
     halfBlockWidth = dist a b / fromIntegral (length psOnLine - 1)
     blockCenPs = snd $ evenOddSplit psOnLine
diff --git a/src/Dodge/Room/Pillar.hs b/src/Dodge/Room/Pillar.hs
index 880e87e0d..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
+    aline = PutLineBlock baseBlockPane 9
 
 smallPillar :: PSType
 smallPillar = PutBlock defaultBlock baseBlockPane $ reverse $ square 5
@@ -39,9 +39,9 @@ crossPillar :: Float -> Float -> Placement
 crossPillar w' h' = ps0jPushPS (aline (V2 (-w) 0) (V2 w 0))
     $ sps0 (aline (V2 0 (-h)) (V2 0 h))
   where
-    w = w' - 10
-    h = h' - 10
-    aline = PutLineBlock baseBlockPane
+    w = w' - 9
+    h = h' - 9
+    aline = PutLineBlock baseBlockPane 9
 
 roomPillarsSquare :: RandomGen g => State g Room
 roomPillarsSquare = do

From 6f02efe0abbc2b6732c346fb10958640274f615d Mon Sep 17 00:00:00 2001
From: justin <justin.g.kruger@gmail.com>
Date: Sat, 2 Jul 2022 11:35:47 +0100
Subject: [PATCH 13/13] Match Dodge.Floor with efficientRuntime branch

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

diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs
index 822e0ac31..393c1a8c1 100644
--- a/src/Dodge/Floor.hs
+++ b/src/Dodge/Floor.hs
@@ -41,9 +41,9 @@ initialAnoTree :: Annotation
 initialAnoTree = OnwardList 
         $ intersperse (AnTree corDoor)
     [ IntAnno $ AnTree . startRoom
-    , AnRoom $ roomCCrits 10
     , AnRoom $ return airlock0
     , AnRoom slowDoorRoom
+--    , AnRoom $ roomCCrits 10
     , AnTree firstBreather
 --    , AnTree $ telRoomLev 1 >>= rToOnward "telRoomLev" . pure . cleatOnward
 --    ]