Improve diagnostics for level generation

src/Dodge/Layout/Tree/Polymorphic.hs

@@ -14,6 +14,7 @@ module Dodge.Layout.Tree.Polymorphic
     , splitTrunk
     , applyToRandomNode
     , addToTrunk
+    , bfnumberTree
     )
     where
 import Dodge.RandomHelp
@@ -142,3 +143,16 @@ splitTrunk :: RandomGen g => Tree a -> State g (Tree a, [Tree a])
 splitTrunk t = do
     i <- state $ randomR (0, trunkDepth t)
     return $ splitTrunkAt i t
+
+-- untested
+bfnumberTree :: Tree a -> Tree (a,Int)
+bfnumberTree = fst . f 0
+  where
+    f i (Node x ts) =
+        let (ts',i') = g (i+1) ts
+        in (Node (x,i) ts', i')
+    g i (t:ts) = 
+        let (t',i') = f i t
+            (ts',i'') = g i' ts
+        in ((t': ts'), i'')
+    g i [] = ([], i)

src/Dodge/Layout/Tree/Shift.hs

@@ -6,7 +6,7 @@ Returns a list; after this step the structure is determined by the actual positi
 module Dodge.Layout.Tree.Shift
     ( shiftRoomTreeSearchAll
     , shiftExpandTree
-    , shiftRoomSearchIO
+    , positionRooms
     ) where
 import Dodge.Room.Data
 import Dodge.Room.Link
@@ -18,6 +18,7 @@ import Data.Tree
 import Data.Sequence hiding (zipWith)
 import Data.List (delete)
 import Data.Maybe (listToMaybe)
+import Data.Bifunctor
 import Control.Lens hiding (Empty, (<|) , (|>))
 
 {- | All: Depth first search of trees of rooms, produces a list of lists of rooms that are not clipping.  -}
@@ -43,37 +44,77 @@ shiftRoomTreeSearchAll bs (Node r ts :<| tseq)
     useLink l = r & rmLinks %~ delete l
         & rmUsedLinks %~ (l :)
     f l = applyToRoot (shiftRoomToLink l)
-shiftRoomSearchIO
+
+positionRooms :: Tree Room -> IO (Maybe [Room])
+--positionRooms = shiftRoomSearchIO 0 [] . singleton
+positionRooms t =
+    let (Node (r,i) ts) = bfnumberTree t
+    in posRms (map pointsToPoly $ _rmBound r) (r,i) ts Empty
+
+type RoomInt = (Room,Int)
+
+posRms
     :: [ConvexPoly]
+    -> RoomInt
+    -> [Tree RoomInt]
+    -> Seq (Tree RoomInt)
+    -> IO (Maybe [Room])
+posRms _ _ [] Empty = return $ Just []
+posRms bounds (rtoadd,_) [] (Node (r,i) ts :<| tseq) = fmap (fmap (rtoadd:)) $ posRms bounds (r,i) ts tseq
+posRms bounds (r,i) (t:ts) tseq = tryLinks' (_rmLinks r)
+  where
+    tryLinks' [] = do
+        putStrLn "All links tried"
+        return Nothing
+    tryLinks' (l:ls) 
+        | clipping   = tryLinks' ls
+        | otherwise = do
+            putStrLn $ "Trying link from " ++ show i ++ " to " ++ show i'
+            mayrs <- posRms (convexBounds ++ bounds) useLink ts (tseq |> shiftedt)
+            case mayrs of
+                Nothing -> do putStrLn ("Backtracking to " ++ show i) >> tryLinks' ls
+                Just rs -> return (Just rs)
+      where
+        convexBounds = map pointsToPoly $ _rmBound r'
+        clipping = or (convexPolysOverlap <$> convexBounds <*> bounds)
+        useLink = (r & rmLinks %~ delete l & rmUsedLinks %~ (l :)
+            , i)
+        shiftedt@(Node (r',i') _) = applyToRoot (first $ shiftRoomToLink l) t
+        
+
+shiftRoomSearchIO
+    :: Int
+    -> [ConvexPoly]
     -> Seq (Tree Room)
     -> IO (Maybe [Room])
-shiftRoomSearchIO _ Empty = return (Just [])
-shiftRoomSearchIO bs (Node r ts :<| tseq) 
+shiftRoomSearchIO _ _ Empty = return (Just [])
+shiftRoomSearchIO i bs (Node r ts :<| tseq) 
     | roomIsClipping = do
-        putStrLn "Room clipping"
+        putStrLn $ "Room " ++ show i ++ " clipping"
         return Nothing
-    | otherwise      = fmap (fmap (r:)) $ placeLinkedRooms newBounds r ts tseq
+    | otherwise      = fmap (fmap (r:)) $ placeLinkedRooms i 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
+placeLinkedRooms :: Int -> [ConvexPoly] -> Room -> [Tree Room] -> (Seq (Tree Room)) -> IO (Maybe [Room])
+placeLinkedRooms i bs _ [] tseq
+    = shiftRoomSearchIO (i+1) bs tseq
+placeLinkedRooms i bs r (t:ts) tseq
+    = tryLinks i ls bs r t ts tseq
   where
     ls = init $ _rmLinks r
 
-tryLinks :: [(Point2,Float)] -> [ConvexPoly] -> Room -> Tree Room -> [Tree Room] -> (Seq (Tree Room))
+tryLinks :: Int 
+    -> [(Point2,Float)] -> [ConvexPoly] -> Room -> Tree Room -> [Tree Room] -> (Seq (Tree Room))
     -> IO (Maybe [Room])
-tryLinks [] _ _ _ _ _ = do
-    putStrLn "Tried all links"
+tryLinks i [] _ _ _ _ _ = do
+    putStrLn $ "Tried all links for room " ++ show i
     return Nothing
-tryLinks (l:ls) bs r t ts tseq = do
-    branch <- placeLinkedRooms bs useLink ts (tseq |> shiftedt)
+tryLinks i (l:ls) bs r t ts tseq = do
+    branch <- placeLinkedRooms i bs useLink ts (tseq |> shiftedt)
     case branch of
-        Nothing -> tryLinks ls bs r t ts tseq
+        Nothing -> tryLinks i ls bs r t ts tseq
         Just rs -> return $ Just rs
   where
     useLink = r & rmLinks %~ delete l