Add selection box on left click drag
This commit is contained in:
+16
-118
@@ -2,46 +2,37 @@
|
||||
|
||||
module Dodge.Debug (debugEvents,drawDebug) where
|
||||
|
||||
import AesonHelp
|
||||
import Control.Lens
|
||||
import Control.Monad
|
||||
import Data.Aeson.Types
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
import Data.List (sortOn)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe
|
||||
import Data.Ord
|
||||
import qualified Data.Set as S
|
||||
import Dodge.Base.Coordinate
|
||||
import Dodge.Base.Window
|
||||
import Dodge.Data.Universe
|
||||
import Dodge.Debug.Picture
|
||||
import Dodge.WorldEvent.ThingsHit
|
||||
import Geometry.Vector
|
||||
import Linear
|
||||
import Padding
|
||||
import Picture.Base
|
||||
import qualified SDL
|
||||
import ShortShow
|
||||
|
||||
debugEvents :: Universe -> Universe
|
||||
debugEvents u = case dbools ^. at Enable_debug of
|
||||
debugEvents u = case dbools ^. at Display_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
|
||||
debugEvent db u = u & uvDebug . at db .~ debugItem db u
|
||||
|
||||
debugItem :: DebugBool -> Universe -> [DebugItem]
|
||||
debugItem :: DebugBool -> Universe -> Maybe [DebugItem]
|
||||
debugItem = \case
|
||||
Collision_test -> mempty
|
||||
Circ_collision_test -> mempty
|
||||
Select_creature -> return . selectCreatureDebugItem
|
||||
Show_walls_near_point_cursor -> mempty
|
||||
Show_walls_near_segment -> mempty
|
||||
Enable_debug -> mempty
|
||||
Display_debug -> mempty
|
||||
Noclip -> mempty
|
||||
Remove_LOS -> mempty
|
||||
Cull_more_lights -> mempty
|
||||
@@ -59,24 +50,22 @@ debugItem = \case
|
||||
Inspect_wall -> mempty
|
||||
Cr_awareness -> mempty
|
||||
Show_sound -> mempty
|
||||
Cr_status -> drawCrInfo
|
||||
Cr_status -> Just . drawCrInfo
|
||||
Mouse_position -> mempty
|
||||
Walls_info -> mempty
|
||||
Pathing -> mempty
|
||||
Show_path_between -> mempty
|
||||
|
||||
drawCrInfo :: Universe -> [DebugItem]
|
||||
drawCrInfo u = mapMaybe f . IM.elems $ w ^. cWorld . lWorld . creatures
|
||||
drawCrInfo u = foldMap f . IM.elems $ w ^. cWorld . lWorld . creatures
|
||||
where
|
||||
w = u ^. uvWorld
|
||||
g h str = fmap $ ((rightPad 7 '.' str ++ "...") ++) . h
|
||||
f cr = do
|
||||
f cr = fromMaybe [] $ do
|
||||
guard $
|
||||
pointIsOnScreen (u ^. uvConfig) (w ^. wCam) (cr ^. crPos . _xy)
|
||||
&& cr ^. crID /= 0
|
||||
Just $
|
||||
DebugItem
|
||||
( catMaybes
|
||||
Just $ (\x -> DebugItem x (const id)) <$> catMaybes
|
||||
[ g show "crID" $ cr ^? crID
|
||||
, g show "crHP" $ cr ^? crHP . _HP
|
||||
, g show "crStrategy" $ cr ^? crActionPlan . apStrategy
|
||||
@@ -85,114 +74,23 @@ drawCrInfo u = mapMaybe f . IM.elems $ w ^. cWorld . lWorld . creatures
|
||||
, g show "crAction" $ cr ^? crActionPlan . apAction
|
||||
, g show "crImpulse" $ cr ^? crActionPlan . apImpulse
|
||||
]
|
||||
)
|
||||
(DebugV2 $ cr ^. crPos . _xy)
|
||||
|
||||
--drawCrInfo :: Config -> World -> Picture
|
||||
--drawCrInfo cfig w =
|
||||
-- setLayer FixedCoordLayer $
|
||||
-- renderInfoListsAt (2 * hw - 400) 0 cfig cam $
|
||||
-- mapMaybe crDisplayInfo $ IM.elems $ w ^. cWorld . lWorld . creatures
|
||||
--closestCreatureID :: Universe -> Maybe Int
|
||||
--closestCreatureID u =
|
||||
-- fmap (_crID . snd) . listToMaybe
|
||||
-- . sortOn (Down . dist mwp . fst)
|
||||
-- . crsHitRadial mwp 100
|
||||
-- $ _uvWorld u
|
||||
-- where
|
||||
-- cam = w ^. wCam
|
||||
-- crDisplayInfo :: Creature -> Maybe (Point2, [String])
|
||||
-- crDisplayInfo cr
|
||||
-- | _crID cr == 0 = Nothing
|
||||
-- | crOnScreen =
|
||||
-- Just
|
||||
-- ( cr ^. crPos . _xy
|
||||
-- , catMaybes
|
||||
-- -- [fmap show $ ap ^? crGoal
|
||||
-- [ fpreShow "crHP" $ cr ^? crHP . _HP
|
||||
-- , fpreShow "crStrategy" $ ap ^? apStrategy
|
||||
-- , fmap (("crPos....." ++) . shortShow) $ cr ^? crPos . _xy
|
||||
-- , fpreShow "cpVigilance" $ cr ^? crPerception . cpVigilance
|
||||
-- , fpreShow "crAction" $ ap ^? apAction
|
||||
-- , fpreShow "crImpulse" $ ap ^? apImpulse
|
||||
-- ]
|
||||
-- )
|
||||
-- | otherwise = Nothing
|
||||
-- where
|
||||
-- ap = _crActionPlan cr
|
||||
-- crOnScreen = pointIsOnScreen cfig cam $ cr ^. crPos . _xy
|
||||
--
|
||||
-- fpreShow :: (Show a, Functor f) => String -> f a -> f String
|
||||
-- fpreShow str = fmap (((rightPad 7 '.' str ++ "...") ++) . show)
|
||||
-- hw = halfWidth cfig
|
||||
|
||||
selectCreatureDebugItem :: Universe -> DebugItem
|
||||
selectCreatureDebugItem u =
|
||||
DebugItem
|
||||
{ _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 . ix 0 . debugInfo . debugInt)]
|
||||
$ do
|
||||
cid <- u ^? uvDebug . ix Select_creature . ix 0 . debugInfo . debugMInt . _Just
|
||||
i <- u ^? uvDebug . ix Select_creature . ix 0 . 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 . ix 0 . 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)
|
||||
-- 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
|
||||
Select_creature -> mempty
|
||||
Show_walls_near_point_cursor -> drawWallsNearCursor $ _uvWorld u
|
||||
Show_walls_near_segment -> drawWallsNearSegment $ _uvWorld u
|
||||
Enable_debug -> mempty
|
||||
Display_debug -> mempty
|
||||
Noclip -> mempty
|
||||
Remove_LOS -> mempty
|
||||
Cull_more_lights -> mempty
|
||||
|
||||
Reference in New Issue
Block a user