module Dungeon where import Prelude hiding (floor) import Control.Monad import qualified System.Random as R import Data.Binary import Data.Map as M import Data.List as L import Data.Ratio import Data.Maybe import Geometry import GeometryRnd import Level import Item import Random import qualified Terrain import qualified ItemKind import WorldLoc import Tile -- TODO: qualified -- | The complete dungeon is a map from level names to levels. -- We usually store all but the current level in this data structure. newtype Dungeon = Dungeon (M.Map LevelId Level) deriving Show instance Binary Dungeon where put (Dungeon dng) = put (M.elems dng) get = liftM dungeon get -- | Create a dungeon from a list of levels. dungeon :: [Level] -> Dungeon dungeon = Dungeon . M.fromList . L.map (\ l -> (lname l, l)) -- | Extract a level from a dungeon. getDungeonLevel :: LevelId -> Dungeon -> (Level, Dungeon) getDungeonLevel ln (Dungeon dng) = (dng ! ln, Dungeon (M.delete ln dng)) -- | Put a level into a dungeon. putDungeonLevel :: Level -> Dungeon -> Dungeon putDungeonLevel lvl (Dungeon dng) = Dungeon (M.insert (lname lvl) lvl dng) sizeDungeon :: Dungeon -> Int sizeDungeon (Dungeon dng) = M.size dng type Corridor = [(Y,X)] type Room = Area -- | Create a random room according to given parameters. mkRoom :: Int -> -- ^ border columns (Y,X) -> -- ^ minimum size Area -> -- ^ this is an area, not the room itself Rnd Room -- ^ this is the upper-left and lower-right corner of the room mkRoom bd (ym,xm) ((y0,x0),(y1,x1)) = do (ry0,rx0) <- locInArea ((y0 + bd,x0 + bd),(y1 - bd - ym + 1,x1 - bd - xm + 1)) (ry1,rx1) <- locInArea ((ry0 + ym - 1,rx0 + xm - 1),(y1 - bd,x1 - bd)) return ((ry0,rx0),(ry1,rx1)) -- | Create a no-room, i.e., a single corridor field. mkNoRoom :: Int -> -- ^ border columns Area -> -- ^ this is an area, not the room itself Rnd Room -- ^ this is the upper-left and lower-right corner of the room mkNoRoom bd ((y0,x0),(y1,x1)) = do (ry,rx) <- locInArea ((y0 + bd,x0 + bd),(y1 - bd,x1 - bd)) return ((ry,rx),(ry,rx)) data HV = Horiz | Vert deriving (Eq, Show, Bounded) fromHV Horiz = True fromHV Vert = False toHV True = Horiz toHV False = Vert instance R.Random HV where randomR (a,b) g = case R.randomR (fromHV a, fromHV b) g of (b, g') -> (toHV b, g') random g = R.randomR (minBound, maxBound) g -- | Create a corridor, either horizontal or vertical, with -- a possible intermediate part that is in the opposite direction. mkCorridor :: HV -> (Loc,Loc) -> Area -> Rnd [(Y,X)] {- straight sections of the corridor -} mkCorridor hv ((y0,x0),(y1,x1)) b = do (ry,rx) <- findLocInArea b (const True) -- (ry,rx) is intermediate point the path crosses -- hv decides whether we start in horizontal or vertical direction case hv of Horiz -> return [(y0,x0),(y0,rx),(y1,rx),(y1,x1)] Vert -> return [(y0,x0),(ry,x0),(ry,x1),(y1,x1)] -- | Try to connect two rooms with a corridor. -- The condition passed to mkCorridor is tricky; there might not always -- exist a suitable intermediate point if the rooms are allowed to be close -- together ... connectRooms :: Area -> Area -> Rnd [Loc] connectRooms sa@((sy0,sx0),(sy1,sx1)) ta@((ty0,tx0),(ty1,tx1)) = do (sy,sx) <- locInArea sa (ty,tx) <- locInArea ta let xok = sx1 < tx0 - 3 let xarea = normalizeArea ((sy,sx1+2),(ty,tx0-2)) let yok = sy1 < ty0 - 3 let yarea = normalizeArea ((sy1+2,sx),(ty0-2,tx)) let xyarea = normalizeArea ((sy1+2,sx1+2),(ty0-2,tx0-2)) (hv,area) <- if xok && yok then fmap (\ hv -> (hv,xyarea)) (binaryChoice Horiz Vert) else if xok then return (Horiz,xarea) else return (Vert,yarea) mkCorridor hv ((sy,sx),(ty,tx)) area digCorridors :: Corridor -> LMap digCorridors (p1:p2:ps) = M.union corPos (digCorridors (p2:ps)) where corLoc = fromTo p1 p2 corPos = M.fromList $ L.zip corLoc (repeat $ newTile Terrain.floorDark) digCorridors _ = M.empty mergeCorridor :: (Tile, Tile) -> (Tile, Tile) -> (Tile, Tile) mergeCorridor _ (Tile t is, u) | Terrain.isRock t = (Tile Terrain.opening is, u) mergeCorridor _ (Tile t is, u) | Terrain.isOpening t = (Tile Terrain.opening is, u) mergeCorridor _ (Tile t is, u) | Terrain.isFloor t = (Tile t is, u) mergeCorridor (x, u) _ = (x, u) -- | Create a new tile. newTile :: Terrain.Terrain -> (Tile, Tile) newTile t = (Tile t [], Tile Terrain.unknown []) -- | Create a level consisting of only one room. Optionally, insert some walls. emptyRoom :: (Level -> Rnd (LMap -> LMap)) -> LevelConfig -> LevelId -> Rnd (Maybe (Maybe WorldLoc) -> Maybe (Maybe WorldLoc) -> Level, Loc, Loc) emptyRoom addRocksRnd cfg@(LevelConfig { levelSize = (sy,sx) }) nm = do let lmap = digRoom Terrain.Light ((1,1),(sy-1,sx-1)) (emptyLMap (sy,sx)) let smap = M.fromList [ ((y,x),-100) | y <- [0..sy], x <- [0..sx] ] let lvl = Level nm emptyParty (sy,sx) emptyParty smap lmap "" -- locations of the stairs su <- findLoc lvl (const floor) sd <- findLoc lvl (\ l t -> floor t && distance (su,l) > minStairsDistance cfg) is <- rollItems cfg lvl su addRocks <- addRocksRnd lvl let addItem lmap (l,it) = M.update (\ (t,r) -> Just (t { titems = it : titems t }, r)) l lmap flmap lu ld = addRocks $ maybe id (\ l -> M.insert su (newTile (Terrain.stairs Terrain.Light Up l))) lu $ maybe id (\ l -> M.insert sd (newTile (Terrain.stairs Terrain.Light Down l))) ld $ (\lmap -> L.foldl' addItem lmap is) $ lmap level lu ld = Level nm emptyParty (sy,sx) emptyParty smap (flmap lu ld) "bigroom" return (level, su, sd) -- | For a bigroom level: Create a level consisting of only one, empty room. bigRoom :: LevelConfig -> LevelId -> Rnd (Maybe (Maybe WorldLoc) -> Maybe (Maybe WorldLoc) -> Level, Loc, Loc) bigRoom = emptyRoom (\ lvl -> return id) -- | For a noiseroom level: Create a level consisting of only one room -- with randomly distributed pillars. noiseRoom :: LevelConfig -> LevelId -> Rnd (Maybe (Maybe WorldLoc) -> Maybe (Maybe WorldLoc) -> Level, Loc, Loc) noiseRoom cfg = let addRocks lvl = do rs <- rollPillars cfg lvl let insertRock lmap l = case lmap `at` l of Tile t [] | Terrain.isFloor t -> M.insert l (newTile Terrain.rock) lmap _ -> lmap return $ \ lmap -> L.foldl' insertRock lmap rs in emptyRoom addRocks cfg data LevelConfig = LevelConfig { levelGrid :: Rnd (Y,X), minRoomSize :: Rnd (Y,X), darkRoomChance :: Rnd Bool, border :: Int, -- must be at least 2! levelSize :: (Y,X), -- lower right point extraConnects :: (Y,X) -> Int, -- relative to grid (in fact a range, because of duplicate connects) noRooms :: (Y,X) -> Rnd Int, -- range, relative to grid minStairsDistance :: Int, -- must not be too large doorChance :: Rnd Bool, doorOpenChance :: Rnd Bool, doorSecretChance :: Rnd Bool, doorSecretMax :: Int, nrItems :: Rnd Int, -- range depth :: Int -- general indicator of difficulty } normalLevelSize :: (Y,X) normalLevelSize = (22,79) defaultLevelConfig :: Int -> LevelConfig defaultLevelConfig d = LevelConfig { levelGrid = do y <- randomR (2,4) x <- randomR (3,5) return (y,x), minRoomSize = return (2,2), darkRoomChance = chance $ 1%((22 - (2 * fromIntegral d)) `max` 2), border = 2, levelSize = normalLevelSize, extraConnects = \ (y,x) -> (y*x) `div` 3, noRooms = \ (y,x) -> randomR (0,(y*x) `div` 3), minStairsDistance = 676, doorChance = chance $ 2%3, doorOpenChance = chance $ 1%10, doorSecretChance = chance $ 1%4, doorSecretMax = 15, nrItems = randomR (5,10), depth = d } largeLevelConfig :: Int -> LevelConfig largeLevelConfig d = (defaultLevelConfig d) { levelGrid = return (7,10), levelSize = (77,231), extraConnects = const 10 } -- | Create a "normal" dungeon level. Takes a configuration in order -- to tweak all sorts of data. {- Leve is generated by an algorithm inspired by the original Rogue, as follows: * The available area is divided into a 3 by 3 grid where each of the 9 grid cells has approximately the same size. * In each of the 9 grid cells one room is placed at a random location. The minimum size of a room is 2 by 2 floor tiles. A room is surrounded by walls, and the walls still have to fit into the assigned grid cells. * Rooms that are on horizontally or vertically adjacent grid cells may be connected by a corridor. Corridors consist of 3 segments of straight lines (either "horizontal, vertical, horizontal" or "vertical, horizontal, vertical"). They end in openings in the walls of the room they connect. It is possible that one or two of the 3 segments have length 0, such that the resulting corridor is L-shaped or even a single straight line. * Corridors are generated randomly in such a way that at least every room on the grid is connected, and a few more might be. It is not sufficient to always connect all adjacent rooms. * Stairs up and down are placed. Stairs are always located in two different randomly chosen rooms. -} rogueRoom :: LevelConfig -> LevelId -> Rnd (Maybe (Maybe WorldLoc) -> Maybe (Maybe WorldLoc) -> Level, Loc, Loc) rogueRoom cfg nm = do lgrid <- levelGrid cfg lminroom <- minRoomSize cfg let gs = grid lgrid ((0, 0), levelSize cfg) -- grid locations of "no-rooms" nrnr <- noRooms cfg lgrid nr <- replicateM nrnr (do let (y,x) = lgrid yg <- randomR (0,y-1) xg <- randomR (0,x-1) return (yg,xg)) rs0 <- mapM (\ (i,r) -> do r' <- if i `elem` nr then mkNoRoom (border cfg) r else mkRoom (border cfg) lminroom r return (i,r')) gs let rooms :: [(Loc, Loc)] rooms = L.map snd rs0 dlrooms <- (mapM (\ r -> darkRoomChance cfg >>= \ c -> return (r, Terrain.toDL (not c))) rooms) :: Rnd [((Loc, Loc), Terrain.DL)] let rs = M.fromList rs0 connects <- connectGrid lgrid addedConnects <- replicateM (extraConnects cfg lgrid) (randomConnection lgrid) let allConnects = L.nub (addedConnects ++ connects) cs <- mapM (\ (p0,p1) -> do let r0 = rs ! p0 r1 = rs ! p1 connectRooms r0 r1) allConnects let smap = M.fromList [ ((y,x),-100) | let (sy,sx) = levelSize cfg, y <- [0..sy], x <- [0..sx] ] let lrooms = L.foldr (\ (r, dl) m -> digRoom dl r m) M.empty dlrooms lcorridors = M.unions (L.map digCorridors cs) lrocks = emptyLMap (levelSize cfg) lmap = M.union (M.unionWith mergeCorridor lcorridors lrooms) lrocks let lvl = Level nm emptyParty (levelSize cfg) emptyParty smap lmap "" -- convert openings into doors dlmap <- fmap M.fromList . mapM (\ o@((y,x),(t,r)) -> case t of Tile t _ | Terrain.isOpening t -> do -- openings have a certain chance to be doors; -- doors have a certain chance to be open; and -- closed doors have a certain chance to be -- secret rb <- doorChance cfg ro <- doorOpenChance cfg rs <- if ro then return Nothing else do rsc <- doorSecretChance cfg fmap Just (if rsc then randomR (doorSecretMax cfg `div` 2, doorSecretMax cfg) else return 0) if rb then return ((y,x),newTile (Terrain.door rs)) else return o _ -> return o) . M.toList $ lmap -- locations of the stairs su <- findLoc lvl (const floor) sd <- findLocTry 1000 lvl (const floor) (\ l t -> distance (su,l) > minStairsDistance cfg) -- determine number of items, items and locations for the items is <- rollItems cfg lvl su -- generate map and level from the data let meta = show allConnects return (\ lu ld -> let flmap = maybe id (\ l -> M.update (\ (t,r) -> Just $ newTile (Terrain.stairs (Terrain.toDL $ light t) Up l)) su) lu $ maybe id (\ l -> M.update (\ (t,r) -> Just $ newTile (Terrain.stairs (Terrain.toDL $ light t) Down l)) sd) ld $ L.foldr (\ (l,it) f -> M.update (\ (t,r) -> Just (t { titems = it : titems t }, r)) l . f) id is dlmap in Level nm emptyParty (levelSize cfg) emptyParty smap flmap meta, su, sd) rollItems :: LevelConfig -> Level -> Loc -> Rnd [(Loc, Item)] rollItems cfg lvl ploc = do nri <- nrItems cfg replicateM nri $ do t <- newItem (depth cfg) l <- case ItemKind.jname (ItemKind.getIK (ikind t)) of "sword" -> -- swords generated close to monsters; MUAHAHAHA findLocTry 200 lvl (const floor) (\ l t -> distance (ploc, l) > 400) _ -> findLoc lvl (const floor) return (l,t) rollPillars :: LevelConfig -> Level -> Rnd [Loc] rollPillars cfg lvl = do nri <- 100 *~ nrItems cfg replicateM nri $ do l <- findLoc lvl (const floor) return l emptyLMap :: (Y, X) -> LMap emptyLMap (my, mx) = M.fromList [ ((y, x), newTile Terrain.rock) | x <- [0..mx], y <- [0..my] ] -- | If the room has size 1, it is assumed to be a no-room, and a single -- corridor field will be dug instead of a room. digRoom :: Terrain.DL -> Room -> LMap -> LMap digRoom dl ((y0, x0), (y1, x1)) l | y0 == y1 && x0 == x1 = M.insert (y0, x0) (newTile Terrain.floorDark) l | otherwise = let floorDL = if dl == Terrain.Light then Terrain.floorLight else Terrain.floorDark rm = [ ((y, x), newTile floorDL) | x <- [x0..x1], y <- [y0..y1] ] ++ [ ((y, x), newTile Terrain.rock) | x <- [x0-1, x1+1], y <- [y0..y1] ] ++ [ ((y, x), newTile Terrain.rock) | x <- [x0-1..x1+1], y <- [y0-1, y1+1] ] in M.unionWith const (M.fromList rm) l