Allow for rooms to inherit floor tiling from parents

src/Data/Tile.hs

@@ -1,10 +1,14 @@
 {-# LANGUAGE TemplateHaskell #-}
-module Data.Tile
+--{-# LANGUAGE StrictData #-}
-    where
+module Data.Tile where
 import Geometry.Data
 
 import Control.Lens
 
+data Floor 
+    = InheritFloor
+--    | TileWith Float
+    | Tiled { _tiles :: [Tile]}
 data Tile = Tile
     { _tilePoly :: [Point2]
     , _tileZero :: Point2   -- ^ point in the world where tile texture is 0,0
@@ -12,4 +16,5 @@ data Tile = Tile
     , _tileZ    :: Float
     }
   deriving (Eq, Ord, Show)
+makeLenses ''Floor
 makeLenses ''Tile

src/Dodge/Default/Room.hs

@@ -1,5 +1,5 @@
-module Dodge.Default.Room
+module Dodge.Default.Room where
-    where
+import Data.Tile
 import Geometry.Data
 import Dodge.LevelGen.Data
 import qualified Data.IntMap.Strict as IM
@@ -16,7 +16,7 @@ defaultRoom = Room
     , _rmPartPmnt   = Nothing
     , _rmExtPmnt    = Nothing
     , _rmBound      = []
-    , _rmFloor      = []
+    , _rmFloor      = InheritFloor
     , _rmName       = "defaultRoom"
     , _rmShift      = (V2 0 0 , 0)
     , _rmViewpoints = []

src/Dodge/Layout.hs

@@ -2,6 +2,7 @@
 module Dodge.Layout 
     ( generateLevelFromRoomList
     ) where
+import Data.Tile
 import Dodge.Data
 import Dodge.Path
 import Dodge.ShiftPoint
@@ -46,9 +47,9 @@ generateLevelFromRoomList gr' w
     . doExtendedPlacements
     . doIndividualPlacements
 --    . flip (mapAccumR doRoomPlacements) (IM.elems rs')
+    . setFloors
     . worldToGenWorld rs'
     $ w { _walls        = wallsFromRooms rs
-        , _floorTiles   = floorsFromRooms rs
         , _gameRooms    = gameRoomsFromRooms (IM.elems rs')
         , _pathGraph    = path
         , _pathGraphP   = pairPath
@@ -57,12 +58,38 @@ generateLevelFromRoomList gr' w
     path = pairsToGraph dist pairPath
     pairPath = concatMap _rmPath rs
     rs = map doRoomShift $ IM.elems rs'
-    rs'= mapM (shuffleRoomPos >=> addRandomTile) gr' & evalState $ _randGen w
+    --rs'= mapM (shuffleRoomPos >=> addRandomTile) gr' & evalState $ _randGen w
+    rs'= mapM shuffleRoomPos gr' & evalState $ _randGen w
 
-addRandomTile :: RandomGen g => Room -> State g Room
+putFloorTiles :: GenWorld -> GenWorld
-addRandomTile r = do
+putFloorTiles gw = gw & gWorld . floorTiles .~ floorsFromGenWorld gw
-    z <- state $ randomR (0,63)
+
-    return $ addTile z r
+setFloors :: GenWorld -> GenWorld
+setFloors gw = putFloorTiles $ setTiles gw
+--setFloors gw = setTiles gw
+
+-- note the order of traversal of the rooms is important
+-- hence the reverse
+-- this is not ideal: should do this in some more sensible way
+setTiles :: GenWorld -> GenWorld
+setTiles gw = foldr setTile gw . reverse . IM.elems $ _gRooms gw
+
+setTile :: Room -> GenWorld -> GenWorld
+setTile r gw = -- gw & gRooms . ix (fromJust (_rmMID r)) . rmFloor .~ Tiled [Tile poly 0 (V2 1 0) 16]
+        case _rmFloor r of
+    Tiled {} -> gw
+    InheritFloor -> gw & gRooms . ix (fromJust (_rmMID r)) . rmFloor .~ Tiled [t & tilePoly .~ poly]
+  where
+    t = case _rmMParent r of
+        Nothing -> Tile poly (V2 0 0) (V2 1 0) 16
+        Just pid -> head $ _tiles $ _rmFloor $ _gRooms gw IM.! pid
+    rp = _rmPolys r
+    poly = orderPolygon . convexHullSafe . nubBy ((==) `on` roundPoint2) $ concat rp
+
+--addRandomTile :: RandomGen g => Room -> State g Room
+--addRandomTile r = do
+--    z <- state $ randomR (0,63)
+--    return $ addTile z r
 
 shuffleRoomPos :: RandomGen g => Room -> State g Room
 shuffleRoomPos rm = do
@@ -206,7 +233,15 @@ gameRoomFromRoom rm = GameRoom
     getDir _ = 0 -- fallback
 
 floorsFromRooms :: [Room] -> [(Point3,Point3)]
-floorsFromRooms = concatMap (concatMap tToRender . _rmFloor)
+floorsFromRooms = concatMap (concatMap tToRender . getTiles . _rmFloor . doRoomShift)
+
+floorsFromGenWorld :: GenWorld -> [(Point3,Point3)]
+floorsFromGenWorld = floorsFromRooms . IM.elems . _gRooms 
+
+getTiles :: Floor -> [Tile]
+getTiles fl = case fl of
+    Tiled xs -> xs
+    _ -> error "tiles not correctly set for some room"
 
 --divideWall :: Wall -> [Wall]
 --divideWall wl
@@ -246,10 +281,10 @@ floorsFromRooms = concatMap (concatMap tToRender . _rmFloor)
 --      where 
 --        (p,a) = last $ _rmLinks r
 
-addTile :: Float -> Room -> Room
+--addTile :: Float -> Room -> Room
-addTile z r
+--addTile z r
-    | not (null (_rmFloor r)) || null rp = r
+--    | not (null (_rmFloor r)) || null rp = r
-    | otherwise = r & rmFloor .~ [makeTileFromPoly poly z]
+--    | otherwise = r & rmFloor .~ [makeTileFromPoly poly z]
-  where
+--  where
-    rp = _rmPolys r
+--    rp = _rmPolys r
-    poly = orderPolygon . convexHullSafe . nubBy ((==) `on` roundPoint2) $ concat rp
+--    poly = orderPolygon . convexHullSafe . nubBy ((==) `on` roundPoint2) $ concat rp

src/Dodge/LevelGen/Data.hs

@@ -79,7 +79,7 @@ data Room = Room
     , _rmPartPmnt   :: Maybe ([Placement] -> Placement)
     , _rmExtPmnt    :: Maybe Placement
     , _rmBound      :: [ [Point2] ]
-    , _rmFloor      :: [Tile]
+    , _rmFloor      :: Floor
     , _rmName       :: String
     , _rmShift      :: (Point2, Float)
     , _rmViewpoints :: [Point2]

src/Dodge/Room/Corridor.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE TupleSections #-}
-module Dodge.Room.Corridor
+module Dodge.Room.Corridor where
-    where
+import Data.Tile
 import Dodge.LevelGen.Data
 import Dodge.RoomLink
 --import Dodge.Room.Foreground
@@ -22,7 +22,7 @@ corridor = defaultRoom
     , _rmPath  = concatMap (doublePair . (,) (V2 20 60) . fst) lnks
     , _rmPmnts = [ spanLightI (V2 0 40) (V2 40 40) ]
     , _rmBound = [ rectNSWE 50 30 0 40 ]
-    , _rmFloor = [makeTileFromPoly poly 2]  
+    , _rmFloor = Tiled [makeTileFromPoly poly 2]  
     , _rmRandPSs = [psRandRanges (10,30) (30,60) (0,2*pi)]
     , _rmName = "Corridor"
     }

src/Dodge/Room/Link.hs

@@ -134,7 +134,7 @@ shiftRoomBy shift r = r
     & rmPath  %~ map (shiftPathBy shift)
     & rmBound %~ fmap (map (shiftPointBy shift))
     & rmShift %~ shiftPosDirBy shift
-    & rmFloor %~ map 
+    & rmFloor . tiles %~ map 
         ( (tilePoly %~ map (shiftPointBy shift))
         . (tileZero %~ shiftPointBy shift    )
         . (tileX    %~ shiftPointBy shift         )

src/Dodge/Room/Procedural.hs

@@ -52,7 +52,7 @@ roomRect x y xn yn = defaultRoom
     , _rmPos   = map (`UnusedSpot` 0) posps
     , _rmPmnts    = []
     , _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)]
-    , _rmFloor = [Tile 
+    , _rmFloor = Tiled [Tile 
             { _tilePoly = rectNSWE y 0 0 x
             , _tileZero = V2 0 0
             , _tileX    = V2 1 0
@@ -93,7 +93,7 @@ combineRooms r r' = defaultRoom
     , _rmPmnts    = map (shiftPlacement $ _rmShift r)  (_rmPmnts r) 
               ++ map (shiftPlacement $ _rmShift r') (_rmPmnts r')
     , _rmBound = _rmBound r ++ _rmBound r'
-    , _rmFloor = _rmFloor r ++ _rmFloor r'
+    , _rmFloor = combineFloors (_rmFloor r) (_rmFloor r')
     , _rmShift  = (V2 0 0 , 0)
     }
 -- not that this assumes that any link paths are integral
@@ -102,6 +102,9 @@ clampPath = bimap f f
   where
     f (V2 x y) = V2 (g x) (g y)
     g = (fromIntegral :: Int -> Float) . floor
+
+combineFloors :: Floor -> Floor -> Floor
+combineFloors f _ = f
 {- Randomly generate a top fourth of a room possibly with a wall.
 Add a light and a 'PutNothing' placement.  -}
 quarterRoomFlat :: RandomGen g => Float -> State g Room

src/Dodge/Room/Room.hs

@@ -1,4 +1,5 @@
 module Dodge.Room.Room where
+import Data.Tile
 import Dodge.Data
 import Dodge.PlacementSpot
 import Dodge.RoomLink
@@ -206,7 +207,7 @@ roomOctogon = defaultRoom
     , _rmPath  = allPairs $ map fst lnks -- this is too much
     , _rmPmnts = []
     , _rmBound = [map toV2 [(-20,30),(20,30),(60,70),(60,110),(20,150),(-20,150),(-60,110),(-60,70)] ]
-    , _rmFloor = [makeTileFromPoly poly 7]
+    , _rmFloor = Tiled [makeTileFromPoly poly 7]
     }
   where 
     poly = map toV2 [(-20,40),(20,40),(50,70),(50,110),(20,140),(-20,140),(-50,110),(-50,70)]
@@ -228,7 +229,7 @@ roomNgon n x = defaultRoom
     , _rmPath  = [] -- TODO
     , _rmPmnts = []
     , _rmBound = [poly]
-    , _rmFloor = [makeTileFromPoly poly 9]
+    , _rmFloor = Tiled [makeTileFromPoly poly 9]
     , _rmName = show n ++ "gon"
     }
   where 

src/Dodge/Tree/Shift.hs

@@ -23,7 +23,9 @@ type RoomInt = (Room,Int)
 
 positionRoomsFromTree :: Tree RoomInt -> IO (Maybe [RoomInt])
 positionRoomsFromTree (Node (r,i) ts) = printHeader 
-    >> posRms (map pointsToPoly $ _rmBound r) (r,i) (zipCount ts) Empty
+    >> posRms (map pointsToPoly $ _rmBound r') (r',i) (zipCount ts) Empty
+  where
+    r' = r & rmMID ?~ 0
 
 posRms :: [ConvexPoly]
     -> RoomInt