{-# LANGUAGE TupleSections #-}
module Game.LambdaHack.Server.DungeonGen
( FreshDungeon(..), dungeonGen
#ifdef EXPOSE_INTERNAL
, convertTileMaps, buildTileMap, anchorDown, buildLevel
, snapToStairList, placeDownStairs, levelFromCave
#endif
) where
import Prelude ()
import Game.LambdaHack.Core.Prelude
import qualified Control.Monad.Trans.State.Strict as St
import Data.Either (rights)
import qualified Data.EnumMap.Strict as EM
import qualified Data.IntMap.Strict as IM
import qualified Data.Text as T
import qualified Data.Text.IO as T
import System.IO (hFlush, stdout)
import System.IO.Unsafe (unsafePerformIO)
import qualified System.Random as R
import Game.LambdaHack.Common.Area
import Game.LambdaHack.Definition.Defs
import qualified Game.LambdaHack.Core.Dice as Dice
import Game.LambdaHack.Common.Kind
import Game.LambdaHack.Common.Level
import Game.LambdaHack.Common.Point
import qualified Game.LambdaHack.Common.PointArray as PointArray
import Game.LambdaHack.Core.Random
import qualified Game.LambdaHack.Common.Tile as Tile
import Game.LambdaHack.Common.Time
import Game.LambdaHack.Common.Types
import Game.LambdaHack.Content.CaveKind
import Game.LambdaHack.Content.ModeKind
import qualified Game.LambdaHack.Content.PlaceKind as PK
import Game.LambdaHack.Content.RuleKind
import Game.LambdaHack.Content.TileKind (TileKind)
import qualified Game.LambdaHack.Content.TileKind as TK
import Game.LambdaHack.Server.DungeonGen.AreaRnd
import Game.LambdaHack.Server.DungeonGen.Cave
import Game.LambdaHack.Server.DungeonGen.Place
import Game.LambdaHack.Server.ServerOptions
convertTileMaps :: COps -> Bool -> Rnd (ContentId TileKind)
-> Maybe (Rnd (ContentId TileKind)) -> Area -> TileMapEM
-> Rnd TileMap
convertTileMaps COps{corule=RuleContent{rXmax, rYmax}, cotile, coTileSpeedup}
areAllWalkable cdefTile mpickPassable darea ltile = do
let outerId = ouniqGroup cotile "unknown outer fence"
runCdefTile :: (R.StdGen, (Int, [(Int, ContentId TileKind)]))
-> ( ContentId TileKind
, (R.StdGen, (Int, [(Int, ContentId TileKind)])) )
runCdefTile (gen1, (pI, assocs)) =
let p = toEnum pI
in if p `inside` darea
then case assocs of
(p2, t2) : rest | p2 == pI -> (t2, (gen1, (pI + 1, rest)))
_ -> let (tile, gen2) = St.runState cdefTile gen1
in (tile, (gen2, (pI + 1, assocs)))
else (outerId, (gen1, (pI + 1, assocs)))
runUnfold gen =
let (gen1, gen2) = R.split gen
in (PointArray.unfoldrNA
rXmax rYmax runCdefTile
(gen1, (0, IM.assocs $ EM.enumMapToIntMap ltile)), gen2)
converted1 <- St.state runUnfold
case mpickPassable of
_ | areAllWalkable -> return converted1
Nothing -> return converted1
Just pickPassable -> do
let passes p@Point{..} array =
Tile.isWalkable coTileSpeedup (array PointArray.! p)
blocksHorizontal (Point x y) array =
not (passes (Point (x + 1) y) array
|| passes (Point (x - 1) y) array)
blocksVertical (Point x y) array =
not (passes (Point x (y + 1)) array
|| passes (Point x (y - 1)) array)
xeven Point{..} = px `mod` 2 == 0
yeven Point{..} = py `mod` 2 == 0
activeArea = fromMaybe (error $ "" `showFailure` darea) $ shrink darea
connect included blocks walkableTile array =
let g p c = if p `inside` activeArea
&& included p
&& not (Tile.isEasyOpen coTileSpeedup c)
&& p `EM.notMember` ltile
&& blocks p array
then walkableTile
else c
in PointArray.imapA g array
walkable2 <- pickPassable
let converted2 = connect xeven blocksHorizontal walkable2 converted1
walkable3 <- pickPassable
let converted3 = connect yeven blocksVertical walkable3 converted2
walkable4 <- pickPassable
let converted4 =
connect (not . xeven) blocksHorizontal walkable4 converted3
walkable5 <- pickPassable
let converted5 =
connect (not . yeven) blocksVertical walkable5 converted4
return converted5
buildTileMap :: COps -> Cave -> Rnd TileMap
buildTileMap cops@COps{cotile, cocave} Cave{dkind, darea, dmap} = do
let CaveKind{cpassable, cdefTile} = okind cocave dkind
pickDefTile = fromMaybe (error $ "" `showFailure` cdefTile)
<$> opick cotile cdefTile (const True)
wcond = Tile.isEasyOpenKind
mpickPassable =
if cpassable
then Just $ fromMaybe (error $ "" `showFailure` cdefTile)
<$> opick cotile cdefTile wcond
else Nothing
nwcond = not . Tile.kindHasFeature TK.Walkable
areAllWalkable <- isNothing <$> opick cotile cdefTile nwcond
convertTileMaps cops areAllWalkable pickDefTile mpickPassable darea dmap
anchorDown :: Y
anchorDown = 5
buildLevel :: COps -> ServerOptions -> Int -> GroupName CaveKind
-> Int -> Dice.AbsDepth -> [(Point, Text)]
-> Rnd (Level, [(Point, Text)])
buildLevel cops@COps{cocave, coplace, corule=RuleContent{..}} serverOptions
ln genName minD totalDepth lstairPrev = do
dkind <- fromMaybe (error $ "" `showFailure` genName)
<$> opick cocave genName (const True)
let kc = okind cocave dkind
d = if cfenceApart kc then 1 else 0
ldepth = Dice.AbsDepth $ abs ln
darea =
let (lxPrev, lyPrev) = unzip $ map (px . fst &&& py . fst) lstairPrev
lxMin = max 0
$ -4 - d + minimum (rXmax - 1 : lxPrev)
lxMax = min (rXmax - 1)
$ 4 + d + maximum (0 : lxPrev)
lyMin = max 0
$ -3 - d + minimum (rYmax - 1 : lyPrev)
lyMax = min (rYmax - 1)
$ 3 + d + maximum (0 : lyPrev)
xspan = max (lxMax - lxMin + 1) $ cXminSize kc
yspan = max (lyMax - lyMin + 1) $ cYminSize kc
x0 = min lxMin $ max (lxMax - xspan + 1) $ (rXmax - xspan) `div` 2
y0 = min lyMin $ max (lyMax - yspan + 1) $ (rYmax - yspan) `div` 2
in fromMaybe (error $ "" `showFailure` kc)
$ toArea (x0, y0, x0 + xspan - 1, y0 + yspan - 1)
extraStairs <- castDice ldepth totalDepth $ cextraStairs kc
let (abandonedStairs, remainingStairsDown) =
if ln == minD then (length lstairPrev, 0)
else let double = min (length lstairPrev) extraStairs
single = max 0 $ extraStairs - double
in (length lstairPrev - double, single)
(lstairsSingleUp, lstairsDouble) = splitAt abandonedStairs lstairPrev
pstairsSingleUp = map fst lstairsSingleUp
pstairsDouble = map fst lstairsDouble
pallUpStairs = pstairsDouble ++ pstairsSingleUp
boot = let (x0, y0, x1, y1) = fromArea darea
in rights $ map (snapToStairList 0 pallUpStairs)
[ Point (x0 + 4 + d) (y0 + 3 + d)
, Point (x1 - 4 - d) (y1 - anchorDown + 1) ]
fixedEscape <- case cescapeFreq kc of
[] -> return []
escapeFreq -> do
mepos <- placeDownStairs "escape" True serverOptions ln
kc darea pallUpStairs boot
case mepos of
Just epos -> return [(epos, escapeFreq)]
Nothing -> return []
let pescape = map fst fixedEscape
pallUpAndEscape = pescape ++ pallUpStairs
addSingleDown :: [Point] -> Int -> Rnd [Point]
addSingleDown acc 0 = return acc
addSingleDown acc k = do
mpos <- placeDownStairs "stairs" False serverOptions ln
kc darea (pallUpAndEscape ++ acc) boot
case mpos of
Just pos -> addSingleDown (pos : acc) (k - 1)
Nothing -> return acc
pstairsSingleDown <- addSingleDown [] remainingStairsDown
let freqDouble carried =
filter (\(gn, _) -> carried `elem` T.words (fromGroupName gn))
$ cstairFreq kc ++ cstairAllowed kc
fixedStairsDouble = map (second freqDouble) lstairsDouble
freqUp carried =
map (first (\gn -> toGroupName $ fromGroupName gn <+> "up"))
$ freqDouble carried
fixedStairsUp = map (second freqUp) lstairsSingleUp
freqDown =
map (first (\gn -> toGroupName $ fromGroupName gn <+> "down"))
$ cstairFreq kc
fixedStairsDown = map (, freqDown) pstairsSingleDown
pallExits = pallUpAndEscape ++ pstairsSingleDown
fixedCenters = EM.fromList $
fixedEscape ++ fixedStairsDouble ++ fixedStairsUp ++ fixedStairsDown
bootExtra <- if EM.null fixedCenters then do
mpointExtra <-
placeDownStairs "extra boot" False serverOptions ln
kc darea pallExits boot
return $! maybeToList mpointExtra
else return []
let posUp Point{..} = Point (px - 1) py
posDn Point{..} = Point (px + 1) py
lstair = ( map posUp $ pstairsSingleUp ++ pstairsDouble
, map posDn $ pstairsDouble ++ pstairsSingleDown )
cellSize <- castDiceXY ldepth totalDepth $ ccellSize kc
let subArea = fromMaybe (error $ "" `showFailure` kc) $ shrink darea
area = if cfenceApart kc then subArea else darea
(lgr, gs) = grid fixedCenters (boot ++ bootExtra) area cellSize
dsecret <- randomR (1, maxBound)
cave <- buildCave cops ldepth totalDepth darea dsecret dkind lgr gs bootExtra
cmap <- buildTileMap cops cave
let lvl = levelFromCave cops cave ldepth cmap lstair pescape
stairCarried p0 =
let Place{qkind} = dstairs cave EM.! p0
freq = map (first $ T.words . tshow)
(PK.pfreq $ okind coplace qkind)
carriedAll = filter (\t -> any (\(ws, _) -> t `elem` ws) freq)
rstairWordCarried
in case carriedAll of
[t] -> (p0, t)
_ -> error $ "wrong carried stair word"
`showFailure` (freq, carriedAll, kc)
return (lvl, lstairsDouble ++ map stairCarried pstairsSingleDown)
snapToStairList :: Int -> [Point] -> Point -> Either Point Point
snapToStairList _ [] p = Right p
snapToStairList a (pos : rest) p =
let nx = if px pos > px p + 5 + a || px pos < px p - 5 - a
then px p
else px pos
ny = if py pos > py p + 3 + a || py pos < py p - 3 - a
then py p
else py pos
np = Point nx ny
in if np == pos then Left np else snapToStairList a rest np
placeDownStairs :: Text -> Bool -> ServerOptions -> Int
-> CaveKind -> Area -> [Point] -> [Point]
-> Rnd (Maybe Point)
placeDownStairs object cornerPermitted serverOptions ln
CaveKind{cminStairDist, cfenceApart} darea ps boot = do
let dist cmin p = all (\pos -> chessDist p pos > cmin) ps
(x0, y0, x1, y1) = fromArea darea
notInCorner Point{..} =
cornerPermitted
|| x1 - x0 + 1 < 40 || y1 - y0 + 1 < 20
|| px > x0 + 9 && px < x1 - 9
|| py > y0 + 6 && py < y1 - 6
f p = case snapToStairList 0 ps p of
Left{} -> Nothing
Right np -> let nnp = either id id $ snapToStairList 0 boot np
in if notInCorner nnp then Just nnp else Nothing
g p = case snapToStairList 2 ps p of
Left{} -> Nothing
Right np -> let nnp = either id id $ snapToStairList 2 boot np
in if notInCorner nnp && dist cminStairDist nnp
then Just nnp
else Nothing
focusArea = let d = if cfenceApart then 1 else 0
in fromMaybe (error $ "" `showFailure` darea)
$ toArea ( x0 + 4 + d, y0 + 3 + d
, x1 - 4 - d, y1 - anchorDown + 1 )
mpos <- findPointInArea focusArea g 300 f
let !_ = if isNothing mpos && sdumpInitRngs serverOptions
then unsafePerformIO $ do
T.hPutStrLn stdout $
"Failed to place" <+> object <+> "on level"
<+> tshow ln <> ", in" <+> tshow darea
hFlush stdout
#ifdef WITH_EXPENSIVE_ASSERTIONS
error "possible, but unexpected; alarm!"
#endif
else ()
return mpos
levelFromCave :: COps -> Cave -> Dice.AbsDepth
-> TileMap -> ([Point], [Point]) -> [Point]
-> Level
levelFromCave COps{coTileSpeedup} Cave{..} ldepth ltile lstair lescape =
let f n t | Tile.isExplorable coTileSpeedup t = n + 1
| otherwise = n
lexpl = PointArray.foldlA' f 0 ltile
in Level
{ lkind = dkind
, ldepth
, lfloor = EM.empty
, lembed = EM.empty
, lbig = EM.empty
, lproj = EM.empty
, ltile
, lentry = dentry
, larea = darea
, lsmell = EM.empty
, lstair
, lescape
, lseen = 0
, lexpl
, ltime = timeZero
, lnight = dnight
}
data FreshDungeon = FreshDungeon
{ freshDungeon :: Dungeon
, freshTotalDepth :: Dice.AbsDepth
}
dungeonGen :: COps -> ServerOptions -> Caves -> Rnd FreshDungeon
dungeonGen cops serverOptions caves = do
let keys = concatMap fst caves
minD = minimum keys
maxD = maximum keys
freshTotalDepth = assert (signum minD == signum maxD)
$ Dice.AbsDepth
$ max 10 $ max (abs minD) (abs maxD)
placeCaveGroup :: ([(LevelId, Level)], [(Point, Text)])
-> (Int, GroupName CaveKind)
-> Rnd ([(LevelId, Level)], [(Point, Text)])
placeCaveGroup (lvls, ldown) (n, genName) = do
(newLevel, ldown2) <-
buildLevel cops serverOptions n genName minD freshTotalDepth ldown
return ((toEnum n, newLevel) : lvls, ldown2)
buildLvls :: ([(LevelId, Level)], [(Point, Text)])
-> ([Int], [GroupName CaveKind])
-> Rnd ([(LevelId, Level)], [(Point, Text)])
buildLvls (lvls, ldown) (ns, l) = assert (length ns == length l) $ do
lShuffled <- shuffle l
let nsl = zip ns lShuffled
foldlM' placeCaveGroup (lvls, ldown) nsl
(levels, _) <- foldlM' buildLvls ([], []) caves
let freshDungeon = EM.fromList levels
return $! FreshDungeon{..}