From c740ca084450aaca48d7e7c96a513ec66f362c0b Mon Sep 17 00:00:00 2001
From: jgk <justin.g.kruger@gmail.com>
Date: Thu, 22 Apr 2021 17:31:57 +0200
Subject: [PATCH] Improve room clip testing

---
 src/Dodge/Floor.hs             | 12 ++++++++++--
 src/Dodge/Layout/Tree/Shift.hs |  2 +-
 src/Geometry.hs                |  9 +++++++--
 3 files changed, 18 insertions(+), 5 deletions(-)

diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs
index 624e45082..cccf7a507 100644
--- a/src/Dodge/Floor.hs
+++ b/src/Dodge/Floor.hs
@@ -33,8 +33,16 @@ roomTreex = do
     struct' <- aTreeStrut
     let struct = Node [EndRoom] []
     let t' = padCorridors struct
-        t = treeTrunk [[StartRoom],[OrAno [--[DoorAno],[Corridor],
-                                           [DoorNumAno 0,AirlockAno]] ],[FirstWeapon],[Corridor]] t'
+        t = treeTrunk 
+                [[StartRoom]
+                ,[OrAno [[DoorAno]
+                        ,[Corridor]
+                        ,[DoorNumAno 0,AirlockAno]] 
+                        ]
+                ,[FirstWeapon]
+                ,[Corridor]
+                ] 
+                t'
     fmap (shiftExpandTree . expandTreeBy id) $ mapM annoToRoomTree t
 
 levx :: RandomGen g => State g [Room]
diff --git a/src/Dodge/Layout/Tree/Shift.hs b/src/Dodge/Layout/Tree/Shift.hs
index 8e3e5cc42..1c8247d1c 100644
--- a/src/Dodge/Layout/Tree/Shift.hs
+++ b/src/Dodge/Layout/Tree/Shift.hs
@@ -47,7 +47,7 @@ shiftRoomTreeSearchAll bs (Node r ts :<| ts')
   where
     ls = init $ _rmLinks r
     newBounds = _rmBound r : bs
-    roomIsClipping = any (polysIntersect (_rmBound r)) bs
+    roomIsClipping = any (polysOverlap (_rmBound r)) bs
     rm l = r & rmLinks %~ delete l
     f l = applyToRoot (shiftRoomToLink l)
 
diff --git a/src/Geometry.hs b/src/Geometry.hs
index d4e53124d..95d21787b 100644
--- a/src/Geometry.hs
+++ b/src/Geometry.hs
@@ -226,9 +226,14 @@ polysIntersect (p:ps) (q:qs)
   where 
     pairs1 = zip (p:ps) (ps++[p])
     pairs2 = zip (q:qs) (qs++[q])
+polysIntersect _ _ = False
 
-polysIntersect [] _ = False
-polysIntersect _ [] = False
+-- | Test whether two polygons intersect or if one is contained in the other.
+polysOverlap :: [Point2] -> [Point2] -> Bool
+polysOverlap (p:ps) (q:qs) = polysIntersect (p:ps) (q:qs) 
+    || pointInPolygon p (q:qs)
+    || pointInPolygon q (p:ps)
+polysOverlap _ _ = False
 
 -- | Test whether any polygons from a first list intersect with any polygons from
 -- a second list.