Unify debug pictures

src/Dodge/Debug.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE LambdaCase #-}
-module Dodge.Debug where
+module Dodge.Debug (debugEvents) where
 
 import Data.Aeson.Types
 import AesonHelp
@@ -15,59 +15,61 @@ import Dodge.WorldEvent.ThingsHit
 import Geometry.Vector
 import qualified SDL
 import Data.Ord
+import Data.Foldable (fold)
 
 debugEvents :: Universe -> Universe
 debugEvents u = case dbools ^. at Enable_debug of
     Nothing -> u
-    Just () -> S.foldr debugEvent u dbools
+    Just () -> S.foldr debugEvent (u & uvDebug .~ mempty) dbools
   where
     dbools = u ^. uvConfig . debug_booleans
 
 debugEvent :: DebugBool -> Universe -> Universe
-debugEvent db u = u & uvDebug . at db .~ debugEvent' u db
---  case db of
---    Collision_test -> u & uvDebug . at Collision_test ?~ collisionDebugItem u
---    Circ_collision_test -> u & uvDebug . at Circ_collision_test ?~ circCollisionDebugItem u
---    Select_creature -> u & uvDebug . at Select_creature ?~ selectCreatureDebugItem u
---    _ -> u
+debugEvent db u = u & uvDebug . at db .~ debugItem db u
 
-debugEvent' :: Universe -> DebugBool -> Maybe DebugItem
-debugEvent' u = \case
-    Collision_test -> Just $ collisionDebugItem u
-    Circ_collision_test -> Just $ circCollisionDebugItem u
-    Select_creature -> Just $ selectCreatureDebugItem u
-    Show_walls_near_point_cursor -> Just 
-        (DebugItem (const $ drawWallsNearCursor w) (const mempty) NoDebugInfo)
-    Show_walls_near_segment -> Just 
-        (DebugItem (const $ drawWallsNearSegment w) (const mempty) NoDebugInfo)
-    _ -> Nothing
-  where
-    w = u ^. uvWorld
+debugItem :: DebugBool -> Universe -> Maybe DebugItem
+debugItem = \case
+    Collision_test -> constDPic (drawCollisionTest . _uvWorld)
+    Circ_collision_test -> constDPic (drawCircCollisionTest . _uvWorld)
+    Select_creature -> Just . selectCreatureDebugItem
+    Show_walls_near_point_cursor -> constDPic (drawWallsNearCursor . _uvWorld)
+    Show_walls_near_segment -> constDPic (drawWallsNearSegment . _uvWorld)
+    Enable_debug -> const Nothing
+    Noclip -> const Nothing
+    Remove_LOS -> const Nothing
+    Cull_more_lights -> const Nothing
+    Close_shape_culling -> const Nothing
+    Bound_box_screen -> const Nothing
+    Show_ms_frame -> const Nothing
+    View_boundaries -> constDPic (viewBoundaries . _uvWorld)
+    Show_bound_box -> constDPic (drawBoundingBox . _uvWorld)
+    Show_wall_search_rays -> constDPic $ drawWallSearchRays . _uvWorld
+    Show_dda_test -> constDPic $ drawDDATest . _uvWorld
+    Show_far_wall_detect -> constDPic $ drawFarWallDetect . _uvWorld
+    Show_walls_near_point_you -> constDPic $ drawWallsNearYou . _uvWorld
+    Show_zone_near_point_cursor -> constDPic $ drawZoneNearPointCursor . _uvWorld
+    Show_zone_circ -> constDPic $ drawZoneCirc . _uvWorld
+    Inspect_wall -> constDPic $ drawInspectWalls . _uvWorld
+    Cr_awareness -> constDPic $ drawCreatureDisplayTexts . _uvWorld
+    Show_sound ->  constDPic $ \u -> 
+        fold (M.map (soundPic (u ^. uvConfig) (u ^. uvWorld)) $ u ^. uvWorld . playingSounds)
+    Cr_status -> constDPic $ \u -> drawCrInfo (u ^. uvConfig) (u ^. uvWorld)
+    Mouse_position -> constDPic $ drawMousePosition . _uvWorld
+    Walls_info -> constDPic $ drawWlIDs . _uvWorld
+    Pathing -> constDPic $ \u ->  drawPathing (u ^. uvConfig) (u ^. uvWorld)
+    Show_path_between -> constDPic $ drawPathBetween . _uvWorld
 
-collisionDebugItem :: Universe -> DebugItem
-collisionDebugItem u =
-    DebugItem
-        { _debugPic = const $ drawCollisionTest $ u ^. uvWorld
-        , _debugMessage = const []
-        , _debugInfo = NoDebugInfo
-        }
+constDPic :: (Universe -> Picture) -> Universe -> Maybe DebugItem
+constDPic p u = Just $ DebugItem (p u) mempty NoDebugInfo
 
 selectCreatureDebugItem :: Universe -> DebugItem
 selectCreatureDebugItem u =
     DebugItem
-        { _debugPic = const mempty
-        , _debugMessage = debugSelectCreatureMessage
+        { _debugPic = mempty
+        , _debugMessage = debugSelectCreatureMessage u
         , _debugInfo = scrollDebugInfoInt (length $ debugSelectCreatureList 0 u) u $ clickGetCreature u
         }
 
-circCollisionDebugItem :: Universe -> DebugItem
-circCollisionDebugItem _ =
-    DebugItem
-        { _debugPic = drawCircCollisionTest . (^. uvWorld)
-        , _debugMessage = const []
-        , _debugInfo = NoDebugInfo
-        }
-
 scrollDebugInfoInt :: Int -> Universe -> DebugInfo -> DebugInfo
 scrollDebugInfoInt i u
     | SDL.ScancodeRShift `M.member` (u ^. uvWorld . input . pressedKeys) =