(broken) commit
This commit is contained in:
+1
-1
@@ -94,7 +94,7 @@ firstWorldLoad theConfig = do
|
|||||||
, _uvLastFrameTicks = 0
|
, _uvLastFrameTicks = 0
|
||||||
, _uvFrameTicks = 0
|
, _uvFrameTicks = 0
|
||||||
, _uvRAMSave = Nothing
|
, _uvRAMSave = Nothing
|
||||||
, _uvDebugInfo = mempty
|
, _uvDebug = mempty
|
||||||
}
|
}
|
||||||
return $ u & uvScreenLayers .~ [splashMenu u]
|
return $ u & uvScreenLayers .~ [splashMenu u]
|
||||||
|
|
||||||
|
|||||||
@@ -7,10 +7,10 @@ module Dodge.Base.Window (
|
|||||||
screenBox,
|
screenBox,
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
import Control.Lens
|
||||||
import Dodge.Data.Camera
|
import Dodge.Data.Camera
|
||||||
import Dodge.Data.Config
|
import Dodge.Data.Config
|
||||||
import Geometry
|
import Geometry
|
||||||
import Control.Lens
|
|
||||||
|
|
||||||
-- | A box covering the screen in world coordinates
|
-- | A box covering the screen in world coordinates
|
||||||
screenPolygon :: Configuration -> Camera -> [Point2]
|
screenPolygon :: Configuration -> Camera -> [Point2]
|
||||||
@@ -45,8 +45,8 @@ screenPolygonBord xbord ybord cfig w = [tr, tl, bl, br]
|
|||||||
bl = theTransform (V2 (- hw) (- hh))
|
bl = theTransform (V2 (- hw) (- hh))
|
||||||
|
|
||||||
halfWidth, halfHeight :: Configuration -> Float
|
halfWidth, halfHeight :: Configuration -> Float
|
||||||
halfWidth = (0.5 *) . windowXFloat
|
halfWidth = (0.5 *) . windowXFloat
|
||||||
halfHeight = (0.5 *) . windowYFloat
|
halfHeight = (0.5 *) . windowYFloat
|
||||||
|
|
||||||
-- | A box of the size of the screen in screen centered coordinates
|
-- | A box of the size of the screen in screen centered coordinates
|
||||||
screenBox :: Configuration -> [Point2]
|
screenBox :: Configuration -> [Point2]
|
||||||
@@ -54,5 +54,3 @@ screenBox w = rectNSWE hh (- hh) (- hw) hw
|
|||||||
where
|
where
|
||||||
hw = halfWidth w
|
hw = halfWidth w
|
||||||
hh = halfHeight w
|
hh = halfHeight w
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
@@ -13,6 +13,7 @@ module Dodge.Data.Universe (
|
|||||||
module Loop.Data,
|
module Loop.Data,
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
import qualified Data.Map.Strict as M
|
||||||
import GHC.Word (Word32)
|
import GHC.Word (Word32)
|
||||||
import Dodge.Data.SelectionList
|
import Dodge.Data.SelectionList
|
||||||
import Control.Lens
|
import Control.Lens
|
||||||
@@ -39,15 +40,23 @@ data Universe = Universe
|
|||||||
, _uvLastFrameTicks :: Word32
|
, _uvLastFrameTicks :: Word32
|
||||||
, _uvFrameTicks :: Word32
|
, _uvFrameTicks :: Word32
|
||||||
, _uvRAMSave :: Maybe World
|
, _uvRAMSave :: Maybe World
|
||||||
, _uvDebugInfo :: [DebugInfo]
|
, _uvDebug :: M.Map DebugBool DebugItem
|
||||||
}
|
}
|
||||||
|
|
||||||
data DebugInfo
|
data DebugItem = DebugItem
|
||||||
= DebugWorldPos
|
{ _debugPic :: Picture
|
||||||
|
, _debugInfo :: [DebugMessage]
|
||||||
|
}
|
||||||
|
|
||||||
|
data DebugMessage
|
||||||
|
= DebugSimpleMessage
|
||||||
|
{ _debugMessage :: [String]
|
||||||
|
}
|
||||||
|
| DebugWorldPosMessage
|
||||||
{ _debugWorldPos :: V3 Float
|
{ _debugWorldPos :: V3 Float
|
||||||
, _debugMessage :: [String]
|
, _debugMessage :: [String]
|
||||||
}
|
}
|
||||||
| DebugScreenPos
|
| DebugScreenPosMessage
|
||||||
{ _debugScreenPos :: V2 Float
|
{ _debugScreenPos :: V2 Float
|
||||||
, _debugMessage :: [String]
|
, _debugMessage :: [String]
|
||||||
}
|
}
|
||||||
|
|||||||
+8
-1
@@ -1,5 +1,6 @@
|
|||||||
module Dodge.Debug where
|
module Dodge.Debug where
|
||||||
|
|
||||||
|
import Dodge.Debug.Picture
|
||||||
import Control.Lens
|
import Control.Lens
|
||||||
import Dodge.Data.Universe
|
import Dodge.Data.Universe
|
||||||
import qualified Data.Set as S
|
import qualified Data.Set as S
|
||||||
@@ -13,5 +14,11 @@ debugEvents u = case dbools ^. at Enable_debug of
|
|||||||
|
|
||||||
debugEvent :: DebugBool -> Universe -> Universe
|
debugEvent :: DebugBool -> Universe -> Universe
|
||||||
debugEvent db u = case db of
|
debugEvent db u = case db of
|
||||||
Collision_test -> u
|
Collision_test -> u & uvDebug . at Collision_test ?~ collisionDebugItem u
|
||||||
_ -> u
|
_ -> u
|
||||||
|
|
||||||
|
collisionDebugItem :: Universe -> DebugItem
|
||||||
|
collisionDebugItem u = DebugItem
|
||||||
|
{ _debugPic = drawCollisionTest $ u ^. uvWorld
|
||||||
|
, _debugInfo = []
|
||||||
|
}
|
||||||
|
|||||||
+349
-3
@@ -1,12 +1,64 @@
|
|||||||
module Dodge.Debug.Picture where
|
module Dodge.Debug.Picture where
|
||||||
|
|
||||||
import Control.Lens
|
import Control.Lens
|
||||||
|
import Control.Monad (guard)
|
||||||
|
import Data.Foldable
|
||||||
|
import qualified Data.Graph.Inductive as FGL
|
||||||
|
import qualified Data.Map.Strict as M
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
|
import qualified Data.Set as Set
|
||||||
|
import Dodge.Base
|
||||||
|
import Dodge.Creature.Picture
|
||||||
|
import Dodge.Creature.Picture.Awareness
|
||||||
|
import Dodge.Data.Universe
|
||||||
|
|
||||||
|
import Dodge.Base.Coordinate
|
||||||
|
import Dodge.Draw
|
||||||
|
import Dodge.Flare
|
||||||
|
import Dodge.GameRoom
|
||||||
|
import Dodge.Graph
|
||||||
|
import Dodge.Path
|
||||||
|
import Dodge.Picture.SizeInvariant
|
||||||
|
import Dodge.RadarBlip
|
||||||
|
import Dodge.Render.InfoBox
|
||||||
|
import Dodge.Render.List
|
||||||
|
import Dodge.Render.Picture
|
||||||
|
import Dodge.ShortShow
|
||||||
|
import Dodge.SoundLogic.LoadSound
|
||||||
|
import Dodge.Viewpoints
|
||||||
|
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 Shape
|
||||||
|
import ShapePicture
|
||||||
|
import ShortShow
|
||||||
|
import Sound.Data
|
||||||
|
import Dodge.Zoning.Wall
|
||||||
|
import Dodge.Path
|
||||||
|
import Dodge.Creature.Picture.Awareness
|
||||||
|
import qualified Data.Graph.Inductive as FGL
|
||||||
|
import Sound.Data
|
||||||
|
import Control.Lens
|
||||||
|
import qualified Data.IntMap.Strict as IM
|
||||||
|
import qualified Data.Map.Strict as M
|
||||||
|
import Data.Maybe
|
||||||
|
import qualified Data.Set as S
|
||||||
import Dodge.Base.Wall
|
import Dodge.Base.Wall
|
||||||
import Dodge.Base.Window
|
import Dodge.Base.Window
|
||||||
import Dodge.Data.Universe
|
import Dodge.Data.Universe
|
||||||
|
import Dodge.Render.Label
|
||||||
|
import Dodge.Render.List
|
||||||
|
import Dodge.WorldEvent.ThingsHit
|
||||||
|
import Dodge.Zoning.Base
|
||||||
|
import Dodge.Zoning.Creature
|
||||||
import Geometry
|
import Geometry
|
||||||
import Picture
|
import Picture
|
||||||
|
import SDL (MouseButton (..))
|
||||||
|
|
||||||
printPoint :: Point2 -> Picture
|
printPoint :: Point2 -> Picture
|
||||||
printPoint p = color white $ uncurryV translate p $ pictures [circle 3, scale 0.05 0.05 $ text (show p)]
|
printPoint p = color white $ uncurryV translate p $ pictures [circle 3, scale 0.05 0.05 $ text (show p)]
|
||||||
@@ -46,9 +98,6 @@ lineOnScreenCone cfig w p1 p2 =
|
|||||||
| otherwise = orderPolygon ((w ^. wCam . camViewFrom) : sp')
|
| otherwise = orderPolygon ((w ^. wCam . camViewFrom) : sp')
|
||||||
sps = zip sp (tail sp ++ [head sp])
|
sps = zip sp (tail sp ++ [head sp])
|
||||||
|
|
||||||
pointOnScreen :: Configuration -> Camera -> Point2 -> Bool
|
|
||||||
pointOnScreen cfig w p = pointInPolygon p $ screenPolygon cfig w
|
|
||||||
|
|
||||||
drawWallFace :: Configuration -> World -> Wall -> Picture
|
drawWallFace :: Configuration -> World -> Wall -> Picture
|
||||||
drawWallFace cfig w wall
|
drawWallFace cfig w wall
|
||||||
| isRHS sightFrom x y || not (wlIsOpaque wall) = blank
|
| isRHS sightFrom x y || not (wlIsOpaque wall) = blank
|
||||||
@@ -78,3 +127,300 @@ intersectLinefromScreen cfig w a b =
|
|||||||
. mapMaybe (\(x, y) -> intersectSegLineFrom x y b (b +.+ b -.- a))
|
. mapMaybe (\(x, y) -> intersectSegLineFrom x y b (b +.+ b -.- a))
|
||||||
. loopPairs
|
. loopPairs
|
||||||
$ screenPolygon cfig (w ^. wCam)
|
$ screenPolygon cfig (w ^. wCam)
|
||||||
|
|
||||||
|
drawCollisionTest :: World -> Picture
|
||||||
|
drawCollisionTest w = fromMaybe mempty $ do
|
||||||
|
a <- w ^. input . clickPos . at ButtonLeft
|
||||||
|
b <- w ^. input . clickPos . at ButtonRight
|
||||||
|
return $
|
||||||
|
setLayer DebugLayer (color orange $ line [a, b])
|
||||||
|
<> foldMap (drawCross . fst) (crHit a b w)
|
||||||
|
<> 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)
|
||||||
|
|
||||||
|
drawZoneCol :: Color -> Float -> V2 Int -> Picture
|
||||||
|
drawZoneCol col s (V2 x y) = setLayer DebugLayer . color col $ thickLine 2 (p : ps ++ [p])
|
||||||
|
where
|
||||||
|
(p : ps) =
|
||||||
|
zipWith (+.+) (square 1) $
|
||||||
|
map ((s *.*) . (each %~ fromIntegral)) [V2 x y, V2 (x + 1) y, V2 (x + 1) (y + 1), V2 x (y + 1)]
|
||||||
|
|
||||||
|
debugDraw :: Configuration -> World -> Picture
|
||||||
|
{-# INLINE debugDraw #-}
|
||||||
|
debugDraw cfig w
|
||||||
|
| Enable_debug `S.member` _debug_booleans cfig =
|
||||||
|
pic
|
||||||
|
<> setLayer FixedCoordLayer (listPicturesAt (0.5 * halfWidth cfig) 0 cfig $ map text ts)
|
||||||
|
| otherwise = mempty
|
||||||
|
where
|
||||||
|
pic = foldMap (debugDraw' cfig w) (_debug_booleans cfig)
|
||||||
|
ts = map show (S.toList $ _debug_booleans cfig)
|
||||||
|
|
||||||
|
debugDraw' :: Configuration -> 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 -> drawWallsNearCursor w
|
||||||
|
Show_walls_near_point_you -> drawWallsNearYou w
|
||||||
|
Show_zone_near_point_cursor -> drawZoneNearPointCursor w
|
||||||
|
Inspect_wall -> drawInspectWalls w
|
||||||
|
Cr_awareness -> drawCreatureDisplayTexts w
|
||||||
|
Show_sound -> pictures $ 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
|
||||||
|
|
||||||
|
drawCreatureDisplayTexts :: World -> Picture
|
||||||
|
drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (w ^. cWorld . lWorld . creatures)
|
||||||
|
|
||||||
|
drawPathBetween :: World -> Picture
|
||||||
|
drawPathBetween w = fromMaybe mempty $ do
|
||||||
|
sp <- w ^. input . clickPos . at ButtonLeft
|
||||||
|
ep <- w ^. input . clickPos . at ButtonRight
|
||||||
|
let nodepos = (`getNodePos` w)
|
||||||
|
nodelist = makePathBetween sp ep w
|
||||||
|
return . setLayer DebugLayer $
|
||||||
|
color rose (foldMap (arrowPath . mapMaybe nodepos) nodelist)
|
||||||
|
<> 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)
|
||||||
|
|
||||||
|
drawWallsNearYou :: World -> Picture
|
||||||
|
drawWallsNearYou w = fromMaybe mempty $ do
|
||||||
|
p <- w ^? cWorld . lWorld . creatures . ix 0 . crPos
|
||||||
|
return $ setLayer DebugLayer $ foldMap f $ wlsNearPoint p w
|
||||||
|
where
|
||||||
|
f wl = color violet $ thickLine 3 [a, b]
|
||||||
|
where
|
||||||
|
(a, b) = _wlLine wl
|
||||||
|
|
||||||
|
drawWallsNearCursor :: World -> Picture
|
||||||
|
drawWallsNearCursor w =
|
||||||
|
setLayer DebugLayer $ foldMap f $ wlsNearPoint (mouseWorldPos (_input w) (_wCam w)) w
|
||||||
|
where
|
||||||
|
f wl = color rose $ thickLine 3 [a, b]
|
||||||
|
where
|
||||||
|
(a, b) = _wlLine wl
|
||||||
|
|
||||||
|
drawInspectWalls :: World -> Picture
|
||||||
|
drawInspectWalls w = fromMaybe mempty $ 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 w wl =
|
||||||
|
setLayer DebugLayer $
|
||||||
|
color rose (thickLine 3 [a, b])
|
||||||
|
<> foldMap (drawDoorPaths w) (wl ^? wlStructure . wsDoor)
|
||||||
|
where
|
||||||
|
(a, b) = _wlLine wl
|
||||||
|
|
||||||
|
drawDoorPaths :: World -> Int -> Picture
|
||||||
|
drawDoorPaths w drid = fromMaybe mempty $ do
|
||||||
|
paths <- w ^? cWorld . lWorld . doors . ix drid . drObstructs
|
||||||
|
return $ foldMap' (drawPathEdge . (^. penPathEdge)) paths
|
||||||
|
|
||||||
|
drawPathEdge :: PathEdge -> Picture
|
||||||
|
drawPathEdge pe =
|
||||||
|
setLayer DebugLayer $
|
||||||
|
multiArrow (_peStart pe) (_peEnd pe) green (S.map obstacleColor (_peObstacles pe))
|
||||||
|
|
||||||
|
obstacleColor :: EdgeObstacle -> Color
|
||||||
|
obstacleColor eo = case eo of
|
||||||
|
WallObstacle -> cyan
|
||||||
|
DoorObstacle -> red
|
||||||
|
AutoDoorObstacle -> yellow
|
||||||
|
BlockObstacle -> blue
|
||||||
|
|
||||||
|
drawFarWallDetect :: World -> Picture
|
||||||
|
drawFarWallDetect w =
|
||||||
|
setLayer DebugLayer
|
||||||
|
. color yellow
|
||||||
|
. foldMap
|
||||||
|
( \q ->
|
||||||
|
line
|
||||||
|
[ p
|
||||||
|
, fst $ collidePoint p q $ filter wlIsOpaque $ 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]
|
||||||
|
|
||||||
|
drawDDATest :: World -> Picture
|
||||||
|
drawDDATest w =
|
||||||
|
foldMap (drawZoneCol orange 50) ps
|
||||||
|
<> setLayer DebugLayer (color yellow (line [cvf, mwp]))
|
||||||
|
where
|
||||||
|
cvf = w ^. wCam . camViewFrom
|
||||||
|
mwp = mouseWorldPos (w ^. input) (w ^. wCam)
|
||||||
|
ps = zoneOfSeg 50 cvf mwp
|
||||||
|
|
||||||
|
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]
|
||||||
|
|
||||||
|
viewBoundaries :: World -> Picture
|
||||||
|
viewBoundaries 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)
|
||||||
|
|
||||||
|
viewClipBounds :: Configuration -> 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 :: Configuration -> 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)
|
||||||
|
|
||||||
|
drawWlIDs :: World -> Picture
|
||||||
|
drawWlIDs w = setLayer FixedCoordLayer $ foldMap f (w ^. cWorld . lWorld . walls)
|
||||||
|
where
|
||||||
|
f wl
|
||||||
|
| dist (_crPos $ you w) (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)
|
||||||
|
|
||||||
|
|
||||||
|
drawCrInfo :: Configuration -> World -> Picture
|
||||||
|
drawCrInfo cfig w =
|
||||||
|
setLayer FixedCoordLayer $
|
||||||
|
renderInfoListsAt (2 * hw - 400) 0 cfig cam $
|
||||||
|
mapMaybe (crDisplayInfo cfig cam) $ IM.elems $ w ^. cWorld . lWorld . creatures
|
||||||
|
where
|
||||||
|
cam = w ^. wCam
|
||||||
|
drawPathing :: Configuration -> World -> Picture
|
||||||
|
drawPathing cfig w =
|
||||||
|
setLayer DebugLayer $
|
||||||
|
foldMap (edgeToPic (screenPolygon cfig (w ^. wCam)) . (^?! _3)) (FGL.labEdges gr)
|
||||||
|
<> foldMap dispInc (graphToIncidence gr)
|
||||||
|
where
|
||||||
|
dispInc (p, n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n
|
||||||
|
gr = w ^. cWorld . pathGraph
|
||||||
|
|
||||||
|
crDisplayInfo :: Configuration -> Camera -> Creature -> Maybe (Point2, [String])
|
||||||
|
crDisplayInfo cfig cam cr
|
||||||
|
| _crID cr == 0 = Nothing
|
||||||
|
| crOnScreen =
|
||||||
|
Just
|
||||||
|
( _crPos cr
|
||||||
|
, catMaybes
|
||||||
|
-- [fmap show $ ap ^? crGoal
|
||||||
|
[ fpreShow "crHP" $ cr ^? crHP
|
||||||
|
, fpreShow "crStrategy" $ ap ^? apStrategy
|
||||||
|
, fmap (("crPos....." ++) . shortShow) $ cr ^? crPos
|
||||||
|
, fpreShow "cpVigilance" $ cr ^? crPerception . cpVigilance
|
||||||
|
, -- , fmap show $ cr ^? crOldPos
|
||||||
|
fpreShow "crAction" $ ap ^? apAction
|
||||||
|
, fpreShow "crImpulse" $ ap ^? apImpulse
|
||||||
|
]
|
||||||
|
)
|
||||||
|
| otherwise = Nothing
|
||||||
|
where
|
||||||
|
ap = _crActionPlan cr
|
||||||
|
crOnScreen = pointOnScreen cfig cam $ _crPos cr
|
||||||
|
|
||||||
|
fpreShow :: (Show a, Functor f) => String -> f a -> f String
|
||||||
|
fpreShow str = fmap (((rightPad 7 '.' str ++ "...") ++) . show)
|
||||||
|
hw = halfWidth cfig
|
||||||
|
|
||||||
|
drawPathing :: Configuration -> World -> Picture
|
||||||
|
drawPathing cfig w =
|
||||||
|
setLayer DebugLayer $
|
||||||
|
foldMap (edgeToPic (screenPolygon cfig (w ^. wCam)) . (^?! _3)) (FGL.labEdges gr)
|
||||||
|
<> foldMap dispInc (graphToIncidence gr)
|
||||||
|
where
|
||||||
|
dispInc (p, n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n
|
||||||
|
gr = w ^. cWorld . pathGraph
|
||||||
|
|
||||||
|
edgeToPic :: [Point2] -> PathEdge -> Picture
|
||||||
|
edgeToPic poly pe
|
||||||
|
| not (pointInPolygon sp poly) && not (pointInPolygon ep poly) = mempty
|
||||||
|
| otherwise = drawPathEdge pe
|
||||||
|
where
|
||||||
|
sp = _peStart pe
|
||||||
|
ep = _peEnd pe
|
||||||
|
|
||||||
|
|||||||
@@ -2,7 +2,6 @@ module Dodge.Render.ShapePicture (
|
|||||||
worldSPic,
|
worldSPic,
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import SDL (MouseButton (..))
|
|
||||||
import Control.Lens
|
import Control.Lens
|
||||||
import Control.Monad (guard)
|
import Control.Monad (guard)
|
||||||
import Data.Foldable
|
import Data.Foldable
|
||||||
@@ -23,13 +22,11 @@ import Dodge.Path
|
|||||||
import Dodge.Picture.SizeInvariant
|
import Dodge.Picture.SizeInvariant
|
||||||
import Dodge.RadarBlip
|
import Dodge.RadarBlip
|
||||||
import Dodge.Render.InfoBox
|
import Dodge.Render.InfoBox
|
||||||
import Dodge.Render.Label
|
|
||||||
import Dodge.Render.List
|
import Dodge.Render.List
|
||||||
import Dodge.Render.Picture
|
import Dodge.Render.Picture
|
||||||
import Dodge.ShortShow
|
import Dodge.ShortShow
|
||||||
import Dodge.SoundLogic.LoadSound
|
import Dodge.SoundLogic.LoadSound
|
||||||
import Dodge.Viewpoints
|
import Dodge.Viewpoints
|
||||||
import Dodge.WorldEvent.ThingsHit
|
|
||||||
import Dodge.Zoning
|
import Dodge.Zoning
|
||||||
import Dodge.Zoning.Base
|
import Dodge.Zoning.Base
|
||||||
import Geometry
|
import Geometry
|
||||||
@@ -37,6 +34,7 @@ import Geometry.ConvexPoly
|
|||||||
import qualified IntMapHelp as IM
|
import qualified IntMapHelp as IM
|
||||||
import Padding
|
import Padding
|
||||||
import Picture
|
import Picture
|
||||||
|
import SDL (MouseButton (..))
|
||||||
import Shape
|
import Shape
|
||||||
import ShapePicture
|
import ShapePicture
|
||||||
import ShortShow
|
import ShortShow
|
||||||
@@ -77,9 +75,9 @@ drawSweep cr w = fromMaybe mempty $ do
|
|||||||
| a - cdir < - pi = cdir - 2 * pi
|
| a - cdir < - pi = cdir - 2 * pi
|
||||||
| otherwise = cdir
|
| otherwise = cdir
|
||||||
return $
|
return $
|
||||||
setLayer FixedCoordLayer $
|
setLayer FixedCoordLayer $
|
||||||
uncurryV translate (worldPosToScreen campos p) $
|
uncurryV translate (worldPosToScreen campos p) $
|
||||||
arcFull (a - rot) 10 white (a' - rot) 1 white (5 + dist mwp p * campos ^. camZoom) white
|
arcFull (a - rot) 10 white (a' - rot) 1 white (5 + dist mwp p * campos ^. camZoom) white
|
||||||
where
|
where
|
||||||
cdir = _crDir cr
|
cdir = _crDir cr
|
||||||
rot = campos ^. camRot
|
rot = campos ^. camRot
|
||||||
@@ -165,183 +163,9 @@ extraPics cfig u =
|
|||||||
w = u ^. uvWorld
|
w = u ^. uvWorld
|
||||||
lw = w ^. cWorld . lWorld
|
lw = w ^. cWorld . lWorld
|
||||||
|
|
||||||
debugDraw :: Configuration -> World -> Picture
|
|
||||||
{-# INLINE debugDraw #-}
|
|
||||||
debugDraw cfig w
|
|
||||||
| Enable_debug `Set.member` _debug_booleans cfig =
|
|
||||||
pic
|
|
||||||
<> setLayer FixedCoordLayer (listPicturesAt (0.5 * halfWidth cfig) 0 cfig $ map text ts)
|
|
||||||
| otherwise = mempty
|
|
||||||
where
|
|
||||||
pic = foldMap (debugDraw' cfig w) (_debug_booleans cfig)
|
|
||||||
ts = map show (Set.toList $ _debug_booleans cfig)
|
|
||||||
|
|
||||||
debugDraw' :: Configuration -> 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 -> drawWallsNearCursor w
|
|
||||||
Show_walls_near_point_you -> drawWallsNearYou w
|
|
||||||
Show_zone_near_point_cursor -> drawZoneNearPointCursor w
|
|
||||||
Inspect_wall -> drawInspectWalls w
|
|
||||||
Cr_awareness -> drawCreatureDisplayTexts w
|
|
||||||
Show_sound -> pictures $ 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 -> drawCollisionTest w
|
|
||||||
|
|
||||||
drawCollisionTest :: World -> Picture
|
|
||||||
drawCollisionTest w = fromMaybe mempty $ do
|
|
||||||
a <- w ^. input . clickPos . at ButtonLeft
|
|
||||||
b <- w ^. input . clickPos . at ButtonRight
|
|
||||||
return $ setLayer DebugLayer (color orange $ line [a, b])
|
|
||||||
<> foldMap (drawCross . fst) (crHit a b w)
|
|
||||||
<> 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)
|
|
||||||
|
|
||||||
drawCreatureDisplayTexts :: World -> Picture
|
|
||||||
drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (w ^. cWorld . lWorld . creatures)
|
|
||||||
|
|
||||||
drawPathBetween :: World -> Picture
|
|
||||||
drawPathBetween w = fromMaybe mempty $ do
|
|
||||||
sp <- w ^. input . clickPos . at ButtonLeft
|
|
||||||
ep <- w ^. input . clickPos . at ButtonRight
|
|
||||||
let nodepos = (`getNodePos` w)
|
|
||||||
nodelist = makePathBetween sp ep w
|
|
||||||
return . setLayer DebugLayer $
|
|
||||||
color rose (foldMap (arrowPath . mapMaybe nodepos) nodelist)
|
|
||||||
<> 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)
|
|
||||||
|
|
||||||
drawWallsNearYou :: World -> Picture
|
|
||||||
drawWallsNearYou w = fromMaybe mempty $ do
|
|
||||||
p <- w ^? cWorld . lWorld . creatures . ix 0 . crPos
|
|
||||||
return $ setLayer DebugLayer $ foldMap f $ wlsNearPoint p w
|
|
||||||
where
|
|
||||||
f wl = color violet $ thickLine 3 [a, b]
|
|
||||||
where
|
|
||||||
(a, b) = _wlLine wl
|
|
||||||
|
|
||||||
drawWallsNearCursor :: World -> Picture
|
|
||||||
drawWallsNearCursor w =
|
|
||||||
setLayer DebugLayer $ foldMap f $ wlsNearPoint (mouseWorldPos (_input w) (_wCam w)) w
|
|
||||||
where
|
|
||||||
f wl = color rose $ thickLine 3 [a, b]
|
|
||||||
where
|
|
||||||
(a, b) = _wlLine wl
|
|
||||||
|
|
||||||
drawInspectWalls :: World -> Picture
|
|
||||||
drawInspectWalls w = fromMaybe mempty $ 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 w wl =
|
|
||||||
setLayer DebugLayer $
|
|
||||||
color rose (thickLine 3 [a, b])
|
|
||||||
<> foldMap (drawDoorPaths w) (wl ^? wlStructure . wsDoor)
|
|
||||||
where
|
|
||||||
(a, b) = _wlLine wl
|
|
||||||
|
|
||||||
drawDoorPaths :: World -> Int -> Picture
|
|
||||||
drawDoorPaths w drid = fromMaybe mempty $ do
|
|
||||||
paths <- w ^? cWorld . lWorld . doors . ix drid . drObstructs
|
|
||||||
return $ foldMap' (drawPathEdge . (^. penPathEdge)) paths
|
|
||||||
|
|
||||||
drawPathEdge :: PathEdge -> Picture
|
|
||||||
drawPathEdge pe =
|
|
||||||
setLayer DebugLayer $
|
|
||||||
multiArrow (_peStart pe) (_peEnd pe) green (Set.map obstacleColor (_peObstacles pe))
|
|
||||||
|
|
||||||
obstacleColor :: EdgeObstacle -> Color
|
|
||||||
obstacleColor eo = case eo of
|
|
||||||
WallObstacle -> cyan
|
|
||||||
DoorObstacle -> red
|
|
||||||
AutoDoorObstacle -> yellow
|
|
||||||
BlockObstacle -> blue
|
|
||||||
|
|
||||||
drawFarWallDetect :: World -> Picture
|
|
||||||
drawFarWallDetect w =
|
|
||||||
setLayer DebugLayer
|
|
||||||
. color yellow
|
|
||||||
. foldMap
|
|
||||||
( \q ->
|
|
||||||
line
|
|
||||||
[ p
|
|
||||||
, fst $ collidePoint p q $ filter wlIsOpaque $ 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]
|
|
||||||
|
|
||||||
drawDDATest :: World -> Picture
|
|
||||||
drawDDATest w =
|
|
||||||
foldMap (drawZoneCol orange 50) ps
|
|
||||||
<> setLayer DebugLayer (color yellow (line [cvf, mwp]))
|
|
||||||
where
|
|
||||||
cvf = w ^. wCam . camViewFrom
|
|
||||||
mwp = mouseWorldPos (w ^. input) (w ^. wCam)
|
|
||||||
ps = zoneOfSeg 50 cvf mwp
|
|
||||||
|
|
||||||
drawZoneCol :: Color -> Float -> V2 Int -> Picture
|
|
||||||
drawZoneCol col s (V2 x y) = setLayer DebugLayer . color col $ thickLine 2 (p : ps ++ [p])
|
|
||||||
where
|
|
||||||
(p : ps) =
|
|
||||||
zipWith (+.+) innerSquare $
|
|
||||||
map ((s *.*) . (each %~ fromIntegral)) [V2 x y, V2 (x + 1) y, V2 (x + 1) (y + 1), V2 x (y + 1)]
|
|
||||||
|
|
||||||
innerSquare :: [Point2]
|
|
||||||
innerSquare = [V2 1 1, V2 (-1) 1, V2 (-1) (-1), V2 1 (-1)]
|
|
||||||
|
|
||||||
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]
|
|
||||||
|
|
||||||
testPic :: Configuration -> World -> Picture
|
testPic :: Configuration -> World -> Picture
|
||||||
testPic _ _ = mempty
|
testPic _ _ = mempty
|
||||||
|
|
||||||
drawBoundingBox :: World -> Picture
|
|
||||||
drawBoundingBox w = setLayer DebugLayer $ color green $ line $ (x : xs) ++ [x]
|
|
||||||
where
|
|
||||||
(x : xs) = w ^. wCam . camBoundBox
|
|
||||||
|
|
||||||
ppDraw :: PressPlate -> Picture
|
ppDraw :: PressPlate -> Picture
|
||||||
ppDraw c = uncurryV translate (_ppPos c) $ rotate (_ppRot c) (_ppPict c)
|
ppDraw c = uncurryV translate (_ppPos c) $ rotate (_ppRot c) (_ppPict c)
|
||||||
|
|
||||||
@@ -360,116 +184,3 @@ mcSPic mc =
|
|||||||
uncurryV translateSPxy (_mcPos mc) $
|
uncurryV translateSPxy (_mcPos mc) $
|
||||||
rotateSP (_mcDir mc) (drawMachine mc)
|
rotateSP (_mcDir mc) (drawMachine mc)
|
||||||
|
|
||||||
soundPic :: Configuration -> 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)
|
|
||||||
|
|
||||||
drawWlIDs :: World -> Picture
|
|
||||||
drawWlIDs w = setLayer FixedCoordLayer $ foldMap f (w ^. cWorld . lWorld . walls)
|
|
||||||
where
|
|
||||||
f wl
|
|
||||||
| dist (_crPos $ you w) (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)
|
|
||||||
|
|
||||||
edgeToPic :: [Point2] -> PathEdge -> Picture
|
|
||||||
edgeToPic poly pe
|
|
||||||
| not (pointInPolygon sp poly) && not (pointInPolygon ep poly) = mempty
|
|
||||||
| otherwise = drawPathEdge pe
|
|
||||||
where
|
|
||||||
sp = _peStart pe
|
|
||||||
ep = _peEnd pe
|
|
||||||
|
|
||||||
drawPathing :: Configuration -> World -> Picture
|
|
||||||
drawPathing cfig w =
|
|
||||||
setLayer DebugLayer $
|
|
||||||
foldMap (edgeToPic (screenPolygon cfig (w ^. wCam)) . (^?! _3)) (FGL.labEdges gr)
|
|
||||||
<> foldMap dispInc (graphToIncidence gr)
|
|
||||||
where
|
|
||||||
dispInc (p, n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n
|
|
||||||
gr = w ^. cWorld . pathGraph
|
|
||||||
|
|
||||||
crDisplayInfo :: Configuration -> Camera -> Creature -> Maybe (Point2, [String])
|
|
||||||
crDisplayInfo cfig cam cr
|
|
||||||
| _crID cr == 0 = Nothing
|
|
||||||
| crOnScreen =
|
|
||||||
Just
|
|
||||||
( _crPos cr
|
|
||||||
, catMaybes
|
|
||||||
-- [fmap show $ ap ^? crGoal
|
|
||||||
[ fpreShow "crHP" $ cr ^? crHP
|
|
||||||
, fpreShow "crStrategy" $ ap ^? apStrategy
|
|
||||||
, fmap (("crPos....." ++) . shortShow) $ cr ^? crPos
|
|
||||||
, fpreShow "cpVigilance" $ cr ^? crPerception . cpVigilance
|
|
||||||
, -- , fmap show $ cr ^? crOldPos
|
|
||||||
fpreShow "crAction" $ ap ^? apAction
|
|
||||||
, fpreShow "crImpulse" $ ap ^? apImpulse
|
|
||||||
]
|
|
||||||
)
|
|
||||||
| otherwise = Nothing
|
|
||||||
where
|
|
||||||
ap = _crActionPlan cr
|
|
||||||
crOnScreen = pointOnScreen cfig cam $ _crPos cr
|
|
||||||
|
|
||||||
fpreShow :: (Show a, Functor f) => String -> f a -> f String
|
|
||||||
fpreShow str = fmap (((rightPad 7 '.' str ++ "...") ++) . show)
|
|
||||||
|
|
||||||
drawCrInfo :: Configuration -> World -> Picture
|
|
||||||
drawCrInfo cfig w =
|
|
||||||
setLayer FixedCoordLayer $
|
|
||||||
renderInfoListsAt (2 * hw - 400) 0 cfig cam $
|
|
||||||
mapMaybe (crDisplayInfo cfig cam) $ IM.elems $ w ^. cWorld . lWorld . creatures
|
|
||||||
where
|
|
||||||
cam = w ^. wCam
|
|
||||||
hw = halfWidth cfig
|
|
||||||
|
|
||||||
viewBoundaries :: World -> Picture
|
|
||||||
viewBoundaries 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)
|
|
||||||
|
|
||||||
viewClipBounds :: Configuration -> 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
|
|
||||||
|
|||||||
Reference in New Issue
Block a user