Hack fix to wall carving, expand polygon and retry if first cut fails

src/Dodge/Floor.hs

@@ -36,41 +36,41 @@ lev1 = do
             ++ [return $ connectRoom corridor
                ,return $ connectRoom door
                ,glassSwitchBack >>= randomiseLinks]
---            ++ [return $ connectRoom corridor
+            ++ [return $ connectRoom corridor
---               ,return $ connectRoom door]
+               ,return $ connectRoom door]
---            ++ [miniRoom3]
+            ++ [miniRoom3]
---            ++ [return $ connectRoom corridor
+            ++ [return $ connectRoom corridor
---               ,return $ connectRoom door]
+               ,return $ connectRoom door]
---            ++ [roomCCrits]
+            ++ [roomCCrits]
---            ++ [return $ connectRoom corridor
+            ++ [return $ connectRoom corridor
---               ,return $ connectRoom door]
+               ,return $ connectRoom door]
---            ++[roomMiniIntro]
+            ++[roomMiniIntro]
---            ++ [longRoom >>= randomiseLinks]
+            ++ [longRoom >>= randomiseLinks]
---            ++ [return $ connectRoom corridor
+            ++ [return $ connectRoom corridor
---               ,return $ connectRoom door]
+               ,return $ connectRoom door]
             ++ firstWeapon
---            ++ [return $ connectRoom corridor
+            ++ [return $ connectRoom corridor
---               ,return $ connectRoom door]
+               ,return $ connectRoom door]
---            ++ [randomiseLinks =<< pistolerRoom]
+            ++ [randomiseLinks =<< pistolerRoom]
---            ++ [return $ connectRoom door]
+            ++ [return $ connectRoom door]
---             ++ [randomiseLinks =<< shooterRoom]
+             ++ [randomiseLinks =<< shooterRoom]
---             ++ (replicate 3 $ randomiseLinks corridor)
+             ++ (replicate 3 $ randomiseLinks corridor)
---            ++ [return $ connectRoom (set rmPS [PS (20,40) 0 basicLS] corridor)]
+            ++ [return $ connectRoom (set rmPS [PS (20,40) 0 basicLS] corridor)]
---            ++ [return $ connectRoom corridor]
+            ++ [return $ connectRoom corridor]
---             ++ (replicate 3 $ randomiseLinks corridor)
+             ++ (replicate 3 $ randomiseLinks corridor)
---            ++ [return $ connectRoom corridor]
+            ++ [return $ connectRoom corridor]
---            ++[return $ connectRoom corridor,return $ connectRoom door]
+            ++[return $ connectRoom corridor,return $ connectRoom door]
---            ++ [shootingRange]
+            ++ [shootingRange]
---               ++ (replicate 3 $ randomiseLinks corridor)
+               ++ (replicate 3 $ randomiseLinks corridor)
---              ++[roomMiniIntro]
+              ++[roomMiniIntro]
---               ++ (replicate 3 $ randomiseLinks corridor)
+               ++ (replicate 3 $ randomiseLinks corridor)
---              ++ [return $ connectRoom corridor
+              ++ [return $ connectRoom corridor
---                 ,return $ connectRoom door
+                 ,return $ connectRoom door
---                 ,slowDoorRoom]
+                 ,slowDoorRoom]
---            ++ [return $ connectRoom corridor
+            ++ [return $ connectRoom corridor
---               ,spawnerRoom
+               ,spawnerRoom
---               ,return $ connectRoom corridor
+               ,return $ connectRoom corridor
---               ]
+               ]
             )
             $ randomiseLinks corridor
 

src/Dodge/LevelGen/StaticWalls.hs

@@ -25,8 +25,20 @@ type WallP = (Point2,Point2)
 
 -- | Cut out a polygon from a set of walls, and check for errors in the
 -- created walls.
+-- If created walls are not consistent, expand poly and retry.
 cutWalls :: [Point2] -> [WallP] -> [WallP]
 cutWalls ps wls = case mapMaybe (flip checkWallRight newWalls) newWalls of
+    [] -> newWalls
+    _  -> cutWalls (expandPolyBy 0.01 ps) wls
+  where
+    newWalls = cutWalls' ps wls
+    errsL = mapMaybe (flip checkWallLeft newWalls) newWalls
+
+-- | Cut out a polygon from a set of walls, and check for errors in the
+-- created walls.
+-- Give error if created walls are not consistent.
+cutWalls'' :: [Point2] -> [WallP] -> [WallP]
+cutWalls'' ps wls = case mapMaybe (flip checkWallRight newWalls) newWalls of
     [] -> newWalls
     errs -> error $ "during level generation function cutWalls: when cutting poly:\n" ++ show ps 
         ++ "\nRight corner errors:\n"
@@ -73,13 +85,16 @@ checkWallLeft (x,y) wls
 -- (possibly three if the wall extends across the polygon),
 -- 2. remove any created walls that are inside the polygon,
 -- 3. create the required new walls along the polygon boundary.
+-- 4. fuse wall endpoints that end up close to each or to polygon intersection points
+-- 5. remove any walls that ended up zero length after fusing
+-- 6. remove any duplicate walls
 -- Unclear behaviour if a line in the polygon is colinear with a wall.
 cutWalls' :: [Point2] -> [WallP] -> [WallP]
 cutWalls' qs walls = 
---    nub
+    nub
---    . filter (not.wallIsZeroLength) 
+    . filter (not.wallIsZeroLength) 
---    . fuseWallsWith zs
+    . fuseWallsWith zs
-    addPolyWalls rs  
+    . addPolyWalls rs  
 --    . removeWallsInPolygon ps 
 --    . filter (not.wallIsZeroLength) 
 --    . fuseWallsWith zs
@@ -89,10 +104,14 @@ cutWalls' qs walls =
     (zs,cwals) = cutWallsWithPoints ps walls
     ps = orderPolygon qs
     rs = orderPolygon $ nub $ zs ++ qs
--- unused steps:
+
--- fuse wall endpoints that end up close to each or to polygon intersection points
+-- | Given a value and a poly, pushes the poly points out from the center by the
--- remove any walls that ended up zero length after fusing
+-- value amount.
--- remove any duplicate walls
+expandPolyBy :: Float -> [Point2] -> [Point2]
+expandPolyBy x ps = map f ps
+  where
+    cp = (1/(fromIntegral (length ps))) *.* (foldr (+.+) (0,0) ps)
+    f p = p +.+ x *.* (p -.- cp)
 
 -- | Given a polygon expressed as a list of points and a collection of walls,
 -- returns: 

test/Spec.hs

@@ -41,7 +41,7 @@ shrinkTris (x:xs) = xs : map (x :) (shrinkTris xs)
 
 genTri = zip <$> trip <*> trip 
   where
-    trip = vectorOf 3 $ fmap fromIntegral $ choose (0,5::Int)
+    trip = vectorOf 3 $ fmap fromIntegral $ choose (0,3::Int)
 
 genTris = listOf genTri
 
@@ -49,9 +49,5 @@ genTris = listOf genTri
 --extractLoops [] = []
 --extractLoops (x:xs) = 
   
---[[(4.0,10.0),(6.0,2.0),(3.0,0.0)],[(9.0,3.0),(2.0,5.0),(0.0,6.0)]]
 --
---[[(314.0,-396.0),(0.0,-223.71985),(-239.32773,357.25983)],[(0.0,0.0),(-84.0,-177.0),(237.0,-355.5366)]]
+--[[(0.0,1.0),(3.0,4.0),(5.0,5.0)],[(2.0,0.0),(2.0,4.0),(1.0,1.0)],[(5.0,5.0),(2.0,2.0),(1.0,3.0)]]
---
---
---[[(5.0,2.0),(3.0,5.0),(1.0,2.0)],[(3.0,2.0),(2.0,0.0),(4.0,0.0)],[(5.0,1.0),(3.0,0.0),(3.0,1.0)]]