Ready for replacement of Either with bespoke data type for compo trees

src/Dodge/Tree/Shift.hs

@@ -0,0 +1,58 @@
+{- | Given a tree of rooms, tries to shift them into place in such a way that their
+links connect and that none of them clip.
+Creates a list of rooms; after this step the structure is determined by the actual positions of rooms.  -}
+module Dodge.Tree.Shift
+    ( positionRoomsFromTree
+    ) where
+import Dodge.LevelGen.Data
+import Dodge.Room.Link
+import Dodge.Tree.Polymorphic
+import Geometry.ConvexPoly
+import Geometry.Data
+
+import Data.Tree
+import Data.Sequence hiding (zipWith)
+import Data.List (delete)
+import Data.Bifunctor
+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) ts Empty
+
+posRms :: [ConvexPoly]
+    -> RoomInt
+    -> [Tree RoomInt]
+    -> Seq (Tree RoomInt)
+    -> IO (Maybe [Room])
+posRms bounds (parent,_) [] st = case st of
+    Empty -> return $ Just []
+    Node childi ts :<| tseq 
+        -> fmap (finalLinksUpdate parent:) <$> posRms bounds childi ts tseq
+posRms bounds parenti (t@(Node (_,i') _):ts) tseq = do
+    putStr $ "Trying to place room " ++ show i' ++ ": "
+    tryLinks 0 (_rmLinks parent)
+  where
+    parent = fst parenti
+    tryLinks _ [] = putStrLn "all links tried" >> return Nothing
+    tryLinks j (l:ls) 
+        | clipping  = tryLinks (j+1) ls
+        | otherwise = do
+            putStrLn $ "placing at link " ++ show j
+            mayrs <- posRms (convexBounds ++ bounds) (first upr parenti) ts (tseq |> shiftedt)
+            case mayrs of
+                Nothing -> putStr ("Backtracking to room " ++ show i' ++ ": ") >> tryLinks (j+1) ls
+                Just rs -> return (Just rs)
+      where
+        convexBounds = map pointsToPoly $ _rmBound r'
+        clipping = or (convexPolysOverlap <$> convexBounds <*> bounds)
+        upr rm = doLnkEff l $ rm & rmLinks %~ delete l & rmPos %~ (uncurry (OutLink j) l :)
+        l' = shiftLinkBy (_rmShift parent) l
+        r' = doRoomShift . fst $ rootLabel shiftedt
+        shiftedt = applyToRoot (first $ shiftRoomShiftToLink l') t
+
+doLnkEff :: (Point2,Float) -> Room -> Room
+doLnkEff x rm = case _rmLinkEff rm of
+    (eff:effs) -> eff x $ rm & rmLinkEff .~ effs
+    _ -> rm