Dump some info to sdout when generating level

src/Dodge/Layout/Tree/Annotate.hs

@@ -47,8 +47,8 @@ addLock i t = do
     newBefore <- applyToRandomNode (Key i :) beforeLock
     return $ addToTrunk newBefore [Node [Lock i] afterLock]
 {- | Add one corridor between each parent-child link of a tree of annotations.  -}
-padCorridors :: Tree [Annotation g] -> Tree [Annotation g]
-padCorridors (Node x xs) = Node [Corridor] [Node x (map padCorridors xs)]
+padWithCorridors :: Tree [Annotation g] -> Tree [Annotation g]
+padWithCorridors (Node x xs) = Node [Corridor] [Node x (map padWithCorridors xs)]
 {- Add one to three corridors between each parent-child link of a tree of annotations.  -}
 randomPadCorridors :: RandomGen g => Tree [Annotation g] -> State g (Tree [Annotation g])
 randomPadCorridors  (Node x xs) = do

src/Dodge/Layout/Tree/Shift.hs

@@ -6,17 +6,20 @@ Returns a list; after this step the structure is determined by the actual positi
 module Dodge.Layout.Tree.Shift
     ( shiftRoomTreeSearchAll
     , shiftExpandTree
+    , shiftRoomSearchIO
     ) where
 import Dodge.Room.Data
 import Dodge.Room.Link
 import Dodge.Layout.Tree.Polymorphic
 import Geometry.ConvexPoly
+import Geometry
 
 import Data.Tree
 import Data.Sequence hiding (zipWith)
 import Data.List (delete)
 import Data.Maybe (listToMaybe)
 import Control.Lens hiding (Empty, (<|) , (|>))
+
 {- | All: Depth first search of trees of rooms, produces a list of lists of rooms that are not clipping.  -}
 shiftRoomTreeSearchAll 
     :: [ConvexPoly]       -- ^ Clipping bounds
@@ -40,6 +43,43 @@ shiftRoomTreeSearchAll bs (Node r ts :<| tseq)
     useLink l = r & rmLinks %~ delete l
         & rmUsedLinks %~ (l :)
     f l = applyToRoot (shiftRoomToLink l)
+shiftRoomSearchIO
+    :: [ConvexPoly]
+    -> Seq (Tree Room)
+    -> IO (Maybe [Room])
+shiftRoomSearchIO _ Empty = return (Just [])
+shiftRoomSearchIO bs (Node r ts :<| tseq) 
+    | roomIsClipping = do
+        putStrLn "Room clipping"
+        return Nothing
+    | otherwise      = fmap (fmap (r:)) $ placeLinkedRooms newBounds r ts tseq
+  where
+    convexBounds = map pointsToPoly $ _rmBound r
+    newBounds = convexBounds ++ bs
+    roomIsClipping = or (convexPolysOverlap <$> convexBounds <*> bs)
+placeLinkedRooms :: [ConvexPoly] -> Room -> [Tree Room] -> (Seq (Tree Room)) -> IO (Maybe [Room])
+placeLinkedRooms bs _ [] tseq
+    = shiftRoomSearchIO bs tseq
+placeLinkedRooms bs r (t:ts) tseq
+    = tryLinks ls bs r t ts tseq
+  where
+    ls = init $ _rmLinks r
+
+tryLinks :: [(Point2,Float)] -> [ConvexPoly] -> Room -> Tree Room -> [Tree Room] -> (Seq (Tree Room))
+    -> IO (Maybe [Room])
+tryLinks [] _ _ _ _ _ = do
+    putStrLn "Tried all links"
+    return Nothing
+tryLinks (l:ls) bs r t ts tseq = do
+    branch <- placeLinkedRooms bs useLink ts (tseq |> shiftedt)
+    case branch of
+        Nothing -> tryLinks ls bs r t ts tseq
+        Just rs -> return $ Just rs
+  where
+    useLink = r & rmLinks %~ delete l
+        & rmUsedLinks %~ (l :)
+    shiftedt = applyToRoot (shiftRoomToLink l) t
+
 {- |
 Depth first search of trees of rooms, maybe produces a list rooms that are not clipping.
  -}