Allow for complex room bounds for clip checks

2021-05-03 00:57:17 +02:00
parent f71724ae8b
commit 2bf23db935
14 changed files with 92 additions and 152 deletions
@@ -16,29 +16,27 @@ import Data.List
 import Data.Maybe
 import qualified Data.IntMap as IM
 import qualified Data.Set as S
-
+-- | Describe a wall as two points.
+-- Order is important: the wall face is to the left as you move from 'fst'
+-- to 'snd'.
 type WallP = (Point2,Point2)
-
 -- | Test whether lines are near parallel.
 -- Assumes non-zero length lines.
 nearParallel :: WallP -> WallP -> Bool
 nearParallel (a,b) (x,y)
    = dotV (a -.- b) (vNormal (x -.- y)) < 0.01
-
 -- | Test for near collinearity.
 -- Assumes non-zero length lines.
 nearCollinear :: WallP -> WallP -> Bool
 nearCollinear (a,b) (x,y)
    | a /= x = nearParallel (a,b) (x,y) && nearParallel (a,b) (a,x)
    | otherwise = nearParallel (a,b) (x,y) && nearParallel (a,b) (a,y)
-
 -- | Remove inverse walls.
 removeInverseWalls :: [WallP] -> [WallP]
 removeInverseWalls ((a,b):ps)
    | (b,a) `elem` ps = removeInverseWalls $ delete (b,a) ps
    | otherwise       = (a,b) : removeInverseWalls ps
 removeInverseWalls ps = ps
-
 -- | Cut out a polygon from a set of walls, and check for errors in the
 -- created walls.
 -- If created walls are not consistent, rotate and expand poly and retry.
@@ -51,7 +49,8 @@ cutWalls ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
  where
    newWalls = cutWalls' ps wls
    errsL = mapMaybe (`checkWallLeft` newWalls) newWalls
-
+-- | As 'cutWalls', but rotate in the other direction.
+cutWallsL :: [Point2] -> [WallP] -> [WallP]
 cutWallsL ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
    [] -> newWalls
 --    _  -> cutWalls (expandPolyBy 100 ps) wls
@@ -60,7 +59,6 @@ cutWallsL ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
  where
    newWalls = cutWalls' ps wls
    errsL = mapMaybe (`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.
@@ -79,7 +77,6 @@ cutWalls'' ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
  where
    newWalls = cutWalls' ps wls
    errsL = mapMaybe (`checkWallLeft` newWalls) newWalls
-
 -- | Given a specific wall and list of walls, checks that the number of walls leaving the
 -- second point is the same as the number of walls entering the second point of
 -- the specific wall.
@@ -104,7 +101,6 @@ checkWallLeft (x,y) wls
  where
    ins     = filter (\(a,b) -> a == x) wls
    outs    = filter (\(a,b) -> b == x) wls
-
 -- | 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.
 -- The overall procedure is: 
@@ -131,7 +127,6 @@ cutWalls' qs walls =
    (zs,cwals) = cutWallsWithPoints ps walls
    ps = orderPolygon qs
    rs = orderPolygon $ nub $ zs ++ qs
-
 -- | Given a value and a poly, pushes the poly points out from the center by the
 -- value amount.
 expandPolyBy :: Float -> [Point2] -> [Point2]
@@ -139,7 +134,6 @@ 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: 
 -- fst: points of the polygon's intersection with walls
@@ -151,21 +145,20 @@ cutWallsWithPoints (p:ps) ws = foldr f ([],ws) (zip (p:ps) (ps++[p]))
        ( nub $ as ++ cutWallsPoints p1 p2 ws'
        , concatMap (cutWall p1 p2) ws'
        )
-
 -- | List the points of intersection between a segment and collection of walls.
 cutWallsPoints :: Point2 -> Point2 -> [WallP] -> [Point2]
 --cutWallsPoints p1 p2 ws = mapMaybe (\(x:y:_) -> intersectExtendedSegSeg p1 p2 x y)
 cutWallsPoints p1 p2 = mapMaybe (uncurry $ myIntersectSegSeg p1 p2)
-
 -- | Given a segment and a wall, split the wall into two if it crosses the segment.
 cutWall :: Point2 -> Point2 -> WallP -> [WallP]
 cutWall p1 p2 (x,y) = case myIntersectSegSeg p1 p2 x y of
    Nothing -> [(x,y)]
    Just cp -> [(x,cp),(cp,y)]
-
-addPolyWalls :: [Point2] -> [WallP] -> [WallP]
+addPolyWalls 
+    :: [Point2] -- ^ Multiple walls described as a polygon.
+    -> [WallP] 
+    -> [WallP]
 addPolyWalls (q:qs) walls = foldr addPolyWall walls (zip (q:qs) (qs++[q]))
-
 -- | Add a new wall to a list of walls only if either
 -- 1. no wall already exists on the normal line from the new wall
 -- 2. any of the first existing walls hit on the normal line from the new wall
@@ -176,40 +169,36 @@ addPolyWall :: WallP -> [WallP] -> [WallP]
 addPolyWall (p1,p2) walls =
    case maybeWs of 
        Just ws -> if all (\(x,y) -> isLHS x y p3) ws
-                   then walls
-                   else (p1,p2) : walls
+            then walls
+            else (p1,p2) : walls
        Nothing -> ((p1,p2) : walls)
  where 
    p3 = 0.5 *.* (p1 +.+ p2)
    p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1)
    maybeWs = fmap (map fst)
-              . listToMaybe
-              $ groupBy ((==) `on` (dist p3 . snd))
-                wlsP
+        . listToMaybe
+        $ groupBy ((==) `on` (dist p3 . snd))
+          wlsP
    wlsP :: [(WallP, Point2)]
    wlsP = sortBy (compare `on` (dist p3 . snd))
-              . catMaybes
-              $ zipWith f walls maybes
+        . catMaybes
+        $ zipWith f walls maybes
    f a (Just b) = Just (a,b)
    f _ Nothing  = Nothing
    maybes = map (uncurry $ myIntersectSegSeg p3 p4) walls
-
 -- | 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
 findClosePoint ps p = find (\q -> dist p q < 5) ps
-
 -- | Given a list of points and a point, returns the point if none in the list
 -- is close to the point.
 pointIfNotClose :: [Point2] -> Point2 -> Maybe Point2
 pointIfNotClose ps p = case findClosePoint ps p of
-                        Nothing -> Just p
-                        _       -> Nothing
-
+    Nothing -> Just p
+    _       -> Nothing
 -- | Fuses a point with one in a list if any are close enough.
 fusePoint :: [Point2] -> Point2 -> Point2
 fusePoint ps p = fromMaybe p $ findClosePoint ps p
-
 -- | Given a list of points and wall, moves the wall to be on the points if it is
 -- close to any of the points.
 -- If either wall point is not moved, this point gets added to the list.
@@ -218,7 +207,6 @@ fuseWall (ps, (x,y)) = ( nub (x':y':ps) , (x',y') )
  where 
    x' = fusePoint ps x
    y' = fusePoint (x':ps) y
-
 -- | Given list of points and collection of walls, fuses the wall ends if
 -- they are close to the list of points or each other.
 fuseWallsWith :: [Point2] -> [WallP] -> [WallP]
@@ -227,10 +215,8 @@ fuseWallsWith zs ws = snd $ foldr fuseWalls' (zs, []) ws
    fuseWalls' w (ps, ws) = 
        let (qs, w') = fuseWall (ps, w)
        in  (qs, w' :  ws)
-
 -- | Test if fst p == snd p.
 wallIsZeroLength (x,y) = x == y
-
 -- | Given a polygon and list of walls, removes walls inside the polygon.
 removeWallsInPolygon :: [Point2] -> [WallP] -> [WallP]
 removeWallsInPolygon ps = filter (not . cond)