Work towards cross-room placements

src/Dodge/Layout/Tree/Annotate.hs

@@ -61,26 +61,26 @@ roomThenCorridor theRoom = fmap (\r -> Node (Left theRoom) [(pure . Right) r])
                                 (randomiseOutLinks corridor)
 {- | Create a random room tree structure from a list of annotations.  -}
 annoToRoomTree :: RandomGen g => [Annotation g] -> State g (Tree (Either Room Room))
-annoToRoomTree [OrAno as] = do
-    a <- takeOne as
-    annoToRoomTree a
-annoToRoomTree [Corridor] = pure . Right <$> randomiseOutLinks corridor
-annoToRoomTree [CorridorDebug] = pure . Right <$> randomiseOutLinks corridorDebug
-annoToRoomTree [DoorAno] = roomThenCorridor door
-annoToRoomTree [AirlockAno] = airlock >>=  roomThenCorridor
-annoToRoomTree [FirstWeapon] = do
-    branchWP <- branchRectWith weaponRoom
-    blockedC <- longBlockedCorridor
-    join $ takeOne $ return (appendEitherTree branchWP [blockedC]) : replicate 5 weaponRoom
-annoToRoomTree [EndRoom] = fmap (pure . Right) (telRoomLev 1)
-annoToRoomTree [StartRoom] = startRoom
-annoToRoomTree (SpecificRoom rt:_) = rt
-annoToRoomTree (BossAno cr : _) = do
-    br <- bossRoom cr
-    branchRectWith . pure . fmap Left $ treeFromPost [corridor,corridor] br
-annoToRoomTree (TreasureAno crs loot : _) =
-    branchRectWith . fmap (pure . Left) $ lootRoom crs loot
-annoToRoomTree _ = do
-    w <- state $ randomR (100,400)
-    h <- state $ randomR (200,400)
-    fmap (pure . Right) . randomiseOutLinks $ roomRectAutoLinks w h
+annoToRoomTree anos = case anos of
+    [OrAno as] -> do
+        a <- takeOne as
+        annoToRoomTree a
+    [Corridor] -> pure . Right <$> randomiseOutLinks corridor
+    [CorridorDebug] -> pure . Right <$> randomiseOutLinks corridorDebug
+    [DoorAno] -> roomThenCorridor door
+    [AirlockAno] -> airlock >>=  roomThenCorridor
+    [FirstWeapon] -> do
+        branchWP <- branchRectWith weaponRoom
+        blockedC <- longBlockedCorridor
+        join $ takeOne $ return (appendEitherTree branchWP [blockedC]) : replicate 5 weaponRoom
+    [EndRoom] -> fmap (pure . Right) (telRoomLev 1)
+    [StartRoom] -> startRoom
+    (SpecificRoom rt:_) -> rt
+    (BossAno cr : _) -> do
+        br <- bossRoom cr
+        branchRectWith . pure . fmap Left $ treeFromPost [corridor,corridor] br
+    (TreasureAno crs loot : _) -> branchRectWith . fmap (pure . Left) $ lootRoom crs loot
+    _ -> do
+        w <- state $ randomR (100,400)
+        h <- state $ randomR (200,400)
+        fmap (pure . Right) . randomiseOutLinks $ roomRectAutoLinks w h

src/Dodge/Layout/Tree/Shift.hs

@@ -1,11 +1,8 @@
-{- |
-Given a tree of rooms, tries to shift them into place in such a way that their
+{- | 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.
-Returns a list; after this step the structure is determined by the actual positions of rooms.
- -}
+Creates a list of rooms; after this step the structure is determined by the actual positions of rooms.  -}
 module Dodge.Layout.Tree.Shift
-    ( shiftRoomTreeSearchAll
-    , positionRooms
+    ( positionRooms
     ) where
 import Dodge.Room.Data
 import Dodge.Room.Link
@@ -15,34 +12,9 @@ import Geometry.ConvexPoly
 import Data.Tree
 import Data.Sequence hiding (zipWith)
 import Data.List (delete)
---import Data.Maybe (listToMaybe)
 import Data.Bifunctor
 import Control.Lens hiding (Empty, (<|) , (|>))
 
-{- | All: Depth first search of trees of rooms, produces a list of lists of rooms that are not clipping.  -}
-shiftRoomTreeSearchAll 
-    :: [ConvexPoly]       -- ^ Clipping bounds
-    -> Seq (Tree Room)  -- ^ Rooms to be added
-    -> [[Room]]
-shiftRoomTreeSearchAll _ Empty = [[]]
-shiftRoomTreeSearchAll bs (Node r ts :<| tseq)
---    | roomIsClipping = [] -- this is called too often--might get memoized?
---    | otherwise = case ts of
---        [] -> (r :) <$> shiftRoomTreeSearchAll newBounds tseq
---        (s:ss) -> concatMap (\l -> shiftRoomTreeSearchAll bs (Node (useLink l) ss <| (tseq |> f l s))) ls
-    = case ts of
-        [] | roomIsClipping -> []
-        [] -> (r :) <$> shiftRoomTreeSearchAll newBounds tseq
-        (s:ss) -> concatMap (\l -> shiftRoomTreeSearchAll bs (Node (useLink l) ss <| (tseq |> f l s))) ls
-  where
-    convexBounds = map pointsToPoly $ _rmBound r
-    ls = init $ _rmLinks r
-    newBounds = convexBounds ++ bs
-    roomIsClipping = or (convexPolysOverlap <$> convexBounds <*> bs)
-    useLink l = r & rmLinks %~ delete l
-        & rmUsedLinks %~ (l :)
-    f l = applyToRoot (shiftRoomToLink l)
-
 positionRooms :: Tree RoomInt -> IO (Maybe [Room])
 positionRooms (Node (r,i) ts) = posRms (map pointsToPoly $ _rmBound r) (r,i) ts Empty
 
@@ -59,30 +31,22 @@ posRms bounds (rtoadd,_) [] (Node (r,i) ts :<| tseq)
     = fmap (setLastLinkToUsed rtoadd:) <$> posRms bounds (r,i) ts tseq
 posRms bounds (r,i) (t@(Node (_,i') _):ts) tseq = do
     putStr $ "Trying to place room " ++ show i' ++ ": "
-    tryLinks' (0::Int) (_rmLinks r)
+    tryLinks (0::Int) (_rmLinks r)
   where
-    tryLinks' _ [] = do
+    tryLinks _ [] = do
         putStrLn "all links tried"
         return Nothing
-    tryLinks' j (l:ls) 
-        | clipping   = tryLinks' (j+1) ls
+    tryLinks j (l:ls) 
+        | clipping   = tryLinks (j+1) ls
         | otherwise = do
             putStrLn $ "placing at link " ++ show j
             mayrs <- posRms (convexBounds ++ bounds) useLink ts (tseq |> shiftedt)
             case mayrs of
-                Nothing -> do putStr ("Backtracking to room " ++ show i' ++ ": ") >> tryLinks' (j+1) ls
+                Nothing -> do 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)
-        useLink = (r & rmLinks %~ delete l & rmUsedLinks %~ (l :)
+        useLink = (r & rmLinks %~ delete l & rmUsedLinks %~ (uncurry (OutLink (Prelude.length ts)) l :)
             , i)
         shiftedt@(Node (r',_) _) = applyToRoot (first $ shiftRoomToLink l) t
-        
-
-setLastLinkToUsed :: Room -> Room
-setLastLinkToUsed rm = case _rmLinks rm of
-    (_:_) -> rm
-        & rmLinks %~ init
-        & rmUsedLinks %~ (last (_rmLinks rm) :)
-    _ -> rm