loop/src/Dodge/LevelGen/StaticWalls.hs

{-|
Module      : Dodge.LevelGen.StaticWalls
Description : Concerns carving out of static walls to create the general room plan of the level.
-}
module Dodge.LevelGen.StaticWalls 
    ( cutWalls
    , removeInverseWalls
    , expandPolyByFixed
    , cutPoly
    , expandPolyCorners
    )
    where
import Geometry
--import Geometry.ConvexPoly
import FoldableHelp

import Data.List.Extra
import Data.Maybe
-- | Describe a wall as two points.
-- Order is important: the wall face is to the left of the line going from 
-- 'fst' to 'snd'.
-- TODO remove duplication
type WallP = (Point2,Point2)
-- | 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, retry, rotating and expanding poly.
cutWalls :: [Point2] -> [WallP] -> [WallP]
cutWalls ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
    [] -> newWalls
    _  -> cutWallsRetry 0 ps wls
  where
    newWalls = cutPoly ps wls
cutWallsRetry :: Int -> [Point2] -> [WallP] -> [WallP]
cutWallsRetry i ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
    [] -> newWalls
    _  -> cutWallsRetry (i+1) ps wls
  where
    newWalls = cutPoly ps' wls
    ps' = map (rotateV a) $ expandPolyBy x ps
    x = fromIntegral i / 100
    a | even i    = 0.001
      | otherwise = negate 0.001
-- | 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.
-- On success returns Nothing, on failure returns Just the specific wall and the
-- list of walls leaving the second point.
checkWallRight :: WallP -> [WallP] -> Maybe (WallP,[WallP])
checkWallRight (x,y) wls 
    | length ins == length outs = Nothing
    | otherwise                 = Just ((x,y), outs)
  where
    ins     = filter (\(_,b) -> b == y) wls
    outs    = filter (\(a,_) -> a == y) 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: 
-- 1. split walls that intersect with the polygon into two 
-- (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
-- 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
-- Be aware that we do not remove all colinear walls; this may still cause bugs
cutPoly :: [Point2] -> [WallP] -> [WallP]
cutPoly qs wls = nubOrd
    . removeInverseWalls
    . filter (not . wallIsZeroLength) 
    . fuseWallsWith zs
    . addPolyWalls rs  
    $ removeWallsInPolygon ps 
     cwals
  where 
    (zs,cwals) = cutWallsWithPoints ps wls
    ps = orderPolygon qs
    rs = orderPolygon $ nubOrd $ zs ++ qs
-- | Given a value and a poly, pushes the poly points out from the center by the
-- factor amount.
expandPolyBy :: Float -> [Point2] -> [Point2]
expandPolyBy x ps = map f ps
  where
    f p = p +.+ x *.* (p -.- centroid ps)
-- | Given a value and a poly, pushes the poly points out from the center by the
-- fixed amount.
expandPolyByFixed :: Float -> [Point2] -> [Point2]
expandPolyByFixed x ps = map f ps
  where
    f p = p +.+ x *.* squashNormalizeV (p -.- centroid ps)
-- | Given a value and a poly, pushes points out by a fixed amount along an
-- angle determined by the corner, i.e. by the two other neighbour points
expandPolyCorners :: Float -> [Point2] -> [Point2]
expandPolyCorners d (x:y:z:xs) = zipWith3 f (x:y:z:xs) (y:z:xs++[x]) (z:xs ++ [x,y])
  where
    f l c r = c +.+ d *.* normalizeV (normalizeV (c -.- r) +.+ normalizeV (c -.- l))
expandPolyCorners _ _ = error "trying to expand poly corners of 2 or fewer points"
-- | Given a polygon expressed as a list of points and a collection of walls,
-- returns: 
-- fst: points of the polygon's intersection with walls
-- snd: the collection of walls after cutting by the polygon.
cutWallsWithPoints :: [Point2] -> [WallP] -> ([Point2], [WallP] )
cutWallsWithPoints (p:ps) ws = foldl' f ([],ws) (zip (p:ps) (ps++[p]))
  where 
    f (as,ws') (p1,p2) = 
        ( nubOrd $ as ++ cutWallsPoints p1 p2 ws'
        , concatMap (cutWall p1 p2) ws'
        )
cutWallsWithPoints _ _ = error "Trying to cut empty polygon"
-- | List the points of intersection between a segment and collection of walls.
cutWallsPoints :: Point2 -> Point2 -> [WallP] -> [Point2]
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)]
-- | Add poly walls?
addPolyWalls 
    :: [Point2] -- ^ Multiple walls described as a polygon.
    -> [WallP] 
    -> [WallP]
addPolyWalls (q:qs) wls = foldl' addPolyWall wls (zip (q:qs) (qs++[q]))
addPolyWalls _ _ = error "Trying to add empty poly walls"
-- | 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
-- face away from the new wall.
-- The normal line is the line from the center point of the new wall outwards 
-- along the clockwise normal of the new wall (currently 10000 units along)
addPolyWall :: [WallP] -> WallP -> [WallP]
addPolyWall wls (p1,p2) =
    case maybeWs of 
        Just ws -> if uncurry isLHS ws p3
            then wls
            else (p1,p2) : wls
        Nothing -> (p1,p2) : wls
  where 
    maybeWs = safeMinimumOnMaybe (fmap (dist p3) . f) wls
    p3 = 0.5 *.* (p1 +.+ p2)
    p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1)
    f = uncurry $ myIntersectSegSeg p3 p4
-- | 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
-- | Fuses a point with one in a list if any are close enough.
fusePoint :: [Point2] -> Point2 -> ([Point2],Point2)
fusePoint ps p = case findClosePoint ps p of
    Just q  -> (ps,q)
    Nothing -> (p: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.
fuseWall :: [Point2] -> WallP -> ([Point2], WallP)
fuseWall ps (x,y) = ( rs , (x',y') )
  where 
    (qs,y') = fusePoint ps y
    (rs,x') = fusePoint qs x
-- | 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]
fuseWallsWith zs ws = snd $ foldl' fuseWalls (zs, []) ws
  where 
    fuseWalls (ps, ws') w = 
        let (qs, w') = fuseWall ps w
        in  (qs, w' :  ws')
-- | Test if fst p == snd p.
wallIsZeroLength :: Eq a => (a,a) -> Bool
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)
  where 
    cond wall = pointInOrOnPolygon (0.5 *.* uncurry (+.+) wall) ps