Random tree structure generation of rooms

src/Dodge/Layout/Tree/Annotate.hs

@@ -5,6 +5,10 @@ module Dodge.Layout.Tree.Annotate
     where
 import Dodge.RandomHelp
 import Dodge.Layout.Tree.Polymorphic
+import Dodge.Room.Procedural
+import Dodge.Room.Link
+import Dodge.Room.Data
+import Dodge.Room
 
 import Data.Tree
 import Control.Monad.State
@@ -13,6 +17,7 @@ import System.Random
 data Annotation
     = Lock Int
     | Key  Int
+    | Corridor
 
 addLock :: RandomGen g => Int -> Tree [Annotation] -> State g (Tree [Annotation])
 addLock i t = do
@@ -20,5 +25,9 @@ addLock i t = do
     newBefore <- applyToRandomNode (Key i :) beforeLock
     return $ addToTrunk newBefore [Node [Lock i] afterLock]
 
---annoToRoom :: RandomGen g => [Annotation] -> State g (Either Room Room)
---annoToRoom as = undefined
+padCorridors :: Tree [Annotation] -> Tree [Annotation]
+padCorridors (Node x xs) = Node [Corridor] [Node x (map padCorridors xs)]
+
+annoToRoom :: RandomGen g => [Annotation] -> State g Room
+annoToRoom [Corridor] = takeOne [corridor]
+annoToRoom _ = randLinks $ roomRectAutoLinks 200 200

src/Dodge/Layout/Tree/Either.hs

@@ -3,6 +3,8 @@ Combining and composing trees with 'Either' nodes.
 -}
 module Dodge.Layout.Tree.Either
     ( expandTreeBy
+    , connectRoom
+    , deadRoom
     ) where
 import Data.Tree
 
@@ -20,3 +22,15 @@ expandTreeBy f (Node x xs) = appendAndRemove $ f x
 
 removeEither (Left y)  = y
 removeEither (Right y) = y
+
+{- 
+Make a singleton connection of an Either Tree.
+-}
+connectRoom :: a -> Tree (Either a a)
+connectRoom r = Node (Right r) [] 
+
+{-
+Make a singleton dead end of an Either Tree.
+-}
+deadRoom :: a -> Tree (Either a a)
+deadRoom r = Node (Left r) []

src/Dodge/Layout/Tree/Polymorphic.hs

@@ -29,7 +29,7 @@ treeTrunk (x:xs) t = Node x [treeTrunk xs t]
 Applies a function to the root of a tree.
 -}
 applyToRoot :: (a -> a) -> Tree a -> Tree a
-applyToRoot f (Node x xs) = Node (f x) xs
+applyToRoot f (Node t ts) = Node (f t) ts
 
 treeSize = length . flatten
 

src/Dodge/Layout/Tree/Shift.hs

@@ -0,0 +1,55 @@
+module Dodge.Layout.Tree.Shift
+    where
+import Dodge.Room.Data
+import Dodge.Room.Link
+import Dodge.Layout.Tree.Polymorphic
+import Geometry
+
+import Data.Tree
+import Data.Sequence hiding (zipWith)
+import Data.List (delete)
+import Data.Maybe (listToMaybe)
+import Control.Lens hiding (Empty, (<|) , (|>))
+
+shiftRoomTreeConstruct :: [[Point2]] -> Tree Room -> Maybe (Tree Room)
+shiftRoomTreeConstruct bs (Node t ts)
+    | roomIsClipping = Nothing
+    | otherwise = case children of
+        Nothing -> Nothing
+        Just ts' -> Just $ Node t ts'
+  where
+    roomIsClipping = any (polysIntersect (_rmBound t)) bs
+    children = sequence 
+             $ zipWith (\l -> shiftRoomTreeConstruct (_rmBound t : bs) 
+                                    . applyToRoot (shiftRoomToLink l))
+                       (_rmLinks t)
+                       ts
+
+shiftRoomTreeSearch :: [[Point2]] -> Seq (Tree Room) -> Maybe [Room]
+shiftRoomTreeSearch _  Empty = Just []
+shiftRoomTreeSearch bs (Node r ts :<| ts')
+    | roomIsClipping = Nothing
+    | otherwise = fmap (r :) $ shiftRoomTreeSearch newBounds $ ts' >< children
+  where
+    roomIsClipping = any (polysIntersect (_rmBound r)) bs
+    newBounds = _rmBound r : bs
+    children = fromList $ zipWith (\l -> applyToRoot (shiftRoomToLink l))
+                       (_rmLinks r)
+                       ts
+
+shiftRoomTreeSearchAll :: [[Point2]] -> Seq (Tree Room) -> [[Room]]
+shiftRoomTreeSearchAll _ Empty = [[]]
+shiftRoomTreeSearchAll bs (Node r ts :<| ts')
+    | roomIsClipping = [] -- this is called too often, but whatever
+    | otherwise = case ts of
+        [] -> (r :) <$> (shiftRoomTreeSearchAll newBounds $ 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
+    roomIsClipping = any (polysIntersect (_rmBound r)) bs
+    rm l = r & rmLinks %~ delete l
+    f l = applyToRoot (shiftRoomToLink l)
+
+shiftExpandTree :: Tree Room -> Maybe [Room]
+shiftExpandTree = listToMaybe . shiftRoomTreeSearchAll [] . singleton