justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Partial fix to static wall generation, add haddocks

Browse Source
This commit is contained in:
jgk
2021-04-04 14:06:56 +02:00
parent 3a1b15aced
commit 1b6b89f4d7
3 changed files with 103 additions and 62 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/LevelGen/StaticWalls.hs
+79 -51
View File
@@ -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]
src/Geometry.hs
-8
View File
@@ -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"
test/Spec.hs
+24 -3
View File
@@ -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)]]