Add debugging for pathfinding

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