Add tree structure generation

src/Dodge/Room/CheckConsistency.hs

@@ -0,0 +1,17 @@
+module Dodge.Room.CheckConsistency
+  where
+import Dodge.Room.Data
+import Dodge.Graph
+
+linksOnPath :: Room -> Bool
+linksOnPath r = all pointOnPath linkPoints
+  where
+    linkPoints = map fst $ _rmLinks r
+    pointOnPath p = elem p $ concatMap flat2 $ _rmPath r
+    flat2 (x,y) = [x,y]
+
+pathConnected :: Room -> Bool
+pathConnected = isSingleton . pairsToSCC . _rmPath
+  where
+    isSingleton (_:[]) = True
+    isSingleton _ = False

src/Dodge/Room/Placement.hs

@@ -1,3 +1,4 @@
+-- | Module defining helper placements for rooms.
 module Dodge.Room.Placement
   where
 import Dodge.Data
@@ -7,7 +8,6 @@ import Dodge.Creature.Inanimate
 
 import Geometry
 
--- module defining helper placements for rooms
 
 putLamp = PutCrit lamp
 

src/Dodge/Room/Procedural.hs

@@ -0,0 +1,60 @@
+module Dodge.Room.Procedural
+  where
+import Dodge.Room.Data
+import Dodge.Room.Placement
+import Dodge.LevelGen
+import Dodge.LevelGen.Data
+import Geometry
+
+import Data.List (nub,sortBy)
+import Data.Function (on)
+{-
+A simple rectangular room with a light in the center.
+Creates links and pathfinding graph.
+ -}
+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
+    { _rmPolys = [rectNSWE  y 0 0 x ]
+    , _rmLinks = lnks
+    , _rmPath  = concatMap doublePair pth
+    , _rmPS    = [PS (x/2,y/2) 0 $ putLamp]
+    , _rmBound = rectNSWE (y+5) (-5) (-5) (x+5)
+    }
+  where 
+    yd = (y - 40) / fromIntegral yn
+    xd = (x - 40) / fromIntegral xn
+    elnks = flip zip (repeat ( pi/2)) $ translateS (0,20) $ gridPoints  0  1      yd (yn+1)
+    wlnks = flip zip (repeat (-pi/2)) $ translateS (x,20) $ gridPoints  0  1      yd (yn+1)
+    nlnks = flip zip (repeat (    0)) $ translateS (20,y) $ gridPoints xd (xn+1)  0  1
+    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)
+
+roomRectAutoLinks :: Float -> Float -> Room
+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 
+                         $ concatMap (\p -> map (\(a,b) -> (p +.+ a,p +.+ b)) $ makeRect x y)
+                         $ gridPoints x nx y ny
+
+gridPoints :: Float -> Int -> Float -> Int -> [Point2]
+gridPoints x nx y ny = [(a,b) | a <- take nx $ scanl (+) 0 $ repeat x
+                              , b <- take ny $ scanl (+) 0 $ repeat y
+                       ]
+
+makeRect :: Float -> Float -> [(Point2,Point2)]
+makeRect x y = [((0,0),(x,0))
+               ,((0,0),(0,y))
+               ,((x,y),(x,0))
+               ,((x,y),(0,y))
+               ]
+
+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)