Improve debugDraw

package.yaml

@@ -23,6 +23,7 @@ dependencies:
 - base >= 4.7 && < 5
 - containers
 - unordered-containers
+- bitwise-enum
   #- heap
 - sdl2
 - sdl2-mixer

src/Dodge/Path.hs

@@ -119,24 +119,13 @@ addEdges nodemap gr = runIdentity . S.fold_ f (mempty,gr) id
     g a = nodemap M.! a
 
 obstructPathsCrossing :: Point2 -> Point2 -> World -> ( World, [(Int,Int,PathEdge)])
-obstructPathsCrossing sp ep w = 
+obstructPathsCrossing sp' ep w = 
     ( w & pathGraph %~ updateedges
-    , runIdentity $ S.toList_ edges
+    , runIdentity $ S.toList_ es
     )
   where
-    edges = S.filter edgecrosses $ nearSeg _peZoning sp ep w
+    es = S.filter edgecrosses $ nearSeg _peZoning sp' ep w
-    edgecrosses (_,_,pe) = isJust $ intersectSegSeg sp ep (_peStart pe) (_peEnd pe)
+    edgecrosses (_,_,pe) = isJust $ intersectSegSeg sp' ep (_peStart pe) (_peEnd pe)
-    updateedges gr = runIdentity $ S.fold_ updateedge gr id edges
+    updateedges gr = runIdentity $ S.fold_ updateedge gr id es
     updateedge gr (x,y,pe) 
         = insEdge (x,y,pe & peObstacles . at BlockObstacle ?~ ()) $ delEdge (x,y) gr
-
-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 pg'

src/Dodge/Placement/PlaceSpot.hs

@@ -7,7 +7,7 @@ module Dodge.Placement.PlaceSpot
     ) where
 import Dodge.Placement.Shift
 import Dodge.Data
-import Dodge.Path
+--import Dodge.Path
 import Dodge.Placement.PlaceSpot.Block
 import Dodge.Placement.PlaceSpot.TriggerDoor
 import Dodge.Default.Wall

src/Dodge/Placement/PlaceSpot/Block.hs

@@ -9,7 +9,7 @@ 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
 
@@ -94,7 +94,6 @@ plLineBlock basePane blwidth a b gw = ( 0
         ,_wlLine = ps
         ,_wlDraw = visStatus
         }
-    listWalls = concat $ zipWith makeWallAt blockCenPs is
 
 -- | Must be done after inserting the block
 insertWalls :: Int -> [Wall] -> World -> World

src/Dodge/Render/ShapePicture.hs

@@ -82,39 +82,44 @@ extraPics cfig w = pictures (_decorations w)
     <> concatMapPic clDraw (_clouds w      )
     <> concatMapPic ppDraw (_pressPlates w )
     <> viewClipBounds cfig w
---    <> debugDraw cfig w
+    <> debugDraw cfig w
 
 debugDraw :: Configuration -> World -> Picture
-debugDraw cfig w = pic
+{-# INLINE debugDraw #-}
-    <> setLayer FixedCoordLayer (listPicturesAt (0.5*halfWidth cfig) 0 cfig $ map text ts)
+debugDraw cfig w =
+    pic
+    <> 
+    setLayer FixedCoordLayer (listPicturesAt (0.5*halfWidth cfig) 0 cfig $ map text ts)
   where
-    (ts, pic) = foldMap (f . debugDraw' cfig w) (_debug_booleans cfig)
+    (ts, pic) = foldMap (debugDraw' cfig w) (_debug_booleans cfig)
-    f (Left s) = ([s],mempty)
-    f (Right pic') = (mempty,pic')
 
-debugDraw' :: Configuration -> World -> DebugBool -> Either String Picture
+debugDraw' :: Configuration -> World -> DebugBool -> ([String],Picture)
+{-# INLINE debugDraw' #-}
 debugDraw' cfig w bl = case bl of
-    Noclip      -> Left "Noclip"
+    Noclip      -> lstring "Noclip"
-    Remove_LOS  -> Left "No line of sight"
+    Remove_LOS  -> lstring "No line of sight"
-    Cull_more_lights    -> Left "Cull more lights"
+    Cull_more_lights    -> lstring "Cull more lights"
-    Close_shape_culling -> Left "Close shape culling"
+    Close_shape_culling -> lstring "Close shape culling"
-    Bound_box_screen    -> Left "bound box screen, this should be moved"
+    Bound_box_screen    -> lstring "bound box screen, this should be moved"
-    Show_ms_frame           -> Right mempty
+    Show_ms_frame           -> rdraw mempty
-    View_boundaries         -> Right $ viewBoundaries w
+    View_boundaries         -> rdraw $ viewBoundaries w
-    Show_bound_box          -> Right $ drawBoundingBox w
+    Show_bound_box          -> rdraw $ drawBoundingBox w
-    Show_wall_search_rays   -> Right $ drawWallSearchRays w
+    Show_wall_search_rays   -> rdraw $ drawWallSearchRays w
-    Show_dda_test           -> Right $ drawDDATest w
+    Show_dda_test           -> rdraw $ drawDDATest w
-    Show_far_wall_detect    -> Right $ drawFarWallDetect w
+    Show_far_wall_detect    -> rdraw $ drawFarWallDetect w
-    Show_select             -> Right $ drawWorldSelect w
+    Show_select             -> rdraw $ drawWorldSelect w
-    Inspect_wall            -> Right $ drawInspectWalls w
+    Inspect_wall            -> rdraw $ drawInspectWalls w
-    Cr_awareness            -> Right $ drawCreatureDisplayTexts w
+    Cr_awareness            -> rdraw $ drawCreatureDisplayTexts w
-    Show_sound              -> Right $ pictures $ M.map (soundPic cfig w) $ _playingSounds w
+    Show_sound              -> rdraw $ pictures $ M.map (soundPic cfig w) $ _playingSounds w
-    Cr_status               -> Right $ drawCrInfo cfig w
+    Cr_status               -> rdraw $ drawCrInfo cfig w
-    Mouse_position          -> Right $ drawMousePosition cfig w
+    Mouse_position          -> rdraw $ drawMousePosition cfig w
-    Walls_info              -> Right $ drawWlIDs cfig w
+    Walls_info              -> rdraw $ drawWlIDs cfig w
-    Pathing                 -> Right $ drawPathing cfig w
+    Pathing                 -> rdraw $ drawPathing cfig w
-    Show_nodes_near_select  -> Right $ drawNodesNearSelect w
+    Show_nodes_near_select  -> rdraw $ drawNodesNearSelect w
-    Show_path_between       -> Right $ drawPathBetween w
+    Show_path_between       -> rdraw $ drawPathBetween w
+  where
+    lstring str = ([str],mempty)
+    rdraw   pic = (mempty,pic)
 
 drawCreatureDisplayTexts :: World -> Picture
 drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (_creatures w)