Partial fix to static wall generation, add haddocks

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
+checkWallRight (x,y) wls 
-    [w] -> Nothing
+    | length ins == length outs = Nothing
-    wls -> Just ((x,y), wls)
+    | 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
+checkWallLeft (x,y) wls
-    [w] -> Nothing
+    | length ins == length outs = Nothing
-    wls -> Just ((x,y),wls)
+    | 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
+-- | 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
+-- 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: 
+-- unused steps:
--- 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,
+-- | Given a polygon expressed as a list of points and a collection of walls,
--- returns: fst: points of the polygon's intersection with walls
+-- returns: 
---          snd: the collection of walls after cutting by the polygon
+-- 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
+-- | Add a new wall to a list of walls only if either
--- such that this existing wall faces towards the new wall
+-- 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 = 
+addPolyWall (p1,p2) walls =
-    case maybeW of Just (x,y) -> if isLHS x y p3
+    case maybeWs of 
-                                 then walls
+        Just ws -> if all (\(x,y) -> isLHS x y p3) ws
-                                 else (p1,p2) : walls
+                   then walls
-                   Nothing -> ((p1,p2) : walls)
+                   else (p1,p2) : walls
+        Nothing -> ((p1,p2) : walls)
   where 
     p3 = 0.5 *.* (p1 +.+ p2)
     p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1)
-    maybeW = listToMaybe 
+    maybeWs = -- listToMaybe .
-              . fst
+              fmap fst
-              . unzip
+              . fmap unzip
-              . sortBy (compare `on` (dist p3 . snd))
+              . 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
+-- | Given a list of points and a point, returns a point in the list if any is close
-intersectExtendedSegSeg p1 p2 a1 a2 = myIntersectSegSeg p1' p2' a1' a2'
+-- to the point.
-  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
 
+-- | 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
+-- | Given a list of points and wall, moves the wall to be on the points if it is
--- close to any of the points
+-- close to any of the points.
--- if either wall point is not moved, this point gets added to the list
+-- 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
+-- | Given list of points and collection of walls, fuses the wall ends if
--- they are close to the list of points or each other
+-- 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
+    cond wall = 
---        pointInsidePolygon (fst wall) ps
+        pointInOrOnPolygon (0.5 *.* (fst wall +.+ snd wall)) ps
---                        && pointInsidePolygon (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

@@ -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

@@ -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)]]