Tweak debug display

src/Dodge/Debug.hs

@@ -1,28 +1,31 @@
 {-# LANGUAGE LambdaCase #-}
+
 module Dodge.Debug (debugEvents) where
 
-import Padding
-import Dodge.Base.Window
-import ShortShow
-import Linear
-import Dodge.Render.InfoBox
-import Picture.Base
-import Geometry.Data
-import qualified Data.IntMap.Strict as IM
-import Data.Aeson.Types
+--import Dodge.Render.InfoBox
+
 import AesonHelp
 import Control.Lens
+import Control.Monad
+import Data.Aeson.Types
+import qualified Data.IntMap.Strict as IM
 import Data.List (sortOn)
 import qualified Data.Map.Strict as M
 import Data.Maybe
+import Data.Ord
 import qualified Data.Set as S
 import Dodge.Base.Coordinate
+import Dodge.Base.Window
 import Dodge.Data.Universe
 import Dodge.Debug.Picture
 import Dodge.WorldEvent.ThingsHit
 import Geometry.Vector
+import Linear
+import Padding
+import Picture.Base
 import qualified SDL
-import Data.Ord
+import ShortShow
+
 --import Data.Foldable (fold)
 
 debugEvents :: Universe -> Universe
@@ -35,11 +38,11 @@ debugEvents u = case dbools ^. at Enable_debug of
 debugEvent :: DebugBool -> Universe -> Universe
 debugEvent db u = u & uvDebug . at db .~ debugItem db u
 
-debugItem :: DebugBool -> Universe -> Maybe DebugItem
+debugItem :: DebugBool -> Universe -> Maybe [DebugItem]
 debugItem = \case
     Collision_test -> constDPic (drawCollisionTest . _uvWorld)
     Circ_collision_test -> constDPic (drawCircCollisionTest . _uvWorld)
-    Select_creature -> Just . selectCreatureDebugItem
+    Select_creature -> Just . return . selectCreatureDebugItem
     Show_walls_near_point_cursor -> constDPic (drawWallsNearCursor . _uvWorld)
     Show_walls_near_segment -> constDPic (drawWallsNearSegment . _uvWorld)
     Enable_debug -> const Nothing
@@ -59,27 +62,47 @@ debugItem = \case
     Show_zone_circ -> constDPic $ drawZoneCirc . _uvWorld
     Inspect_wall -> constDPic $ drawInspectWalls . _uvWorld
     Cr_awareness -> constDPic $ drawCreatureDisplayTexts . _uvWorld
-    Show_sound ->  constDPic $ \u -> 
+    Show_sound -> constDPic $ \u ->
         fold (M.map (soundPic (u ^. uvConfig) (u ^. uvWorld)) $ u ^. uvWorld . playingSounds)
-    Cr_status -> constDPic $ \u -> drawCrInfo (u ^. uvConfig) (u ^. uvWorld)
+    Cr_status -> Just . drawCrInfo
     Mouse_position -> constDPic $ drawMousePosition . _uvWorld
     Walls_info -> constDPic $ drawWlIDs . _uvWorld
-    Pathing -> constDPic $ \u ->  drawPathing (u ^. uvConfig) (u ^. uvWorld)
+    Pathing -> constDPic $ \u -> drawPathing (u ^. uvConfig) (u ^. uvWorld)
     Show_path_between -> constDPic $ drawPathBetween . _uvWorld
 
-constDPic :: (Universe -> Picture) -> Universe -> Maybe DebugItem
-constDPic p u = Just $ DebugItem (p u) mempty NoDebugInfo
+constDPic :: (Universe -> Picture) -> Universe -> Maybe [DebugItem]
+constDPic p u = Just [DebugItem (p u) mempty NoDebugInfo]
 
-drawCrInfo' :: Universe -> Maybe DebugItem
-drawCrInfo' u = do
-    undefined
---    
+drawCrInfo :: Universe -> [DebugItem]
+drawCrInfo u = mapMaybe f . IM.elems $ w ^. cWorld . lWorld . creatures
+  where
+    w = u ^. uvWorld
+    g h str = fmap $ ((rightPad 7 '.' str ++ "...") ++) . h
+    f cr = do
+        guard $
+            pointIsOnScreen (u ^. uvConfig) (w ^. wCam) (cr ^. crPos . _xy)
+                && cr ^. crID /= 0
+        Just $
+            DebugItem
+                mempty
+                ( catMaybes
+                    [ g show "crID" $ cr ^? crID
+                    , g show "crHP" $ cr ^? crHP . _HP
+                    , g show "crStrategy" $ cr ^? crActionPlan . apStrategy
+                    , g shortShow "crPos" $ cr ^? crPos . _xy
+                    , g show "cpVigilance" $ cr ^? crPerception . cpVigilance
+                    , g show "crAction" $ cr ^? crActionPlan . apAction
+                    , g show "crImpulse" $ cr ^? crActionPlan . apImpulse
+                    ]
+                )
+                (DebugV2 $ cr ^. crPos . _xy)
+
+--drawCrInfo :: Config -> World -> Picture
+--drawCrInfo cfig w =
 --    setLayer FixedCoordLayer $
 --        renderInfoListsAt (2 * hw - 400) 0 cfig cam $
 --            mapMaybe crDisplayInfo $ IM.elems $ w ^. cWorld . lWorld . creatures
 --  where
---    w = u ^. uvWorld
---    cfig = u ^. uvConfig
 --    cam = w ^. wCam
 --    crDisplayInfo :: Creature -> Maybe (Point2, [String])
 --    crDisplayInfo cr
@@ -106,39 +129,6 @@ drawCrInfo' u = do
 --    fpreShow str = fmap (((rightPad 7 '.' str ++ "...") ++) . show)
 --    hw = halfWidth cfig
 
-drawCrInfo :: Config -> World -> Picture
-drawCrInfo cfig w =
-    setLayer FixedCoordLayer $
-        renderInfoListsAt (2 * hw - 400) 0 cfig cam $
-            mapMaybe crDisplayInfo $ IM.elems $ w ^. cWorld . lWorld . creatures
-  where
-    cam = w ^. wCam
-    crDisplayInfo :: Creature -> Maybe (Point2, [String])
-    crDisplayInfo cr
-        | _crID cr == 0 = Nothing
-        | crOnScreen =
-            Just
-                ( cr ^. crPos . _xy
-                , catMaybes
-                    --        [fmap show $ ap ^? crGoal
-                    [ fpreShow "crHP" $ cr ^? crHP . _HP
-                    , fpreShow "crStrategy" $ ap ^? apStrategy
-                    , fmap (("crPos....." ++) . shortShow) $ cr ^? crPos . _xy
-                    , fpreShow "cpVigilance" $ cr ^? crPerception . cpVigilance
-                    , fpreShow "crAction" $ ap ^? apAction
-                    , fpreShow "crImpulse" $ ap ^? apImpulse
-                    ]
-                )
-        | otherwise = Nothing
-      where
-        ap = _crActionPlan cr
-        crOnScreen = pointIsOnScreen cfig cam $ cr ^. crPos . _xy
-
-    fpreShow :: (Show a, Functor f) => String -> f a -> f String
-    fpreShow str = fmap (((rightPad 7 '.' str ++ "...") ++) . show)
-    hw = halfWidth cfig
-
-
 selectCreatureDebugItem :: Universe -> DebugItem
 selectCreatureDebugItem u =
     DebugItem
@@ -155,33 +145,37 @@ scrollDebugInfoInt i u
 
 debugSelectCreatureMessage :: Universe -> [String]
 debugSelectCreatureMessage u = fromMaybe
-    [show (u ^? uvDebug . ix Select_creature . debugInfo . debugInt)]
+    [show (u ^? uvDebug . ix Select_creature . ix 0 . debugInfo . debugInt)]
     $ do
-        cid <- u ^? uvDebug . ix Select_creature . debugInfo . debugMInt . _Just
-        i <- u ^? uvDebug . ix Select_creature . debugInfo . debugInt
+        cid <- u ^? uvDebug . ix Select_creature . ix 0 . debugInfo . debugMInt . _Just
+        i <- u ^? uvDebug . ix Select_creature . ix 0 . debugInfo . debugInt
         cap <- debugSelectCreatureList cid u !! i
         return $ show cid : cap
 
 debugSelectCreatureList :: Int -> Universe -> [Maybe [String]]
 debugSelectCreatureList cid u =
-    [ debugList "ActionPlan"
+    [ debugList
+        "ActionPlan"
         (u ^? uvWorld . cWorld . lWorld . creatures . ix cid . crActionPlan)
-    , debugList "Perception"
+    , debugList
+        "Perception"
         (u ^? uvWorld . cWorld . lWorld . creatures . ix cid . crPerception)
-    , debugList "Intention"
+    , debugList
+        "Intention"
         (u ^? uvWorld . cWorld . lWorld . creatures . ix cid . crIntention)
-    , debugList "Memory"
+    , debugList
+        "Memory"
         (u ^? uvWorld . cWorld . lWorld . creatures . ix cid . crMemory)
-    , debugList "Strategy"
+    , debugList
+        "Strategy"
         (u ^? uvWorld . cWorld . lWorld . creatures . ix cid . crActionPlan . apStrategy)
-    , debugList "Vocalization"
+    , debugList
+        "Vocalization"
         (u ^? uvWorld . cWorld . lWorld . creatures . ix cid . crVocalization)
     ]
 
-
 debugList :: (Functor f, ToJSON a) => String -> f a -> f [String]
-debugList str = fmap (([str] ++) . prettyShort )
-
+debugList str = fmap (([str] ++) . prettyShort)
 
 clickGetCreature :: Universe -> DebugInfo
 clickGetCreature u
@@ -190,7 +184,7 @@ clickGetCreature u
         DebugIntMInt 0 (closestCreatureID u)
     | otherwise =
         fromMaybe (DebugIntMInt 0 Nothing) $
-            u ^? uvDebug . ix Select_creature . debugInfo
+            u ^? uvDebug . ix Select_creature . ix 0 . debugInfo
 
 closestCreatureID :: Universe -> Maybe Int
 closestCreatureID u =