From 8a612be5fe8ff2a4cc978bc9bf9d1058780a4bae Mon Sep 17 00:00:00 2001 From: justin Date: Sat, 2 Jul 2022 17:45:03 +0100 Subject: [PATCH] Improve debugDraw --- package.yaml | 1 + src/Dodge/Path.hs | 21 +++------ src/Dodge/Placement/PlaceSpot.hs | 2 +- src/Dodge/Placement/PlaceSpot/Block.hs | 3 +- src/Dodge/Render/ShapePicture.hs | 61 ++++++++++++++------------ 5 files changed, 41 insertions(+), 47 deletions(-) diff --git a/package.yaml b/package.yaml index 160b8975a..fb5095b4a 100644 --- a/package.yaml +++ b/package.yaml @@ -23,6 +23,7 @@ dependencies: - base >= 4.7 && < 5 - containers - unordered-containers +- bitwise-enum #- heap - sdl2 - sdl2-mixer diff --git a/src/Dodge/Path.hs b/src/Dodge/Path.hs index f9faf8839..c1e987e16 100644 --- a/src/Dodge/Path.hs +++ b/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 - edgecrosses (_,_,pe) = isJust $ intersectSegSeg sp ep (_peStart pe) (_peEnd pe) - updateedges gr = runIdentity $ S.fold_ updateedge gr id edges + es = S.filter edgecrosses $ nearSeg _peZoning sp' ep w + edgecrosses (_,_,pe) = isJust $ intersectSegSeg sp' ep (_peStart pe) (_peEnd pe) + updateedges gr = runIdentity $ S.fold_ updateedge gr id 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' diff --git a/src/Dodge/Placement/PlaceSpot.hs b/src/Dodge/Placement/PlaceSpot.hs index 109e2c9e5..9f5ac8869 100644 --- a/src/Dodge/Placement/PlaceSpot.hs +++ b/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 diff --git a/src/Dodge/Placement/PlaceSpot/Block.hs b/src/Dodge/Placement/PlaceSpot/Block.hs index 355ca030d..adbdbdd32 100644 --- a/src/Dodge/Placement/PlaceSpot/Block.hs +++ b/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 diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index 2a404da3c..73a3d7822 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/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 - <> setLayer FixedCoordLayer (listPicturesAt (0.5*halfWidth cfig) 0 cfig $ map text ts) +{-# INLINE debugDraw #-} +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) - f (Left s) = ([s],mempty) - f (Right pic') = (mempty,pic') + (ts, pic) = foldMap (debugDraw' cfig w) (_debug_booleans cfig) -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" - Remove_LOS -> Left "No line of sight" - Cull_more_lights -> Left "Cull more lights" - Close_shape_culling -> Left "Close shape culling" - Bound_box_screen -> Left "bound box screen, this should be moved" - Show_ms_frame -> Right mempty - View_boundaries -> Right $ viewBoundaries w - Show_bound_box -> Right $ drawBoundingBox w - Show_wall_search_rays -> Right $ drawWallSearchRays w - Show_dda_test -> Right $ drawDDATest w - Show_far_wall_detect -> Right $ drawFarWallDetect w - Show_select -> Right $ drawWorldSelect w - Inspect_wall -> Right $ drawInspectWalls w - Cr_awareness -> Right $ drawCreatureDisplayTexts w - Show_sound -> Right $ pictures $ M.map (soundPic cfig w) $ _playingSounds w - Cr_status -> Right $ drawCrInfo cfig w - Mouse_position -> Right $ drawMousePosition cfig w - Walls_info -> Right $ drawWlIDs cfig w - Pathing -> Right $ drawPathing cfig w - Show_nodes_near_select -> Right $ drawNodesNearSelect w - Show_path_between -> Right $ drawPathBetween w + Noclip -> lstring "Noclip" + Remove_LOS -> lstring "No line of sight" + Cull_more_lights -> lstring "Cull more lights" + Close_shape_culling -> lstring "Close shape culling" + Bound_box_screen -> lstring "bound box screen, this should be moved" + Show_ms_frame -> rdraw mempty + View_boundaries -> rdraw $ viewBoundaries w + Show_bound_box -> rdraw $ drawBoundingBox w + Show_wall_search_rays -> rdraw $ drawWallSearchRays w + Show_dda_test -> rdraw $ drawDDATest w + Show_far_wall_detect -> rdraw $ drawFarWallDetect w + Show_select -> rdraw $ drawWorldSelect w + Inspect_wall -> rdraw $ drawInspectWalls w + Cr_awareness -> rdraw $ drawCreatureDisplayTexts w + Show_sound -> rdraw $ pictures $ M.map (soundPic cfig w) $ _playingSounds w + Cr_status -> rdraw $ drawCrInfo cfig w + Mouse_position -> rdraw $ drawMousePosition cfig w + Walls_info -> rdraw $ drawWlIDs cfig w + Pathing -> rdraw $ drawPathing cfig w + Show_nodes_near_select -> rdraw $ drawNodesNearSelect 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)