Move toward indexed external placements

src/Dodge/Layout/Tree/Shift.hs

@@ -26,33 +26,31 @@ posRms :: [ConvexPoly]
     -> [Tree RoomInt]
     -> Seq (Tree RoomInt)
     -> IO (Maybe [Room])
-posRms _ _ [] Empty = return $ Just []
-posRms bounds (rtoadd,_) [] (Node (r,i) ts :<| tseq) 
-    = fmap (finalLinksUpdate rtoadd:) <$> posRms bounds (r,i) ts tseq
-posRms bounds (parent,i) (t@(Node (_,i') _):ts) tseq = do
+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::Int) (_rmLinks $ doRoomShift parent)
-    tryLinks (0::Int) (_rmLinks parent)
+    tryLinks 0 (_rmLinks parent)
   where
-    tryLinks _ [] = do
-        putStrLn "all links tried"
-        return Nothing
+    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) newr ts (tseq |> shiftedt')
+            mayrs <- posRms (convexBounds ++ bounds) (first upr parenti) ts (tseq |> shiftedt)
             case mayrs of
-                Nothing -> do putStr ("Backtracking to room " ++ show i' ++ ": ") >> tryLinks (j+1) ls
+                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)
-        newr = (lnkEff l $ parent & rmLinks %~ delete l & rmPos %~ (uncurry (OutLink j) l :)
-            , i)
+        upr rm = lnkEff l $ rm & rmLinks %~ delete l & rmPos %~ (uncurry (OutLink j) l :)
         l' = shiftLinkBy (_rmShift parent) l
-        (Node (r',_) _) = applyToRoot (first $ shiftRoomToLink l') t
-        shiftedt' = applyToRoot (first $ shiftRoomShiftToLink l') t
+        r' = doRoomShift . fst $ rootLabel shiftedt
+        shiftedt = applyToRoot (first $ shiftRoomShiftToLink l') t
 
 lnkEff :: (Point2,Float) -> Room -> Room
 lnkEff x rm = case _rmLinkEff rm of