124 lines
4.3 KiB
Haskell
124 lines
4.3 KiB
Haskell
{-# LANGUAGE LambdaCase #-}
|
|
module Dodge.Debug 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
|
|
|
|
debugEvents :: Universe -> Universe
|
|
debugEvents u = case dbools ^. at Enable_debug of
|
|
Nothing -> u
|
|
Just () -> S.foldr debugEvent u dbools
|
|
where
|
|
dbools = u ^. uvConfig . debug_booleans
|
|
|
|
debugEvent :: DebugBool -> Universe -> Universe
|
|
debugEvent db u = u & uvDebug . at db .~ debugEvent' u db
|
|
-- case db of
|
|
-- Collision_test -> u & uvDebug . at Collision_test ?~ collisionDebugItem u
|
|
-- Circ_collision_test -> u & uvDebug . at Circ_collision_test ?~ circCollisionDebugItem u
|
|
-- Select_creature -> u & uvDebug . at Select_creature ?~ selectCreatureDebugItem u
|
|
-- _ -> u
|
|
|
|
debugEvent' :: Universe -> DebugBool -> Maybe DebugItem
|
|
debugEvent' u = \case
|
|
Collision_test -> Just $ collisionDebugItem u
|
|
Circ_collision_test -> Just $ circCollisionDebugItem u
|
|
Select_creature -> Just $ selectCreatureDebugItem u
|
|
Show_walls_near_point_cursor -> Just
|
|
(DebugItem (const $ drawWallsNearCursor w) (const mempty) NoDebugInfo)
|
|
Show_walls_near_segment -> Just
|
|
(DebugItem (const $ drawWallsNearSegment w) (const mempty) NoDebugInfo)
|
|
_ -> Nothing
|
|
where
|
|
w = u ^. uvWorld
|
|
|
|
collisionDebugItem :: Universe -> DebugItem
|
|
collisionDebugItem u =
|
|
DebugItem
|
|
{ _debugPic = const $ drawCollisionTest $ u ^. uvWorld
|
|
, _debugMessage = const []
|
|
, _debugInfo = NoDebugInfo
|
|
}
|
|
|
|
selectCreatureDebugItem :: Universe -> DebugItem
|
|
selectCreatureDebugItem u =
|
|
DebugItem
|
|
{ _debugPic = const mempty
|
|
, _debugMessage = debugSelectCreatureMessage
|
|
, _debugInfo = scrollDebugInfoInt (length $ debugSelectCreatureList 0 u) u $ clickGetCreature u
|
|
}
|
|
|
|
circCollisionDebugItem :: Universe -> DebugItem
|
|
circCollisionDebugItem _ =
|
|
DebugItem
|
|
{ _debugPic = drawCircCollisionTest . (^. uvWorld)
|
|
, _debugMessage = const []
|
|
, _debugInfo = NoDebugInfo
|
|
}
|
|
|
|
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)
|