Use zip counting during room positioning

src/Dodge/Tree/Shift.hs

@@ -21,48 +21,50 @@ import Control.Lens hiding (Empty, (<|) , (|>))
 type RoomInt = (Room,Int)
 
 positionRoomsFromTree :: Tree RoomInt -> IO (Maybe [Room])
-positionRoomsFromTree (Node (r,i) ts) = printHeader >> posRms (map pointsToPoly $ _rmBound r) (r,i) 0 ts Empty
+positionRoomsFromTree (Node (r,i) ts) = printHeader 
+    >> posRms (map pointsToPoly $ _rmBound r) (r,i) (zipCount ts) Empty
 
 posRms :: [ConvexPoly]
     -> RoomInt
-    -> Int -- ^ the number of children already placed
+    -> [(Int,Tree RoomInt)]     -- the list of children, with indices
-    -> [Tree RoomInt]
     -> Seq (Tree RoomInt)
     -> IO (Maybe [Room])
-posRms bounds (parent,_) _ [] st = case st of
+posRms bounds (parent,_) [] st = case st of
     Empty                   -> return $ Just [parent]
-    Node childi ts :<| tseq 
+    Node childi ts :<| tseq -> fmap (parent:) <$> posRms bounds childi (zipCount ts) tseq
-        -> fmap (parent:) <$> posRms bounds childi 0 ts tseq
+posRms bounds parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do
-posRms bounds parenti@(parent,_) numChild (t@(Node childi _):ts) tseq = do
     printInfoCheckNum parenti numChild childi
-    tryParentLinks (0::Int) (rmOutLinks parent)
+    tryParentLinks $ zipCount $ rmOutLinks parent
   where
-    tryParentLinks _ [] = putStrLn "no viable link pairs, backtrack" >> return Nothing
+    tryParentLinks [] = putStrLn "no viable link pairs, backtrack" >> return Nothing
-    tryParentLinks j (l:ls) = do
+    tryParentLinks ((j,outlnk):ls) = tryChildLinks $ zipCount (rmInLinks $ fst childi)
-        tryChildLinks (0::Int) (rmInLinks $ fst childi)
       where
-        tryChildLinks _ [] = tryParentLinks (j+1) ls
+        tryChildLinks [] = tryParentLinks ls
-        tryChildLinks numinlink (il:ils) 
+        tryChildLinks ((numinlink,il):ils) 
-            | clipping = tryChildLinks (numinlink+1) ils
+            | clipping = tryChildLinks ils
             | otherwise = do
                 putStrLn $ show j ++ "-"++show numinlink
                 mayrs <- posRms (convexBounds ++ bounds) 
-                    (first updateparent parenti) (numChild + 1) ts (tseq |> shiftedt)
+                    (first updateparent parenti) its (tseq |> shiftedt)
                 case mayrs of
                     Just rms -> return $ Just rms
                     Nothing -> printInfo parenti numChild childi
-                        >> tryChildLinks (numinlink+1) ils
+                        >> tryChildLinks ils
           where
             convexBounds = map pointsToPoly $ _rmBound r'
             clipping = or (convexPolysOverlap <$> convexBounds <*> bounds)
-            updateparent rm = doLnkEff (lnkPosDir l) $ rm & rmLinks %~ delete l & rmPos %~ (uncurry (UsedOutLink numChild) (lnkPosDir l) :)
+            updateparent rm = doLnkEff (lnkPosDir outlnk) $ rm 
-            l' = shiftLinkBy (_rmShift parent) l
+                & rmLinks %~ delete outlnk & rmPos %~ (uncurry (UsedOutLink numChild) (lnkPosDir outlnk) :)
+            l' = shiftLinkBy (_rmShift parent) outlnk
             r' = doRoomShift . fst $ rootLabel shiftedt
             updatechild rm = rm & rmLinks %~ delete il 
                 & rmPos %~ ( (uncurry (UsedInLink 0) (lnkPosDir il):)
                     . (map (uncurry UnusedLink . lnkPosDir) (delete il (_rmLinks rm)) ++) )
             shiftedt = applyToRoot (first $ updatechild . shiftRoomShiftToLink' (lnkPosDir l') (lnkPosDir il)) t
 
+zipCount :: [a] -> [(Int,a)]
+zipCount = Prelude.zip [0..]
+
 printColumns :: [Int] -> [String] -> IO ()
 printColumns (i:is) (s:strs) = putStr (rightPad i ' ' s) >> printColumns is strs
 printColumns _ strs = putStrLn $ concat strs