From 040849a5507ce7bae3fe1c20696211073adc1aa7 Mon Sep 17 00:00:00 2001 From: justin Date: Fri, 26 Nov 2021 13:57:22 +0000 Subject: [PATCH] Allow for rooms to inherit floor tiling from parents --- src/Data/Tile.hs | 9 ++++-- src/Dodge/Default/Room.hs | 6 ++-- src/Dodge/Layout.hs | 63 ++++++++++++++++++++++++++++-------- src/Dodge/LevelGen/Data.hs | 2 +- src/Dodge/Room/Corridor.hs | 6 ++-- src/Dodge/Room/Link.hs | 2 +- src/Dodge/Room/Procedural.hs | 7 ++-- src/Dodge/Room/Room.hs | 5 +-- src/Dodge/Tree/Shift.hs | 4 ++- 9 files changed, 75 insertions(+), 29 deletions(-) diff --git a/src/Data/Tile.hs b/src/Data/Tile.hs index 9d984f6ec..76b7c3fcc 100644 --- a/src/Data/Tile.hs +++ b/src/Data/Tile.hs @@ -1,10 +1,14 @@ {-# LANGUAGE TemplateHaskell #-} -module Data.Tile - where +--{-# LANGUAGE StrictData #-} +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 diff --git a/src/Dodge/Default/Room.hs b/src/Dodge/Default/Room.hs index 5e5776631..4ea9b5b01 100644 --- a/src/Dodge/Default/Room.hs +++ b/src/Dodge/Default/Room.hs @@ -1,5 +1,5 @@ -module Dodge.Default.Room - where +module Dodge.Default.Room 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 = [] diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index 35062b675..f8b024c10 100644 --- a/src/Dodge/Layout.hs +++ b/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 -addRandomTile r = do - z <- state $ randomR (0,63) - return $ addTile z r +putFloorTiles :: GenWorld -> GenWorld +putFloorTiles gw = gw & gWorld . floorTiles .~ floorsFromGenWorld gw + +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 z r - | not (null (_rmFloor r)) || null rp = r - | otherwise = r & rmFloor .~ [makeTileFromPoly poly z] - where - rp = _rmPolys r - poly = orderPolygon . convexHullSafe . nubBy ((==) `on` roundPoint2) $ concat rp +--addTile :: Float -> Room -> Room +--addTile z r +-- | not (null (_rmFloor r)) || null rp = r +-- | otherwise = r & rmFloor .~ [makeTileFromPoly poly z] +-- where +-- rp = _rmPolys r +-- poly = orderPolygon . convexHullSafe . nubBy ((==) `on` roundPoint2) $ concat rp diff --git a/src/Dodge/LevelGen/Data.hs b/src/Dodge/LevelGen/Data.hs index e8ad5fa7d..94ef42b20 100644 --- a/src/Dodge/LevelGen/Data.hs +++ b/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] diff --git a/src/Dodge/Room/Corridor.hs b/src/Dodge/Room/Corridor.hs index d1a02a775..6d195742c 100644 --- a/src/Dodge/Room/Corridor.hs +++ b/src/Dodge/Room/Corridor.hs @@ -1,6 +1,6 @@ {-# LANGUAGE TupleSections #-} -module Dodge.Room.Corridor - where +module Dodge.Room.Corridor 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" } diff --git a/src/Dodge/Room/Link.hs b/src/Dodge/Room/Link.hs index ef4642967..3b84cbbfa 100644 --- a/src/Dodge/Room/Link.hs +++ b/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 ) diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs index a14e1b678..77f536b42 100644 --- a/src/Dodge/Room/Procedural.hs +++ b/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 diff --git a/src/Dodge/Room/Room.hs b/src/Dodge/Room/Room.hs index 0b2e61fb7..d8e646705 100644 --- a/src/Dodge/Room/Room.hs +++ b/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 diff --git a/src/Dodge/Tree/Shift.hs b/src/Dodge/Tree/Shift.hs index 37568a833..d8d9792b6 100644 --- a/src/Dodge/Tree/Shift.hs +++ b/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