Fix backtracking bug

src/Dodge/Floor.hs

@@ -36,7 +36,7 @@ initialAnoTree :: RandomGen g => Tree [Annotation g]
 initialAnoTree = padSucWithCorridors $ treeFromTrunk 
     [[AnoApplyInt 0 startRoom]
     , [PassthroughLockKeyLists 2 lockRoomKeyItems itemRooms]
---    , [AnoApplyInt 1 lasSensorTurretTest]
+    , [AnoApplyInt 1 lasSensorTurretTest]
 --    ,[ChainAnos 
 --        [[SetLabel 0 $ return $ roomRectAutoLinks 200 200 
 --            & rmExtPmnt ?~ triggerSwitchSPicLight (drawSwitchWire red red)

src/Dodge/Layout.hs

@@ -169,13 +169,13 @@ gameRoomFromRoom rm = GameRoom
         ,p -.- 10 *.* unitVectorAtAngle a
         ]
     unpos (UsedOutLink _ p a) = doubleShift p a
-    unpos (UsedInLink    p a) = doubleShift p a
+    unpos (UsedInLink  _ p a) = doubleShift p a
     unpos _ = []
     undir (UsedOutLink _ _ a) = Just $ 0.5*pi + a + snd (_rmShift rm)
-    undir (UsedInLink    _ a) = Just $ 0.5*pi + a + snd (_rmShift rm)
+    undir (UsedInLink  _ _ a) = Just $ 0.5*pi + a + snd (_rmShift rm)
     undir _ = Nothing
     closePoints x y = roundPoint2 x == roundPoint2 y
-    getDir (UsedInLink _ a:_) = a  + snd (_rmShift rm)
+    getDir (UsedInLink _ _ a:_) = a  + snd (_rmShift rm)
     getDir (_:xs) = getDir xs
     getDir _ = 0 -- fallback
 

src/Dodge/LevelGen/Data.hs

@@ -99,7 +99,7 @@ data RoomWire
      WallWire Point2 Float Float
 data RoomPos 
     = UsedOutLink Int    Point2  Float
-    | UsedInLink  Point2 Float
+    | UsedInLink Int  Point2 Float
     | UnusedLink Point2 Float
     | PosPl   Point2 Float
     | LabPos  Int    RoomPos

src/Dodge/Room/Link.hs

@@ -118,14 +118,14 @@ shiftRoomBy shift r = r
         . (tileX    %~ shiftPointBy shift         )
         )
     & rmViewpoints %~ map (shiftPointBy shift)
-shiftRoomShiftToLink :: (Point2,Float) -> Room -> Room
+--shiftRoomShiftToLink :: (Point2,Float) -> Room -> Room
-shiftRoomShiftToLink l r 
+--shiftRoomShiftToLink l r 
-    = shiftRoomShiftBy l 
+--    = shiftRoomShiftBy l 
-    . shiftRoomShiftBy (V2 0 0       , pi-a)  
+--    . shiftRoomShiftBy (V2 0 0       , pi-a)  
-    $ shiftRoomShiftBy (V2 0 0 -.- p , 0) 
+--    $ shiftRoomShiftBy (V2 0 0 -.- p , 0) 
-    r
+--    r
-  where 
+--  where 
-    (p,a) = head $ _rmInLinks r
+--    (p,a) = head $ _rmInLinks r
 
 shiftRoomShiftToLink' :: (Point2,Float) -> (Point2,Float) -> Room -> Room
 shiftRoomShiftToLink' l inlink r 
@@ -156,7 +156,7 @@ finalLinksUpdate :: Room -> Room
 finalLinksUpdate rm = case _rmInLinks rm of
     (_:_) -> rm
         & rmInLinks %~ tail
-        & rmPos %~ ( (uncurry UsedInLink (head inlnks) :) 
+        & rmPos %~ ( (uncurry (UsedInLink 0) (head inlnks) :) 
                     . (map (uncurry UnusedLink) (outlnks ++ tail inlnks) ++) )
     _ -> rm
   where

src/Dodge/RoomPos.hs

@@ -5,7 +5,7 @@ import Geometry
 extractRoomPos :: RoomPos -> (Point2,Float)
 extractRoomPos rp = case rp of
     UsedOutLink _  p a -> (p,a)
-    UsedInLink     p a -> (p,a)
+    UsedInLink  _  p a -> (p,a)
     UnusedLink p a -> (p,a)
     PosPl      p a -> (p,a)
     LabPos _ rp'   -> extractRoomPos rp'

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)
+                    (first updateparent parenti) (numChild + 1) ts (tseq |> shiftedt)
-                return mayrs
+                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