module Game.LambdaHack.Server.DungeonGen
( FreshDungeon(..), dungeonGen
) where
import Control.Arrow (first)
import Control.Monad
import qualified Data.EnumMap.Strict as EM
import Data.List
import Data.Maybe
import Data.Text (Text)
import qualified Game.LambdaHack.Common.Effect as Effect
import qualified Game.LambdaHack.Common.Feature as F
import qualified Game.LambdaHack.Common.Kind as Kind
import Game.LambdaHack.Common.Level
import Game.LambdaHack.Common.Point
import Game.LambdaHack.Common.PointXY
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.TileKind
import Game.LambdaHack.Server.DungeonGen.Area
import Game.LambdaHack.Server.DungeonGen.Cave hiding (TileMapXY)
import Game.LambdaHack.Server.DungeonGen.Place
import Control.Exception.Assert.Sugar
import Game.LambdaHack.Utils.Frequency
convertTileMaps :: Rnd (Kind.Id TileKind) -> Int -> Int -> TileMapXY
-> Rnd TileMap
convertTileMaps cdefTile cxsize cysize ltile = do
let bounds = (origin, toPoint cxsize $ PointXY (cxsize 1, cysize 1))
assocs = map (first (toPoint cxsize)) (EM.assocs ltile)
pickedTiles <- replicateM (cxsize * cysize) cdefTile
return $ Kind.listArray bounds pickedTiles Kind.// assocs
placeStairs :: Kind.Ops TileKind -> TileMap -> CaveKind -> [Point]
-> Rnd Point
placeStairs cotile cmap CaveKind{..} ps = do
let dist cmin l _ = all (\pos -> chessDist cxsize l pos > cmin) ps
findPosTry 1000 cmap
(\p t -> Tile.hasFeature cotile F.CanActor t
&& dist 0 p t)
[ dist $ cminStairDist
, dist $ cminStairDist `div` 2
, dist $ cminStairDist `div` 4
, dist $ cminStairDist `div` 8
]
buildLevel :: Kind.COps -> Cave -> Int -> Int -> Int -> Int -> Maybe Bool
-> Rnd Level
buildLevel cops@Kind.COps{ cotile=cotile@Kind.Ops{opick, okind}
, cocave=Kind.Ops{okind=cokind} }
Cave{..} ldepth minD maxD nstairUp escapeFeature = do
let kc@CaveKind{..} = cokind dkind
fitArea pos = inside cxsize pos . fromArea . qarea
findLegend pos = maybe clitLegendTile qlegend
$ find (fitArea pos) dplaces
hasEscapeAndSymbol sym t = Tile.kindHasFeature (F.Cause Effect.Escape) t
&& tsymbol t == sym
ascendable = Tile.kindHasFeature $ F.Cause (Effect.Ascend 1)
descendable = Tile.kindHasFeature $ F.Cause (Effect.Ascend (1))
dcond kt = not (Tile.kindHasFeature F.Clear kt)
|| (if dnight then not else id) (Tile.kindHasFeature F.Lit kt)
pickDefTile = fmap (fromMaybe $ assert `failure` cdefTile)
$ opick cdefTile dcond
cmap <- convertTileMaps pickDefTile cxsize cysize dmap
let makeStairs :: Bool -> Bool -> Bool
-> ( [(Point, Kind.Id TileKind)]
, [(Point, Kind.Id TileKind)]
, [(Point, Kind.Id TileKind)] )
-> Rnd ( [(Point, Kind.Id TileKind)]
, [(Point, Kind.Id TileKind)]
, [(Point, Kind.Id TileKind)] )
makeStairs moveUp noAsc noDesc (up, down, upDown) =
if (if moveUp then noAsc else noDesc) then
return (up, down, upDown)
else do
let cond tk = (if moveUp then ascendable tk else descendable tk)
&& (if noAsc then not (ascendable tk) else True)
&& (if noDesc then not (descendable tk) else True)
stairsCur = up ++ down ++ upDown
posCur = nub $ sort $ map fst stairsCur
spos <- placeStairs cotile cmap kc posCur
let legend = findLegend spos
stairId <- fmap (fromMaybe $ assert `failure` legend)
$ opick legend cond
let st = (spos, stairId)
asc = ascendable $ okind stairId
desc = descendable $ okind stairId
return $ case (asc, desc) of
(True, False) -> (st : up, down, upDown)
(False, True) -> (up, st : down, upDown)
(True, True) -> (up, down, st : upDown)
(False, False) -> assert `failure` st
(stairsUp1, stairsDown1, stairsUpDown1) <-
makeStairs False (ldepth == maxD) (ldepth == minD) ([], [], [])
assert (null stairsUp1) skip
let nstairUpLeft = nstairUp length stairsUpDown1
(stairsUp2, stairsDown2, stairsUpDown2) <-
foldM (\sts _ -> makeStairs True (ldepth == maxD) (ldepth == minD) sts)
(stairsUp1, stairsDown1, stairsUpDown1)
[1 .. nstairUpLeft]
(stairsUp, stairsDown, stairsUpDown) <-
if length (stairsUp2 ++ stairsDown2) == 0
then (makeStairs False True (ldepth == minD)
(stairsUp2, stairsDown2, stairsUpDown2))
else return (stairsUp2, stairsDown2, stairsUpDown2)
let stairsUpAndUpDown = stairsUp ++ stairsUpDown
assert (length stairsUpAndUpDown == nstairUp) skip
let stairsTotal = stairsUpAndUpDown ++ stairsDown
posTotal = nub $ sort $ map fst stairsTotal
epos <- placeStairs cotile cmap kc posTotal
escape <- case escapeFeature of
Nothing -> return []
Just True -> do
let legend = findLegend epos
upEscape <- fmap (fromMaybe $ assert `failure` legend)
$ opick legend $ hasEscapeAndSymbol '<'
return [(epos, upEscape)]
Just False -> do
let legend = findLegend epos
downEscape <- fmap (fromMaybe $ assert `failure` legend)
$ opick legend $ hasEscapeAndSymbol '>'
return [(epos, downEscape)]
let exits = stairsTotal ++ escape
ltile = cmap Kind.// exits
lstair = ( map fst $ stairsUp ++ stairsUpDown
, map fst $ stairsUpDown ++ stairsDown )
litemNum <- castDice citemNum
let itemFreq = toFreq cname citemFreq
assert (not $ nullFreq itemFreq) skip
lsecret <- random
return $! levelFromCaveKind cops kc ldepth ltile lstair
litemNum itemFreq lsecret
levelFromCaveKind :: Kind.COps
-> CaveKind -> Int -> TileMap -> ([Point], [Point])
-> Int -> Frequency Text -> Int
-> Level
levelFromCaveKind Kind.COps{cotile}
CaveKind{..} ldepth ltile lstair litemNum litemFreq lsecret =
Level
{ ldepth
, lprio = EM.empty
, lfloor = EM.empty
, ltile
, lxsize = cxsize
, lysize = cysize
, lsmell = EM.empty
, ldesc = cname
, lstair
, lseen = 0
, lclear = let f !n !tk | Tile.isExplorable cotile tk = n + 1
| otherwise = n
in Kind.foldlArray f 0 ltile
, ltime = timeTurn
, litemNum
, litemFreq
, lsecret
, lhidden = chidden
}
findGenerator :: Kind.COps -> Caves
-> LevelId -> LevelId -> LevelId -> Int -> Int
-> Rnd Level
findGenerator cops caves ldepth minD maxD totalDepth nstairUp = do
let Kind.COps{cocave=Kind.Ops{opick}} = cops
(genName, escapeFeature) =
fromMaybe ("dng", Nothing) $ EM.lookup ldepth caves
ci <- fmap (fromMaybe $ assert `failure` genName)
$ opick genName (const True)
cave <- buildCave cops (fromEnum ldepth) totalDepth ci
buildLevel cops cave
(fromEnum ldepth) (fromEnum minD) (fromEnum maxD) nstairUp
escapeFeature
data FreshDungeon = FreshDungeon
{ freshDungeon :: !Dungeon
, freshDepth :: !Int
}
dungeonGen :: Kind.COps -> Caves -> Rnd FreshDungeon
dungeonGen cops caves = do
let (minD, maxD) =
case (EM.minViewWithKey caves, EM.maxViewWithKey caves) of
(Just ((s, _), _), Just ((e, _), _)) -> (s, e)
_ -> assert `failure` "no caves" `twith` caves
totalDepth = if minD == maxD
then 10
else fromEnum maxD fromEnum minD + 1
let gen :: (Int, [(LevelId, Level)]) -> LevelId
-> Rnd (Int, [(LevelId, Level)])
gen (nstairUp, l) ldepth = do
lvl <- findGenerator cops caves ldepth minD maxD totalDepth nstairUp
let nstairDown = length $ snd $ lstair lvl
return $ (nstairDown, (ldepth, lvl) : l)
(nstairUpLast, levels) <- foldM gen (0, []) $ reverse [minD..maxD]
assert (nstairUpLast == 0) skip
let freshDungeon = EM.fromList levels
freshDepth = totalDepth
return FreshDungeon{..}