Random tree structure generation of rooms

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