137 lines
4.8 KiB
Haskell
137 lines
4.8 KiB
Haskell
{-# LANGUAGE LambdaCase #-}
|
|
|
|
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
|
|
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 ShortShow
|
|
|
|
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 -> mempty
|
|
|
|
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 h ls x = do
|
|
rs <- h <$> 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')
|
|
|
|
--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
|
|
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 $ _uvWorld u
|