From 13e8ea85d2ab17545985c7494008a1748ad7f22f Mon Sep 17 00:00:00 2001
From: justin <justin.g.kruger@gmail.com>
Date: Mon, 21 Mar 2022 07:57:21 +0000
Subject: [PATCH] Add extra debug options for viewing room clipping

---
 src/Dodge/Config/Data.hs         |  9 +++++++--
 src/Dodge/Initialisation.hs      | 10 +++++-----
 src/Dodge/Menu.hs                |  2 +-
 src/Dodge/Render/ShapePicture.hs |  5 +++--
 src/Dodge/Room/Procedural.hs     |  4 ----
 5 files changed, 16 insertions(+), 14 deletions(-)

diff --git a/src/Dodge/Config/Data.hs b/src/Dodge/Config/Data.hs
index 8b9745af0..6692f0fbe 100644
--- a/src/Dodge/Config/Data.hs
+++ b/src/Dodge/Config/Data.hs
@@ -22,7 +22,7 @@ data Configuration = Configuration
     , _debug_noclip         :: Bool
     , _debug_cr_status      :: Bool
     , _debug_view_boundaries :: Bool
-    , _debug_view_clip_bounds :: Bool
+    , _debug_view_clip_bounds :: RoomClipping
     , _debug_pathing        :: Bool
     }
   deriving (Generic, Show)
@@ -31,6 +31,11 @@ data ResFactor = FullRes | HalfRes | QuarterRes
 instance ToJSON ResFactor where
   toEncoding = genericToEncoding defaultOptions
 instance FromJSON ResFactor
+data RoomClipping = NoRoomClipBoundaries | AllRoomClipBoundaries | IntersectingRoomClipBoundaries
+  deriving (Generic, Show, Eq, Ord, Enum, Bounded)
+instance ToJSON RoomClipping where
+  toEncoding = genericToEncoding defaultOptions
+instance FromJSON RoomClipping
 resFactorNum :: ResFactor -> Int
 resFactorNum rf = case rf of
     FullRes     -> 1
@@ -62,6 +67,6 @@ defaultConfig = Configuration
     , _debug_noclip         = False
     , _debug_cr_status      = False
     , _debug_view_boundaries = False
-    , _debug_view_clip_bounds = False
+    , _debug_view_clip_bounds = NoRoomClipBoundaries
     , _debug_pathing    = False
     }
diff --git a/src/Dodge/Initialisation.hs b/src/Dodge/Initialisation.hs
index 79652ce74..6e23e6a3c 100644
--- a/src/Dodge/Initialisation.hs
+++ b/src/Dodge/Initialisation.hs
@@ -10,7 +10,6 @@ import Dodge.Creature
 import Dodge.WorldEvent.Cloud
 import Dodge.SoundLogic
 import Geometry.Data
-import Geometry.ConvexPoly
 
 import System.Random
 import qualified Data.Set as S
@@ -43,7 +42,8 @@ initialWorld = defaultWorld
 
 testStringInit :: World -> [String]
 --testStringInit = map (concatMap $ \(_,ct,_,_) -> show ct) . invertListInvMult . yourInv
-testStringInit w = [show $ f $ _roomClipping w]
-  where
-    f (x:xs) = any (convexPolysOverlap x) xs || f xs
-    f [] = False
+testStringInit = const []
+--    w = [show $ f $ _roomClipping w]
+--  where
+--    f (x:xs) = any (convexPolysOverlap x) xs || f xs
+--    f [] = False
diff --git a/src/Dodge/Menu.hs b/src/Dodge/Menu.hs
index 4fc0c586d..44e4cfb32 100644
--- a/src/Dodge/Menu.hs
+++ b/src/Dodge/Menu.hs
@@ -79,7 +79,7 @@ debugMenuOptions =
     , doption ScancodeC debug_noclip "NOCLIP" _debug_noclip
     , doption ScancodeS debug_cr_status "SHOW CREATURE STATUS" _debug_cr_status
     , doption ScancodeV debug_view_boundaries "SHOW VIEW BOUNDARIES" _debug_view_boundaries
-    , doption ScancodeB debug_view_clip_bounds "SHOW ROOM CLIP BOUNDARIES" _debug_view_clip_bounds
+    , makeEnumOption ScancodeB debug_view_clip_bounds "SHOW ROOM CLIP" return
     , doption ScancodeP debug_pathing "SHOW PATHING" _debug_pathing
     ]
   where
diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs
index 7c7b70cd1..241bd8323 100644
--- a/src/Dodge/Render/ShapePicture.hs
+++ b/src/Dodge/Render/ShapePicture.hs
@@ -113,8 +113,9 @@ viewBoundaries cfig w
 
 viewClipBounds :: Configuration -> World -> Picture
 viewClipBounds cfig w
-    | _debug_view_clip_bounds cfig 
---         = setLayer 5 $ color green $ concatMap (polygonWire . _cpPoints) (_roomClipping w)
+    | _debug_view_clip_bounds cfig == AllRoomClipBoundaries
+         = setLayer 5 $ color green $ concatMap (polygonWire . _cpPoints) (_roomClipping w)
+    | _debug_view_clip_bounds cfig == IntersectingRoomClipBoundaries
         = setLayer 5 $ f (_roomClipping w)
     | otherwise = []
   where
diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs
index aee27bd37..f00ae5be8 100644
--- a/src/Dodge/Room/Procedural.hs
+++ b/src/Dodge/Room/Procedural.hs
@@ -170,8 +170,6 @@ quarterRoomTri w = do
             ]
         , _rmBound  = [[V2 0 0,V2 w w,V2 (-w) w]]
         }
---  where
---    w' = w -10
 
 quarterRoomSquare :: RandomGen g => Float -> State g Room
 quarterRoomSquare w = do
@@ -211,8 +209,6 @@ quarterRoomSquare w = do
         --, _rmBound = [map toV2 [(w,w),(0,2*w),(-w,w)]]
         , _rmBound = [ map toV2 [(0,0),(w,w),(0,2*w),(-w,w)] ]
         }
---  where
---    w' = w - 10
 {- | Randomise the ordering of placements in a room.
 Useful for randomising the position of generic placements such as 'PutNothing'. -}
 shufflePlacements :: RandomGen g => Room -> State g Room