justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Tweak debug display

Browse Source
This commit is contained in:
justin
2025-10-14 10:14:30 +01:00
parent 3d602b4f57
commit cadaf00797
7 changed files with 150 additions and 143 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data/Universe.hs
+1 -1
View File
@@ -41,7 +41,7 @@ data Universe = Universe
, _uvLastFrameTicks :: Word32
, _uvFrameTicks :: Word32
, _uvRAMSave :: Maybe World
, _uvDebug :: M.Map DebugBool DebugItem
, _uvDebug :: M.Map DebugBool [DebugItem]
, _uvDebugFloat1 :: Float
, _uvDebugFloat2 :: Float
, _uvDebugMessageOffset :: Int
src/Dodge/Debug.hs
+63 -69
View File
@@ -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 =
src/Dodge/Debug/Picture.hs
+10 -10
View File
@@ -16,7 +16,7 @@ import Dodge.Path
import Dodge.Picture.SizeInvariant
--import Dodge.Render.InfoBox
import Dodge.Render.Label
import Dodge.Render.List
--import Dodge.Render.List
import Dodge.ShortShow
import Dodge.SoundLogic.LoadSound
import Dodge.Viewpoints
@@ -153,15 +153,15 @@ drawZoneCol col s (V2 x y) = setLayer DebugLayer . color col $ thickLine 2 (p :
zipWith (+.+) (square 1) $
map ((s *.*) . (each %~ fromIntegral)) [V2 x y, V2 (x + 1) y, V2 (x + 1) (y + 1), V2 x (y + 1)]
showEnabledDebugs :: Config -> Picture
{-# INLINE showEnabledDebugs #-}
showEnabledDebugs cfig
| Enable_debug `S.member` _debug_booleans cfig =
setLayer FixedCoordLayer (toTopLeft cfig (translate (0.5 * halfWidth cfig) 0 $ drawList $ map text ts))
| otherwise = mempty
where
-- pic = foldMap (debugDraw' cfig w) (_debug_booleans cfig)
ts = map show (S.toList $ _debug_booleans cfig)
--showEnabledDebugs :: Config -> Picture
--{-# INLINE showEnabledDebugs #-}
--showEnabledDebugs cfig
-- | Enable_debug `S.member` _debug_booleans cfig =
-- setLayer FixedCoordLayer (toTopLeft cfig (translate (0.5 * halfWidth cfig) 0 $ drawList $ map text ts))
-- | otherwise = mempty
-- where
-- -- pic = foldMap (debugDraw' cfig w) (_debug_booleans cfig)
-- ts = map show (S.toList $ _debug_booleans cfig)
--debugDraw' :: Config -> World -> DebugBool -> Picture
--{-# INLINE debugDraw' #-}
src/Dodge/Render/List.hs
+8
View File
@@ -16,6 +16,7 @@ module Dodge.Render.List (
selSecDrawCursorAt,
drawTitleBackground, -- should be renamed, made sensible
drawCursorAt,
drawLabelledList,
) where
import qualified Data.IntMap.Strict as IM
@@ -208,6 +209,13 @@ renderListAt tx ty = translate tx (- ty)
drawList :: [Picture] -> Picture
drawList = drawListYgapScaleYoff 0 1 0
drawLabelledList :: [(String,[String])] -> Picture
drawLabelledList ((s,ss):xs)
= translate (-10) 0 (drawListYgapScaleYoff 0 1 0 [ textJustifyRight s])
<> drawListYgapScaleYoff 0 1 0 (text <$> ss)
<> translate 0 (negate $ fromIntegral (max 1 $ length ss) * 20) (drawLabelledList xs)
drawLabelledList [] = mempty
--TODO put the following functions in an appropriate place
-- | Colour picture and add black drop shadow.
src/Dodge/Render/Picture.hs
+11 -8
View File
@@ -2,8 +2,8 @@
module Dodge.Render.Picture (fixedCoordPictures) where
import Linear (_xy)
import Control.Lens
import qualified Data.Map.Strict as M
import Data.Maybe
import Dodge.Base.Coordinate
import Dodge.Base.Window
@@ -13,6 +13,7 @@ import Dodge.Render.List
import Dodge.Render.MenuScreen
import Geometry
import HelpNum
import Linear (_xy)
import Picture
fixedCoordPictures :: Universe -> Picture
@@ -30,18 +31,20 @@ fixedCoordPictures u =
)
<> displayFrameTicks u
<> drawMouseCursor u
<> ( toTopLeft cfig . translate (1.3 * halfWidth cfig) 0
. drawList
. take 50
. drop (u ^. uvDebugMessageOffset)
. map text
$ foldMap _debugMessage (_uvDebug u) -- other debug pics in extraPics
)
<> toTopLeft
cfig
( translate (halfWidth cfig) (10 * fromIntegral (u ^. uvDebugMessageOffset))
. drawLabelledList
. fmap f
. M.toList
$ u ^. uvDebug
)
where
cfig = _uvConfig u
hw = halfWidth cfig
hh = halfHeight cfig
ttl = toTopLeft cfig
f (k, l) = (show k, foldMap _debugMessage l)
displayFrameTicks :: Universe -> Picture
displayFrameTicks u
src/Dodge/Render/ShapePicture.hs
+2 -2
View File
@@ -110,8 +110,8 @@ extraPics cfig u =
<> _flares lw
<> foldMap drawLightSource (_lightSources lw)
<> viewClipBounds cfig w
<> showEnabledDebugs cfig
<> foldMap _debugPic (_uvDebug u) -- debug messages are in fixed coord pics
-- <> showEnabledDebugs cfig
<> foldMap (foldMap _debugPic) (_uvDebug u) -- debug messages are in fixed coord pics
where
w = u ^. uvWorld
lw = w ^. cWorld . lWorld