167 lines
6.0 KiB
Haskell
167 lines
6.0 KiB
Haskell
module Dodge.LevelGen.StaticWalls
|
|
where
|
|
import Dodge.Data
|
|
import Dodge.Base
|
|
import Dodge.Default
|
|
|
|
import Geometry
|
|
|
|
import Control.Lens
|
|
|
|
import Data.Function (on)
|
|
|
|
import Data.List
|
|
import Data.Maybe
|
|
import qualified Data.IntMap as IM
|
|
|
|
import qualified Data.Set as S
|
|
|
|
type WallP = (Point2,Point2)
|
|
|
|
-- the following checks one of the corners of cut walls at each step
|
|
cutWalls :: [Point2] -> [WallP] -> [WallP]
|
|
cutWalls ps wls = case mapMaybe (flip 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 = cutWalls' ps wls
|
|
errsL = mapMaybe (flip checkWallLeft newWalls) newWalls
|
|
|
|
checkWallRight :: WallP -> [WallP] -> Maybe (WallP,[WallP])
|
|
checkWallRight (x,y) wls = case filter (\(a,b) -> a == y ) wls of
|
|
[w] -> Nothing
|
|
wls -> Just ((x,y), wls)
|
|
checkWallLeft :: WallP -> [WallP] -> Maybe (WallP,[WallP])
|
|
checkWallLeft (x,y) wls = case filter (\(a,b) -> b == x ) wls of
|
|
[w] -> Nothing
|
|
wls -> Just ((x,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
|
|
cutWalls' :: [Point2] -> [WallP] -> [WallP]
|
|
cutWalls' qs walls =
|
|
nub
|
|
. filter (not.wallIsZeroLength)
|
|
. fuseWallsWith zs
|
|
. addPolyWalls rs
|
|
-- . removeWallsInPolygon ps
|
|
-- . filter (not.wallIsZeroLength)
|
|
-- . fuseWallsWith zs
|
|
$ removeWallsInPolygon ps
|
|
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)
|
|
-- remove any created walls that are inside the polygon
|
|
-- create the required new walls along the polygon boundary
|
|
-- fuse wall endpoints that end up close to each or to polygon intersection points
|
|
-- remove any walls that ended up zero length after fusing
|
|
-- remove any duplicate walls
|
|
|
|
-- 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 = foldr f ([],ws) (zip (p:ps) (ps++[p]))
|
|
where
|
|
f (p1,p2) (as,ws') =
|
|
( nub $ as ++ cutWallsPoints p1 p2 ws'
|
|
, concatMap (cutWall p1 p2) ws'
|
|
)
|
|
|
|
-- lists 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 ws = mapMaybe (uncurry $ myIntersectSegSeg p1 p2) ws
|
|
|
|
-- 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 (q:qs) walls = foldr addPolyWall walls (zip (q:qs) (qs++[q]))
|
|
|
|
-- adds a wall if there is not already a wall on the clockwise normal to this wall
|
|
-- such that this existing wall faces towards the new wall
|
|
addPolyWall :: WallP -> [WallP] -> [WallP]
|
|
addPolyWall (p1,p2) walls =
|
|
case maybeW of Just (x,y) -> if isLHS x y p3
|
|
then walls
|
|
else (p1,p2) : walls
|
|
Nothing -> ((p1,p2) : walls)
|
|
where
|
|
p3 = 0.5 *.* (p1 +.+ p2)
|
|
p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1)
|
|
maybeW = listToMaybe
|
|
. fst
|
|
. unzip
|
|
. sortBy (compare `on` (dist p3 . snd))
|
|
. catMaybes
|
|
$ zipWith f walls maybes
|
|
f a (Just b) = Just (a,b)
|
|
f _ Nothing = Nothing
|
|
maybes = map (uncurry $ myIntersectSegSeg p3 p4) walls
|
|
|
|
-- intersects two segments, each extended by one unit in both directions
|
|
intersectExtendedSegSeg p1 p2 a1 a2 = myIntersectSegSeg p1' p2' a1' a2'
|
|
where
|
|
p1' = p1 +.+ normalizeV (p1 -.- p2)
|
|
p2' = p2 +.+ normalizeV (p2 -.- p1)
|
|
a1' = a1 +.+ normalizeV (a1 -.- a2)
|
|
a2' = a2 +.+ normalizeV (a2 -.- a1)
|
|
|
|
-- given a list of points and a point, returns a point in the list if any is close
|
|
-- enough to the point
|
|
findClosePoint :: [Point2] -> Point2 -> Maybe Point2
|
|
findClosePoint ps p = find (\q -> dist p q < 5) ps
|
|
|
|
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
|
|
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
|
|
fuseWall :: ([Point2], WallP) -> ([Point2], WallP)
|
|
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]
|
|
fuseWallsWith zs ws = snd $ foldr fuseWalls' (zs, []) ws
|
|
where
|
|
fuseWalls' w (ps, ws) =
|
|
let (qs, w') = fuseWall (ps, w)
|
|
in (qs, w' : ws)
|
|
|
|
wallIsZeroLength (x,y) = x == y
|
|
|
|
removeWallsInPolygon :: [Point2] -> [WallP] -> [WallP]
|
|
removeWallsInPolygon ps walls = filter (not . cond) walls
|
|
where
|
|
cond wall = pointInsidePolygon (fst wall) ps
|
|
&& pointInsidePolygon (snd wall) ps
|
|
|