diff --git a/src/Dodge/LevelGen/StaticWalls.hs b/src/Dodge/LevelGen/StaticWalls.hs index 6ec629ffc..438fe4aa7 100644 --- a/src/Dodge/LevelGen/StaticWalls.hs +++ b/src/Dodge/LevelGen/StaticWalls.hs @@ -1,3 +1,7 @@ +{-| +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 @@ -19,7 +23,8 @@ import qualified Data.Set as S type WallP = (Point2,Point2) --- the following checks one of the corners of cut walls at each step +-- | Cut out a polygon from a set of walls, and check for errors in the +-- created walls. cutWalls :: [Point2] -> [WallP] -> [WallP] cutWalls ps wls = case mapMaybe (flip checkWallRight newWalls) newWalls of [] -> newWalls @@ -36,20 +41,40 @@ cutWalls ps wls = case mapMaybe (flip checkWallRight newWalls) newWalls of newWalls = cutWalls' ps wls errsL = mapMaybe (flip 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 = case filter (\(a,b) -> a == y ) wls of - [w] -> Nothing - wls -> Just ((x,y), wls) +checkWallRight (x,y) wls + | length ins == length outs = Nothing + | otherwise = Just ((x,y), outs) + where + ins = filter (\(a,b) -> b == y) wls + outs = filter (\(a,b) -> 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 = case filter (\(a,b) -> b == x ) wls of - [w] -> Nothing - wls -> Just ((x,y),wls) +checkWallLeft (x,y) wls + | length ins == length outs = Nothing + | otherwise = Just ((x,y), outs) + 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 +-- | 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. +-- Unclear behaviour if a line in the polygon is colinear with a wall. cutWalls' :: [Point2] -> [WallP] -> [WallP] -cutWalls' [] walls = walls -cutWalls' [x,y] walls = walls cutWalls' qs walls = -- nub -- . filter (not.wallIsZeroLength) @@ -64,18 +89,15 @@ cutWalls' qs walls = (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 +-- unused steps: -- 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 +-- | 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 @@ -84,12 +106,12 @@ cutWallsWithPoints (p:ps) ws = foldr f ([],ws) (zip (p:ps) (ps++[p])) , concatMap (cutWall p1 p2) ws' ) --- lists the points of intersection between a segment and collection of walls +-- | 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 ws = mapMaybe (uncurry $ myIntersectSegSeg p1 p2) ws --- given a segment and a wall, split the wall into two if it crosses the segment +-- | 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)] @@ -98,60 +120,63 @@ cutWall p1 p2 (x,y) = case myIntersectSegSeg p1 p2 x y of 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 +-- | 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 (p1,p2) walls = - case maybeW of Just (x,y) -> if isLHS x y p3 - then walls - else (p1,p2) : walls - Nothing -> ((p1,p2) : walls) +addPolyWall (p1,p2) walls = + case maybeWs of + Just ws -> if all (\(x,y) -> isLHS x y p3) ws + 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)) + maybeWs = -- listToMaybe . + fmap fst + . fmap unzip + . listToMaybe + $ groupBy ((==) `on` (dist p3 . snd)) + wlsP + wlsP :: [(WallP, Point2)] + wlsP = 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 +-- | 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 +-- | 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 +-- | 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 +-- | 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 @@ -161,13 +186,16 @@ fuseWallsWith zs ws = snd $ foldr fuseWalls' (zs, []) ws wallIsZeroLength (x,y) = x == y +-- | Given a polygon and list of walls, removes walls inside the polygon. removeWallsInPolygon :: [Point2] -> [WallP] -> [WallP] removeWallsInPolygon ps walls = filter (not . cond) walls where - cond wall = pointInsidePolygon (0.5 *.* (fst wall +.+ snd wall)) ps --- pointInsidePolygon (fst wall) ps --- && pointInsidePolygon (snd wall) ps + cond wall = + pointInOrOnPolygon (0.5 *.* (fst wall +.+ snd wall)) ps +-- pointInOrOnPolygon (fst wall) ps +-- && pointInOrOnPolygon (snd wall) ps +hw x y = 0.5 *.* (x +.+ y) --pairElems :: Eq a => [(a,a)] -> [a] diff --git a/src/Geometry.hs b/src/Geometry.hs index 0c8614ad6..630a19921 100644 --- a/src/Geometry.hs +++ b/src/Geometry.hs @@ -57,14 +57,6 @@ pointInPolygon :: Point2 -> [Point2] -> Bool pointInPolygon !p [] = False pointInPolygon !p (x:xs) = all (\l -> uncurry (errorIsLHS 1) l p) $ zip (x:xs) (xs ++ [x]) -pointInsidePolygon :: Point2 -> [Point2] -> Bool -pointInsidePolygon !p (x:xs) = all (\l -> not (uncurry isRHS l (p +.+ normalizeV s))) pairs - || any (\l -> uncurry isOnLine l p) pairs - where - pairs = zip (x:xs) (xs ++ [x]) - s = ((1/fromIntegral (length (x:xs))) *.* (foldr1 (+.+) (x:xs))) -.- p - - errorPointInPolygon :: Int -> Point2 -> [Point2] -> Bool errorPointInPolygon !i !p xs | length xs == 1 = error "one point polygon" diff --git a/test/Spec.hs b/test/Spec.hs index 55b42155a..1344baae1 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -14,19 +14,34 @@ nextPair (_,y) = filter (\(x,_) -> x == y) isLooping :: Eq a => [(a,a)] -> Bool isLooping xs = all (( == 1) . length . flip nextPair xs) xs +isLooping' :: Eq a => [(a,a)] -> Bool +isLooping' xs = all (f xs) xs + where + f ys (x,y) = length ins == length outs && length rins == length routs + where + ins = filter (\(a,b) -> a == x) ys + outs = filter (\(a,b) -> b == x) ys + rins = filter (\(a,b) -> a == y) ys + routs = filter (\(a,b) -> b == y) ys + polygonStrictlyConvex :: [Point2] -> Bool polygonStrictlyConvex ps = True --prop_looping :: [Point2] -> [WallP] -> Bool prop_looping = forAllShrink genTris shrinkTris $ \tris -> - isLooping $ foldr cutWalls' [] tris + (all (not . (\[a,b,c] -> isOnLine a b c + || isOnLine a c b + || isOnLine b c a + ) ) tris) + ==> (isLooping' $ foldr cutWalls' [] tris) -shrinkTris (x:xs) = xs : map (x :) (shrink xs) +shrinkTris [] = [] +shrinkTris (x:xs) = xs : map (x :) (shrinkTris xs) genTri = zip <$> trip <*> trip where - trip = vectorOf 3 $ choose (-500,500::Float) + trip = vectorOf 3 $ fmap fromIntegral $ choose (0,5::Int) genTris = listOf genTri @@ -34,3 +49,9 @@ genTris = listOf genTri --extractLoops [] = [] --extractLoops (x:xs) = +--[[(4.0,10.0),(6.0,2.0),(3.0,0.0)],[(9.0,3.0),(2.0,5.0),(0.0,6.0)]] +-- +--[[(314.0,-396.0),(0.0,-223.71985),(-239.32773,357.25983)],[(0.0,0.0),(-84.0,-177.0),(237.0,-355.5366)]] +-- +-- +--[[(5.0,2.0),(3.0,5.0),(1.0,2.0)],[(3.0,2.0),(2.0,0.0),(4.0,0.0)],[(5.0,1.0),(3.0,0.0),(3.0,1.0)]]