Allow for multiple in links

src/Dodge/Room/Link.hs

@@ -5,7 +5,8 @@ The last link in the list is considered the incoming link, the other links are
 the outgoing links.  -}
 module Dodge.Room.Link
     ( shiftRoomToLink
-    , shiftRoomShiftToLink
+    --, shiftRoomShiftToLink
+    , shiftRoomShiftToLink'
     , shiftRoomBy
     , shiftLinkBy
     , doRoomShift
@@ -98,6 +99,7 @@ shiftRoomToLink l r
     r
   where 
     (p,a) = head $ _rmInLinks r
+
 doRoomShift :: Room -> Room
 doRoomShift rm = shiftRoomBy (_rmShift rm) rm & rmShift .~ _rmShift rm
 
@@ -124,6 +126,15 @@ shiftRoomShiftToLink l r
     r
   where 
     (p,a) = head $ _rmInLinks r
+
+shiftRoomShiftToLink' :: (Point2,Float) -> (Point2,Float) -> Room -> Room
+shiftRoomShiftToLink' l inlink r 
+    = shiftRoomShiftBy l 
+    . shiftRoomShiftBy (V2 0 0       , pi-a)  
+    $ shiftRoomShiftBy (V2 0 0 -.- p , 0) 
+    r
+  where 
+    (p,a) = inlink
 -- NOTE placements, when placed, will be shifted by the value _rmShift
 shiftRoomShiftBy :: (Point2,Float) -> Room -> Room
 shiftRoomShiftBy shift r = r

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
+    tryParentLinks _ [] = putStrLn "all link pairs tried" >> return Nothing
-    tryLinks _ [] = putStrLn "all links tried" >> return Nothing
+    tryParentLinks j (l:ls) = do
-    tryLinks j (l:ls) 
+        tryChildLinks (0::Int) (_rmInLinks $ fst childi)
-        | 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)
       where
-        convexBounds = map pointsToPoly $ _rmBound r'
+        tryChildLinks _ [] = tryParentLinks (j+1) ls
-        clipping = or (convexPolysOverlap <$> convexBounds <*> bounds)
+        tryChildLinks numinlink (il:ils) 
-        upr rm = doLnkEff l $ rm & rmOutLinks %~ delete l & rmPos %~ (uncurry (UsedOutLink numChild) l :)
+            | clipping = tryChildLinks (numinlink+1) ils
-        l' = shiftLinkBy (_rmShift parent) l
+            | otherwise = do
-        r' = doRoomShift . fst $ rootLabel shiftedt
+                putStrLn $ show j ++ "-"++show numinlink
-        shiftedt = applyToRoot (first $ shiftRoomShiftToLink l') t
+                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)
+    putStr $ rpns 20 (_rmName parentrm ++ "-" ++ show parenti )
-          ++ rpns 9 (" child " ++ show childn )
+          ++ rpns 5 (show childn ++ " ")
-          ++ rpns 25 (" of " ++ _rmName parentrm ++ "-" ++ show parenti )
+          ++ rpns 20 (_rmName childrm ++ "-" ++ show childi )
   where
     rpns x s = rightPadNoSquash x ' ' s