Random tree structure generation of rooms

src/Dodge/Room/Corridor.hs

@@ -0,0 +1,67 @@
+module Dodge.Room.Corridor
+    where
+import Dodge.Room.Data
+import Geometry
+
+corridor :: Room
+corridor = Room
+    { _rmPolys = [rectNSWE 80 0 0 40
+                 ,[(0,80), (0,80) +.+ rotateV (pi/3) (40,0),(40,80)]
+                 ,[(40,0), (0,0) +.+ rotateV (0-pi/3) (40,0),( 0, 0)]
+                 ]
+    , _rmLinks = lnks
+    , _rmPath  = concatMap (doublePair . (,) (20,60)) $ map fst lnks
+    , _rmPS    = []
+    , _rmBound = [] -- rectNSWE 50 30 0 40
+    }
+  where 
+    lnks = 
+        [((20,70)  ,0)
+        ,((20,80) +.+ rotateV (0-pi/3) (-10,0),  pi/6)
+        ,((20,80) +.+ rotateV (  pi/3) ( 10,0),0-pi/6)
+        ,((20,10)    ,pi)
+        ]
+corridorN :: Room
+corridorN = Room
+    { _rmPolys = [rectNSWE 80 0 0 40
+                 ]
+    , _rmLinks = lnks
+    , _rmPath  = pth
+    , _rmPS    = []
+    , _rmBound = rectNSWE 50 30 0 40
+    }
+    where lnks = [((20,70)  ,0)
+                 ,((20,10)    ,pi)
+                 ]
+          pth = doublePair ((20,70),(20,10))
+
+tEast :: Room
+tEast = Room
+    { _rmPolys = [rectNSWE 80 0  (-20) (20)
+                 ,rectNSWE 80 40 (-40) 40
+                 ]
+    , _rmLinks = lnks
+    , _rmPath  = concatMap (doublePair . (,) (0,60)) $ map fst lnks
+    , _rmPS    = []
+    , _rmBound = rectNSWE 70 10 0 40
+    }
+    where lnks = [(( 30,60),-pi/2)
+                 ,((-30,60),pi/2)
+                 ,((0,10),pi)
+                 ]
+tWest :: Room
+tWest = Room
+    { _rmPolys = [rectNSWE 80 0  (-20) (20)
+                 ,rectNSWE 80 40 (-40) 40
+                 ]
+    , _rmLinks = lnks
+    , _rmPath  = concatMap (doublePair . (,) (0,60)) $ map fst lnks
+    , _rmPS    = []
+    , _rmBound = rectNSWE 70 10 0 40
+    }
+  where 
+    lnks = 
+        [((-30,60),pi/2)
+        ,(( 30,60),-pi/2)
+        ,((0,10),pi)
+        ]

src/Dodge/Room/Link.hs

@@ -0,0 +1,57 @@
+module Dodge.Room.Link
+    where
+import Dodge.LevelGen
+import Dodge.LevelGen.Data
+import Dodge.Room.Data
+import Dodge.RandomHelp
+import Geometry
+
+import System.Random
+import Control.Monad.State
+import Control.Lens
+import Data.List (delete)
+
+randLinks :: RandomGen g => Room -> State g Room
+randLinks r = do
+    newLinks <- shuffle $ init $ _rmLinks r
+    return $ r {_rmLinks = newLinks ++ [last $ _rmLinks r]}
+
+filterLinks :: RandomGen g => ((Point2,Float) -> Bool) -> Room -> State g Room
+filterLinks cond r = do
+    newLinks <- shuffle $ filter cond $ init $ _rmLinks r
+    return $ r {_rmLinks = newLinks ++ [last $ _rmLinks r]}
+
+changeLinkTo :: RandomGen g => ((Point2,Float) -> Bool) -> Room -> State g Room
+changeLinkTo cond r = do
+    l <- takeOne $ filter cond $ _rmLinks r
+    let newLinks = delete l (_rmLinks r) ++ [l]
+    return $ r {_rmLinks = newLinks}
+
+{- | Move a room so that the last link in '_rmLinks' lines up to 
+an external point and direction.
+This is intended to work when the external point is an outgoing link from another room.
+-}
+shiftRoomToLink :: (Point2,Float) -> Room -> Room
+shiftRoomToLink l r 
+    = shiftRoomBy l 
+    . shiftRoomBy ((0,0) -.- (rotateV (pi-a) p),0) 
+    $ shiftRoomBy ((0,0),pi-a)  r
+  where 
+    (p,a) = last $ _rmLinks r
+
+shiftRoomBy :: (Point2,Float) -> Room -> Room
+shiftRoomBy shift@(pos,rot) r = 
+   over rmPolys (fmap (map (shiftPointBy shift)))
+   $ over rmLinks (fmap (shiftLinkBy shift))
+   $ over rmPath (map (shiftPathPointBy shift))
+   $ over rmPS (fmap (shiftPSBy shift))
+   $ over rmBound (map (shiftPointBy shift))
+   r
+
+shiftLinkBy (pos,rot) (p,r) = (shiftPointBy (pos,rot) p, r + rot)
+shiftPSBy (pos,rot) ps = case ps of
+    PS {} -> over psPos (shiftPointBy (pos,rot))
+                            $ over psRot (+rot)
+                            ps
+
+shiftPathPointBy s (p1,p2) = (shiftPointBy s p1, shiftPointBy s p2)