Allow for multiple in links

src/Dodge/Tree/Shift.hs

@@ -32,37 +32,35 @@ posRms bounds (parent,_) _ [] st = case st of
     Empty -> return $ Just [parent]
     Node childi ts :<| tseq 
         -> fmap (finalLinksUpdate parent:) <$> posRms bounds childi 0 ts tseq
-posRms bounds parenti numChild (t@(Node childi _):ts) tseq = do
+posRms bounds parenti@(parent,_) numChild (t@(Node childi _):ts) tseq = do
     printInfo parenti numChild childi
-    tryLinks (0::Int) (_rmOutLinks parent)
+    tryParentLinks (0::Int) (_rmOutLinks parent)
   where
-    parent = fst parenti
-    tryLinks _ [] = putStrLn "all links tried" >> return Nothing
-    tryLinks j (l:ls) 
-        | clipping  = tryLinks (j+1) ls
-        | otherwise = do
-            putStrLn $ "placed at link " ++ show j
-            mayrs <- posRms (convexBounds ++ bounds) 
-                (first upr parenti) (numChild + 1) ts (tseq |> shiftedt)
-            case mayrs of
-                Nothing -> do
-                    putStr "Backtrack: " 
-                    printInfo parenti numChild childi
-                    tryLinks (j+1) ls
-                Just rs -> return (Just rs)
+    tryParentLinks _ [] = putStrLn "all link pairs tried" >> return Nothing
+    tryParentLinks j (l:ls) = do
+        tryChildLinks (0::Int) (_rmInLinks $ fst childi)
       where
-        convexBounds = map pointsToPoly $ _rmBound r'
-        clipping = or (convexPolysOverlap <$> convexBounds <*> bounds)
-        upr rm = doLnkEff l $ rm & rmOutLinks %~ delete l & rmPos %~ (uncurry (UsedOutLink numChild) l :)
-        l' = shiftLinkBy (_rmShift parent) l
-        r' = doRoomShift . fst $ rootLabel shiftedt
-        shiftedt = applyToRoot (first $ shiftRoomShiftToLink l') t
+        tryChildLinks _ [] = tryParentLinks (j+1) ls
+        tryChildLinks numinlink (il:ils) 
+            | clipping = tryChildLinks (numinlink+1) ils
+            | otherwise = do
+                putStrLn $ show j ++ "-"++show numinlink
+                mayrs <- posRms (convexBounds ++ bounds) 
+                    (first upr parenti) (numChild + 1) ts (tseq |> shiftedt)
+                return mayrs
+          where
+            convexBounds = map pointsToPoly $ _rmBound r'
+            clipping = or (convexPolysOverlap <$> convexBounds <*> bounds)
+            upr rm = doLnkEff l $ rm & rmOutLinks %~ delete l & rmPos %~ (uncurry (UsedOutLink numChild) l :)
+            l' = shiftLinkBy (_rmShift parent) l
+            r' = doRoomShift . fst $ rootLabel shiftedt
+            shiftedt = applyToRoot (first $ shiftRoomShiftToLink' l' il) 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 )
+    putStr $ rpns 20 (_rmName parentrm ++ "-" ++ show parenti )
+          ++ rpns 5 (show childn ++ " ")
+          ++ rpns 20 (_rmName childrm ++ "-" ++ show childi )
   where
     rpns x s = rightPadNoSquash x ' ' s