Allow for complex room bounds for clip checks

src/Dodge/Floor.hs

@@ -1,3 +1,5 @@
+{- |
+The tree of rooms that make up a level. -}
 module Dodge.Floor
     ( levx
     ) where
@@ -33,17 +35,19 @@ import Control.Lens
 import Control.Monad.State
 import Control.Monad.Loops
 import System.Random
-
+{- |
+A test level tree. -}
 roomTreex :: RandomGen g => State g (Maybe [Room])
 roomTreex = do
     struct' <- aTreeStrut
 --    let struct = treeFromPost [[SpecificRoom $ fmap (pure . Right) pistolerRoom]] [EndRoom]
-    let struct = treeFromPost [[Corridor,SpecificRoom $ fmap (pure . Right) testRoom]] [EndRoom]
+    let struct = treeFromPost [[Corridor,SpecificRoom $ fmap (pure . Right) randomFourCornerRoom]] [EndRoom]
     let t' = padCorridors struct
         t = treeFromTrunk 
             [[StartRoom]
             ,[Corridor]
-            ,[SpecificRoom $ (pure . pure . Right) $ airlockCrystal 20]
+            ,[BossAno $ addArmour launcherCrit & crHP +~ 800
+                & crState . crDropsOnDeath .~ DropSpecific [0] ]
             ,[Corridor]
             ,[DoorAno]
             ,[SpecificRoom $ fmap (pure . Right) 
@@ -55,7 +59,7 @@ roomTreex = do
                     ]
             ,[FirstWeapon]
             ,[Corridor]
-            ,[SpecificRoom $ fmap (pure . Right) testRoom]
+            ,[SpecificRoom $ fmap (pure . Right) randomFourCornerRoom]
             ,[Corridor]
             ,[OrAno 
                 [[SpecificRoom $ branchRectWith $ fmap (pure . Left) armouredChasers]
@@ -74,51 +78,3 @@ roomTreex = do
 levx :: RandomGen g => State g [Room]
 levx = untilJust roomTreex
 
-lev1' :: RandomGen g => State g (Tree Room)
-lev1' = do
-    firstWeapon <- takeOne $ [[branchRectWith weaponRoom,longBlockedCorridor]] ++ replicate 5 [weaponRoom]
-    iterateWhile boundClip $ fmap (shiftRoomTree . expandTreeBy id) 
-        $ sequence $ treeFromPost 
-        (
-        [return $ return $ Right deadEndRoom
-        ]
-        ++ [return $ connectRoom corridor
-           ,return $ connectRoom door
-           ,glassSwitchBack >>= (fmap connectRoom . randomiseOutLinks)]
-        ++ [return $ connectRoom corridor
-           ,return $ connectRoom door]
-        ++ [miniRoom3]
-        ++ [return $ connectRoom corridor
-           ,return $ connectRoom door]
-        ++ [roomCCrits]
-        ++ [return $ connectRoom corridor
-           ,return $ connectRoom door]
-        ++[roomMiniIntro]
-        ++ [longRoom >>= (fmap connectRoom . randomiseOutLinks)]
-        ++ [return $ connectRoom corridor
-           ,return $ connectRoom door]
-        ++ firstWeapon
-        ++ [return $ connectRoom corridor
-           ,return $ connectRoom door]
-        ++ [(fmap connectRoom . randomiseOutLinks) =<< pistolerRoom]
-        ++ [return $ connectRoom door]
-         ++ [(fmap connectRoom . randomiseOutLinks) =<< shooterRoom]
-         ++ (replicate 3 $ (fmap connectRoom . randomiseOutLinks) corridor)
-        ++ [return $ connectRoom (set rmPS [PS (20,40) 0 basicLS] corridor)]
-        ++ [return $ connectRoom corridor]
-         ++ (replicate 3 $ (fmap connectRoom . randomiseOutLinks) corridor)
-        ++ [return $ connectRoom corridor]
-        ++[return $ connectRoom corridor,return $ connectRoom door]
-        ++ [shootingRange]
-           ++ (replicate 3 $ (fmap connectRoom . randomiseOutLinks) corridor)
-          ++[roomMiniIntro]
-           ++ (replicate 3 $ (fmap connectRoom . randomiseOutLinks) corridor)
-          ++ [return $ connectRoom corridor
-             ,return $ connectRoom door
-             ,slowDoorRoom]
-        ++ [return $ connectRoom corridor
-           ,spawnerRoom
-           ,return $ connectRoom corridor
-           ]
-        )
-        $ (fmap connectRoom . randomiseOutLinks) corridor

src/Dodge/Layout.hs

@@ -116,17 +116,6 @@ insertInZone :: Int -> Int -> a -> IM.IntMap (IM.IntMap a) -> IM.IntMap (IM.IntM
 insertInZone x y obj = IM.insertWith f x $ IM.singleton y obj
     where f _ = IM.insert y obj
 
--- the old version of this used a version of polysIntersect with intersectSegSeg'
-boundClip :: Tree Room -> Bool
-boundClip t = or $ map (uncurry polysIntersect) [(x,y) | x<- xs, y<-xs, x>y]
-                    ++ map f [(ps,qs) | ps <- xs, qs <-xs, ps/=qs]
-    where xs = map _rmBound $ flatten t
-          f ([],qs) = False
-          f ((p:_),qs) = pointInPolygon p qs
-
-noBoundClip :: Tree Room -> Bool
-noBoundClip = not . boundClip
-
 shiftRoomTree :: Tree Room -> Tree Room
 shiftRoomTree (Node t []) = Node t []
 shiftRoomTree (Node t ts) = Node t 

src/Dodge/Layout/Tree/Annotate.hs

@@ -83,7 +83,9 @@ annoToRoomTree [StartRoom] = do
     h <- state $ randomR (200,400)
     pure . Right <$> randomiseOutLinks (shiftRoomBy ((-20,-20),0) $ roomRectAutoLinks w h)
 annoToRoomTree (SpecificRoom rt:_) = rt
-annoToRoomTree (BossAno cr : _) = branchRectWith . fmap (pure . Left) $ bossRoom cr
+annoToRoomTree (BossAno cr : _) = do
+    br <- bossRoom cr
+    branchRectWith . pure . fmap (Left) $ treeFromPost [corridor,corridor] br
 annoToRoomTree (TreasureAno crs loot : _) =
     branchRectWith . fmap (pure . Left) $ lootRoom crs loot
 annoToRoomTree _ = do

src/Dodge/Layout/Tree/Shift.hs

@@ -28,8 +28,8 @@ shiftRoomTreeSearch bs (Node r ts :<| ts')
     | roomIsClipping = Nothing
     | otherwise = fmap (r :) $ shiftRoomTreeSearch newBounds $ ts' >< children
   where
-    roomIsClipping = any (polysIntersect (_rmBound r)) bs
+    roomIsClipping = or (polysIntersect <$> _rmBound r <*> bs)
-    newBounds = _rmBound r : bs
+    newBounds = _rmBound r ++ bs
     children = fromList $ zipWith (\l -> applyToRoot (shiftRoomToLink l))
                        (_rmLinks r)
                        ts
@@ -48,8 +48,8 @@ shiftRoomTreeSearchAll bs (Node r ts :<| ts')
         (s:ss) -> concatMap (\l -> shiftRoomTreeSearchAll bs (Node (rm l) ss <| (ts' |> f l s))) ls
   where
     ls = init $ _rmLinks r
-    newBounds = _rmBound r : bs
+    newBounds = _rmBound r ++ bs
-    roomIsClipping = any (polysOverlap (_rmBound r)) bs
+    roomIsClipping = or (polysOverlap <$> _rmBound r <*> bs)
     rm l = r & rmLinks %~ delete l
     f l = applyToRoot (shiftRoomToLink l)
 {- |

src/Dodge/LevelGen/StaticWalls.hs

@@ -16,29 +16,27 @@ import Data.List
 import Data.Maybe
 import qualified Data.IntMap as IM
 import qualified Data.Set as S
-
+-- | Describe a wall as two points.
+-- Order is important: the wall face is to the left as you move from 'fst'
+-- to 'snd'.
 type WallP = (Point2,Point2)
-
 -- | Test whether lines are near parallel.
 -- Assumes non-zero length lines.
 nearParallel :: WallP -> WallP -> Bool
 nearParallel (a,b) (x,y)
     = dotV (a -.- b) (vNormal (x -.- y)) < 0.01
-
 -- | Test for near collinearity.
 -- Assumes non-zero length lines.
 nearCollinear :: WallP -> WallP -> Bool
 nearCollinear (a,b) (x,y)
     | a /= x = nearParallel (a,b) (x,y) && nearParallel (a,b) (a,x)
     | otherwise = nearParallel (a,b) (x,y) && nearParallel (a,b) (a,y)
-
 -- | Remove inverse walls.
 removeInverseWalls :: [WallP] -> [WallP]
 removeInverseWalls ((a,b):ps)
     | (b,a) `elem` ps = removeInverseWalls $ delete (b,a) ps
     | otherwise       = (a,b) : removeInverseWalls ps
 removeInverseWalls ps = ps
-
 -- | Cut out a polygon from a set of walls, and check for errors in the
 -- created walls.
 -- If created walls are not consistent, rotate and expand poly and retry.
@@ -51,7 +49,8 @@ cutWalls ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
   where
     newWalls = cutWalls' ps wls
     errsL = mapMaybe (`checkWallLeft` newWalls) newWalls
-
+-- | As 'cutWalls', but rotate in the other direction.
+cutWallsL :: [Point2] -> [WallP] -> [WallP]
 cutWallsL ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
     [] -> newWalls
 --    _  -> cutWalls (expandPolyBy 100 ps) wls
@@ -60,7 +59,6 @@ cutWallsL ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
   where
     newWalls = cutWalls' ps wls
     errsL = mapMaybe (`checkWallLeft` newWalls) newWalls
-
 -- | Cut out a polygon from a set of walls, and check for errors in the
 -- created walls.
 -- Give error if created walls are not consistent.
@@ -79,7 +77,6 @@ cutWalls'' ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
   where
     newWalls = cutWalls' ps wls
     errsL = mapMaybe (`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.
@@ -104,7 +101,6 @@ checkWallLeft (x,y) wls
   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.
 -- The overall procedure is: 
@@ -131,7 +127,6 @@ cutWalls' qs walls =
     (zs,cwals) = cutWallsWithPoints ps walls
     ps = orderPolygon qs
     rs = orderPolygon $ nub $ zs ++ qs
-
 -- | Given a value and a poly, pushes the poly points out from the center by the
 -- value amount.
 expandPolyBy :: Float -> [Point2] -> [Point2]
@@ -139,7 +134,6 @@ expandPolyBy x ps = map f ps
   where
     cp = 1/(fromIntegral (length ps)) *.* foldr (+.+) (0,0) ps
     f p = p +.+ x *.* (p -.- cp)
-
 -- | Given a polygon expressed as a list of points and a collection of walls,
 -- returns: 
 -- fst: points of the polygon's intersection with walls
@@ -151,21 +145,20 @@ cutWallsWithPoints (p:ps) ws = foldr f ([],ws) (zip (p:ps) (ps++[p]))
         ( nub $ as ++ cutWallsPoints p1 p2 ws'
         , concatMap (cutWall p1 p2) ws'
         )
-
 -- | 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 = mapMaybe (uncurry $ myIntersectSegSeg p1 p2)
-
 -- | 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 
-addPolyWalls :: [Point2] -> [WallP] -> [WallP]
+    :: [Point2] -- ^ Multiple walls described as a polygon.
+    -> [WallP] 
+    -> [WallP]
 addPolyWalls (q:qs) walls = foldr addPolyWall walls (zip (q:qs) (qs++[q]))
-
 -- | 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
@@ -176,40 +169,36 @@ addPolyWall :: WallP -> [WallP] -> [WallP]
 addPolyWall (p1,p2) walls =
     case maybeWs of 
         Just ws -> if all (\(x,y) -> isLHS x y p3) ws
-                   then walls
+            then walls
-                   else (p1,p2) : walls
+            else (p1,p2) : walls
         Nothing -> ((p1,p2) : walls)
   where 
     p3 = 0.5 *.* (p1 +.+ p2)
     p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1)
     maybeWs = fmap (map fst)
-              . listToMaybe
+        . listToMaybe
-              $ groupBy ((==) `on` (dist p3 . snd))
+        $ groupBy ((==) `on` (dist p3 . snd))
-                wlsP
+          wlsP
     wlsP :: [(WallP, Point2)]
     wlsP = sortBy (compare `on` (dist p3 . snd))
-              . catMaybes
+        . catMaybes
-              $ zipWith f walls maybes
+        $ zipWith f walls maybes
     f a (Just b) = Just (a,b)
     f _ Nothing  = Nothing
     maybes = map (uncurry $ myIntersectSegSeg p3 p4) walls
-
 -- | 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 -> Just p
-                        _       -> Nothing
+    _       -> 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.
@@ -218,7 +207,6 @@ 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]
@@ -227,10 +215,8 @@ fuseWallsWith zs ws = snd $ foldr fuseWalls' (zs, []) ws
     fuseWalls' w (ps, ws) = 
         let (qs, w') = fuseWall (ps, w)
         in  (qs, w' :  ws)
-
 -- | Test if fst p == snd p.
 wallIsZeroLength (x,y) = x == y
-
 -- | Given a polygon and list of walls, removes walls inside the polygon.
 removeWallsInPolygon :: [Point2] -> [WallP] -> [WallP]
 removeWallsInPolygon ps = filter (not . cond)

src/Dodge/Room.hs

@@ -56,7 +56,7 @@ roomC x y = Room
     , _rmPath  = []
     , _rmPS    = [windowLine (x/2,0) (x/2,y-60)
                  ]
-    , _rmBound = rectNSWE (y+5) (-5) (-5) (x+5)
+    , _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)]
     }
   where 
     lnks = 
@@ -240,7 +240,7 @@ roomOctogon = Room
     , _rmLinks = lnks
     , _rmPath  = allPairs $ map fst lnks
     , _rmPS    = []
-    , _rmBound = [(-20,30),(20,30),(60,70),(60,110),(20,150),(-20,150),(-60,110),(-60,70)] 
+    , _rmBound = [[(-20,30),(20,30),(60,70),(60,110),(20,150),(-20,150),(-60,110),(-60,70)] ]
     }
     where lnks = [((0,140),0)
                  ,((35,125),0-pi/4)
@@ -369,7 +369,7 @@ deadEndRoom = Room
     , _rmLinks = lnks
     , _rmPath  = []
     , _rmPS    = [PS (0,-10) 0 putLamp]
-    , _rmBound = rectNSWE 20 (-20) (-30) 30
+    , _rmBound = [rectNSWE 20 (-20) (-30) 30]
     }
     where lnks = [((0,30)  ,0)
                  ]

src/Dodge/Room/Airlock.hs

@@ -28,7 +28,7 @@ airlockOneWay n = Room
                                                                  (M.insert (DoorNumOpen n) True))
                  ]
     --, _rmBound = rectNSWE 90 30 (-30) 30
-    , _rmBound = rectNSWE 75 15 0 40
+    , _rmBound = [rectNSWE 75 15 0 40]
     }
     where lnks = [((0,85),0)
                  ,((0, 5),pi)
@@ -66,7 +66,7 @@ airlock0 n = Room
                            (over worldState (M.insert (DoorNumOpen n) False))
         ,PS (-25, 50) 0 putLamp
         ]
-    , _rmBound = rectNSWE 75 15 0 40
+    , _rmBound = [rectNSWE 75 15 0 40]
     }
   where 
     lnks = [((20,95),0)
@@ -105,12 +105,12 @@ airlock90 n = Room
         ,PS (60, 60) 0 putLamp
         ]
     , _rmBound = 
-        [ (10,10)
+        [[ (10,10)
         , (10,100)
         , (100,150)
         , (150,100)
         , (100,10)
-        ]
+        ]]
     }
   where 
     cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)

src/Dodge/Room/Boss.hs

@@ -35,13 +35,14 @@ roomOctogon x = Room
         ,crystalLine (negate $ x/2,-x) (-x,negate (x/2))
         ,blockLine (-40,40-x) (40,40-x)
         ]
-    , _rmBound = rectNSWE x (-x) (-x) x
+    , _rmBound = [rectNSWE x (-x) (-x) x]
     }
   where
     fx = 4 * x / 5
 
 bossRoom :: RandomGen g => Creature -> State g Room
-bossRoom cr = pure $ roomOctogon 300 & rmPS %~ ( PS (0,100) (negate $ pi/2) (PutCrit cr) :)
+--bossRoom cr = pure $ roomOctogon 300 & rmPS %~ ( PS (0,100) (negate $ pi/2) (PutCrit cr) :)
+bossRoom cr = pure $ roomCross 200 300 & rmPS %~ ( PS (0,100) (negate $ pi/2) (PutCrit cr) :)
 
 armouredChasers :: RandomGen g => State g Room
 armouredChasers = do
@@ -52,3 +53,23 @@ armouredChasers = do
   where
     cs = (armourChaseCrit & crState . crDropsOnDeath .~ DropSpecific [0]) 
             : replicate 4 chaseCrit
+
+roomCross 
+    :: Float -- ^ First width/2
+    -> Float -- ^ Second width/2
+    -> Room
+roomCross x y = Room
+    { _rmPolys = [rectNSWE y (-y) (-x) x
+                 ,rectNSWE (-x) x y (-y)
+                 ]
+    , _rmLinks = [((x,y-20),negate $ pi/2)]
+    , _rmPath  = []
+    , _rmPS = 
+        [PS ( x, 0) 0 putLamp
+        ,PS (-x, 0) 0 putLamp
+        ,PS ( 0, x) 0 putLamp
+        ,PS ( 0,-x) 0 putLamp
+        ]
+    , _rmBound = [rectNSWE x (-x) (-x) x]
+    }
+  where

src/Dodge/Room/Corridor.hs

@@ -15,7 +15,7 @@ corridor = Room
     , _rmLinks = lnks
     , _rmPath  = concatMap (doublePair . (,) (20,60) . fst) lnks
     , _rmPS    = []
-    , _rmBound = rectNSWE 50 30 0 40
+    , _rmBound = [ rectNSWE 50 30 0 40 ]
     }
   where 
     lnks = 
@@ -31,7 +31,7 @@ corridorN = Room
     , _rmLinks = lnks
     , _rmPath  = pth
     , _rmPS    = []
-    , _rmBound = rectNSWE 50 30 0 40
+    , _rmBound = [ rectNSWE 50 30 0 40 ]
     }
     where lnks = [((20,70)  ,0)
                  ,((20,10)    ,pi)
@@ -46,7 +46,7 @@ tEast = Room
     , _rmLinks = lnks
     , _rmPath  = concatMap (doublePair . (,) (0,60) . fst) lnks
     , _rmPS    = []
-    , _rmBound = rectNSWE 70 10 0 40
+    , _rmBound = [ rectNSWE 70 10 0 40 ]
     }
     where lnks = [(( 30,60),-pi/2)
                  ,((-30,60),pi/2)
@@ -60,7 +60,7 @@ tWest = Room
     , _rmLinks = lnks
     , _rmPath  = concatMap (doublePair . (,) (0,60) . fst) lnks
     , _rmPS    = []
-    , _rmBound = rectNSWE 70 10 0 40
+    , _rmBound = [ rectNSWE 70 10 0 40 ]
     }
   where 
     lnks = 

src/Dodge/Room/Data.hs

@@ -21,6 +21,6 @@ data Room = Room
     , _rmLinks  :: [(Point2,Float)]
     , _rmPath :: [(Point2, Point2)]
     , _rmPS :: [PlacementSpot]
-    , _rmBound :: [Point2]
+    , _rmBound :: [ [Point2] ]
     }
 makeLenses ''Room

src/Dodge/Room/Link.hs

@@ -69,7 +69,7 @@ shiftRoomBy shift@(pos,rot) r =
    $ over rmLinks (fmap (shiftLinkBy shift))
    $ over rmPath (map (shiftPathPointBy shift))
    $ over rmPS (fmap (shiftPSBy shift))
-   $ over rmBound (map (shiftPointBy shift))
+   $ over rmBound (fmap (map (shiftPointBy shift)))
    r
 
 shiftLinkBy (pos,rot) (p,r) = (shiftPointBy (pos,rot) p, r + rot)

src/Dodge/Room/Procedural.hs

@@ -4,7 +4,7 @@ Procedural creation of rooms and subroom parts.
 module Dodge.Room.Procedural
     ( roomRect
     , roomRectAutoLinks
-    , testRoom
+    , randomFourCornerRoom
     , centerVaultRoom
     ) where
 import Dodge.Data
@@ -43,7 +43,7 @@ roomRect x y xn yn = Room
     , _rmLinks = lnks
     , _rmPath  = concatMap doublePair pth
     , _rmPS    = [PS (x/2,y/2) 0 putLamp]
-    , _rmBound = rectNSWE (y+5) (-5) (-5) (x+5)
+    , _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)]
     }
   where 
     yd = (y - 40) / fromIntegral yn
@@ -81,22 +81,17 @@ linksAndPath :: [(Point2,Float)] -> [(Point2,Point2)] -> [(Point2,Point2)]
 linksAndPath lnks subpth = subpth ++ concatMap linkClosest lnks
   where 
     linkClosest (p,_) = doublePair (p, minimumBy (compare `on` dist p) $ map fst subpth)
-
 {- Combines two rooms into one room.
-Combines into one big bound, concatenates the rest.
+Combines into one big bound, concatenates the rest.  -}
--}
 combineRooms :: Room -> Room -> Room
 combineRooms r r' = Room
     { _rmPolys = _rmPolys r ++ _rmPolys r'
     , _rmLinks = _rmLinks r ++ _rmLinks r'
     , _rmPath  = _rmPath  r ++ _rmPath  r'
     , _rmPS    = _rmPS    r ++ _rmPS    r'
-    , _rmBound = convexHull . nubBy (\a b -> dist a b < 5) $ _rmBound r ++ _rmBound r'
+    , _rmBound = _rmBound r ++ _rmBound r'
     }
-
+{- The top fourth of a room of a given height.  -}
-{-
-The top fourth of a room of a given height.
--}
 fourth 
     :: Float -- ^ Distance from center of room to top edge
     -> Room
@@ -107,24 +102,13 @@ fourth w = Room
     , _rmPS     = 
         [PS (0,w/2) 0 putLamp
         ]
-    , _rmBound  = [(w,w),(-w,w)]
+    , _rmBound  = [[(0,0),(w,w),(-w,w)]]
     }
-
+{- Randomly generate a top fourth of a room possibly with a wall.
-{-
+Add a light and a 'PutNothing' placement.  -}
-Randomly generate a top fourth of a room possibly with a wall.
-Add a light and a 'PutNothing' placement.
--}
 fourthWall :: RandomGen g => Float -> State g Room
 fourthWall w = do
     b <- takeOne 
-        --[   [ PS (20-w,w-40) 0  putLamp
-        --    , PS (w-20,w-40) pi PutNothing
-        --    ]
---        [   [ PS (20-w,w-40) 0  putLamp
---            , PS (0,40)      0  putLamp
---            , PS (w-20,w-40) pi PutNothing
---            , blockLine (w/2,w) (negate $ w/2,w/2)
---            ]
         [   [ PS (20-w,w-40) 0  putLamp
             , PS (0,40)      0  putLamp
             , PS (w-20,w-20) pi PutNothing
@@ -147,7 +131,7 @@ fourthWall w = do
         , _rmLinks  = [((0,w), 0)]
         , _rmPath   = [((0,w),(0,0)),((0,0),(0,w))]
         , _rmPS     = b
-        , _rmBound  = [(w,w),(-w,w)]
+        , _rmBound  = [[(0,0),(w,w),(-w,w)]]
         }
 
 fourthCorner :: Float -> Room
@@ -159,7 +143,7 @@ fourthCorner w = Room
         ]
     , _rmPath   = [((0,w),(0,0)),((0,0),(0,w))]
     , _rmPS     = [PS (0,w) 0 putLamp]
-    , _rmBound  = [(w,w),(0,2*w),(-w,w)]
+    , _rmBound  = [[(w,w),(0,2*w),(-w,w)]]
     }
 
 fourthCornerWall :: RandomGen g => Float -> State g Room
@@ -196,9 +180,9 @@ fourthCornerWall w = do
             ]
         , _rmPath   = [((0,w),(0,0)),((0,0),(0,w))]
         , _rmPS     = b
-        , _rmBound  = [(w,w),(0,2*w),(-w,w)]
+        , _rmBound  = [[(w,w),(0,2*w),(-w,w)]]
         }
-
+{- | Replace the first 'PutNothing' with a given 'PSType'. -}
 fillNothingPlacement :: PSType -> Room -> Room
 fillNothingPlacement pst r =
     r & rmPS %~ replaceNothingWith pst
@@ -206,17 +190,20 @@ fillNothingPlacement pst r =
     replaceNothingWith x (PS p rot PutNothing: pss) = PS p rot x : pss
     replaceNothingWith x (ps:pss) = ps : replaceNothingWith x pss
     replaceNothingWith _ [] = []
-
+{- | Successively fill 'PutNothing' placements with a list of given 'PSType's.
+-}
 fillNothingPlacements :: [PSType] -> Room -> Room
 fillNothingPlacements pst r = foldr fillNothingPlacement r pst
-
+{- | Randomise the ordering of placements in a room.
+Useful for randomising the position of generic placements such as 'PutNothing'. -}
 shufflePlacements :: RandomGen g => Room -> State g Room
 shufflePlacements r = do
     newPSs <- shuffle $ _rmPS r
     return $ r & rmPS .~ newPSs
-
+{- | A randomly generate room based on four randomly generated corners. 
-testRoom :: RandomGen g => State g Room
+Tight corridors, random placements. -}
-testRoom = do
+randomFourCornerRoom :: RandomGen g => State g Room
+randomFourCornerRoom = do
     corners <- replicateM 4 . join $ takeOne [fourthWall 100, fourthCornerWall 100]
     nItms <- state $ randomR (1,2)
     itms <- takeN nItms $ fmap PutFlIt $ [autoRadar,autoSonar,remoteLauncher,jetPack,blinkGun] ++ replicate 5 (medkit 500)
@@ -228,7 +215,6 @@ testRoom = do
         . foldr1 combineRooms 
         $ zipWith (\r a -> shiftRoomBy ((0,0),a) r) corners [0,pi/2,pi,3*pi/2]
         )
-
 {- | Creates room with a central vault with doors around it.
 -}
 centerVaultRoom
@@ -268,7 +254,7 @@ centerVaultRoom n w h d = do
             ]
             ++ concat (zipWith (\i r -> map (shiftPSBy ((0,0),r)) $ theDoor i) 
                         [n, n+1, n+2, n+3] [0,pi/2,pi,3*pi/2])
-        , _rmBound  = rectNSWE h (-h) (-w) w
+        , _rmBound  = [rectNSWE h (-h) (-w) w]
         }
   where
     col = dim $ dim $ bright red

src/Dodge/Room/RoadBlock.hs

@@ -47,7 +47,7 @@ litCorridor90 = do
             , PS ( 20,h-40) 0   $ PutID 0
             , PS (-20,h-80) 0   $ PutID 2
             ]
-        , _rmBound = poly
+        , _rmBound = [poly]
         }
 
 noWeaponTest :: RandomGen g => State g (Tree (Either Room Room))

src/Dodge/Room/Treasure.hs

@@ -39,7 +39,7 @@ triLootRoom w h = pure $ Room
         ,PS (0,h-15)  0 putLamp
         ,PS (0,-60)  0 putLamp
         ]
-    , _rmBound  = convexHull $ tri ++ base
+    , _rmBound  = [tri , base]
     }
   where
     tri =