Automatically inherit tile positioning

src/Dodge/Layout.hs

@@ -6,6 +6,7 @@ module Dodge.Layout (
     shuffleRoomPos,
 ) where
 
+import Control.Monad
 -- import Dodge.Path.Translate
 import qualified Control.Foldl as L
 import Control.Lens
@@ -67,21 +68,26 @@ randomCompass w =
 setTiles :: GenWorld -> GenWorld
 setTiles gw = foldr setTile gw . reverse . IM.elems $ _genRooms gw
 
+roomTileZeroShift :: Room -> Point2A
+roomTileZeroShift rm = fromMaybe (rm ^. rmShift) 
+    $ rm ^? rmFloor . tiles . ix 0 . tileZeroShift . _Just
+
 setTile :: Room -> GenWorld -> GenWorld
 setTile r gw = case _rmFloor r of
-    Tiled{} -> gw
+    Tiled xs -> fromMaybe gw $ do
+        pid <- r ^. rmMParent
+        rm <- gw ^? genRooms . ix pid
+        guard $ rm ^? rmFloor . tiles . ix 0 . tileArrayZ == xs ^? ix 0 . tileArrayZ
+        return $ gw & genRooms . ix (fromJust (_rmMID r)) . rmFloor . tiles . ix 0 . tileZeroShift 
+            ?~ roomTileZeroShift rm
     InheritFloor ->
         gw & genRooms . ix (fromJust (_rmMID r)) . rmFloor .~ Tiled [t & tilePoly .~ poly]
   where
     t = fromMaybe (Tile poly (V2 0 0) (V2 1 0) 16 Nothing) $ do
             pid <- r ^. rmMParent
             rm <- gw ^? genRooms . ix pid
-            (gw ^? genRooms . ix pid . rmFloor . tiles . ix 0)
-                <&> tileZeroShift ?~ _rmShift rm
-            
---    t = case _rmMParent r of
---        Nothing -> Tile poly (V2 0 0) (V2 1 0) 16
---        Just pid -> head $ _tiles $ _rmFloor $ _genRooms gw IM.! pid
+            (rm ^? rmFloor . tiles . ix 0)
+                <&> tileZeroShift ?~ roomTileZeroShift rm
     poly =
         orderPolygon
             . convexHullSafe