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

src/Dodge/Room/Link.hs

@@ -37,18 +37,13 @@ doRoomShift rm = shiftRoomBy (_rmShift rm) rm & rmShift .~ _rmShift rm
 shiftRoomBy :: (Point2, Float) -> Room -> Room
 shiftRoomBy shift r =
     r
-        & rmPolys %~ fmap (map (shiftPointBy shift))
-        & rmLinks %~ fmap (shiftLinkBy shift)
+        & rmPolys . each . each %~ shiftPointBy shift
+        & rmLinks . each %~ shiftLinkBy shift
         & rmPath %~ S.map (shiftPathBy shift)
-        & rmBound %~ fmap (map (shiftPointBy shift))
+        & rmBound . each . each %~ shiftPointBy shift
         & rmShift %~ shiftPosDirBy shift
         & rmFloor . tiles . each %~ shiftTile shift
---            %~ map
---                ( (tilePoly %~ map (shiftPointBy shift))
---                    . (tileZero %~ shiftPointBy shift)
---                    . (tileTangentPos %~ shiftPointBy shift)
---                )
-        & rmViewpoints %~ map (shiftPointBy shift)
+        & rmViewpoints . each %~ shiftPointBy shift
 
 shiftTile :: Point2A -> Tile -> Tile
 shiftTile shift tl = case tl ^. tileZeroShift of

src/Dodge/Room/Tutorial.hs

@@ -430,12 +430,15 @@ loadAmmoTut = do
             . analyserByDoor (RequireEquipment (AMMOMAG DRUMMAG)) i
             =<< shuffleLinks
             =<< join (takeOne [roomNgon 6 80, roomRectAutoLights 100 100])
+--            =<< join (takeOne [roomNgon 6 80])
     j <- nextLayoutInt
     wprm <-
         putSingleLight
             . addDoorAtNthLinkToggleInterrupt 0 ["DOOR LOCKDOWN ACTIVE"] j
             =<< shuffleLinks
-            =<< roomRectAutoLights 100 100
+--            =<< roomRectAutoLights 100 100
+            =<< join (takeOne [roomNgon 6 80, roomRectAutoLights 100 100])
+--            =<< join (takeOne [roomNgon 6 80])
     droom <- distributerRoom BulletAmmo (10 ^ (4::Int))
     ncrits <- takeOne [1,1,2,2,2,3]
     croom <- roomCCrits ncrits

src/Dodge/TestString.hs

@@ -35,8 +35,8 @@ import Data.Monoid
 import RandomHelp
 
 testStringInit :: Universe -> [String]
-testStringInit u = -- fmap show (u ^.. uvWorld . cWorld . lWorld . creatures . ix 0 . crWallTouch . each)
-     (fmap show $ u ^.. uvWorld . cWorld . lWorld . creatures . each . crStance . carriage)
+testStringInit _ = mempty -- fmap show (u ^.. uvWorld . cWorld . lWorld . creatures . ix 0 . crWallTouch . each)
+--     (fmap show $ u ^.. uvWorld . cWorld . lWorld . creatures . each . crStance . carriage)
 --    (fmap show $ u ^.. uvWorld . cWorld . lWorld . creatures . each . crStance . carriage . strideAmount)
 -- a    <> fromMaybe [] (do
 -- a    w1 <- u ^? uvWorld . cWorld . lWorld . walls . ix 18