Add tree structure generation

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)