module Game.LambdaHack.Server.DungeonGen
( FreshDungeon(..), dungeonGen
#ifdef EXPOSE_INTERNAL
, convertTileMaps, buildTileMap, buildLevel, placeDownStairs
, levelFromCaveKind
#endif
) where
import Prelude ()
import Game.LambdaHack.Common.Prelude
import qualified Control.Monad.Trans.State.Strict as St
import qualified Data.EnumMap.Strict as EM
import qualified Data.IntMap.Strict as IM
import Data.Tuple
import qualified System.Random as R
import qualified Game.LambdaHack.Common.Dice as Dice
import Game.LambdaHack.Common.Frequency
import Game.LambdaHack.Common.Kind
import Game.LambdaHack.Common.Level
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.Point
import qualified Game.LambdaHack.Common.PointArray as PointArray
import Game.LambdaHack.Common.Random
import qualified Game.LambdaHack.Common.Tile as Tile
import Game.LambdaHack.Common.Time
import Game.LambdaHack.Content.CaveKind
import Game.LambdaHack.Content.ModeKind
import Game.LambdaHack.Content.PlaceKind (PlaceKind)
import Game.LambdaHack.Content.TileKind (TileKind)
import qualified Game.LambdaHack.Content.TileKind as TK
import Game.LambdaHack.Server.DungeonGen.Cave
import Game.LambdaHack.Server.DungeonGen.Place
convertTileMaps :: COps -> Bool -> Rnd (ContentId TileKind)
-> Maybe (Rnd (ContentId TileKind)) -> Int -> Int -> TileMapEM
-> Rnd TileMap
convertTileMaps COps{coTileSpeedup} areAllWalkable
cdefTile mpickPassable cxsize cysize ltile = do
let runCdefTile :: R.StdGen -> (ContentId TileKind, R.StdGen)
runCdefTile = St.runState cdefTile
runUnfold gen =
let (gen1, gen2) = R.split gen
in (PointArray.unfoldrNA cxsize cysize runCdefTile gen1, gen2)
converted0 <- St.state runUnfold
let converted1 = converted0 PointArray.// EM.assocs ltile
case mpickPassable of
_ | areAllWalkable -> return converted1
Nothing -> return converted1
Just pickPassable -> do
let passes p@Point{..} array =
px >= 0 && px <= cxsize - 1
&& py >= 0 && py <= cysize - 1
&& 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
connect included blocks walkableTile array =
let g n c = if included n
&& not (Tile.isEasyOpen coTileSpeedup c)
&& n `EM.notMember` ltile
&& blocks n 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, dmap, dnight} = do
let CaveKind{cxsize, cysize, cpassable, cdefTile} = okind cocave dkind
nightCond kt = not (Tile.kindHasFeature TK.Walkable kt)
|| (if dnight then id else not)
(Tile.kindHasFeature TK.Dark kt)
pickDefTile = fromMaybe (error $ "" `showFailure` cdefTile)
<$> opick cotile cdefTile nightCond
wcond kt = Tile.isEasyOpenKind kt && nightCond kt
mpickPassable =
if cpassable
then Just $ fromMaybe (error $ "" `showFailure` cdefTile)
<$> opick cotile cdefTile wcond
else Nothing
nwcond kt = not (Tile.kindHasFeature TK.Walkable kt) && nightCond kt
areAllWalkable <- isNothing <$> opick cotile cdefTile nwcond
convertTileMaps cops areAllWalkable
pickDefTile mpickPassable cxsize cysize dmap
buildLevel :: COps -> Int -> GroupName CaveKind
-> Int -> Dice.AbsDepth -> [Point]
-> Rnd (Level, [Point])
buildLevel cops@COps{cocave} ln genName minD totalDepth lstairPrev = do
dkind <- fromMaybe (error $ "" `showFailure` genName)
<$> opick cocave genName (const True)
let kc = okind cocave dkind
ldepth = Dice.AbsDepth $ abs ln
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
lallUpStairs = lstairsDouble ++ lstairsSingleUp
freq = toFreq ("buildLevel" <+> tshow ln) $ map swap $ cstairFreq kc
addSingleDown :: [(Point, GroupName PlaceKind)] -> Int
-> Rnd [(Point, GroupName PlaceKind)]
addSingleDown acc 0 = return acc
addSingleDown acc k = do
pos <- placeDownStairs kc $ lallUpStairs ++ map fst acc
stairGroup <- frequency freq
addSingleDown ((pos, stairGroup) : acc) (k - 1)
stairsSingleDown <- addSingleDown [] remainingStairsDown
let lstairsSingleDown = map fst stairsSingleDown
fixedStairsDouble <- mapM (\p -> do
stairGroup <- frequency freq
return (p, stairGroup)) lstairsDouble
fixedStairsUp <- mapM (\p -> do
stairGroup <- frequency freq
return (p, toGroupName $ tshow stairGroup <+> "up")) lstairsSingleUp
let fixedStairsDown = map (\(p, t) ->
(p, toGroupName $ tshow t <+> "down")) stairsSingleDown
lallStairs = lallUpStairs ++ lstairsSingleDown
fixedEscape <- case cescapeGroup kc of
Nothing -> return []
Just escapeGroup -> do
epos <- placeDownStairs kc lallStairs
return [(epos, escapeGroup)]
let lescape = map fst fixedEscape
fixedCenters = EM.fromList $
fixedEscape ++ fixedStairsDouble ++ fixedStairsUp ++ fixedStairsDown
posUp Point{..} = Point (px - 1) py
posDn Point{..} = Point (px + 1) py
lstair = ( map posUp $ lstairsSingleUp ++ lstairsDouble
, map posDn $ lstairsDouble ++ lstairsSingleDown )
dsecret <- randomR (1, maxBound)
cave <- buildCave cops ldepth totalDepth dsecret dkind fixedCenters
cmap <- buildTileMap cops cave
let lvl =
levelFromCaveKind cops dkind ldepth cmap lstair lescape (dnight cave)
return (lvl, lstairsDouble ++ lstairsSingleDown)
placeDownStairs :: CaveKind -> [Point] -> Rnd Point
placeDownStairs kc@CaveKind{..} ps = do
let dist cmin p = all (\pos -> chessDist p pos > cmin) ps
distProj p = all (\pos -> (px pos == px p
|| px pos > px p + 5
|| px pos < px p - 5)
&& (py pos == py p
|| py pos > py p + 3
|| py pos < py p - 3))
$ ps ++ bootFixedCenters kc
minDist = if length ps >= 3 then 0 else cminStairDist
f p@Point{..} =
if p `inside` (9, 8, cxsize - 10, cysize - anchorDown - 5)
then if dist minDist p && distProj p then Just p else Nothing
else let nx = if | px < 9 -> 4
| px > cxsize - 10 -> cxsize - 5
| otherwise -> px
ny = if | py < 8 -> 3
| py > cysize - anchorDown - 5 -> cysize - anchorDown
| otherwise -> py
np = Point nx ny
in if dist 0 np && distProj np then Just np else Nothing
findPoint cxsize cysize f
levelFromCaveKind :: COps -> ContentId CaveKind -> Dice.AbsDepth
-> TileMap -> ([Point], [Point]) -> [Point] -> Bool
-> Level
levelFromCaveKind COps{cocave, coTileSpeedup}
lkind ldepth ltile lstair lescape lnight =
let f n t | Tile.isExplorable coTileSpeedup t = n + 1
| otherwise = n
lexpl = PointArray.foldlA' f 0 ltile
CaveKind{cxsize, cysize} = okind cocave lkind
in Level
{ lkind
, ldepth
, lfloor = EM.empty
, lembed = EM.empty
, lactor = EM.empty
, ltile
, lxsize = cxsize
, lysize = cysize
, lsmell = EM.empty
, lstair
, lescape
, lseen = 0
, lexpl
, ltime = timeZero
, lnight
}
data FreshDungeon = FreshDungeon
{ freshDungeon :: Dungeon
, freshTotalDepth :: Dice.AbsDepth
}
dungeonGen :: COps -> Caves -> Rnd FreshDungeon
dungeonGen cops caves = do
let (minD, maxD) =
case (IM.minViewWithKey caves, IM.maxViewWithKey caves) of
(Just ((s, _), _), Just ((e, _), _)) -> (s, e)
_ -> error $ "no caves" `showFailure` caves
freshTotalDepth = assert (signum minD == signum maxD)
$ Dice.AbsDepth
$ max 10 $ max (abs minD) (abs maxD)
buildLvl :: ([(LevelId, Level)], [Point])
-> (Int, GroupName CaveKind)
-> Rnd ([(LevelId, Level)], [Point])
buildLvl (l, ldown) (n, genName) = do
(lvl, ldown2) <- buildLevel cops n genName minD freshTotalDepth ldown
return ((toEnum n, lvl) : l, ldown2)
(levels, _) <- foldlM' buildLvl ([], []) $ reverse $ IM.assocs caves
let freshDungeon = EM.fromList levels
return $! FreshDungeon{..}