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

Allow more debug interaction

Browse Source
This commit is contained in:
justin
2025-10-16 10:45:37 +01:00
parent 315e6b1c04
commit df85624a49
6 changed files with 306 additions and 202 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data/Config.hs
+2
View File
@@ -91,6 +91,8 @@ data DebugBool
| Show_zone_circ
| Inspect_wall
| Show_path_between
| Show_writable_values
| Show_mouse_click_pos
deriving (Eq, Ord, Bounded, Enum, Show)
data ResFactor = DoubleRes | FullRes | HalfRes | QuarterRes | EighthRes | SixteenthRes
src/Dodge/Data/Universe.hs
+9
View File
@@ -13,6 +13,7 @@ module Dodge.Data.Universe (
module Loop.Data,
) where
import Geometry.Data
import Sound.Data
import qualified Data.Map.Strict as M
import GHC.Word (Word32)
@@ -43,10 +44,18 @@ data Universe = Universe
, _uvDebug :: M.Map DebugBool [DebugItem]
, _uvDebugFloat1 :: Float
, _uvDebugFloat2 :: Float
, _uvDebugV2_1 :: Point2
, _uvDebugV2_2 :: Point2
, _uvDebugPathShowType :: PathShowType
, _uvDebugMessageOffset :: Int
, _uvSoundQueue :: [SoundID] -- sounds without a position, to be played once
}
data PathShowType
= PathBetweenLeftRightClick
| PathBetweenDebugV2s
deriving (Show,Eq,Ord,Enum,Bounded)
data DebugItem = DebugItem
{ _debugMessage :: String
, _debugFunction :: Universe -> Universe
src/Dodge/Debug.hs
+103 -35
View File
@@ -1,9 +1,7 @@
{-# LANGUAGE LambdaCase #-}
module Dodge.Debug (debugEvents,drawDebug) where
module Dodge.Debug (debugEvents, drawDebug) where
import qualified SDL
import System.Hclip
import Control.Lens
import Control.Monad
import qualified Data.IntMap.Strict as IM
@@ -16,13 +14,16 @@ import Dodge.Debug.Picture
import Linear
import Padding
import Picture.Base
import ShortShow
import qualified SDL
import System.Hclip
import Text.Read
debugEvents :: Universe -> Universe
debugEvents u = case dbools ^. at Display_debug of
Nothing -> u & uvDebug .~ mempty
Just () -> S.foldr debugEvent (u & uvDebug .~ mempty) dbools
& overDebugEvent
Just () ->
S.foldr debugEvent (u & uvDebug .~ mempty) dbools
& overDebugEvent
where
dbools = u ^. uvConfig . debug_booleans
@@ -63,7 +64,68 @@ debugItem = \case
Mouse_position -> mempty
Walls_info -> mempty
Pathing -> mempty
Show_path_between -> mempty
Show_path_between -> Just . return . debugShowPath
Show_writable_values -> debugWritableValues
Show_mouse_click_pos -> debugMouseClickPos
debugShowPath :: Universe -> DebugItem
debugShowPath u =
DebugItem (u ^. uvDebugPathShowType . to show) f
where
f u' = fromMaybe u' $ do
guard (u ^. uvWorld . input . mouseButtons . at SDL.ButtonLeft == Just 0)
return (u' & uvDebugPathShowType %~ succB)
succB :: (Eq a, Bounded a, Enum a) => a -> a
succB x
| x == maxBound = minBound
| otherwise = succ x
debugWritableValues :: Universe -> Maybe [DebugItem]
debugWritableValues u =
Just $
mapMaybe f $
[ (uvDebugV2_1, uvDebugV2_1)
, (uvDebugV2_2, uvDebugV2_2)
]
where
f (gt, st) = do
s <- u ^? gt
return $ DebugItem (show s) (applyClip st)
applyClip ::
Read b =>
((a -> Identity b) -> Universe -> Identity Universe) ->
Universe ->
Universe
applyClip l u' = fromMaybe u' $ do
guard (u' ^. uvWorld . input . mouseButtons . at SDL.ButtonLeft == Just 0)
return $ u' & uvIOEffects %~ f
where
f g u = do
s <- getClipboard
case readMaybe s of
Just x -> g (u & l .~ x)
Nothing -> g u
debugMouseClickPos :: Universe -> Maybe [DebugItem]
debugMouseClickPos u =
Just $
mapMaybe
f
[ uvWorld . input . clickPos . at SDL.ButtonLeft
, uvWorld . input . clickPos . at SDL.ButtonRight
, uvWorld . input . heldPos . at SDL.ButtonLeft
, uvWorld . input . heldPos . at SDL.ButtonRight
, uvWorld . input . clickWorldPos . at SDL.ButtonLeft
, uvWorld . input . clickWorldPos . at SDL.ButtonRight
, uvWorld . input . heldWorldPos . at SDL.ButtonLeft
, uvWorld . input . heldWorldPos . at SDL.ButtonRight
]
where
f l = do
s <- show <$> u ^. l
return $ DebugItem s (setClip s)
drawCrInfo' :: Universe -> Maybe [DebugItem]
drawCrInfo' u = case drawCrInfo u of
@@ -74,26 +136,29 @@ drawCrInfo :: Universe -> [DebugItem]
drawCrInfo u = foldMap f . IM.elems $ w ^. cWorld . lWorld . creatures
where
w = u ^. uvWorld
g h ls x = do
rs <- h <$> x
return $ DebugItem ((rightPad 7 '.' ls ++ "...") ++ rs) (setclip rs)
g ls x = do
rs <- show <$> x
return $ DebugItem ((rightPad 7 '.' ls ++ "...") ++ rs) (setClip rs)
f cr = fromMaybe [] $ do
guard $
pointIsOnScreen (u ^. uvConfig) (w ^. wCam) (cr ^. crPos . _xy)
&& cr ^. crID /= 0
Just $ 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
, g show "crName" $ cr ^? crName
]
setclip s u'' = fromMaybe u'' $ do
guard (SDL.ButtonLeft `M.member` (u'' ^. uvWorld . input . mouseButtons))
return $ u'' & uvIOEffects %~ (\m u' -> setClipboard s >> m u')
Just $
catMaybes
[ g "crID" $ cr ^? crID
, g "crHP" $ cr ^? crHP . _HP
, g "crStrategy" $ cr ^? crActionPlan . apStrategy
, g "crPos" $ cr ^? crPos . _xy
, g "cpVigilance" $ cr ^? crPerception . cpVigilance
, g "crAction" $ cr ^? crActionPlan . apAction
, g "crImpulse" $ cr ^? crActionPlan . apImpulse
, g "crName" $ cr ^? crName
]
setClip :: String -> Universe -> Universe
setClip s u = fromMaybe u $ do
guard (u ^. uvWorld . input . mouseButtons . at SDL.ButtonLeft == Just 0)
return $ u & uvIOEffects %~ (\m u' -> setClipboard s >> m u')
--closestCreatureID :: Universe -> Maybe Int
--closestCreatureID u =
@@ -120,17 +185,20 @@ drawDebug u = \case
View_boundaries -> viewBoundaries $ _uvWorld u
Show_bound_box -> drawBoundingBox $ _uvWorld u
Show_wall_search_rays -> drawWallSearchRays $ _uvWorld u
Show_dda_test -> drawDDATest $ _uvWorld u
Show_far_wall_detect -> drawFarWallDetect $ _uvWorld u
Show_walls_near_point_you -> drawWallsNearYou $ _uvWorld u
Show_zone_near_point_cursor -> drawZoneNearPointCursor $ _uvWorld u
Show_zone_circ -> drawZoneCirc $ _uvWorld u
Inspect_wall -> drawInspectWalls $ _uvWorld u
Cr_awareness -> drawCreatureDisplayTexts $ _uvWorld u
Show_sound -> fold
$ M.map (soundPic (u ^. uvConfig) (u ^. uvWorld)) $ u ^. uvWorld . playingSounds
Show_dda_test -> drawDDATest $ _uvWorld u
Show_far_wall_detect -> drawFarWallDetect $ _uvWorld u
Show_walls_near_point_you -> drawWallsNearYou $ _uvWorld u
Show_zone_near_point_cursor -> drawZoneNearPointCursor $ _uvWorld u
Show_zone_circ -> drawZoneCirc $ _uvWorld u
Inspect_wall -> drawInspectWalls $ _uvWorld u
Cr_awareness -> drawCreatureDisplayTexts $ _uvWorld u
Show_sound ->
fold $
M.map (soundPic (u ^. uvConfig) (u ^. uvWorld)) $ u ^. uvWorld . playingSounds
Cr_status -> mempty
Mouse_position -> drawMousePosition $ _uvWorld u
Walls_info -> drawWlIDs $ _uvWorld u
Mouse_position -> drawMousePosition $ _uvWorld u
Walls_info -> drawWlIDs $ _uvWorld u
Pathing -> drawPathing (u ^. uvConfig) (u ^. uvWorld)
Show_path_between -> drawPathBetween $ _uvWorld u
Show_path_between -> drawPathBetween u
Show_writable_values -> mempty
Show_mouse_click_pos -> mempty
src/Dodge/Debug/Picture.hs
+12 -4
View File
@@ -198,17 +198,25 @@ drawZoneCol col s (V2 x y) = setLayer DebugLayer . color col $ thickLine 2 (p :
drawCreatureDisplayTexts :: World -> Picture
drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (w ^. cWorld . lWorld . creatures)
drawPathBetween :: World -> Picture
drawPathBetween w = concat $ do
sp <- w ^. input . heldWorldPos . at ButtonLeft
ep <- w ^. input . heldWorldPos . at ButtonRight
drawPathBetween :: Universe -> Picture
drawPathBetween u = concat $ do
sp <- case u ^. uvDebugPathShowType of
PathBetweenLeftRightClick -> w ^. input . heldWorldPos . at ButtonLeft
PathBetweenDebugV2s -> u ^? uvDebugV2_1
ep <- case u ^. uvDebugPathShowType of
PathBetweenLeftRightClick -> w ^. input . heldWorldPos . at ButtonRight
PathBetweenDebugV2s -> u ^? uvDebugV2_2
let nodepos = (`getNodePos` w)
nodelist = makePathBetween sp ep w
return . setLayer DebugLayer $
color rose (foldMap (arrowPath . mapMaybe nodepos) nodelist)
<> drawCrossCol green sp
<> drawCrossCol cyan ep
<> foldMap (color green . arrow sp) (nodepos =<< walkableNodeNear w sp)
<> foldMap (color cyan . flip arrow ep) (nodepos =<< walkableNodeNear w ep)
<> foldMap (color orange . arrow sp) (pointTowardsImpulse sp ep w)
where
w = u ^. uvWorld
drawWallsNearYou :: World -> Picture
drawWallsNearYou w = concat $ do