Fix wall cutting bug by removing inverse walls

src/Dodge/LevelGen/StaticWalls.hs

@@ -10,7 +10,6 @@ import Dodge.Data
 import Geometry
 
 --import Control.Lens
-import Data.Function (on)
 import Data.List
 import Data.Maybe
 --import qualified Data.IntMap as IM
@@ -113,10 +112,15 @@ checkWallLeft (x,y) wls
 -- 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
+-- 7. remove any inverse walls
 -- Unclear behaviour if a line in the polygon is colinear with a wall.
+-- Step 7 is important for the check whether or not to add a wall, otherwise a
+-- wall may be added where it shouldn't because the wrong facing wall is
+-- collided with
 cutPoly :: [Point2] -> [WallP] -> [WallP]
 cutPoly qs wls = 
     nub
+    . removeInverseWalls
     . filter (not . wallIsZeroLength) 
     . fuseWallsWith zs
     . addPolyWalls rs  
@@ -174,24 +178,16 @@ addPolyWalls _ _ = error "Trying to add empty poly walls"
 addPolyWall :: WallP -> [WallP] -> [WallP]
 addPolyWall (p1,p2) wls =
     case maybeWs of 
-        Just ws -> if all (\(x,y) -> isLHS x y p3) ws
+        Just ws -> if uncurry isLHS ws p3
             then wls
             else (p1,p2) : wls
         Nothing -> (p1,p2) : wls
   where 
+    maybeWs = listToMaybe hitWls
+    hitWls = sortOn (dist p3 . fromJust . f) $ filter (isJust . f) wls
     p3 = 0.5 *.* (p1 +.+ p2)
     p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1)
-    maybeWs = fmap (map fst)
+    f = uncurry $ myIntersectSegSeg p3 p4
-        . listToMaybe
-        $ groupBy ((==) `on` (dist p3 . snd))
-          wlsP
-    wlsP :: [(WallP, Point2)]
-    wlsP = sortBy (compare `on` (dist p3 . snd))
-        . catMaybes
-        $ zipWith f wls maybes
-    f a (Just b) = Just (a,b)
-    f _ Nothing  = Nothing
-    maybes = map (uncurry $ myIntersectSegSeg p3 p4) wls
 -- | Given a list of points and a point, returns a point in the list if any is close
 -- to the point.
 findClosePoint :: [Point2] -> Point2 -> Maybe Point2
@@ -229,6 +225,11 @@ removeWallsInPolygon :: [Point2] -> [WallP] -> [WallP]
 removeWallsInPolygon ps = filter (not . cond)
   where 
     cond wall = pointInOrOnPolygon (0.5 *.* uncurry (+.+) wall) ps
+-- | Given a polygon and list of walls, finds walls inside the polygon.
+findWallsInPolygon :: [Point2] -> [WallP] -> [WallP]
+findWallsInPolygon ps = filter cond
+  where 
+    cond wall = pointInOrOnPolygon (0.5 *.* uncurry (+.+) wall) ps
 
 brokenWalls :: [(Point2,Point2)]
 brokenWalls = 
@@ -255,3 +256,65 @@ expandToSquare (a,b) = [(a,b),(b,c),(c,d),(d,a)]
 
 minWalls :: [(Point2,Point2)]
 minWalls = expandToSquare iBWall
+
+brokenZs :: [Point2]
+brokenCwals :: [WallP]
+(brokenZs,brokenCwals) = cutWallsWithPoints brokenPoly brokenWalls
+
+minZs :: [Point2]
+minCwals :: [WallP]
+(minZs,minCwals) = cutWallsWithPoints brokenPoly minWalls
+
+brokenRs :: [Point2]
+brokenRs = orderPolygon $ nub $ minZs ++ brokenPoly
+
+brokenAfterRemovedWalls :: [WallP]
+brokenAfterRemovedWalls = removeWallsInPolygon (orderPolygon brokenPoly) brokenCwals
+minAfterRemovedWalls :: [WallP]
+minAfterRemovedWalls = removeWallsInPolygon (orderPolygon brokenPoly) minCwals
+
+brokenRemovedWalls :: [WallP]
+brokenRemovedWalls = findWallsInPolygon (orderPolygon brokenPoly) brokenCwals
+minRemovedWalls :: [WallP]
+minRemovedWalls = findWallsInPolygon (orderPolygon brokenPoly) minCwals
+
+addedPolyWalls :: [Point2] -> [WallP] -> [WallP]
+addedPolyWalls ps wls = addPolyWalls ps wls \\ wls
+
+brokenAddedWalls :: [WallP]
+brokenAddedWalls = addedPolyWalls brokenRs brokenAfterRemovedWalls
+minAddedWalls :: [WallP]
+minAddedWalls = addedPolyWalls brokenRs minAfterRemovedWalls
+
+brokenAdd :: WallP
+brokenAdd = head brokenAddedWalls
+
+findShadowWall :: WallP -> [WallP] -> Maybe WallP
+findShadowWall (p1,p2) wls = listToMaybe hitWls
+  where 
+    p3 = 0.5 *.* (p1 +.+ p2)
+    p4 = p3 +.+ 10000 *.* rotateV (negate $ pi/4) (vNormal (p2 -.- p1))
+    hitWls = sortOn (dist p3 . fromJust . f) $ filter (isJust . f) wls
+    f = uncurry $ myIntersectSegSeg p3 p4
+
+findShadowWalls :: WallP -> [WallP] -> [WallP]
+findShadowWalls (p1,p2) wls = hitWls
+  where 
+    p3 = 0.5 *.* (p1 +.+ p2)
+    p4 = p3 +.+ 10000 *.* rotateV (0) (vNormal (p2 -.- p1))
+    hitWls = sortOn (dist p3 . fromJust . f) $ filter (isJust . f) wls
+    f = uncurry $ myIntersectSegSeg p3 p4
+
+addWallDebug :: WallP -> [WallP] -> [WallP]
+addWallDebug (p1,p2) wls =
+    case maybeWs of 
+        Just ws -> if uncurry isLHS ws p3
+            then wls
+            else (p1,p2) : wls
+        Nothing -> (p1,p2) : wls
+  where 
+    maybeWs = listToMaybe hitWls
+    hitWls = sortOn (dist p3 . fromJust . f) $ filter (isJust . f) wls
+    p3 = 0.5 *.* (p1 +.+ p2)
+    p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1)
+    f = uncurry $ myIntersectSegSeg p3 p4