126 lines
5.0 KiB
Haskell
126 lines
5.0 KiB
Haskell
{-# LANGUAGE LambdaCase #-}
|
|
module Dodge.Debug (debugEvents) where
|
|
|
|
import Data.Aeson.Types
|
|
import AesonHelp
|
|
import Control.Lens
|
|
import Data.List (sortOn)
|
|
import qualified Data.Map.Strict as M
|
|
import Data.Maybe
|
|
import qualified Data.Set as S
|
|
import Dodge.Base.Coordinate
|
|
import Dodge.Data.Universe
|
|
import Dodge.Debug.Picture
|
|
import Dodge.WorldEvent.ThingsHit
|
|
import Geometry.Vector
|
|
import qualified SDL
|
|
import Data.Ord
|
|
import Data.Foldable (fold)
|
|
|
|
debugEvents :: Universe -> Universe
|
|
debugEvents u = case dbools ^. at Enable_debug of
|
|
Nothing -> u
|
|
Just () -> S.foldr debugEvent (u & uvDebug .~ mempty) dbools
|
|
where
|
|
dbools = u ^. uvConfig . debug_booleans
|
|
|
|
debugEvent :: DebugBool -> Universe -> Universe
|
|
debugEvent db u = u & uvDebug . at db .~ debugItem db u
|
|
|
|
debugItem :: DebugBool -> Universe -> Maybe DebugItem
|
|
debugItem = \case
|
|
Collision_test -> constDPic (drawCollisionTest . _uvWorld)
|
|
Circ_collision_test -> constDPic (drawCircCollisionTest . _uvWorld)
|
|
Select_creature -> Just . selectCreatureDebugItem
|
|
Show_walls_near_point_cursor -> constDPic (drawWallsNearCursor . _uvWorld)
|
|
Show_walls_near_segment -> constDPic (drawWallsNearSegment . _uvWorld)
|
|
Enable_debug -> const Nothing
|
|
Noclip -> const Nothing
|
|
Remove_LOS -> const Nothing
|
|
Cull_more_lights -> const Nothing
|
|
Close_shape_culling -> const Nothing
|
|
Bound_box_screen -> const Nothing
|
|
Show_ms_frame -> const Nothing
|
|
View_boundaries -> constDPic (viewBoundaries . _uvWorld)
|
|
Show_bound_box -> constDPic (drawBoundingBox . _uvWorld)
|
|
Show_wall_search_rays -> constDPic $ drawWallSearchRays . _uvWorld
|
|
Show_dda_test -> constDPic $ drawDDATest . _uvWorld
|
|
Show_far_wall_detect -> constDPic $ drawFarWallDetect . _uvWorld
|
|
Show_walls_near_point_you -> constDPic $ drawWallsNearYou . _uvWorld
|
|
Show_zone_near_point_cursor -> constDPic $ drawZoneNearPointCursor . _uvWorld
|
|
Show_zone_circ -> constDPic $ drawZoneCirc . _uvWorld
|
|
Inspect_wall -> constDPic $ drawInspectWalls . _uvWorld
|
|
Cr_awareness -> constDPic $ drawCreatureDisplayTexts . _uvWorld
|
|
Show_sound -> constDPic $ \u ->
|
|
fold (M.map (soundPic (u ^. uvConfig) (u ^. uvWorld)) $ u ^. uvWorld . playingSounds)
|
|
Cr_status -> constDPic $ \u -> drawCrInfo (u ^. uvConfig) (u ^. uvWorld)
|
|
Mouse_position -> constDPic $ drawMousePosition . _uvWorld
|
|
Walls_info -> constDPic $ drawWlIDs . _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
|
|
|
|
selectCreatureDebugItem :: Universe -> DebugItem
|
|
selectCreatureDebugItem u =
|
|
DebugItem
|
|
{ _debugPic = mempty
|
|
, _debugMessage = debugSelectCreatureMessage u
|
|
, _debugInfo = scrollDebugInfoInt (length $ debugSelectCreatureList 0 u) u $ clickGetCreature u
|
|
}
|
|
|
|
scrollDebugInfoInt :: Int -> Universe -> DebugInfo -> DebugInfo
|
|
scrollDebugInfoInt i u
|
|
| SDL.ScancodeRShift `M.member` (u ^. uvWorld . input . pressedKeys) =
|
|
debugInt %~ ((`mod` i) . (+ (u ^. uvWorld . input . scrollAmount)))
|
|
| otherwise = id
|
|
|
|
debugSelectCreatureMessage :: Universe -> [String]
|
|
debugSelectCreatureMessage u = fromMaybe
|
|
[show (u ^? uvDebug . ix Select_creature . debugInfo . debugInt)]
|
|
$ do
|
|
cid <- u ^? uvDebug . ix Select_creature . debugInfo . debugMInt . _Just
|
|
i <- u ^? uvDebug . ix Select_creature . debugInfo . debugInt
|
|
cap <- debugSelectCreatureList cid u !! i
|
|
return $ show cid : cap
|
|
|
|
debugSelectCreatureList :: Int -> Universe -> [Maybe [String]]
|
|
debugSelectCreatureList cid u =
|
|
[ debugList "ActionPlan"
|
|
(u ^? uvWorld . cWorld . lWorld . creatures . ix cid . crActionPlan)
|
|
, debugList "Perception"
|
|
(u ^? uvWorld . cWorld . lWorld . creatures . ix cid . crPerception)
|
|
, debugList "Intention"
|
|
(u ^? uvWorld . cWorld . lWorld . creatures . ix cid . crIntention)
|
|
, debugList "Memory"
|
|
(u ^? uvWorld . cWorld . lWorld . creatures . ix cid . crMemory)
|
|
, debugList "Strategy"
|
|
(u ^? uvWorld . cWorld . lWorld . creatures . ix cid . crActionPlan . apStrategy)
|
|
, 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 )
|
|
|
|
|
|
clickGetCreature :: Universe -> DebugInfo
|
|
clickGetCreature u
|
|
| SDL.ButtonLeft `M.member` (u ^. uvWorld . input . mouseButtons)
|
|
&& SDL.ScancodeRShift `M.member` (u ^. uvWorld . input . pressedKeys) =
|
|
DebugIntMInt 0 (closestCreatureID u)
|
|
| otherwise =
|
|
fromMaybe (DebugIntMInt 0 Nothing) $
|
|
u ^? uvDebug . ix Select_creature . debugInfo
|
|
|
|
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)
|