module Game.LambdaHack.Server.DungeonGen.Cave
( Cave(..), anchorDown, bootFixedCenters, buildCave
#ifdef EXPOSE_INTERNAL
, pickOpening, digCorridors
#endif
) where
import Prelude ()
import Game.LambdaHack.Common.Prelude
import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import Data.Key (mapWithKeyM)
import qualified Game.LambdaHack.Common.Dice as Dice
import Game.LambdaHack.Common.Kind
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.Point
import Game.LambdaHack.Common.Random
import qualified Game.LambdaHack.Common.Tile as Tile
import Game.LambdaHack.Common.Vector
import Game.LambdaHack.Content.CaveKind
import Game.LambdaHack.Content.PlaceKind
import Game.LambdaHack.Content.TileKind (TileKind)
import Game.LambdaHack.Server.DungeonGen.Area
import Game.LambdaHack.Server.DungeonGen.AreaRnd
import Game.LambdaHack.Server.DungeonGen.Place
data Cave = Cave
{ dkind :: ContentId CaveKind
, dsecret :: Int
, dmap :: TileMapEM
, dplaces :: [Place]
, dnight :: Bool
}
deriving Show
anchorDown :: Y
anchorDown = 5
bootFixedCenters :: CaveKind -> [Point]
bootFixedCenters CaveKind{..} =
[Point 4 3, Point (cxsize - 5) (cysize - anchorDown)]
buildCave :: COps
-> Dice.AbsDepth
-> Dice.AbsDepth
-> Int
-> ContentId CaveKind
-> EM.EnumMap Point (GroupName PlaceKind)
-> Rnd Cave
buildCave cops@COps{cotile, cocave, coplace, coTileSpeedup}
ldepth totalDepth dsecret dkind fixedCenters = do
let kc@CaveKind{..} = okind cocave dkind
lgrid' <- castDiceXY ldepth totalDepth cgrid
let fullArea = fromMaybe (error $ "" `showFailure` kc)
$ toArea (0, 0, cxsize - 1, cysize - 1)
subFullArea = fromMaybe (error $ "" `showFailure` kc)
$ toArea (1, 1, cxsize - 2, cysize - 2)
darkCorTile <- fromMaybe (error $ "" `showFailure` cdarkCorTile)
<$> opick cotile cdarkCorTile (const True)
litCorTile <- fromMaybe (error $ "" `showFailure` clitCorTile)
<$> opick cotile clitCorTile (const True)
dnight <- chanceDice ldepth totalDepth cnightChance
let createPlaces lgr' = do
let area | couterFenceTile /= "basic outer fence" = subFullArea
| otherwise = fullArea
(lgr@(gx, gy), gs) =
grid fixedCenters (bootFixedCenters kc) lgr' area
minPlaceSize <- castDiceXY ldepth totalDepth cminPlaceSize
maxPlaceSize <- castDiceXY ldepth totalDepth cmaxPlaceSize
let mergeFixed :: EM.EnumMap Point SpecialArea
-> (Point, SpecialArea)
-> EM.EnumMap Point SpecialArea
mergeFixed !gs0 (!i, !special) =
let mergeSpecial ar p2 f =
case EM.lookup p2 gs0 of
Just (SpecialArea ar2) ->
let aSum = sumAreas ar ar2
sp = SpecialMerged (f aSum) p2
in EM.insert i sp $ EM.delete p2 gs0
_ -> gs0
mergable :: X -> Y -> Maybe HV
mergable x y = case EM.lookup (Point x y) gs0 of
Just (SpecialArea ar) ->
let (x0, y0, x1, y1) = fromArea ar
isFixed p = case gs EM.! p of
SpecialFixed{} -> True
_ -> False
in if
| any isFixed
$ vicinityCardinal gx gy (Point x y) -> Nothing
| y1 - y0 - 3 < snd minPlaceSize -> Just Vert
| x1 - x0 - 3 < fst minPlaceSize -> Just Horiz
| otherwise -> Nothing
_ -> Nothing
in case special of
SpecialArea ar -> case mergable (px i) (py i) of
Nothing -> gs0
Just hv -> case hv of
Vert | py i - 1 >= 0
&& mergable (px i) (py i - 1) == Just Vert ->
mergeSpecial ar i{py = py i - 1} SpecialArea
Vert | py i + 1 < gy
&& mergable (px i) (py i + 1) == Just Vert ->
mergeSpecial ar i{py = py i + 1} SpecialArea
Horiz | px i - 1 >= 0
&& mergable (px i - 1) (py i) == Just Horiz ->
mergeSpecial ar i{px = px i - 1} SpecialArea
Horiz | px i + 1 < gx
&& mergable (px i + 1) (py i) == Just Horiz ->
mergeSpecial ar i{px = px i + 1} SpecialArea
_ -> gs0
SpecialFixed p placeGroup ar ->
let (x0, y0, x1, y1) = fromArea ar
d = 3
vics :: [[Point]]
vics = [ [i {py = py i - 1} | py i - 1 >= 0]
| py p - y0 < d ]
++ [ [i {py = py i + 1} | py i + 1 < gy]
| y1 - py p < d ]
++ [ [i {px = px i - 1} | px i - 1 >= 0]
| px p - x0 < d ]
++ [ [i {px = px i + 1} | px i + 1 < gx]
| x1 - px p < d ]
in case vics of
[[p2]] -> mergeSpecial ar p2 (SpecialFixed p placeGroup)
_ -> gs0
SpecialMerged{} -> error $ "" `showFailure` (gs, gs0, i)
gs2 = foldl' mergeFixed gs $ EM.assocs gs
voidPlaces <- do
let gridArea = fromMaybe (error $ "" `showFailure` lgr)
$ toArea (0, 0, gx - 1, gy - 1)
voidNum = round $ cmaxVoid * fromIntegral (EM.size gs2)
isOrdinaryArea p = case p `EM.lookup` gs2 of
Just SpecialArea{} -> True
_ -> False
reps <- replicateM voidNum (xyInArea gridArea)
return $! ES.fromList $ filter isOrdinaryArea reps
let decidePlace :: Bool
-> ( TileMapEM, [Place]
, EM.EnumMap Point (Area, Fence, Area) )
-> (Point, SpecialArea)
-> Rnd ( TileMapEM, [Place]
, EM.EnumMap Point (Area, Fence, Area) )
decidePlace noVoid (!m, !pls, !qls) (!i, !special) =
case special of
SpecialArea ar -> do
let innerArea = fromMaybe (error $ "" `showFailure` (i, ar))
$ shrink ar
!_A0 = shrink innerArea
!_A1 = assert (isJust _A0 `blame` (innerArea, gs2)) ()
if not noVoid && i `ES.member` voidPlaces
then do
r <- mkVoidRoom innerArea
return (m, pls, EM.insert i (r, FNone, ar) qls)
else do
r <- mkRoom minPlaceSize maxPlaceSize innerArea
(tmap, place) <-
buildPlace cops kc dnight darkCorTile litCorTile
ldepth totalDepth dsecret r Nothing
let fence = pfence $ okind coplace $ qkind place
return ( EM.union tmap m
, place : pls
, EM.insert i (qarea place, fence, ar) qls )
SpecialFixed p@Point{..} placeGroup ar -> do
let innerArea = fromMaybe (error $ "" `showFailure` (i, ar))
$ shrink ar
!_A0 = shrink innerArea
!_A1 = assert (isJust _A0 `blame` (innerArea, gs2)) ()
!_A2 = assert (p `inside` fromArea (fromJust _A0)
`blame` (p, innerArea, fixedCenters)) ()
r = mkFixed maxPlaceSize innerArea p
!_A3 = assert (isJust (shrink r)
`blame` ( r, p, innerArea, ar
, gs2, qls, fixedCenters )) ()
(tmap, place) <-
buildPlace cops kc dnight darkCorTile litCorTile
ldepth totalDepth dsecret r (Just placeGroup)
let fence = pfence $ okind coplace $ qkind place
return ( EM.union tmap m
, place : pls
, EM.insert i (qarea place, fence, ar) qls )
SpecialMerged sp p2 -> do
(lplaces, dplaces, qplaces) <-
decidePlace True (m, pls, qls) (i, sp)
return ( lplaces, dplaces
, EM.insert p2 (qplaces EM.! i) qplaces )
places <- foldlM' (decidePlace False) (EM.empty, [], EM.empty)
$ EM.assocs gs2
return (voidPlaces, lgr, places)
(voidPlaces, lgrid, (lplaces, dplaces, qplaces)) <- createPlaces lgrid'
let lcorridorsFun lgr = do
connects <- connectGrid voidPlaces lgr
addedConnects <- do
let cauxNum =
round $ cauxConnects * fromIntegral (fst lgr * snd lgrid)
cns <- nub . sort <$> replicateM cauxNum (randomConnection lgr)
let notDeadEnd (p, q) =
if | p `ES.member` voidPlaces ->
q `ES.notMember` voidPlaces && sndInCns p
| q `ES.member` voidPlaces -> fstInCns q
| otherwise -> True
sndInCns p = any (\(p0, q0) ->
q0 == p && p0 `ES.notMember` voidPlaces) cns
fstInCns q = any (\(p0, q0) ->
p0 == q && q0 `ES.notMember` voidPlaces) cns
return $! filter notDeadEnd cns
let allConnects = connects `union` addedConnects
connectPos :: (Point, Point) -> Rnd (Maybe Corridor)
connectPos (p0, p1) =
connectPlaces (qplaces EM.! p0) (qplaces EM.! p1)
cs <- catMaybes <$> mapM connectPos allConnects
let pickedCorTile = if dnight then darkCorTile else litCorTile
return $! EM.unions (map (digCorridors pickedCorTile) cs)
lcorridors <- lcorridorsFun lgrid
let doorMapFun lpl lcor = do
let mergeCor _ pl cor = if Tile.isWalkable coTileSpeedup pl
then Nothing
else Just (Tile.buildAs cotile pl, cor)
intersectionWithKeyMaybe combine =
EM.mergeWithKey combine (const EM.empty) (const EM.empty)
interCor = intersectionWithKeyMaybe mergeCor lpl lcor
mapWithKeyM (pickOpening cops kc lplaces litCorTile dsecret)
interCor
doorMap <- doorMapFun lplaces lcorridors
fence <- buildFenceRnd cops couterFenceTile subFullArea
let obscure p t = if isChancePos chidden dsecret p && likelySecret p
then Tile.obscureAs cotile $ Tile.buildAs cotile t
else return t
likelySecret Point{..} = px > 2 && px < cxsize - 3
&& py > 2 && py < cysize - 3
umap = EM.unions [doorMap, lplaces, lcorridors, fence]
dmap <- mapWithKeyM obscure umap
return $! Cave {dkind, dsecret, dmap, dplaces, dnight}
pickOpening :: COps -> CaveKind -> TileMapEM -> ContentId TileKind
-> Int -> Point -> (ContentId TileKind, ContentId TileKind)
-> Rnd (ContentId TileKind)
pickOpening COps{cotile, coTileSpeedup}
CaveKind{cxsize, cysize, cdoorChance, copenChance, chidden}
lplaces litCorTile dsecret
pos (hidden, cor) = do
let nicerCorridor =
if Tile.isLit coTileSpeedup cor then cor
else
let roomTileLit p =
case EM.lookup p lplaces of
Nothing -> False
Just tile -> Tile.isLit coTileSpeedup tile
vic = vicinityCardinal cxsize cysize pos
in if any roomTileLit vic then litCorTile else cor
rd <- chance cdoorChance
if rd then do
doorTrappedId <- Tile.revealAs cotile hidden
if Tile.isDoor coTileSpeedup doorTrappedId then do
ro <- chance copenChance
if ro
then Tile.openTo cotile doorTrappedId
else if isChancePos chidden dsecret pos
then return $! doorTrappedId
else do
doorOpenId <- Tile.openTo cotile doorTrappedId
Tile.closeTo cotile doorOpenId
else return $! doorTrappedId
else return $! nicerCorridor
digCorridors :: ContentId TileKind -> Corridor -> TileMapEM
digCorridors tile (p1:p2:ps) =
EM.union corPos (digCorridors tile (p2:ps))
where
cor = fromTo p1 p2
corPos = EM.fromList $ zip cor (repeat tile)
digCorridors _ _ = EM.empty