Fix wall zoning

src/Dodge/Render/ShapePicture.hs

@@ -7,6 +7,7 @@ import Dodge.Render.InfoBox
 import Dodge.Debug.Picture
 import Dodge.Picture.SizeInvariant
 import Dodge.Data
+import Dodge.Zone
 import Dodge.Base
 --import Dodge.Base.Window
 import Dodge.SoundLogic.LoadSound
@@ -14,6 +15,7 @@ import Dodge.Graph
 import Dodge.GameRoom
 import Dodge.Update.Camera
 import Dodge.Item.Draw
+import Dodge.Wall.Zone
 --import Dodge.Zone
 import Geometry
 import Geometry.Zone
@@ -34,9 +36,11 @@ import qualified Streaming.Prelude as S
 worldSPic :: Configuration -> World -> SPic
 worldSPic cfig w = 
     (extraShapes w, extraPics cfig w)
+    --(mempty, extraPics cfig w)
     <> foldMap (dbArg _prDraw) (filtOn _prPos _props)
     <> foldMap (shiftDraw _blPos _blDir _blDraw) (filtOn _blPos _blocks)
     <> foldMap (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _shapes)
+--    <> foldMap (\fs -> uncurryV translateSPf (_fsPos fs) . rotateSP (_fsDir fs) $ _fsSPic fs) (_shapes w)
     <> foldMap (dbArg _cpPict) (filtOn _cpPos _corpses)
     <> foldMap ((($ w) . ($ cfig)) . dbArg _crPict) (filtOn _crPos _creatures)
     <> foldMap floorItemSPic (filtOn _flItPos _floorItems)
@@ -51,7 +55,6 @@ shiftDraw fpos fdir fdraw x = uncurryV translateSPf (fpos x)
     . rotateSP (fdir x)
     $ fdraw x x
 
-
 cullPoint :: Configuration -> World -> Point2 -> Bool
 cullPoint cfig w p 
     | debugOn Close_shape_culling cfig = pointInPolygon p (_boundBox w)
@@ -72,20 +75,55 @@ extraPics cfig w = pictures (_decorations w)
     <> concatMapPic clDraw (_clouds w      )
     <> concatMapPic ppDraw (_pressPlates w )
     <> soundPics cfig w
-    <> viewBoundaries 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)
   where
     cfigdraw boption draw
         | debugOn boption cfig = draw cfig w
         | otherwise = mempty
 
+drawInspectWalls :: World -> Picture
+drawInspectWalls w = foldMap (drawInspectWall w) 
+    $ filter (isJust . uncurry (intersectSegSeg a b) . _wlLine)
+    $ IM.elems $ _walls w
+  where
+    (a,b) = _wSelect w
+
+drawInspectWall :: World -> Wall -> Picture
+drawInspectWall _ wl = setLayer DebugLayer $ 
+        color rose (thickLine 3 [a,b])
+    <> foldMap (drawZone zoneSize)
+        (runIdentity $ S.toList_ $ zoneOfWall wl)
+  where
+    (a,b) = _wlLine wl 
+--    $ line [a,b]
+--  where
+--    (a,b) = _wSelect w
+
+drawWorldSelect :: World -> Picture
+drawWorldSelect w = setLayer DebugLayer . color cyan 
+    $ line [a,b]
+  where
+    (a,b) = _wSelect w
+
+drawFarWallDetect :: World -> Picture
+drawFarWallDetect w = setLayer DebugLayer . color yellow 
+    . concatMap (\q -> line [p,q]) 
+    . map (\q -> fst $ collidePoint p q $ S.filter wlIsOpaque $ wallsAlongLine p q w)
+    $ runIdentity $ S.toList_ $ streamViewpoints p w
+  where
+    p = _cameraViewFrom w
+
 drawDDATest :: World -> Picture
 drawDDATest w = runIdentity (S.foldMap_ (drawZone 50) ps)
     <> runIdentity (S.foldMap_ (drawZone' 50) ps')
@@ -107,7 +145,7 @@ crossPic :: Float -> Picture
 crossPic x = line [V2 x x,V2 (-x) (-x)] <> line [V2 (-x) x,V2 x (-x)]
 
 drawZone :: Float -> V2 Int -> Picture
-drawZone s (V2 x y) = setLayer DebugLayer . color orange $ line (p:ps ++ [p])
+drawZone s (V2 x y) = setLayer DebugLayer . color orange $ thickLine 2 (p:ps ++ [p])
   where
     (p:ps) = zipWith (+.+) innerSquare $ map ((s*.*) . (each %~ fromIntegral)) [V2 x y, V2 (x+1) y, V2 (x+1) (y+1), V2 x (y+1)]
 
@@ -235,12 +273,9 @@ drawCrInfo cfig w
   where
     hw = halfWidth cfig
 
-viewBoundaries :: Configuration -> World -> Picture
-viewBoundaries cfig w
-    | debugOn View_boundaries cfig 
-        = setLayer DebugLayer $ color green (concatMap (polygonWire . _grBound) grs)
-        <> color yellow (concatMap (\q -> line [p,q]) $ farWallPoints p w)
-    | otherwise = []
+viewBoundaries :: World -> Picture
+viewBoundaries w = setLayer DebugLayer $ color green (concatMap (polygonWire . _grBound) grs)
+    <> color yellow (concatMap (\q -> line [p,q]) $ farWallPoints p w)
   where
     p = _crPos $ you w
     grs = filter (pointInOrOnPolygon p . _grBound) (_gameRooms w)