331 lines
16 KiB
Haskell
331 lines
16 KiB
Haskell
--{-# LANGUAGE TupleSections #-}
|
|
{-|
|
|
Module : Dodge.LevelGen.StaticWalls
|
|
Description : Concerns carving out of static walls to create the general room plan of the level.
|
|
-}
|
|
module Dodge.LevelGen.StaticWalls
|
|
where
|
|
import Dodge.Data
|
|
import Geometry
|
|
import Geometry.ConvexPoly
|
|
--import Geometry.Data
|
|
import FoldableHelp
|
|
|
|
--import Control.Lens
|
|
import Data.List.Extra
|
|
import Data.Maybe
|
|
import Data.Bifunctor
|
|
-- | Describe a wall as two points.
|
|
-- Order is important: the wall face is to the left of the line going 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, retry, rotating and expanding poly.
|
|
cutWalls :: [Point2] -> [WallP] -> [WallP]
|
|
cutWalls ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
|
|
[] -> newWalls
|
|
_ -> cutWallsRetry 0 ps wls
|
|
-- _ -> wls
|
|
-- _ -> error $ show ps
|
|
where
|
|
newWalls = cutPoly ps wls
|
|
cutWallsRetry :: Int -> [Point2] -> [WallP] -> [WallP]
|
|
--cutWallsRetry 200 ps wls = error $ show ps ++ show wls
|
|
cutWallsRetry i ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
|
|
[] -> newWalls
|
|
_ -> cutWallsRetry (i+1) ps wls
|
|
-- _ -> wls
|
|
-- _ -> error $ show ps
|
|
where
|
|
newWalls = cutPoly ps' wls
|
|
--ps' = map (rotateV a) $ expandPolyBy 0.1 ps
|
|
ps' = map (rotateV a) $ expandPolyBy x ps
|
|
x = fromIntegral i / 100
|
|
a | even i = 0.001
|
|
| otherwise = negate 0.001
|
|
-- | 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 (`checkWallRight` newWalls) newWalls of
|
|
[] -> newWalls
|
|
errs -> error $ "during level generation function cutWalls: when cutting poly:\n" ++ show ps
|
|
++ "\nRight corner errors:\n"
|
|
++ unlines (map show errs)
|
|
++ "\nLeft corner errors:\n"
|
|
++ unlines (map show errsL)
|
|
++ "\nWalls before cut:\n"
|
|
++ unlines (map show wls)
|
|
++ "\nWalls after cut:\n"
|
|
++ unlines (map show newWalls)
|
|
where
|
|
newWalls = cutPoly 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.
|
|
-- 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 specific wall and list of walls, checks that the number of walls leaving the
|
|
-- first point is the same as the number of walls entering the first point of
|
|
-- the specific wall.
|
|
-- On success returns Nothing, on failure returns Just the specific wall and the
|
|
-- list of walls leaving the first point.
|
|
checkWallLeft :: WallP -> [WallP] -> Maybe (WallP,[WallP])
|
|
checkWallLeft (x,y) wls
|
|
| length ins == length outs = Nothing
|
|
| otherwise = Just ((x,y), outs)
|
|
where
|
|
ins = filter (\(a,_) -> a == x) wls
|
|
outs = filter (\(_,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:
|
|
-- 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
|
|
--cp = 1/fromIntegral (length ps) *.* foldl' (+.+) (V2 0 0) ps
|
|
cp = centroid ps
|
|
f p = p +.+ x *.* (p -.- cp)
|
|
-- | 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
|
|
--cp = 1/fromIntegral (length ps) *.* foldl' (+.+) (V2 0 0) ps
|
|
cp = centroid ps
|
|
f p = p +.+ x *.* safeNormalizeV (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
|
|
-- 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 = safeMinimumOn (dist p3 . fromJust . f) $ filter (isJust . f) wls
|
|
--maybeWs = fmap fst $ safeMinimumOn (dist p3 . snd) $ mapMaybe (\x -> (x,) <$> f x) wls
|
|
maybeWs = safeMinimumOnMaybe (fmap (dist p3) . f) wls
|
|
p3 = 0.5 *.* (p1 +.+ p2)
|
|
p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1)
|
|
f = uncurry $ myIntersectSegSeg p3 p4
|
|
--g = uncurry $ intersectSegSegTest 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
|
|
-- | 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
|
|
-- | 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
|
|
|
|
-----------------------DEBUG CODE:
|
|
-- | 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 = map (bimap toV2 toV2)
|
|
[((330.12192,3032.2456),(190.52365,2995.8352)),((190.52365,2995.8352),(203.94716,2945.9377)),((214.33855,2907.311),(230.12193,2859.0405)),((230.12193,2859.0405),(366.7245,2895.643)),((366.7245,2895.643),(330.12192,3032.2456)),((366.7245,2895.643),(230.12193,2859.0405)),((230.12193,2859.0405),(266.7245,2722.438)),((266.7245,2722.438),(403.32703,2759.0405)),((403.32703,2759.0405),(503.32703,2932.2456)),((466.72446,3068.8481),(330.12192,3032.2456)),((330.12192,3032.2456),(366.7245,2895.643)),((503.32703,2932.2456),(466.72446,3068.8481)),((203.94716,2945.9377),(145.99155,2930.4084)),((156.38292,2891.7817),(214.33855,2907.311)),((107.47222,2920.979),(34.06077,2901.2295)),((34.06077,2901.2295),(52.571453,2832.4224)),((70.17772,2796.55),(174.45558,2824.6025)),((174.45558,2824.6025),(156.38292,2891.7817)),((100.76944,2955.4202),(107.47222,2920.979)),((145.99155,2930.4084),(140.79587,2949.722)),((52.571453,2832.4224),(35.882084,2827.9504)),((31.745949,2785.4312),(70.17772,2796.55)),((88.14497,3002.5354),(100.76944,2955.4202)),((140.79587,2949.722),(120.21855,3027.0303)),((35.882084,2827.9504),(-22.07344,2812.4214)),((-31.039248,2768.608),(31.745949,2785.4312)),((-261.32483,3408.5737),(-303.9881,3451.237)),((-303.9881,3451.237),(-332.27234,3422.9526)),((-332.27234,3422.9526),(-289.84595,3380.5264)),((-261.56174,3352.242),(88.14497,3002.5354)),((120.21855,3027.0303),(-233.27742,3380.5264)),((-289.84595,3380.5264),(-332.2724,3338.0999)),((-332.2724,3338.0999),(-303.9881,3309.8157)),((-303.9881,3309.8157),(-261.56174,3352.242)),((-22.07344,2812.4214),(-89.68823,2794.304)),((-79.335526,2755.667),(-31.039248,2768.608)),((-210.16953,3456.4133),(-261.32483,3408.5737)),((-233.27742,3380.5264),(-194.64026,3419.1633)),((-128.32533,2783.9514),(-200.79468,3054.4106)),((-200.79468,3054.4106),(-780.35016,2899.1191)),((-780.35016,2899.1191),(-625.05865,2319.5635)),((-625.05865,2319.5635),(-45.503174,2474.855)),((-45.503174,2474.855),(-117.97253,2745.3142)),((-89.68823,2794.304),(-128.32533,2783.9514)),((-117.97253,2745.3142),(-79.335526,2755.667)),((-178.49438,3590.2566),(-241.50847,3573.372)),((-241.50847,3573.372),(-210.16953,3456.4133)),((-194.64026,3419.1633),(-136.80266,3434.6611)),((-98.165634,3445.014),(-139.85736,3600.6094)),((-92.98925,3425.6953),(-98.165634,3445.014)),((-136.80266,3434.6611),(-127.74397,3400.8535)),((-187.553,3624.064),(-178.49438,3590.2566)),((-139.85736,3600.6094),(-148.91603,3634.4167)),((-127.74397,3400.8535),(-111.20285,3339.121)),((-78.55679,3371.8325),(-92.98925,3425.6953)),((-349.5008,4383.0093),(-388.13782,4372.6563)),((-388.13782,4372.6563),(-485.18823,3653.0168)),((-485.18823,3653.0168),(-477.42368,3624.039)),((-477.42368,3624.039),(-206.96445,3696.5085)),((-168.32744,3706.861),(102.131805,3779.3306)),((102.131805,3779.3306),(94.36725,3808.308)),((94.36725,3808.308),(-349.5008,4383.0093)),((-206.96445,3696.5085),(-187.553,3624.064)),((-148.91603,3634.4167),(-168.32744,3706.861)),((299.35522,3346.2668),(97.2383,3547.9797)),((97.2383,3547.9797),(-78.55679,3371.8325)),((-111.20285,3339.121),(116.74672,3110.6904)),((116.74672,3110.6904),(320.08704,3314.438)),((352.084,3395.578),(299.35522,3346.2668)),((320.08704,3314.438),(367.6133,3358.328)),((495.06226,3666.979),(293.8115,3613.054)),((293.8115,3613.054),(352.084,3395.578)),((367.6133,3358.328),(563.6875,3410.866)),((563.6875,3410.866),(495.06226,3666.979))]
|
|
|
|
--intersectingBrokenWalls :: [(Point2,Point2)]
|
|
--intersectingBrokenWalls = filter (uncurry test) brokenWalls
|
|
-- where
|
|
-- polyPairs = zip brokenPoly (tail brokenPoly ++ [head brokenPoly])
|
|
-- test a b = any (isJust . uncurry (myIntersectSegSeg a b)) polyPairs
|
|
|
|
--brokenPoly :: [Point2]
|
|
--brokenPoly = [(434.66675,2833.3225),(503.9488,2793.3225),(523.9488,2827.9636),(454.66675,2867.9636)]
|
|
|
|
--iBWall :: (Point2,Point2)
|
|
--iBWall = ((403.32703,2759.0405),(503.32703,2932.2456))
|
|
|
|
expandToSquare :: (Point2,Point2) -> [(Point2,Point2)]
|
|
expandToSquare (a,b) = [(a,b),(b,c),(c,d),(d,a)]
|
|
where
|
|
v = a -.- b
|
|
c = b +.+ vNormal v
|
|
d = a +.+ vNormal v
|
|
|
|
--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 = safeMinimumOn (dist p3 . fromJust . f) $ filter (isJust . f) wls
|
|
-- where
|
|
-- p3 = 0.5 *.* (p1 +.+ p2)
|
|
-- p4 = p3 +.+ 10000 *.* rotateV (negate $ pi/4) (vNormal (p2 -.- p1))
|
|
-- f = uncurry $ myIntersectSegSeg p3 p4
|
|
--
|
|
--findShadowWalls :: WallP -> [WallP] -> [WallP]
|
|
--findShadowWalls (p1,p2) wls = hitWls
|
|
-- where
|
|
-- 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
|
|
--
|
|
--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 = safeMinimumOn (dist p3 . fromJust . f) $ filter (isJust . f) wls
|
|
-- p3 = 0.5 *.* (p1 +.+ p2)
|
|
-- p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1)
|
|
-- f = uncurry $ myIntersectSegSeg p3 p4
|