Correct room link position numbering

src/Dodge/Tree/Compose.hs

@@ -14,9 +14,9 @@ import Data.Tree
 expandTree :: CompTree a -> Tree a
 expandTree (Node root extChildren) = case root of
     Node (UseAll x)     _   -> Node x (map expandTree extChildren)
-    Node (UseSome is x) _   -> Node x (map expandTree $ map (\i -> extChildren !! i) is)
+    Node (UseSome is x) _   -> Node x (map (expandTree . \i -> extChildren !! i) is)
     Node (UseNone _)    _   -> fmap _unCompose root
-    Node (PassDown x)   xs  -> Node x $ map (expandTree . (\ct -> Node ct extChildren)) xs
+    Node (PassDown x)   xs  -> Node x $ map (expandTree . (`Node` extChildren)) xs
     Node (SplitDown x)  xs  -> Node x $ map expandTree $ zipWith Node xs 
             $ map (:[]) extChildren ++ repeat []
 

src/Dodge/Tree/Shift.hs

@@ -9,6 +9,7 @@ import Dodge.Room.Link
 import Dodge.Tree.Polymorphic
 import Geometry.ConvexPoly
 import Geometry.Data
+import Padding
 
 import Data.Tree
 import Data.Sequence hiding (zipWith)
@@ -19,35 +20,40 @@ import Control.Lens hiding (Empty, (<|) , (|>))
 type RoomInt = (Room,Int)
 
 positionRoomsFromTree :: Tree RoomInt -> IO (Maybe [Room])
-positionRoomsFromTree (Node (r,i) ts) = posRms (map pointsToPoly $ _rmBound r) (r,i) ts Empty
+positionRoomsFromTree (Node (r,i) ts) = posRms (map pointsToPoly $ _rmBound r) (r,i) 0 ts Empty
 
 posRms :: [ConvexPoly]
     -> RoomInt
+    -> Int -- ^ the number of children already placed
     -> [Tree RoomInt]
     -> Seq (Tree RoomInt)
     -> IO (Maybe [Room])
-posRms bounds (parent,_) [] st = case st of
+posRms bounds (parent,_) _ [] st = case st of
     Empty -> return $ Just []
     Node childi ts :<| tseq 
-        -> fmap (finalLinksUpdate parent:) <$> posRms bounds childi ts tseq
-posRms bounds parenti (t@(Node (_,i') _):ts) tseq = do
-    putStr $ "Trying to place room " ++ show i' ++ ": "
-    tryLinks 0 (_rmLinks parent)
+        -> 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 ))
+    tryLinks (0::Int) (_rmLinks parent)
   where
+    rpns x s = rightPadNoSquash x ' ' s
     parent = fst parenti
     tryLinks _ [] = putStrLn "all links tried" >> return Nothing
     tryLinks j (l:ls) 
         | clipping  = tryLinks (j+1) ls
         | otherwise = do
-            putStrLn $ "placing at link " ++ show j
-            mayrs <- posRms (convexBounds ++ bounds) (first upr parenti) ts (tseq |> shiftedt)
+            putStrLn $ "placed at link " ++ show j
+            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
                 Just rs -> return (Just rs)
       where
         convexBounds = map pointsToPoly $ _rmBound r'
         clipping = or (convexPolysOverlap <$> convexBounds <*> bounds)
-        upr rm = doLnkEff l $ rm & rmLinks %~ delete l & rmPos %~ (uncurry (OutLink j) l :)
+        upr rm = doLnkEff l $ rm & rmLinks %~ delete l & rmPos %~ (uncurry (OutLink numChild) l :)
         l' = shiftLinkBy (_rmShift parent) l
         r' = doRoomShift . fst $ rootLabel shiftedt
         shiftedt = applyToRoot (first $ shiftRoomShiftToLink l') t