Fix bug not adding last positioned room to list

src/Dodge/Tree/Compose.hs

@@ -11,6 +11,7 @@ module Dodge.Tree.Compose
     ) where
 import Dodge.Tree.Compose.Data
 import Dodge.Tree.Polymorphic
+import Dodge.Base
 import Data.Tree
 
 expandTree :: CompTree a -> Tree a
@@ -24,7 +25,8 @@ expandTree (Node root extChildren) = case root of
             $ map (:[]) extChildren ++ repeat []
 
 overwriteLabel :: Int -> (a -> ComposingNode a) -> SubCompTree a -> [SubCompTree a] -> SubCompTree a
-overwriteLabel i f t ts = head $ updateSingleNode islabel update t
+overwriteLabel i f t ts = errorHead ("tried to overwriteLabel " ++ show i)
+    $ updateSingleNode islabel update t
   where
     islabel (UseLabel j _) | i == j = True
     islabel _ = False

src/Dodge/Tree/Shift.hs

@@ -29,16 +29,13 @@ posRms :: [ConvexPoly]
     -> Seq (Tree RoomInt)
     -> IO (Maybe [Room])
 posRms bounds (parent,_) _ [] st = case st of
-    Empty -> return $ Just []
+    Empty -> return $ Just [parent]
     Node childi ts :<| tseq 
         -> fmap (finalLinksUpdate parent:) <$> posRms bounds childi 0 ts tseq
-posRms bounds parenti@(pr,i) numChild (t@(Node (cr,i') _):ts) tseq = do
-    putStr $ rpns 20 (_rmName cr ++ "-" ++ show i')
-          ++ rpns 9 (" child " ++ show numChild )
-          ++ rpns 25 (" of " ++ _rmName pr ++ "-" ++ show i )
+posRms bounds parenti numChild (t@(Node childi _):ts) tseq = do
+    printInfo parenti numChild childi
     tryLinks (0::Int) (init $ _rmLinks parent)
   where
-    rpns x s = rightPadNoSquash x ' ' s
     parent = fst parenti
     tryLinks _ [] = putStrLn "all links tried" >> return Nothing
     tryLinks j (l:ls) 
@@ -48,11 +45,9 @@ posRms bounds parenti@(pr,i) numChild (t@(Node (cr,i') _):ts) tseq = do
             mayrs <- posRms (convexBounds ++ bounds) 
                 (first upr parenti) (numChild + 1) ts (tseq |> shiftedt)
             case mayrs of
-                --Nothing -> putStr ("Backtracking to room " ++ show i' ++ ": ") >> tryLinks (j+1) ls
                 Nothing -> do
-                    putStr $ "Backtracking to " ++ rpns 20 (_rmName cr ++ "-" ++ show i')
-                        ++ rpns 9 (" child " ++ show numChild )
-                        ++ rpns 25 (" of " ++ _rmName pr ++ "-" ++ show i )
+                    putStr "Backtrack: " 
+                    printInfo parenti numChild childi
                     tryLinks (j+1) ls
                 Just rs -> return (Just rs)
       where
@@ -63,6 +58,14 @@ posRms bounds parenti@(pr,i) numChild (t@(Node (cr,i') _):ts) tseq = do
         r' = doRoomShift . fst $ rootLabel shiftedt
         shiftedt = applyToRoot (first $ shiftRoomShiftToLink l') t
 
+printInfo :: RoomInt -> Int -> RoomInt -> IO ()
+printInfo (parentrm,parenti) childn (childrm,childi) = do
+    putStr $ rpns 20 (_rmName childrm ++ "-" ++ show childi)
+          ++ rpns 9 (" child " ++ show childn )
+          ++ rpns 25 (" of " ++ _rmName parentrm ++ "-" ++ show parenti )
+  where
+    rpns x s = rightPadNoSquash x ' ' s
+
 doLnkEff :: (Point2,Float) -> Room -> Room
 doLnkEff x rm = case _rmLinkEff rm of
     (eff:effs) -> eff x $ rm & rmLinkEff .~ effs