242 lines
7.8 KiB
Haskell
242 lines
7.8 KiB
Haskell
{-# LANGUAGE LambdaCase #-}
|
|
|
|
module Dodge.Debug (debugEvents, drawDebug) where
|
|
|
|
import AesonHelp
|
|
import Control.Lens
|
|
import Control.Monad
|
|
import qualified Data.IntMap.Strict as IM
|
|
import qualified Data.Map.Strict as M
|
|
import Data.Maybe
|
|
import qualified Data.Set as S
|
|
import Dodge.Base.Window
|
|
import Dodge.Data.Universe
|
|
import Dodge.Debug.Picture
|
|
import Linear
|
|
import Padding
|
|
import Picture.Base
|
|
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
|
|
where
|
|
dbools = u ^. uvConfig . debug_booleans
|
|
|
|
overDebugEvent :: Universe -> Universe
|
|
overDebugEvent u = fromMaybe u $ do
|
|
OverDebug db i <- u ^? uvWorld . input . mouseContext
|
|
f <- u ^? uvDebug . ix db . ix i . debugFunction
|
|
return $ f u
|
|
|
|
debugEvent :: DebugBool -> Universe -> Universe
|
|
debugEvent db u = u & uvDebug . at db .~ debugItem db u
|
|
|
|
debugItem :: DebugBool -> Universe -> Maybe [DebugItem]
|
|
debugItem = \case
|
|
Collision_test -> mempty
|
|
Circ_collision_test -> mempty
|
|
Show_walls_near_point_cursor -> mempty
|
|
Show_walls_near_segment -> mempty
|
|
Display_debug -> mempty
|
|
Noclip -> mempty
|
|
Remove_LOS -> mempty
|
|
Cull_more_lights -> mempty
|
|
Close_shape_culling -> mempty
|
|
Bound_box_screen -> mempty
|
|
Show_ms_frame -> mempty
|
|
View_boundaries -> mempty
|
|
Show_bound_box -> mempty
|
|
Show_wall_search_rays -> mempty
|
|
Show_dda_test -> mempty
|
|
Show_far_wall_detect -> mempty
|
|
Show_walls_near_point_you -> mempty
|
|
Show_zone_near_point_cursor -> mempty
|
|
Show_zone_circ -> mempty
|
|
Inspect_wall -> mempty
|
|
Cr_awareness -> mempty
|
|
Show_sound -> mempty
|
|
Cr_status -> drawCrInfo'
|
|
Mouse_position -> mempty
|
|
Walls_info -> mempty
|
|
Pathing -> mempty
|
|
Show_path_between -> Just . return . debugShowPath
|
|
Show_writable_values -> debugWritableValues
|
|
Show_mouse_click_pos -> debugMouseClickPos
|
|
Debug_get -> doDebugGet
|
|
Debug_put -> debugPutItems
|
|
|
|
debugGet :: Universe -> [String]
|
|
debugGet u = foldMap getPretty $ u ^. uvWorld . cWorld . lWorld . shockwaves
|
|
|
|
|
|
debugPutItems :: Universe -> Maybe [DebugItem]
|
|
debugPutItems u = Just $ f <$> [0..debugPutN]
|
|
where
|
|
f i = DebugItem (g i) (doDebugPut i) -- (uvIOEffects %~ doDebugPut i)
|
|
g i = fromMaybe "Not assigned" $ u ^? uvDebugPut . ix i
|
|
|
|
debugPutN :: Int
|
|
debugPutN = 5
|
|
|
|
doDebugPut :: Int -> Universe -> Universe
|
|
doDebugPut i u
|
|
| u ^. uvWorld . input . mouseButtons . at SDL.ButtonLeft == Just 0 = u
|
|
& uvIOEffects %~ \ f u' -> do
|
|
s <- getClipboard
|
|
f $ u' & uvDebugPut . at i ?~ s
|
|
| otherwise = u
|
|
|
|
debugPutDraw :: IM.IntMap String -> Universe -> Picture
|
|
debugPutDraw _ _ = mempty
|
|
|
|
doDebugGet :: Universe -> Maybe [DebugItem]
|
|
doDebugGet u =
|
|
Just $ f <$> debugGet u
|
|
where
|
|
f s = DebugItem s (setClip s)
|
|
|
|
|
|
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
|
|
[] -> Nothing
|
|
xs -> Just xs
|
|
|
|
drawCrInfo :: Universe -> [DebugItem]
|
|
drawCrInfo u = foldMap f . IM.elems $ w ^. cWorld . lWorld . creatures
|
|
where
|
|
w = u ^. uvWorld
|
|
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 "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
|
|
, g "crIntention" $ cr ^? crIntention
|
|
]
|
|
|
|
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 =
|
|
-- fmap (_crID . snd) . listToMaybe
|
|
-- . sortOn (Down . dist mwp . fst)
|
|
-- . crsHitRadial mwp 100
|
|
-- $ _uvWorld u
|
|
-- where
|
|
-- mwp = mouseWorldPos (u ^. uvWorld . input) (u ^. uvWorld . wCam)
|
|
|
|
drawDebug :: Universe -> DebugBool -> Picture
|
|
drawDebug u = \case
|
|
Debug_put -> debugPutDraw (u ^. uvDebugPut) u
|
|
Debug_get -> mempty
|
|
Collision_test -> drawCollisionTest $ _uvWorld u
|
|
Circ_collision_test -> drawCircCollisionTest $ _uvWorld u
|
|
Show_walls_near_point_cursor -> drawWallsNearCursor $ _uvWorld u
|
|
Show_walls_near_segment -> drawWallsNearSegment $ _uvWorld u
|
|
Display_debug -> mempty
|
|
Noclip -> mempty
|
|
Remove_LOS -> mempty
|
|
Cull_more_lights -> mempty
|
|
Close_shape_culling -> mempty
|
|
Bound_box_screen -> mempty
|
|
Show_ms_frame -> mempty
|
|
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
|
|
Cr_status -> mempty
|
|
Mouse_position -> drawMousePosition $ _uvWorld u
|
|
Walls_info -> drawWlIDs $ _uvWorld u
|
|
Pathing -> drawPathing (u ^. uvConfig) (u ^. uvWorld)
|
|
Show_path_between -> drawPathBetween u
|
|
Show_writable_values -> mempty
|
|
Show_mouse_click_pos -> mempty
|