Unify debug pictures
This commit is contained in:
@@ -88,8 +88,8 @@ data DebugBool
|
||||
| Show_walls_near_point_you
|
||||
| Show_walls_near_segment
|
||||
| Show_zone_near_point_cursor
|
||||
| Show_zone_circ
|
||||
| Inspect_wall
|
||||
| Show_nodes_near_select
|
||||
| Show_path_between
|
||||
| Select_creature
|
||||
deriving (Eq, Ord, Bounded, Enum, Show)
|
||||
|
||||
@@ -49,8 +49,8 @@ data Universe = Universe
|
||||
}
|
||||
|
||||
data DebugItem = DebugItem
|
||||
{ _debugPic :: Universe -> Picture
|
||||
, _debugMessage :: Universe -> [String]
|
||||
{ _debugPic :: Picture
|
||||
, _debugMessage :: [String]
|
||||
, _debugInfo :: DebugInfo
|
||||
}
|
||||
|
||||
|
||||
+39
-37
@@ -1,5 +1,5 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
module Dodge.Debug where
|
||||
module Dodge.Debug (debugEvents) where
|
||||
|
||||
import Data.Aeson.Types
|
||||
import AesonHelp
|
||||
@@ -15,59 +15,61 @@ 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 dbools
|
||||
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 .~ 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 db u = u & uvDebug . at db .~ debugItem db 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
|
||||
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
|
||||
|
||||
collisionDebugItem :: Universe -> DebugItem
|
||||
collisionDebugItem u =
|
||||
DebugItem
|
||||
{ _debugPic = const $ drawCollisionTest $ u ^. uvWorld
|
||||
, _debugMessage = const []
|
||||
, _debugInfo = NoDebugInfo
|
||||
}
|
||||
constDPic :: (Universe -> Picture) -> Universe -> Maybe DebugItem
|
||||
constDPic p u = Just $ DebugItem (p u) mempty NoDebugInfo
|
||||
|
||||
selectCreatureDebugItem :: Universe -> DebugItem
|
||||
selectCreatureDebugItem u =
|
||||
DebugItem
|
||||
{ _debugPic = const mempty
|
||||
, _debugMessage = debugSelectCreatureMessage
|
||||
{ _debugPic = mempty
|
||||
, _debugMessage = debugSelectCreatureMessage u
|
||||
, _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) =
|
||||
|
||||
+49
-38
@@ -4,7 +4,6 @@ module Dodge.Debug.Picture where
|
||||
import Control.Lens
|
||||
import Data.Foldable
|
||||
import qualified Data.Graph.Inductive as FGL
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe
|
||||
import qualified Data.Set as S
|
||||
import Dodge.Base
|
||||
@@ -151,48 +150,47 @@ drawZoneCol col s (V2 x y) = setLayer DebugLayer . color col $ thickLine 2 (p :
|
||||
zipWith (+.+) (square 1) $
|
||||
map ((s *.*) . (each %~ fromIntegral)) [V2 x y, V2 (x + 1) y, V2 (x + 1) (y + 1), V2 x (y + 1)]
|
||||
|
||||
debugDraw :: Config -> World -> Picture
|
||||
{-# INLINE debugDraw #-}
|
||||
debugDraw cfig w
|
||||
showEnabledDebugs :: Config -> Picture
|
||||
{-# INLINE showEnabledDebugs #-}
|
||||
showEnabledDebugs cfig
|
||||
| Enable_debug `S.member` _debug_booleans cfig =
|
||||
pic
|
||||
<> setLayer FixedCoordLayer (toTopLeft cfig (translate (0.5 * halfWidth cfig) 0 $ drawList $ map text ts))
|
||||
setLayer FixedCoordLayer (toTopLeft cfig (translate (0.5 * halfWidth cfig) 0 $ drawList $ map text ts))
|
||||
| otherwise = mempty
|
||||
where
|
||||
pic = foldMap (debugDraw' cfig w) (_debug_booleans cfig)
|
||||
-- pic = foldMap (debugDraw' cfig w) (_debug_booleans cfig)
|
||||
ts = map show (S.toList $ _debug_booleans cfig)
|
||||
|
||||
debugDraw' :: Config -> World -> DebugBool -> Picture
|
||||
{-# INLINE debugDraw' #-}
|
||||
debugDraw' cfig w bl = case bl of
|
||||
Enable_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 w
|
||||
Show_bound_box -> drawBoundingBox w
|
||||
Show_wall_search_rays -> drawWallSearchRays w
|
||||
Show_dda_test -> drawDDATest w
|
||||
Show_far_wall_detect -> drawFarWallDetect w
|
||||
Show_walls_near_point_cursor -> mempty
|
||||
Show_walls_near_segment -> mempty
|
||||
Show_walls_near_point_you -> drawWallsNearYou w
|
||||
Show_zone_near_point_cursor -> drawZoneNearPointCursor w
|
||||
Inspect_wall -> drawInspectWalls w
|
||||
Cr_awareness -> drawCreatureDisplayTexts w
|
||||
Show_sound -> fold $ M.map (soundPic cfig w) $ _playingSounds w
|
||||
Cr_status -> drawCrInfo cfig w
|
||||
Mouse_position -> drawMousePosition w
|
||||
Walls_info -> drawWlIDs w
|
||||
Pathing -> drawPathing cfig w
|
||||
Show_nodes_near_select -> undefined --drawNodesNearSelect w
|
||||
Show_path_between -> drawPathBetween w
|
||||
Collision_test -> mempty
|
||||
Circ_collision_test -> mempty
|
||||
Select_creature -> mempty
|
||||
--debugDraw' :: Config -> World -> DebugBool -> Picture
|
||||
--{-# INLINE debugDraw' #-}
|
||||
--debugDraw' cfig w bl = case bl of
|
||||
-- Enable_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_cursor -> mempty
|
||||
-- Show_walls_near_segment -> mempty
|
||||
-- Show_walls_near_point_you -> drawWallsNearYou w
|
||||
-- Show_zone_near_point_cursor -> drawZoneNearPointCursor w
|
||||
-- Show_zone_circ -> drawZoneCirc w
|
||||
-- Inspect_wall -> drawInspectWalls w
|
||||
-- Cr_awareness -> drawCreatureDisplayTexts w
|
||||
-- Show_sound -> fold $ M.map (soundPic cfig w) $ _playingSounds w
|
||||
-- Cr_status -> drawCrInfo cfig w
|
||||
-- Mouse_position -> drawMousePosition w
|
||||
-- Walls_info -> drawWlIDs w
|
||||
-- Pathing -> drawPathing cfig w
|
||||
-- Show_path_between -> drawPathBetween w
|
||||
-- Collision_test -> mempty
|
||||
-- Circ_collision_test -> mempty
|
||||
-- Select_creature -> mempty
|
||||
|
||||
drawCreatureDisplayTexts :: World -> Picture
|
||||
drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (w ^. cWorld . lWorld . creatures)
|
||||
@@ -288,6 +286,19 @@ drawZoneNearPointCursor w =
|
||||
mwp = mouseWorldPos (w ^. input) (w ^. wCam)
|
||||
ps = [zoneOfPoint 50 mwp]
|
||||
|
||||
drawZoneCirc :: World -> Picture
|
||||
drawZoneCirc w = concat $ do
|
||||
a <- w ^. input . clickWorldPos . at ButtonLeft
|
||||
b <- w ^. input . heldWorldPos . at ButtonLeft
|
||||
return $
|
||||
setLayer DebugLayer (uncurryV translate a $ color red $ circle (dist a b))
|
||||
<>
|
||||
setLayer DebugLayer (color green $ line [a, b])
|
||||
-- foldMap (drawZoneCol orange 50) ps
|
||||
-- where
|
||||
-- mwp = mouseWorldPos (w ^. input) (w ^. wCam)
|
||||
-- ps = [zoneOfPoint 50 mwp]
|
||||
|
||||
drawDDATest :: World -> Picture
|
||||
drawDDATest w =
|
||||
foldMap (drawZoneCol orange 50) ps
|
||||
|
||||
@@ -1,140 +0,0 @@
|
||||
module Dodge.Default.World where
|
||||
import Dodge.Data.World
|
||||
import Dodge.Zone.Size
|
||||
import Dodge.Zone.Object
|
||||
import Dodge.Base
|
||||
import Geometry.Vector3D
|
||||
import Geometry.Zone
|
||||
--import Dodge.Config.KeyConfig
|
||||
--import Dodge.Menu
|
||||
--import Picture
|
||||
import Geometry.Data
|
||||
import Geometry.Polygon
|
||||
--import Picture.Texture
|
||||
--import Data.Preload
|
||||
|
||||
import Control.Lens
|
||||
import System.Random
|
||||
import qualified IntMapHelp as IM
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.Set as S
|
||||
import Data.Graph.Inductive.Graph hiding ((&))
|
||||
--import Data.Graph.Inductive.NodeMap
|
||||
--import qualified Data.Vector.Fusion.Stream.Monadic as VS
|
||||
defaultWorld :: World
|
||||
defaultWorld = World
|
||||
{ _keys = S.empty
|
||||
, _magnets = IM.empty
|
||||
, _mouseButtons = mempty
|
||||
, _cameraCenter = V2 0 0
|
||||
, _cameraRot = 0
|
||||
, _cameraZoom = 1
|
||||
, _itemZoom = 1
|
||||
, _defaultZoom = 1
|
||||
, _cameraViewFrom = V2 0 0
|
||||
, _viewDistance = 1000
|
||||
, _modifications = IM.empty
|
||||
, _creatures = IM.empty
|
||||
, _crZoning = Zoning IM.empty crZoneSize zoneOfCreature
|
||||
, _creatureGroups = IM.empty
|
||||
, _clouds = mempty
|
||||
, _clZoning = Zoning IM.empty clZoneSize (zonePos (stripZ . _clPos))
|
||||
, _gusts = IM.empty
|
||||
, _gsZoning = Zoning IM.empty clZoneSize (zonePos _guPos)
|
||||
, _itemPositions = IM.empty
|
||||
, _props = IM.empty
|
||||
, _instantParticles = []
|
||||
, _particles = []
|
||||
, _newBeams = WorldBeams [] [] [] []
|
||||
, _beams = WorldBeams [] [] [] []
|
||||
, _walls = IM.empty
|
||||
, _wallDamages = IM.empty
|
||||
, _blocks = IM.empty
|
||||
, _machines = IM.empty
|
||||
, _terminals = IM.empty
|
||||
, _doors = IM.empty
|
||||
, _coordinates = IM.empty
|
||||
, _triggers = IM.empty
|
||||
, _wlZoning = Zoning IM.empty wlZoneSize zoneOfWall
|
||||
, _floorItems = IM.empty
|
||||
, _floorTiles = []
|
||||
, _randGen = mkStdGen 2
|
||||
, _mousePos = V2 0 0
|
||||
, _testString = const . const []
|
||||
, _debugPicture = mempty
|
||||
, _yourID = 0
|
||||
, _worldEvents = id
|
||||
, _delayedEvents = []
|
||||
, _pressPlates = IM.empty
|
||||
, _buttons = IM.empty
|
||||
, _toPlaySounds = M.empty
|
||||
, _playingSounds = M.empty
|
||||
, _corpses = IM.empty
|
||||
, _decorations = IM.empty
|
||||
--, _savedWorlds = M.empty
|
||||
-- , _menuLayers = []
|
||||
, _clickMousePos = V2 0 0
|
||||
, _pathGraph = PathGraph Data.Graph.Inductive.Graph.empty mempty 0 mempty
|
||||
, _pathGraphP = mempty
|
||||
<<<<<<< HEAD
|
||||
, _pnZoning = Zoning mempty pnZoneSize (zonePos snd)
|
||||
, _peZoning = Zoning mempty pnZoneSize (\x (_,_,PathEdge p q _) -> zoneOfSeg x p q)
|
||||
=======
|
||||
, _pnZoning = Zoning mempty wlZoneSize (zonePos snd)
|
||||
, _peZoning = Zoning mempty wlZoneSize (\x (_,_,e) -> zoneOfSeg x (_peStart e) (_peEnd e))
|
||||
>>>>>>> efficientRuntime
|
||||
, _hud = HUD
|
||||
{ _hudElement = DisplayInventory NoSubInventory
|
||||
, _carteCenter = V2 0 0
|
||||
, _carteZoom = 0.5
|
||||
, _carteRot = 0
|
||||
}
|
||||
, _lightSources = IM.empty
|
||||
, _tempLightSources = [youLight]
|
||||
, _closeObjects = []
|
||||
, _rbOptions = NoRightButtonOptions
|
||||
, _seenLocations = IM.fromList
|
||||
[(0, (_crPos . you, "CURRENT POSITION"))
|
||||
,(1, (const (V2 0 0) , "START POSITION"))
|
||||
]
|
||||
, _selLocation = 0
|
||||
--, _keyConfig = defaultKeyConfigSDL
|
||||
-- , _config = defaultConfig
|
||||
, _sideEffects = return
|
||||
, _shapes = mempty
|
||||
, _distortions = []
|
||||
, _gameRooms = []
|
||||
, _roomClipping = []
|
||||
, _unpauseClock = 0
|
||||
, _worldBounds = defaultBounds
|
||||
, _maybeWorld = Nothing'
|
||||
, _rewindWorlds = []
|
||||
, _timeFlow = NormalTimeFlow
|
||||
, _hammers = defaultWorldHammers
|
||||
, _backspaceTimer = 0
|
||||
, _genParams = GenParams M.empty
|
||||
, _genPlacements = IM.empty
|
||||
, _genRooms = IM.empty
|
||||
, _deathDelay = Nothing
|
||||
, _testFloat = 0
|
||||
, _boundBox = square 100
|
||||
, _boundDist = (100,-100,100,-100)
|
||||
, _lLine = (0,0)
|
||||
, _rLine = (0,0)
|
||||
, _lSelect = 0
|
||||
, _rSelect = 0
|
||||
}
|
||||
defaultWorldHammers :: M.Map WorldHammer HammerPosition
|
||||
defaultWorldHammers = M.fromSet (const HammerUp) $ S.fromList [minBound.. maxBound]
|
||||
youLight :: TempLightSource
|
||||
youLight = TLS
|
||||
{ _tlsParam = LSParam
|
||||
{_lsPos = V3 0 0 0
|
||||
,_lsRad = 150
|
||||
,_lsCol = 0.1
|
||||
}
|
||||
,_tlsUpdate = \w _ -> Just (youLight & tlsParam . lsPos .~ f (_crPos $ you w))
|
||||
,_tlsTime = 0
|
||||
}
|
||||
where
|
||||
f (V2 x y) = V3 x y 100
|
||||
@@ -35,7 +35,7 @@ fixedCoordPictures u =
|
||||
. take 50
|
||||
. drop (u ^. uvDebugMessageOffset)
|
||||
. map text
|
||||
$ foldMap (`_debugMessage` u) (_uvDebug u) -- other debug pics in extraPics
|
||||
$ foldMap _debugMessage (_uvDebug u) -- other debug pics in extraPics
|
||||
)
|
||||
where
|
||||
cfig = _uvConfig u
|
||||
|
||||
@@ -110,8 +110,8 @@ extraPics cfig u =
|
||||
<> foldMap drawLightSource (_lightSources lw)
|
||||
<> foldMap ppDraw (_pressPlates lw)
|
||||
<> viewClipBounds cfig w
|
||||
<> debugDraw cfig w
|
||||
<> foldMap (`_debugPic` u) (_uvDebug u) -- debug messages are in fixed coord pics
|
||||
<> showEnabledDebugs cfig
|
||||
<> foldMap _debugPic (_uvDebug u) -- debug messages are in fixed coord pics
|
||||
where
|
||||
w = u ^. uvWorld
|
||||
lw = w ^. cWorld . lWorld
|
||||
|
||||
Reference in New Issue
Block a user