Fix---at least partially---level generation bug

src/Dodge/LevelGen/StaticWalls.hs

@@ -18,14 +18,18 @@ import qualified Data.Set as S
 
 -- given a polygon of points and collection of walls, cuts out the polygon
 -- ie returns a new set of walls with a hole determined by anticlockwise ordering of the points
-cutWalls :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall
-cutWalls qs walls = createPolyWalls rs  
-                  . IM.filter (not.wallIsZeroLength) 
-                  . removeWallsInPolygon ps 
-                  $ fuseWallsWith zs cwals
-    where (zs,cwals) = cutWallsWithPoints ps walls
-          ps = orderPolygon qs
-          rs = orderPolygon $ nub $ zs ++ qs
+cutWalls' :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall
+cutWalls' qs walls = 
+      IM.filter (not.wallIsZeroLength) 
+    . fuseWallsWith zs
+    .createPolyWalls rs  
+    . IM.filter (not.wallIsZeroLength) 
+    . removeWallsInPolygon ps 
+    $ fuseWallsWith zs cwals
+  where 
+    (zs,cwals) = cutWallsWithPoints ps walls
+    ps = orderPolygon qs
+    rs = orderPolygon $ nub $ zs ++ qs
 -- the overall procedure is: 
 -- split walls that intersect with the polygon into two 
 --      (possibly three if the wall extends across the polygon)
@@ -34,6 +38,30 @@ cutWalls qs walls = createPolyWalls rs
 -- also remove any walls that ended up zero length
 -- draw the required new walls along the polygon boundary
 
+cutWalls :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall
+cutWalls ps wls = case mapMaybe (flip checkWallRight newWalls) newWallsList of
+    [] -> newWalls
+    errs -> error $ "cutWalls: when cutting poly:\n" ++ show ps ++ "\nRight corner errors:\n"
+        ++ unlines (map (show . f) errs)
+        ++ "\nStart walls:\n"
+        ++ unlines (map (show . g) (IM.elems wls))
+        ++ "\nEnd walls:\n"
+        ++ unlines (map (show . g) (IM.elems newWalls))
+  where
+    newWalls = cutWalls' ps wls
+    newWallsList = IM.elems newWalls
+    g v = (_wlID v, _wlLine v)
+    f (v,vs) = (g v, map g vs)
+
+checkWallRight :: Wall -> IM.IntMap Wall -> Maybe (Wall,[Wall])
+checkWallRight wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsRight (_wlLine wl !! 0) wls of
+    [w] -> Nothing
+    wls -> Just (wl, wls)
+checkWallLeft :: Wall -> IM.IntMap Wall -> Maybe (Wall,[Wall])
+checkWallLeft wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsLeft (_wlLine wl !! 1) wls of
+    [w] -> Nothing
+    wls -> Just (wl,wls)
+
 createPolyWalls :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall
 createPolyWalls (q:qs) walls = foldr createPolyWall walls (zip (q:qs) (qs++[q]))
 
@@ -154,21 +182,20 @@ finalFuse = IM.filter (not.wallIsZeroLength) . fuseWallsWith []
 nubWalls :: IM.IntMap Wall -> IM.IntMap Wall
 nubWalls wls = IM.fromList $ nubBy ((==) `on` _wlLine . snd) $ IM.assocs wls
 
-checkWalls' :: IM.IntMap Wall -> IM.IntMap Wall
-checkWalls' wls = case find (\wl -> dist (_wlLine wl !! 0) (_wlLine wl !! 1) < 1) wls of
-    Just wl -> error $ show $ _wlLine wl
-    _       -> wls
-
-checkWalls wls | (nub $ map _wlLine $ IM.elems wls)
-                   == (map _wlLine $ IM.elems wls) = wls
-               | otherwise = error "hasdup"
+--checkWalls' :: IM.IntMap Wall -> IM.IntMap Wall
+--checkWalls' wls = case find (\wl -> dist (_wlLine wl !! 0) (_wlLine wl !! 1) < 1) wls of
+--    Just wl -> error $ show $ _wlLine wl
+--    _       -> wls
+--
+--checkWalls wls | (nub $ map _wlLine $ IM.elems wls)
+--                   == (map _wlLine $ IM.elems wls) = wls
+--               | otherwise = error "hasdup"
 
 -- idea: create inner walls to draw and to cast shadows
 createInnerWalls :: IM.IntMap Wall -> IM.IntMap Wall
 createInnerWalls wls = IM.map (createInnerWall wls) wls
 
 createInnerWall :: IM.IntMap Wall -> Wall -> Wall
---createInnerWall walls wl = wl & wlLine %~ (++) [(0,0)]
 createInnerWall walls wl = wl & wlLine %~ \l -> l ++ [wlL,wlR]
   where wl0 = _wlLine wl !! 0
         wl1 = _wlLine wl !! 1
@@ -183,14 +210,16 @@ createInnerWall walls wl = wl & wlLine %~ \l -> l ++ [wlL,wlR]
 findWallLeft :: Wall -> IM.IntMap Wall -> Wall
 findWallLeft wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsLeft (_wlLine wl !! 1) wls of
     [w] -> w
-    wls   -> error $ "findWallLeft: is there a standalone wall? wlIDs: " ++ show (map _wlID wls)
+    wls   -> error $ "findWallLeft: " ++ show (map _wlID wls)
                                                                  ++ " wlLines: "++ show (map _wlLine wls)
 
 findWallRight :: Wall -> IM.IntMap Wall -> Wall
 findWallRight wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsRight (_wlLine wl !! 0) wls of
     [w] -> w
-    wls   -> error $ "findWallRight: is there a standalone wall? wlIDs: " ++ show (map _wlID wls)
-                                                                 ++ " wlLines: "++ show (map _wlLine wls)
+    wls   -> error $ "findWallRight: wall with ID " ++ show (_wlID wl) ++ " and points " ++
+                    show (_wlLine wl) ++ "\nhas a right corner with and only with the walls "
+                    ++ show (map _wlID wls) ++ "\nwlLines "++ show (map _wlLine wls)
+                    ++ "\nUnless a wall has a corner with exactly one other wall, there is a problem"
 
 findWallsLeft :: Point2 -> IM.IntMap Wall -> IM.IntMap Wall
 findWallsLeft x wls = IM.filter (\wl -> dist x (_wlLine wl !! 0) < 1) wls