430 lines
15 KiB
Haskell
430 lines
15 KiB
Haskell
{-# OPTIONS -Wno-incomplete-uni-patterns #-}
|
|
module Dodge.Debug.Picture where
|
|
|
|
import Linear (_xy, (*^))
|
|
import Control.Lens
|
|
import Data.Foldable
|
|
--import qualified Data.Graph.Inductive as FGL
|
|
import Data.Maybe
|
|
import qualified Data.Set as S
|
|
import Dodge.Base
|
|
import Dodge.Creature.Picture.Awareness
|
|
import Dodge.Data.Universe
|
|
import Dodge.GameRoom
|
|
--import Dodge.Graph
|
|
import Dodge.Path
|
|
import Dodge.Picture.SizeInvariant
|
|
--import Dodge.Render.InfoBox
|
|
import Dodge.Render.Label
|
|
--import Dodge.Render.List
|
|
import Dodge.ShortShow
|
|
import Dodge.SoundLogic.LoadSound
|
|
import Dodge.Viewpoints
|
|
import Dodge.WorldEvent.ThingsHit
|
|
import Dodge.Zoning
|
|
import Dodge.Zoning.Base
|
|
import Geometry
|
|
import Geometry.ConvexPoly
|
|
import qualified IntMapHelp as IM
|
|
--import Padding
|
|
import Picture
|
|
import SDL (MouseButton (..))
|
|
--import ShortShow
|
|
import Sound.Data
|
|
|
|
printPoint :: Point2 -> Picture
|
|
printPoint p = color white $ uncurryV translate p $ fold [circle 3, scale 0.05 0.05 $ text (show p)]
|
|
|
|
printRotPoint :: Float -> Point2 -> Picture
|
|
printRotPoint r p =
|
|
color white
|
|
. uncurryV translate p
|
|
$ fold [circle 3, rotate (negate r) $ scale 0.1 0.1 $ text (show p)]
|
|
|
|
outsideScreenPolygon :: Config -> Camera -> [Point2]
|
|
outsideScreenPolygon cfig w = [tr, tl, bl, br]
|
|
where
|
|
scRot = rotateV (w ^. camRot)
|
|
scZoom p
|
|
| (w ^. camZoom) /= 0 = (1 / (w ^. camZoom)) *^ p
|
|
| otherwise = error "Trying to set screen zoom to zero"
|
|
scTran p = p + (w ^. camCenter)
|
|
tr = f 3 3
|
|
tl = f (-3) 3
|
|
br = f 3 (-3)
|
|
bl = f (-3) (-3)
|
|
f a b = scTran $ scRot $ scZoom $ V2 (a * halfWidth cfig) (b * halfHeight cfig)
|
|
|
|
-- cannot only test if walls are on screen, but also if they are on the cone
|
|
-- towards the center of sight
|
|
lineOnScreenCone :: Config -> World -> Point2 -> Point2 -> Bool
|
|
lineOnScreenCone cfig w p1 p2 =
|
|
pointInPoly p1 sp
|
|
|| pointInPoly p2 sp
|
|
|| any (isJust . uncurry (intersectSegSeg p1 p2)) sps
|
|
where
|
|
sp' = screenPolygon cfig (w ^. wCam)
|
|
vp = w ^. wCam . camViewFrom
|
|
sp
|
|
| pointInPoly vp sp' = sp'
|
|
| otherwise = orderPolygon ((w ^. wCam . camViewFrom) : sp')
|
|
sps = zip sp (tail sp ++ [head sp])
|
|
|
|
drawWallFace :: Config -> World -> Wall -> Picture
|
|
drawWallFace cfig w wall
|
|
| isRHS sightFrom x y || not (wlIsOpaque wall) = mempty
|
|
| otherwise = setDepth (-1) . color (withAlpha 0 black) . polygon $ points
|
|
where
|
|
(x, y) = _wlLine wall
|
|
points = extendConeToScreenEdge cfig w sightFrom (x, y)
|
|
sightFrom = w ^. wCam . camViewFrom
|
|
|
|
extendConeToScreenEdge :: Config -> World -> Point2 -> (Point2, Point2) -> [Point2]
|
|
extendConeToScreenEdge cfig w c (x, y) = orderPolygon $ wallScreenIntersect ++ [x, y] ++ borderPs ++ cornerPs
|
|
where
|
|
borderPs = mapMaybe (intersectLinefromScreen cfig w c) [x, y]
|
|
scpoly = reverse $ screenPolygon cfig (w ^. wCam)
|
|
cornerPs = filter (pointIsInCone c (x, y)) scpoly
|
|
wallScreenIntersect =
|
|
mapMaybe (uncurry $ intersectSegSeg y ((2 *.* y) -.- x))
|
|
. loopPairs
|
|
$ scpoly
|
|
|
|
-- the following assumes that the point a is inside the screen
|
|
-- it still works otherwise, but it might intersect two points:
|
|
-- it is not obvious which will be returned
|
|
intersectLinefromScreen :: Config -> World -> Point2 -> Point2 -> Maybe Point2
|
|
intersectLinefromScreen cfig w a b =
|
|
listToMaybe
|
|
. mapMaybe (\(x, y) -> intersectSegRay x y b (b +.+ b -.- a))
|
|
. loopPairs
|
|
$ screenPolygon cfig (w ^. wCam)
|
|
|
|
drawCollisionTest :: World -> Picture
|
|
drawCollisionTest w = concat $ do
|
|
a <- w ^. input . heldWorldPos . at ButtonLeft
|
|
b <- w ^. input . heldWorldPos . at ButtonRight
|
|
return $
|
|
setLayer DebugLayer (color orange $ line [a, b])
|
|
<> foldMap
|
|
( drawCrossCol red
|
|
-- . xyV3
|
|
. fst
|
|
)
|
|
-- (collide3 (v2z a 0) (v2z b 0) w)
|
|
-- (collide3Floors (v2z a 10) (v2z b (-10)) $ w ^. cWorld . chasms)
|
|
(thingHit a b w)
|
|
|
|
drawCircCollisionTest :: World -> Picture
|
|
drawCircCollisionTest w = concat $ do
|
|
a <- w ^. input . heldWorldPos . at ButtonLeft
|
|
b <- w ^. input . heldWorldPos . at ButtonRight
|
|
let col
|
|
| anythingHitCirc 2 a b w = red
|
|
| otherwise = green
|
|
return $
|
|
setLayer DebugLayer (color col $ line [a, b])
|
|
<> drawCoord a w
|
|
<> drawCoord b w
|
|
|
|
drawWallsNearSegment :: World -> Picture
|
|
drawWallsNearSegment w = concat $ do
|
|
a <- w ^. input . heldWorldPos . at ButtonLeft
|
|
b <- w ^. input . heldWorldPos . at ButtonRight
|
|
return . foldMap f $ wlsNearSeg a b w
|
|
where
|
|
f wl =
|
|
setLayer DebugLayer (color rose $ thickLine 3 [a, b])
|
|
<> drawCoord a w
|
|
<> drawCoord b w
|
|
where
|
|
(a, b) = _wlLine wl
|
|
|
|
-- <> foldMap (drawCross . _crPos) (crsNearSeg a b w)
|
|
-- <> foldMap (drawZoneCol green crZoneSize . zoneOfPoint crZoneSize) (xIntercepts crZoneSize a b)
|
|
-- <> foldMap (drawZoneCol yellow crZoneSize . zoneOfPoint crZoneSize) (yIntercepts' crZoneSize a b)
|
|
-- <> foldMap (drawLabCrossCol blue) (xIntercepts crZoneSize a b)
|
|
|
|
-- # OPTIONS -Wno-incomplete-uni-patterns #-}
|
|
drawZoneCol :: Color -> Float -> V2 Int -> Picture
|
|
drawZoneCol col = drawZone (\ps -> color col $ thickLine 2 (ps ++ [head ps]))
|
|
|
|
drawZone :: ([Point2] -> Picture) -> Float -> V2 Int -> Picture
|
|
drawZone f s (V2 x y) = setLayer DebugLayer $ f ps
|
|
where
|
|
ps = rectNSWE s 0 0 s <&> (+ s *^ (V2 x y & each %~ fromIntegral))
|
|
|
|
--showEnabledDebugs :: Config -> Picture
|
|
--{-# INLINE showEnabledDebugs #-}
|
|
--showEnabledDebugs cfig
|
|
-- | Enable_debug `S.member` _debug_booleans cfig =
|
|
-- 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)
|
|
-- 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 -> 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)
|
|
|
|
drawPathBetween :: Universe -> Picture
|
|
drawPathBetween u = concat $ do
|
|
sp <- case u ^. uvDebugPathShowType of
|
|
PathBetweenLeftRightClick -> w ^. input . heldWorldPos . at ButtonLeft
|
|
PathBetweenDebugV2s -> u ^? uvDebugV2_1
|
|
ep <- case u ^. uvDebugPathShowType of
|
|
PathBetweenLeftRightClick -> w ^. input . heldWorldPos . at ButtonRight
|
|
PathBetweenDebugV2s -> u ^? uvDebugV2_2
|
|
let nodepos = (`getNodePos` w)
|
|
nodelist = makePathBetween sp ep w
|
|
return . setLayer DebugLayer $
|
|
--color rose (foldMap (arrowPath . mapMaybe nodepos) nodelist)
|
|
color rose (foldMap (arrowPath . map nodepos) nodelist)
|
|
<> drawCrossCol green sp
|
|
<> drawCrossCol cyan ep
|
|
<> foldMap ((color green . arrow sp) . nodepos) (walkableNodeNear w sp)
|
|
<> foldMap ((color cyan . flip arrow ep) . nodepos) (walkableNodeNear w ep)
|
|
<> foldMap (color orange . arrow sp) (pointTowardsImpulse sp ep w)
|
|
where
|
|
w = u ^. uvWorld
|
|
|
|
drawWallsNearYou :: World -> Picture
|
|
drawWallsNearYou w = concat $ do
|
|
p <- w ^? cWorld . lWorld . creatures . ix 0 . crPos . _xy
|
|
return $ setLayer DebugLayer $ foldMap f $ wlsNearCirc p 30 w
|
|
where
|
|
f wl = color violet $ thickLine 3 [a, b]
|
|
<> uncurryV translate (0.5 *^ (a + b)) (scale 0.05 0.05 . text $ show (_wlID wl))
|
|
where
|
|
(a, b) = _wlLine wl
|
|
|
|
drawWallsNearCursor :: World -> Picture
|
|
drawWallsNearCursor w =
|
|
foldMap f $ wlsNearPoint (mouseWorldPos (_input w) (_wCam w)) w
|
|
where
|
|
f wl =
|
|
setLayer DebugLayer (color rose $ thickLine 3 [a, b])
|
|
<> drawCoord a w
|
|
<> drawCoord b w
|
|
where
|
|
(a, b) = _wlLine wl
|
|
|
|
drawInspectWalls :: World -> Picture
|
|
drawInspectWalls w = concat $ do
|
|
a <- w ^. input . clickPos . at ButtonLeft
|
|
b <- w ^. input . heldPos . at ButtonLeft
|
|
return $
|
|
setLayer DebugLayer (color orange $ line [a, b])
|
|
<> foldMap
|
|
(drawInspectWall w)
|
|
( filter (isJust . uncurry (intersectSegSeg a b) . _wlLine) $
|
|
IM.elems $ w ^. cWorld . lWorld . walls
|
|
)
|
|
|
|
drawInspectWall :: World -> Wall -> Picture
|
|
drawInspectWall _ wl = setLayer DebugLayer $ color rose (thickLine 3 [a, b])
|
|
where
|
|
(a, b) = _wlLine wl
|
|
|
|
drawPathEdge :: Point2 -> Point2 -> S.Set EdgeObstacle -> Picture
|
|
drawPathEdge x y pe = setLayer DebugLayer $ multiArrow x y green (S.map obstacleColor pe)
|
|
|
|
obstacleColor :: EdgeObstacle -> Color
|
|
obstacleColor eo = case eo of
|
|
WallObstacle WallNotAutoOpen -> red
|
|
WallObstacle WallBlockVisibility -> orange
|
|
WallObstacle WallNotDestrucable -> yellow
|
|
ChasmObstacle -> cyan
|
|
|
|
drawFarWallDetect :: World -> Picture
|
|
drawFarWallDetect w =
|
|
setLayer DebugLayer
|
|
. color yellow
|
|
. foldMap
|
|
( \q ->
|
|
line
|
|
[ p
|
|
, fst $ collidePoint p q $ filter wlIsOpaque $ IM.elems $ wlsNearSeg p q w
|
|
]
|
|
)
|
|
$ getViewpoints p (_cWorld w)
|
|
where
|
|
p = w ^. wCam . camViewFrom
|
|
|
|
drawZoneNearPointCursor :: World -> Picture
|
|
drawZoneNearPointCursor w =
|
|
foldMap (drawZoneCol orange 50) ps
|
|
where
|
|
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
|
|
let r = dist a b
|
|
ps = zoneOfCirc 50 a r
|
|
return $
|
|
setLayer DebugLayer (uncurryV translate a $ color red $ circle r)
|
|
<> setLayer DebugLayer (color green $ line [a, b])
|
|
<> foldMap (drawZoneCol orange 50) ps
|
|
|
|
drawDDATest :: World -> Picture
|
|
drawDDATest w =
|
|
foldMap (drawZoneCol orange 50) ps
|
|
<> foldMap (drawZone f 50) qs
|
|
<> foldMap (drawZone g 50) rs
|
|
<> foldMap (drawCrossCol yellow) xs
|
|
<> setLayer DebugLayer (color yellow (line [x, y]))
|
|
where
|
|
x = w ^. wCam . camViewFrom
|
|
y = mouseWorldPos (w ^. input) (w ^. wCam)
|
|
f [a,_,c,_] = color red $ thickLine 2 [a,c]
|
|
f _ = undefined
|
|
g [_,b,_,d] = color blue $ thickLine 2 [b,d]
|
|
g _ = undefined
|
|
ps = zoneOfSeg 50 x y
|
|
qs = map (zoneOfPoint 50) $ xIntercepts 50 x y
|
|
rs = map (zoneOfPoint 50) $ yIntercepts 50 x y
|
|
xs = xIntercepts 50 x y
|
|
|
|
drawWallSearchRays :: World -> Picture
|
|
drawWallSearchRays w = foldMap (f . fst) $ allVisibleWalls w
|
|
where
|
|
f p =
|
|
setLayer DebugLayer $
|
|
color yellow $
|
|
uncurryV translate p (circle 5)
|
|
<> line [w ^. wCam . camViewFrom, p]
|
|
|
|
viewGameRoomBoundaries :: World -> Picture
|
|
viewGameRoomBoundaries w =
|
|
setLayer DebugLayer $
|
|
color green (foldMap (polygonWire . _grBound) grs)
|
|
<> color yellow (foldMap (\q -> line [p, q]) $ getViewpoints p (_cWorld w))
|
|
where
|
|
p = w ^. wCam . camViewFrom
|
|
grs = filter (pointInOrOnPolygon p . _grBound) (_cwgGameRooms $ _cwGen $ _cWorld w)
|
|
|
|
viewRoomBoundaries :: World -> Picture
|
|
viewRoomBoundaries w =
|
|
setLayer DebugLayer $
|
|
color green (foldMap (foldMap polygonWire . _grRmBounds) grs)
|
|
-- <> color yellow (foldMap (\q -> line [p, q]) $ getViewpoints p (_cWorld w))
|
|
where
|
|
p = w ^. wCam . camViewFrom
|
|
grs = filter (pointInOrOnPolygon p . _grBound) (_cwgGameRooms $ _cwGen $ _cWorld w)
|
|
|
|
viewClipBounds :: Config -> World -> Picture
|
|
viewClipBounds cfig w
|
|
| _debug_view_clip_bounds cfig == AllRoomClipBoundaries =
|
|
setLayer DebugLayer $ color green $ foldMap (polygonWire . _cpPoints) (_cwgRoomClipping $ _cwGen (_cWorld w))
|
|
| _debug_view_clip_bounds cfig == IntersectingRoomClipBoundaries =
|
|
setLayer DebugLayer $ f (_cwgRoomClipping $ _cwGen (_cWorld w))
|
|
| otherwise = mempty
|
|
where
|
|
f (x : xs) = g x xs <> f xs
|
|
f [] = mempty
|
|
g x (y : ys)
|
|
| convexPolysOverlap x y =
|
|
color green (polygonWire $ _cpPoints x)
|
|
<> color yellow (polygonWire $ _cpPoints y)
|
|
<> g x ys
|
|
| otherwise = g x ys
|
|
g _ [] = mempty
|
|
|
|
drawBoundingBox :: World -> Picture
|
|
drawBoundingBox w = setLayer DebugLayer $ color green $ line $ (x : xs) ++ [x]
|
|
where
|
|
(x : xs) = w ^. wCam . camBoundBox
|
|
|
|
soundPic :: Config -> World -> Sound -> Picture
|
|
soundPic cfig w s = fixedSizePicClampArrow 50 50 thePic p cfig w
|
|
where
|
|
p = _soundPos s
|
|
thePic =
|
|
rotate (w ^. wCam . camRot)
|
|
. scale theScale theScale
|
|
. centerText
|
|
. soundToOnomato
|
|
$ _soundChunkID s
|
|
theScale = 0.15 * f (_soundVolume s * 0.0001)
|
|
f x = 1 - 0.5 * (1 - x)
|
|
|
|
drawMousePosition :: World -> Picture
|
|
drawMousePosition w =
|
|
setLayer FixedCoordLayer
|
|
. uncurryV translate (w ^. input . mousePos)
|
|
. scale 0.1 0.1
|
|
. text
|
|
$ shortPoint2 mwp
|
|
where
|
|
mwp = mouseWorldPos (w ^. input) (w ^. wCam)
|
|
|
|
drawCoord :: Point2 -> World -> Picture
|
|
drawCoord p w =
|
|
setLayer FixedCoordLayer
|
|
. uncurryV translate (worldPosToScreen (w ^. wCam) p)
|
|
. scale 0.1 0.1
|
|
. text
|
|
$ shortPoint2 p
|
|
|
|
drawWlIDs :: World -> Picture
|
|
drawWlIDs w = setLayer FixedCoordLayer $ foldMap f (w ^. cWorld . lWorld . walls)
|
|
where
|
|
f wl
|
|
| dist (you w ^. crPos . _xy) (fst (_wlLine wl)) > 200 = mempty -- this should be improved with a better "on screen test"
|
|
| otherwise =
|
|
uncurryV translate p
|
|
. scale 0.1 0.1
|
|
. text
|
|
$ show $ _wlID wl
|
|
where
|
|
p = worldPosToScreen (w ^. wCam) $ 0.5 *.* uncurry (+.+) (_wlLine wl)
|
|
|
|
drawPathing :: Config -> World -> Picture
|
|
drawPathing cfig w = setLayer DebugLayer $ ifoldMap f $ w ^. cWorld . incGraph
|
|
where
|
|
inode i = w ^?! cWorld . incNode . ix i
|
|
f :: Int -> IM.IntMap SimpleEdge -> Picture
|
|
f i = ifoldMap (g i)
|
|
g i j se = edgeToPic (screenPolygon cfig (w ^.wCam))
|
|
(inode i) (inode j) (se ^. seObstacles)
|
|
|
|
edgeToPic :: [Point2] -> Point2 -> Point2 -> S.Set EdgeObstacle -> Picture
|
|
edgeToPic poly sp ep pe
|
|
| not (pointInPoly sp poly) && not (pointInPoly ep poly) = mempty
|
|
| otherwise = drawPathEdge sp ep pe
|