Allow more debug interaction
This commit is contained in:
+103
-35
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user