Fix backtracking bug

src/Dodge/Tree/Shift.hs

@@ -20,7 +20,7 @@ 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) 0 ts Empty
+positionRoomsFromTree (Node (r,i) ts) = printHeader >> posRms (map pointsToPoly $ _rmBound r) (r,i) 0 ts Empty
 
 posRms :: [ConvexPoly]
     -> RoomInt
@@ -31,12 +31,12 @@ posRms :: [ConvexPoly]
 posRms bounds (parent,_) _ [] st = case st of
     Empty -> return $ Just [parent]
     Node childi ts :<| tseq 
-        -> fmap (finalLinksUpdate parent:) <$> posRms bounds childi 0 ts tseq
+        -> fmap (parent:) <$> posRms bounds childi 0 ts tseq
 posRms bounds parenti@(parent,_) numChild (t@(Node childi _):ts) tseq = do
-    printInfo parenti numChild childi
+    printInfoCheckNum parenti numChild childi
     tryParentLinks (0::Int) (_rmOutLinks parent)
   where
-    tryParentLinks _ [] = putStrLn "all link pairs tried" >> return Nothing
+    tryParentLinks _ [] = putStrLn "no viable link pairs, backtrack" >> return Nothing
     tryParentLinks j (l:ls) = do
         tryChildLinks (0::Int) (_rmInLinks $ fst childi)
       where
@@ -46,15 +46,33 @@ posRms bounds parenti@(parent,_) numChild (t@(Node childi _):ts) tseq = do
             | otherwise = do
                 putStrLn $ show j ++ "-"++show numinlink
                 mayrs <- posRms (convexBounds ++ bounds) 
-                    (first upr parenti) (numChild + 1) ts (tseq |> shiftedt)
-                return mayrs
+                    (first updateparent parenti) (numChild + 1) ts (tseq |> shiftedt)
+                case mayrs of
+                    Just rms -> return $ Just rms
+                    Nothing -> printInfo parenti numChild childi
+                        >> tryChildLinks (numinlink+1) ils
           where
             convexBounds = map pointsToPoly $ _rmBound r'
             clipping = or (convexPolysOverlap <$> convexBounds <*> bounds)
-            upr rm = doLnkEff l $ rm & rmOutLinks %~ delete l & rmPos %~ (uncurry (UsedOutLink numChild) l :)
+            updateparent 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
+            updatechild rm = rm & rmInLinks %~ delete il 
+                & rmPos %~ ( (uncurry (UsedInLink 0) il:)
+                    . (map (uncurry UnusedLink) (_rmOutLinks rm ++ newInLinks) ++) )
+              where
+                newInLinks = delete il $ _rmInLinks rm
+            shiftedt = applyToRoot (first $ updatechild . shiftRoomShiftToLink' l' il) t
+
+printColumns :: [Int] -> [String] -> IO ()
+printColumns (i:is) (s:strs) = putStr (rightPad i ' ' s) >> printColumns is strs
+printColumns _ strs = putStrLn $ concat strs
+
+theColumns :: [String] -> IO ()
+theColumns = printColumns [20,5,20,20]
+
+printHeader :: IO ()
+printHeader = theColumns ["Parent","Cnum","Child","Link pair"]
 
 printInfo :: RoomInt -> Int -> RoomInt -> IO ()
 printInfo (parentrm,parenti) childn (childrm,childi) = do
@@ -63,6 +81,14 @@ printInfo (parentrm,parenti) childn (childrm,childi) = do
           ++ rpns 20 (_rmName childrm ++ "-" ++ show childi )
   where
     rpns x s = rightPadNoSquash x ' ' s
+printInfoCheckNum :: RoomInt -> Int -> RoomInt -> IO ()
+printInfoCheckNum p 0 c = printInfo p 0 c
+printInfoCheckNum _ childn (childrm,childi) = do
+    putStr $ rpns 20 ("")
+          ++ rpns 5 (show childn ++ " ")
+          ++ rpns 20 (_rmName childrm ++ "-" ++ show childi )
+  where
+    rpns x s = rightPadNoSquash x ' ' s
 
 doLnkEff :: (Point2,Float) -> Room -> Room
 doLnkEff x rm = case _rmLinkEff rm of