Generate walls using points, fix at least some potential errors
This commit is contained in:
+13
-1
@@ -11,6 +11,7 @@ import Dodge.RandomHelp
|
||||
import Dodge.Path
|
||||
import Dodge.Layout.Tree
|
||||
import Dodge.Room.Data
|
||||
import Dodge.Default
|
||||
|
||||
import Geometry
|
||||
|
||||
@@ -60,8 +61,19 @@ generateFromTree t w = zoning $ placeSpots plmnts
|
||||
makePath :: Tree Room -> [(Point2,Point2)]
|
||||
makePath = concat . map _rmPath . flatten
|
||||
|
||||
-- consider nubbing walls after dividing them
|
||||
wallsFromTree :: Tree Room -> IM.IntMap Wall
|
||||
wallsFromTree t = createInnerWalls $ nubWalls $ divideWalls $ foldr cutWalls IM.empty (concatMap _rmPolys $ flatten t)
|
||||
wallsFromTree t =
|
||||
createInnerWalls
|
||||
. divideWalls
|
||||
. assignKeys
|
||||
. foldr cutWalls [] -- $ map (map (g . roundPoint2))
|
||||
. map (map roundPoint2)
|
||||
$ (concatMap _rmPolys $ flatten t)
|
||||
where
|
||||
assignKeys = IM.fromList . zip [0..] . zipWith f [0..]
|
||||
f i (x,y) = defaultWall {_wlLine = [x,y] , _wlID = i}
|
||||
g (x,y) = (x-3855,y - 2613)
|
||||
|
||||
divideWall :: Wall -> [Wall]
|
||||
divideWall wl
|
||||
|
||||
@@ -4,8 +4,6 @@ module Dodge.LevelGen
|
||||
( module Dodge.LevelGen
|
||||
, cutWalls
|
||||
, createInnerWalls
|
||||
-- , checkWalls
|
||||
, nubWalls
|
||||
, pairsToGraph
|
||||
, makeButton
|
||||
, makeSwitch
|
||||
|
||||
@@ -16,18 +16,45 @@ 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 $ "cutWalls: when cutting poly:\n" ++ show ps
|
||||
++ "\nRight corner errors:\n"
|
||||
++ unlines (map show errs)
|
||||
++ "\nStart walls:\n"
|
||||
++ unlines (map show wls)
|
||||
++ "\nEnd walls:\n"
|
||||
++ unlines (map show newWalls)
|
||||
++ "\nLeft corner errors:\n"
|
||||
++ unlines (map show errsL)
|
||||
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] -> IM.IntMap Wall -> IM.IntMap Wall
|
||||
cutWalls' :: [Point2] -> [WallP] -> [WallP]
|
||||
cutWalls' qs walls =
|
||||
nubWalls
|
||||
. IM.filter (not.wallIsZeroLength)
|
||||
nub
|
||||
. filter (not.wallIsZeroLength)
|
||||
. fuseWallsWith zs
|
||||
. createPolyWalls rs
|
||||
. IM.filter (not.wallIsZeroLength)
|
||||
-- . removeWallsInPolygon ps
|
||||
-- $ fuseWallsWith zs cwals
|
||||
. fuseWallsWith zs
|
||||
-- . filter (not.wallIsZeroLength)
|
||||
-- . fuseWallsWith zs
|
||||
$ removeWallsInPolygon ps
|
||||
cwals
|
||||
where
|
||||
@@ -37,96 +64,66 @@ cutWalls' qs walls =
|
||||
-- the overall procedure is:
|
||||
-- split walls that intersect with the polygon into two
|
||||
-- (possibly three if the wall extends across the polygon)
|
||||
-- fuse wall endpoints that end up close to each or to polygon intersection points
|
||||
-- remove the created walls that are inside the polygon
|
||||
-- also remove any walls that ended up zero length
|
||||
-- remove any created walls that are inside the polygon
|
||||
-- draw the required new walls along the polygon boundary
|
||||
|
||||
-- the following checks one of the corners of cut walls at each step
|
||||
cutWalls :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall
|
||||
cutWalls ps wls = case mapMaybe (flip checkWallRight newWalls) newWallsList of
|
||||
[] -> newWalls
|
||||
errs -> error $ "cutWalls: when cutting poly:\n" ++ show ps ++ "\nRight corner errors:\n"
|
||||
++ unlines (map (show . f) errs)
|
||||
++ "\nStart walls:\n"
|
||||
++ unlines (map (show . g) (IM.elems wls))
|
||||
++ "\nEnd walls:\n"
|
||||
++ unlines (map (show . g) (IM.elems newWalls))
|
||||
where
|
||||
newWalls = cutWalls' ps wls
|
||||
newWallsList = IM.elems newWalls
|
||||
g v = (_wlID v, _wlLine v)
|
||||
f (v,vs) = (g v, map g vs)
|
||||
|
||||
checkWallRight :: Wall -> IM.IntMap Wall -> Maybe (Wall,[Wall])
|
||||
checkWallRight wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsRight (_wlLine wl !! 0) wls of
|
||||
[w] -> Nothing
|
||||
wls -> Just (wl, wls)
|
||||
checkWallLeft :: Wall -> IM.IntMap Wall -> Maybe (Wall,[Wall])
|
||||
checkWallLeft wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsLeft (_wlLine wl !! 1) wls of
|
||||
[w] -> Nothing
|
||||
wls -> Just (wl,wls)
|
||||
|
||||
createPolyWalls :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall
|
||||
createPolyWalls (q:qs) walls = foldr createPolyWall walls (zip (q:qs) (qs++[q]))
|
||||
|
||||
-- creates 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
|
||||
createPolyWall :: (Point2, Point2) -> IM.IntMap Wall -> IM.IntMap Wall
|
||||
createPolyWall (p1,p2) walls =
|
||||
case maybeW of Just w -> if isLHS (_wlLine w !! 0) (_wlLine w !! 1) p3
|
||||
then walls
|
||||
else IM.insert k newWall walls
|
||||
Nothing -> IM.insert k newWall walls
|
||||
where p3 = 0.5 *.* (p1 +.+ p2)
|
||||
p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1)
|
||||
maybeW = wallOnLine p3 p4 walls
|
||||
k = newKey walls
|
||||
newWall = defaultWall {_wlLine = [p1,p2], _wlID = k}
|
||||
|
||||
-- given a segment and a wall, adds a cut point to the wall if it intersects the
|
||||
-- segment
|
||||
cutWall :: Point2 -> Point2 -> Wall -> Wall
|
||||
cutWall p1 p2 wall = case maybeCP of
|
||||
Nothing -> wall
|
||||
Just cp -> wall {_wlLine = [cp,w0,w1]}
|
||||
where wl = _wlLine wall
|
||||
w0 = wl !! 0
|
||||
w1 = wl !! 1
|
||||
maybeCP = intersectExtendedSegSeg p1 p2 w0 w1
|
||||
|
||||
-- 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 segment and a collection of walls, cuts each wall where it intersects
|
||||
-- with the segment, adds the two cut walls
|
||||
addCutWalls :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall
|
||||
addCutWalls p1 p2 ws = foldr addTwoWallsIfCut ws $ IM.map (cutWall p1 p2) ws
|
||||
where addTwoWallsIfCut w ws
|
||||
= case _wlLine w of
|
||||
(cp:w0:w1:[]) -> IM.insert (newKey ws) (w {_wlLine = [cp,w1]
|
||||
,_wlID = newKey ws})
|
||||
$ IM.insert (_wlID w) (w {_wlLine = [w0,cp]}) ws
|
||||
(x:y:[]) -> ws
|
||||
|
||||
-- lists the points of intersection between a segment and collection of walls
|
||||
cutWallsPoints :: Point2 -> Point2 -> IM.IntMap Wall -> [Point2]
|
||||
cutWallsPoints p1 p2 ws = mapMaybe (\(x:y:_) -> intersectExtendedSegSeg p1 p2 x y)
|
||||
$ map _wlLine $ IM.elems ws
|
||||
-- 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] -> IM.IntMap Wall -> ([Point2], IM.IntMap Wall)
|
||||
cutWallsWithPoints :: [Point2] -> [WallP] -> ([Point2], [WallP] )
|
||||
cutWallsWithPoints (p:ps) ws = foldr f ([],ws) (zip (p:ps) (ps++[p]))
|
||||
where f (p1,p2) (as,ws') = ( as ++ cutWallsPoints p1 p2 ws'
|
||||
, addCutWalls p1 p2 ws'
|
||||
)
|
||||
where
|
||||
f (p1,p2) (as,ws') =
|
||||
( 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, adds a cut point to the wall if it intersects 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)]
|
||||
|
||||
createPolyWalls :: [Point2] -> [WallP] -> [WallP]
|
||||
createPolyWalls (q:qs) walls = foldr createPolyWall 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
|
||||
createPolyWall :: WallP -> [WallP] -> [WallP]
|
||||
createPolyWall (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
|
||||
@@ -145,32 +142,24 @@ 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], Wall) -> ([Point2], Wall)
|
||||
fuseWall (ps, w) = ( rs
|
||||
, w Control.Lens.& wlLine .~ [w0,w1]
|
||||
)
|
||||
where qs = catMaybes [pointIfNotClose ps (_wlLine w !! 0)] ++ ps
|
||||
rs = catMaybes [pointIfNotClose qs (_wlLine w !! 1)] ++ qs
|
||||
w0 = fusePoint ps (_wlLine w !! 0)
|
||||
w1 = fusePoint qs (_wlLine w !! 1)
|
||||
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] -> IM.IntMap Wall -> IM.IntMap Wall
|
||||
fuseWallsWith zs ws = snd $ IM.foldr fuseWalls' (zs, IM.empty) ws
|
||||
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, IM.insert (_wlID w') w' ws)
|
||||
in (qs, w' : ws)
|
||||
|
||||
wallIsZeroLength w = l !! 0 == l !! 1
|
||||
where l = _wlLine w
|
||||
wallIsZeroLength (x,y) = x == y
|
||||
|
||||
wallLengthGT x w = dist (l !! 0) (l !! 1) > x
|
||||
where l = _wlLine w
|
||||
|
||||
removeWallsInPolygon :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall
|
||||
removeWallsInPolygon ps walls = IM.filter (not . cond) walls
|
||||
where cond wall = pointInsidePolygon (_wlLine wall !! 0) ps
|
||||
&& pointInsidePolygon (_wlLine wall !! 1) ps
|
||||
removeWallsInPolygon :: [Point2] -> [WallP] -> [WallP]
|
||||
removeWallsInPolygon ps walls = filter (not . cond) walls
|
||||
where cond wall = pointInsidePolygon (fst wall) ps
|
||||
&& pointInsidePolygon (snd wall) ps
|
||||
|
||||
pointInsidePolygon :: Point2 -> [Point2] -> Bool
|
||||
pointInsidePolygon p (x:xs) = all (\l -> not (uncurry isRHS l (p +.+ normalizeV s))) pairs
|
||||
@@ -178,24 +167,8 @@ pointInsidePolygon p (x:xs) = all (\l -> not (uncurry isRHS l (p +.+ normalizeV
|
||||
where pairs = zip (x:xs) (xs ++ [x])
|
||||
s = ((1/fromIntegral (length (x:xs))) *.* (foldr1 (+.+) (x:xs)))
|
||||
-.- p
|
||||
------------------------------------------------------
|
||||
finalFuse :: IM.IntMap Wall -> IM.IntMap Wall
|
||||
finalFuse = IM.filter (not.wallIsZeroLength) . fuseWallsWith []
|
||||
|
||||
------------------------------------------------------
|
||||
|
||||
nubWalls :: IM.IntMap Wall -> IM.IntMap Wall
|
||||
nubWalls wls = IM.fromList $ nubBy ((==) `on` _wlLine . snd) $ IM.assocs wls
|
||||
|
||||
--checkWalls' :: IM.IntMap Wall -> IM.IntMap Wall
|
||||
--checkWalls' wls = case find (\wl -> dist (_wlLine wl !! 0) (_wlLine wl !! 1) < 1) wls of
|
||||
-- Just wl -> error $ show $ _wlLine wl
|
||||
-- _ -> wls
|
||||
--
|
||||
--checkWalls wls | (nub $ map _wlLine $ IM.elems wls)
|
||||
-- == (map _wlLine $ IM.elems wls) = wls
|
||||
-- | otherwise = error "hasdup"
|
||||
|
||||
------------------------------------------------------------------------------------
|
||||
-- idea: create inner walls to draw and to cast shadows
|
||||
createInnerWalls :: IM.IntMap Wall -> IM.IntMap Wall
|
||||
createInnerWalls wls = IM.map (createInnerWall wls) wls
|
||||
|
||||
Reference in New Issue
Block a user