Tweak wall cutting, removes inverse walls

src/Dodge/Floor.hs

@@ -31,7 +31,8 @@ import System.Random
 roomTreex :: RandomGen g => State g (Maybe [Room])
 roomTreex = do
     struct' <- aTreeStrut
-    let struct = treePost [[SpecificRoom $ fmap (pure . Right) pistolerRoom]] [EndRoom]
+--    let struct = treePost [[SpecificRoom $ fmap (pure . Right) pistolerRoom]] [EndRoom]
+    let struct = treePost [[SpecificRoom $ fmap (pure . Right) $ pure testRoom]] [EndRoom]
     let t' = padCorridors struct
         t = treeTrunk 
                 [[StartRoom]

src/Dodge/Item/Weapon/TriggerType.hs

@@ -1,3 +1,6 @@
+{-
+Weapon effects when pulling the trigger.
+ -}
 module Dodge.Item.Weapon.TriggerType
     where
 import Dodge.Data
@@ -6,20 +9,20 @@ import Dodge.CreatureAction (reloadWeapon)
 import Dodge.WorldEvent (muzzleFlashAt,tempLightForAt)
 import Dodge.WorldEvent.Cloud
 import Dodge.RandomHelp
-
 import Dodge.Item.Weapon.Bullet
-
 import Geometry
 
 import System.Random
-
 import Control.Lens
 import Control.Monad.State
-
 import Data.Maybe
 import qualified Data.IntMap.Strict as IM
 
-withThinSmoke :: (Int -> World -> World) -> Int -> World -> World
+withThinSmoke 
+    :: (Int -> World -> World) -- ^ Underlying effect
+    -> Int      -- ^ Creature id
+    -> World 
+    -> World
 withThinSmoke eff cid w = eff cid . foldr makeThinSmokeAt w $ map (+.+ pos) ps
     where
           cr = _creatures w IM.! cid
@@ -27,7 +30,11 @@ withThinSmoke eff cid w = eff cid . foldr makeThinSmokeAt w $ map (+.+ pos) ps
           pos = _crPos cr +.+ ((_crRad cr +0.5) *.* unitVectorAtAngle dir)
           ps = (sequence . replicate 5 . randInCirc) 8 & evalState $ _randGen w
 
-withThickSmoke :: (Int -> World -> World) -> Int -> World -> World
+withThickSmoke 
+    :: (Int -> World -> World) -- ^ Underlying effect
+    -> Int      -- ^ Creature id
+    -> World 
+    -> World
 withThickSmoke eff cid w = eff cid . foldr makeThickSmokeAt w $ map (+.+ pos) ps
     where
           cr = _creatures w IM.! cid
@@ -35,8 +42,16 @@ withThickSmoke eff cid w = eff cid . foldr makeThickSmokeAt w $ map (+.+ pos) ps
           pos = _crPos cr +.+ ((_crRad cr +15) *.* unitVectorAtAngle dir)
           ps = (sequence . replicate 20 . randInCirc) 8 & evalState $ _randGen w
 
-
+{- Shoot a weapon rapidly after a warm up.
-withWarmUp :: Int -> (Int -> World -> World) -> Int -> World -> World
+Applies ammo check as well.
+-}
+withWarmUp 
+    :: Int  -- ^ Warm up time (in frames)
+    -> (Int -> World -> World) 
+            -- ^ Shoot effect
+    -> Int  -- ^ Creature id
+    -> World 
+    -> World
 withWarmUp t f cid w 
     | reloadCondition = fromMaybe w $ reloadWeapon cid w
     | _wpReloadState item /= 0 = w
@@ -65,7 +80,13 @@ withWarmUp t f cid w
     fRate = _wpFireRate item
     reloadCondition = _wpLoadedAmmo item == 0
 
-withSound :: Int -> (Int -> World -> World) -> Int -> World -> World
+{- Adds a sound to a creature based world effect. 
+ The sound is emitted from the creature's position. -}
+withSound 
+    :: Int -- ^ Sound id
+    -> (Int -> World -> World) -- ^ Underlying effect
+    -> Int -- ^ Creature id
+    -> World -> World
 withSound soundid f cid w = (soundOncePos soundid p . f cid) w
   where
     p = _crPos (_creatures w IM.! cid)
@@ -79,6 +100,7 @@ withRecoil
 withRecoil recoilAmount eff cid w = eff cid . over (creatures . ix cid) pushback $ w
   where 
     pushback cr = over crPos (+.+ rotateV (_crDir cr) ((-recoilAmount) / _crMass cr ,0)) cr
+
 withSidePush 
     :: Float    -- ^ Maximal possible side push amount
     -> (Int -> World -> World)  
@@ -91,7 +113,7 @@ withSidePush maxSide eff cid w = eff cid . over (creatures . ix cid) push $ w
     (pushAmount, _) = randomR (-maxSide,maxSide) $ _randGen w
 
 {- 
-Applies an effect and sound with an ammo check.
+Applies a world effect and sound effect after an ammo check.
 -}
 shootWithSound 
     :: Int  -- ^ Sound identifier
@@ -115,14 +137,19 @@ shootWithSound soundid f cid w
                       && _wpFireState item == 0
                       && _wpLoadedAmmo item > 0
     reloadCondition = _wpLoadedAmmo item == 0
-
+{- Applies a world effect after an ammo check. -}
-shoot :: (Int -> World -> World) -> Int -> World -> World
+shoot 
+    :: (Int -> World -> World) 
+            -- ^ Underlying effect, takes creature id as input
+    -> Int  -- ^ Creature id
+    -> World -> World
 shoot f cid w | fireCondition = over (pointerToItem . wpLoadedAmmo) (\ammo -> ammo-1) 
                                     $ set (pointerToItem . wpFireState) (_wpFireRate item)
                                     $ f cid w
               | reloadCondition = fromMaybe w $ reloadWeapon cid w
               | otherwise = w
-    where cr  = (_creatures w IM.! cid)
+  where 
+    cr  = (_creatures w IM.! cid)
     itRef = _crInvSel cr
     item = _crInv cr IM.! itRef
     pointerToItem = creatures . ix cid . crInv . ix itRef
@@ -139,65 +166,124 @@ withMuzFlare f cid w = tempLightForAt 3 pos
           pos = _crPos cr +.+ _crRad cr *.* unitVectorAtAngle (_crDir cr)
           pos2 = _crPos cr +.+ (2 * _crRad cr) *.* unitVectorAtAngle (_crDir cr)
 
-withRandomDir :: Float -> (Int -> World -> World) -> Int -> World -> World
+{-
+Rotates the creature randomly, applies the effect, rotates the creature back.
+-}
+withRandomDir 
+    :: Float    -- ^ Max possible rotation
+    -> (Int -> World -> World) 
+                -- ^ Underlying effect
+    -> Int      -- ^ Creature id
+    -> World 
+    -> World
 withRandomDir acc f cid w = over (creatures . ix cid . crDir) (\d -> d - a) 
                             . f cid 
                             . over (creatures . ix cid . crDir) (+ a)
                             $ set randGen g
                               w
     where (a, g) = randomR (-acc,acc) $ _randGen w
-
+{- Creates a bullet with a given velocity, width, and 'HitEffect'
-withVelWthHiteff :: Point2 -> Float -> HitEffect -> Int -> World -> World
+ -}
+withVelWthHiteff 
+    :: Point2       -- ^ Velocity, x direction is forward with respect to the creature
+    -> Float        -- ^ Bullet width
+    -> HitEffect    -- ^ Bullet effect when hitting creature, wall etc
+    -> Int          -- ^ Creature id
+    -> World 
+    -> World
 withVelWthHiteff vel width hiteff cid w 
-    = over particles' ((:) newbul)
+    = over particles' ((:) newbul) $ set randGen g w
-        $ set randGen g
+  where 
-        w
+    cr = _creatures w IM.! cid
-    where cr = _creatures w IM.! cid
     newbul = aGenBulAt' (Just cid) (numColor colid) pos (rotateV dir vel) hiteff width
     (colid, g) = randomR (0,11) $ _randGen w
     dir = _crDir cr
     pos = _crPos cr +.+ _crRad cr *.* unitVectorAtAngle (_crDir cr)
     pos2 = _crPos cr +.+ (2 * _crRad cr) *.* unitVectorAtAngle (_crDir cr)
-
+{- Translate the creature sideways a random amount, apply the effect, translate back. -}
-withRandomOffset :: Float -> (Int -> World -> World) -> Int -> World -> World
+withRandomOffset 
-withRandomOffset offsetAmount f cid w = over (creatures . ix cid . crPos) (-.- offV) 
+    :: Float    -- ^ Max possible translate
+    -> (Int -> World -> World)
+                -- ^ Underlying effect
+    -> Int      -- ^ Creature id
+    -> World 
+    -> World
+withRandomOffset offsetAmount f cid w 
+    = over (creatures . ix cid . crPos) (-.- offV) 
         . f cid 
         . over (creatures . ix cid . crPos) (+.+ offV)
         $ set randGen g
           w
-    where (offsetVal , g) = randomR (-offsetAmount,offsetAmount) $ _randGen w
+  where 
+    (offsetVal , g) = randomR (-offsetAmount,offsetAmount) $ _randGen w
     cr = _creatures w IM.! cid
     offV = rotateV (_crDir cr) (0,offsetVal)
 
-torqueBeforeForced :: Float -> (Int -> World -> World) -> Int -> World -> World
+-- | Rotates a creature with minimum rotation at least 0.1.
+-- Rotates the player creature before applying the effect, other creatures after.
+torqueBeforeForced 
+    :: Float    -- ^ Max possible rotation (less the 0.1 forced rotation)
+    -> (Int -> World -> World) 
+                -- ^ Underlying effect
+    -> Int      -- ^ Creature id
+    -> World 
+    -> World
 torqueBeforeForced torque feff cid w 
     | cid == 0  = feff cid $ set randGen g $ over (creatures . ix cid . crDir) (+rot') 
                                            $ over cameraRot (+rot') w
     | otherwise = feff cid $ set randGen g $ over (creatures . ix cid . crDir) (+rot') w
-    where (rot, g) = randomR (-torque,torque) $ _randGen w
+  where 
+    (rot, g) = randomR (-torque,torque) $ _randGen w
     rot' | rot < 0   = rot - 0.1
          | otherwise = rot + 0.1
 
-torqueBefore :: Float -> (Int -> World -> World) -> Int -> World -> World
+-- | Rotates the player creature before applying an effect, other creatures after.
+torqueBefore 
+    :: Float    -- ^ Max possible rotation
+    -> (Int -> World -> World) 
+                -- ^ Underlying effect
+    -> Int 
+                -- ^ Creature id
+    -> World 
+    -> World
 torqueBefore torque feff cid w 
     | cid == 0  = feff cid $ set randGen g $ over (creatures . ix cid . crDir) (+rot) 
                                            $ over cameraRot (+rot) w
     | otherwise = feff cid $ set randGen g $ over (creatures . ix cid . crDir) (+rot) w
-    where (rot, g) = randomR (-torque,torque) $ _randGen w
+  where 
-
+    (rot, g) = randomR (-torque,torque) $ _randGen w
-torqueAfter :: Float -> (Int -> World -> World) -> Int -> World -> World
+-- | Rotate a randomly creature after applying an effect.
+torqueAfter
+    :: Float    -- ^ Max possible rotation
+    -> (Int -> World -> World) 
+                -- ^ Underlying effect
+    -> Int 
+                -- ^ Creature id
+    -> World 
+    -> World
 torqueAfter torque feff cid w 
     | cid == 0  = rotateScope $ set randGen g $ over cameraRot (+rot) $ feff cid w
     | otherwise = set randGen g $ over (creatures . ix cid . crDir) (+rot) $ feff cid w
-    where (rot, g) = randomR (-torque,torque) $ _randGen w
+  where 
+    (rot, g) = randomR (-torque,torque) $ _randGen w
     rotateScope w = w & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0))
                           . itAttachment . _Just . scopePos %~ rotateV rot 
-
+{- Create multiple bullets with a given spread, a given amount, given velocity,
-spreadNumVelWthHiteff :: Float -> Int -> Point2 -> Float -> HitEffect -> Int -> World -> World
+given width and given 'HitEffect'.
+ -}
+spreadNumVelWthHiteff 
+    :: Float    -- ^ Spread
+    -> Int      -- ^ Number of bullets
+    -> Point2   -- ^ Velocity, x is direction of creature
+    -> Float    -- ^ Bullet width
+    -> HitEffect -- ^ Effect when hitting creature, wall etc
+    -> Int      -- ^ Creature id
+    -> World 
+    -> World
 spreadNumVelWthHiteff spread num vel wth eff cid w 
-    = over particles' (newbuls ++)
+    = over particles' (newbuls ++) w
-        w
+  where 
-    where cr = _creatures w IM.! cid
+    cr = _creatures w IM.! cid
     newbuls = zipWith3 (\pos d colid -> aGenBulAt' (Just cid) (numColor colid) 
                                               pos (rotateV d vel) eff wth
                       ) poss dirs colids
@@ -208,11 +294,21 @@ spreadNumVelWthHiteff spread num vel wth eff cid w
                             $ randomRs (0,spread/5) (_randGen w)
     colids = take num $ randomRs (0,11) (_randGen w)
 
-numVelWthHitEff :: Int -> Point2 -> Float -> HitEffect -> Int -> World -> World
+{- Create a number of bullets side by side with a given velocity,
+given width and given 'HitEffect'.
+ -}
+numVelWthHitEff 
+    :: Int      -- ^ Amount of bullets
+    -> Point2   -- ^ Velocity, x axis is direction of creature
+    -> Float    -- ^ Bullet width
+    -> HitEffect -- ^ Effect when hitting creature, wall etc
+    -> Int      -- ^ Creature id
+    -> World 
+    -> World
 numVelWthHitEff  num vel wth eff cid w 
-    = over particles' (newbuls ++)
+    = over particles' (newbuls ++) w
-        w
+  where 
-    where cr = _creatures w IM.! cid
+    cr = _creatures w IM.! cid
     newbuls = zipWith (\pos colid -> aGenBulAt' (Just cid) (numColor colid) 
                                                 pos (rotateV d vel) eff wth
                       ) 

src/Dodge/Layout.hs

@@ -5,6 +5,7 @@ module Dodge.Layout
     where
 import Dodge.Data
 import Dodge.LevelGen
+import Dodge.LevelGen.StaticWalls
 import Dodge.LevelGen.Data
 import Dodge.Base
 import Dodge.RandomHelp
@@ -77,6 +78,7 @@ wallsFromTree t =
 --    createInnerWalls 
     divideWalls 
     . assignKeys 
+    . removeInverseWalls
     . foldr cutWalls [] -- map (map (g . roundPoint2)) 
 --    . map (map roundPoint2)
     $ (concatMap _rmPolys $ flatten t)
@@ -88,7 +90,8 @@ wallsFromTree t =
 wallsFromRooms :: [Room] -> IM.IntMap Wall
 wallsFromRooms =
 --    divideWalls .
-    IM.fromList . zip [0..] . zipWith f [0..] . foldr cutWalls [] . concatMap _rmPolys
+    IM.fromList . zip [0..] . zipWith f [0..] . removeInverseWalls 
+        . foldr cutWalls [] . concatMap _rmPolys
   where
     f i (x,y) = defaultWall {_wlLine = [x,y] , _wlID = i}
 

src/Dodge/LevelGen/StaticWalls.hs

@@ -7,22 +7,38 @@ module Dodge.LevelGen.StaticWalls
 import Dodge.Data
 import Dodge.Base
 import Dodge.Default
-
 import Geometry
 
 import Control.Lens
-
 import Data.Function (on)
-
 import Data.Graph
 import Data.List
 import Data.Maybe
 import qualified Data.IntMap as IM
-
 import qualified Data.Set as S
 
 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)
+    | elem (b,a) 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, expand poly and retry.

src/Dodge/Room.hs

@@ -125,7 +125,7 @@ door = Room
                  ,((20, 5),pi)
                  ]
 roomPillars :: Room
-roomPillars = over rmLinks init $ set rmPS plmnts $ roomRect' 240 240 2 2
+roomPillars = over rmLinks init $ set rmPS plmnts $ roomRect 240 240 2 2
   where 
     plmnts = PS (120,120) 0 putLamp 
         : PS (10,10) 0 putLamp 
@@ -171,7 +171,7 @@ glassSwitchBack = do
                  ,blockLine (wth-wllen, 4*hf) (  wth,4*hf)
                  , PS (wth/2,hgt/2) 0 $ putLamp
                  ]
-    return $ set rmPS plmnts $ roomRect' wth hgt 2 6
+    return $ set rmPS plmnts $ roomRect wth hgt 2 6
 
 manyDoors :: Int -> Tree (Either Room Room)
 manyDoors i = treePost (replicate i (Left door)) $ Right door
@@ -182,9 +182,9 @@ glassLesson = do
     return $ Node (Left $ botRoom) [deadRoom door,uppers, treePost (Left door : corridors) $ Right door]
         where uppers = Node (Left door) [deadRoom topRoom]
               botRoom = set rmPS botplmnts 
-                                 $ roomRect' 200 200 1 1
+                                 $ roomRect 200 200 1 1
               topRoom = set rmPS topplmnts 
-                                 $ roomRect' 200 200 1 1
+                                 $ roomRect 200 200 1 1
               botplmnts = [PS (0,0) 0 $ PutWindow (rectNSWE (200) 0 (90) (110)) 
                                       $ withAlpha 0.5 aquamarine
                           ,PS (50,100) 0 $ PutCrit miniGunCrit
@@ -218,7 +218,7 @@ miniRoom1 = do
                      ,blockLine (        0, 40+3*hf) (wllen,40+3*hf)
                      ,blockLine (wth-wllen, 40+4*hf) (  wth,40+4*hf)
                      ]
-        return $ set rmPS plmnts $ shiftRoomBy ((0,40),0) $ roomRect' wth hgt 2 4
+        return $ set rmPS plmnts $ shiftRoomBy ((0,40),0) $ roomRect wth hgt 2 4
 
 miniTree2 :: RandomGen g => State g (Tree (Either Room Room))
 miniTree2 = miniRoom1 >>= randomiseOutLinks >>= changeLinkTo (\p -> (snd . fst) p < 70) 
@@ -277,7 +277,7 @@ roomMiniIntro = fmap (g . expandTreeBy f) $ sequence $ treePost
 
 roomCenterPillar :: RandomGen g => State g Room
 roomCenterPillar = changeLinkTo ((\p -> dist p (120,0) < 10) . fst) 
-                        $ set rmPS plmnts $ roomRect' 240 240 2 2
+                        $ set rmPS plmnts $ roomRect 240 240 2 2
     where plmnts = [ blockLine (115,115) (115,125)
                    , blockLine (125,115) (125,125)
                    , PS (40,120) 0 putLamp
@@ -342,7 +342,7 @@ weaponEmptyRoom = do
                  ,PS (w/2,h/2) 0 $ putLamp
                  ]
     (fmap connectRoom . randomiseOutLinks) =<< (changeLinkTo ((\p -> dist p (w/2,0) < 10) . fst) 
-                        $ set rmPS plmnts $ roomRect' w h 2 2)
+                        $ set rmPS plmnts $ roomRect w h 2 2)
      
 
 weaponUnderCrits :: RandomGen g => State g (Tree (Either Room Room))
@@ -520,7 +520,7 @@ longRoom = do
                     ]
     brls <- fmap (map (\p -> PS (p +.+ (10,200)) 0 $ PutCrit explosiveBarrel) )
                             $ sequence $ replicate 5 $ randInRect (w-20) 900
-    let rm = roomRect' w (h+70) 1 1 & rmPolys %~ ( (++) 
+    let rm = roomRect w (h+70) 1 1 & rmPolys %~ ( (++) 
                                                    [rectNSWE h (h-165) (-45) (w+45)
                                                    ]
                                                  )
@@ -548,7 +548,7 @@ shooterRoom = do
                                    ,PS ( 75,h-80) 0 putLamp
                                    ]
                                  ) 
-                      $ roomRect' 100 h 1 1
+                      $ roomRect 100 h 1 1
                       
 
 shootersRoom1 :: RandomGen g => State g Room
@@ -628,7 +628,7 @@ pistolerRoom = do
                   ++ 
                  concat [f x y | x<-xs,y<-ys]
     return 
-        $ set rmPS plmnts $ roomRect' w h (max i 2) (max i 2)
+        $ set rmPS plmnts $ roomRect w h (max i 2) (max i 2)
 
 shootingRange :: RandomGen g => State g (Tree (Either Room Room))
 shootingRange = do
@@ -658,5 +658,5 @@ spawnerRoom = do
                  ,PS (x/2, y-10) 0 putLamp
                  ]
     let f ((lx,_),_) = lx < x/2-5 
-    roomWithSpawner <- (fmap connectRoom . randomiseOutLinks) =<< filterLinks f (set rmPS plmnts $ roomRect' x y 2 2) 
+    roomWithSpawner <- (fmap connectRoom . randomiseOutLinks) =<< filterLinks f (set rmPS plmnts $ roomRect x y 2 2) 
     return $ treeTrunk [Left (airlock 0)] roomWithSpawner

src/Dodge/Room/Procedural.hs

@@ -1,12 +1,19 @@
+{-
+Procedural creation of rooms.
+-}
 module Dodge.Room.Procedural
-  where
+    ( roomRect
+    , roomRectAutoLinks
+    , testRoom
+    ) where
 import Dodge.Room.Data
 import Dodge.Room.Placement
+import Dodge.Room.Link
 import Dodge.LevelGen
 import Dodge.LevelGen.Data
 import Geometry
 
-import Data.List (nub,sortBy)
+import Data.List (nub,nubBy,sortBy)
 import Data.Function (on)
 --import Control.Monad.State
 --import System.Random
@@ -14,13 +21,13 @@ import Data.Function (on)
 A simple rectangular room with a light in the center.
 Creates links and pathfinding graph.
  -}
-roomRect'
+roomRect
     :: Float    -- ^ Width
     -> Float    -- ^ Height
     -> Int      -- ^ Number of links on vertical walls
     -> Int      -- ^ Number of links on horizontal walls
     -> Room
-roomRect' x y xn yn = Room
+roomRect x y xn yn = Room
     { _rmPolys = [rectNSWE  y 0 0 x ]
     , _rmLinks = lnks
     , _rmPath  = concatMap doublePair pth
@@ -36,9 +43,11 @@ roomRect' x y xn yn = Room
     slnks = flip zip (repeat (   pi)) $ translateS (20,0) $ gridPoints xd (xn+1)  0  1
     lnks = nlnks ++ elnks ++ wlnks ++ slnks
     pth  = linksAndPath lnks $ translateS (20,20) (makeGrid xd xn yd yn)
-
+{-
+Creates a rectangular room, automatically creates links and pathfinding graph at a sensible size.
+-}
 roomRectAutoLinks :: Float -> Float -> Room
-roomRectAutoLinks x y = roomRect' x y ((ceiling x - 40) `div` 60) ((ceiling y - 40) `div` 60)
+roomRectAutoLinks x y = roomRect x y ((ceiling x - 40) `div` 60) ((ceiling y - 40) `div` 60)
 
 makeGrid :: Float -> Int -> Float -> Int -> [(Point2,Point2)]
 makeGrid x nx y ny = nub $ concatMap doublePair 
@@ -61,3 +70,33 @@ linksAndPath :: [(Point2,Float)] -> [(Point2,Point2)] -> [(Point2,Point2)]
 linksAndPath lnks subpth = subpth ++ concatMap linkClosest lnks
     where linkClosest (p,_) = doublePair (p, head $ sortBy (compare `on` dist p) $ map fst subpth)
 
+{- Combines two rooms into one room.
+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'
+    }
+
+northSegment :: Room
+northSegment = Room
+    { _rmPolys  = [ [(0,0),(200,200),(-200,200)] ]
+    , _rmLinks  = [((0,200), 0)]
+    , _rmPath   = [((0,200),(0,0)),((0,0),(0,200))]
+    , _rmPS     = [PS (0,100) 0 putLamp]
+    , _rmBound  = [(200,200),(-200,200)]
+    --, _rmBound  = []
+    }
+
+testRoom :: Room
+testRoom = foldr1 combineRooms $ map (\a -> shiftRoomBy ((0,0),a) northSegment) [0,pi/2,pi,3*pi/2]
+
+---- -- -{- Combines multiple rooms into one room.
+---- -- -Combines into one big poly and one big bound, and concatenates the rest.
+---- -- --}
+---- -- -combineRooms :: [Room] -> Room
+---- -- -combineRooms rs = foldr f 

src/Geometry.hs

@@ -164,6 +164,19 @@ orderPolygon ps = sortBy (compare `on` \p -> argV (p -.- cen)) ps
   where 
     cen = 1/ fromIntegral (length ps) *.* foldr1 (+.+) ps
 
+-- | Adds a point to a convex polygon.
+-- If the point is inside, returns the original.
+-- Points ordered anticlockwise, input not checked.
+addPointPolygon :: Point2 -> [Point2] -> [Point2]
+addPointPolygon p ps
+    | pointInOrOnPolygon p ps = ps
+    | otherwise = orderPolygon $ p : ps
+
+-- | Creates the convex hull of a set of points.
+convexHull :: [Point2] -> [Point2]
+convexHull (x:y:z:xs) = foldr addPointPolygon (orderPolygon (x:y:z:[])) xs
+convexHull _ = error "Tried to create the convex hull of two or less points"
+
 -- | Return distance between two points.
 dist :: Point2 -> Point2 -> Float
 {-# INLINE dist #-}