module Game.LambdaHack.Server.DungeonGen.Cave
( Cave(..), buildCave
) where
import Control.Arrow ((&&&))
import Control.Exception.Assert.Sugar
import Control.Monad
import qualified Data.EnumMap.Strict as EM
import Data.Key (mapWithKeyM)
import Data.List
import qualified Data.Map.Strict as M
import Data.Maybe
import qualified Game.LambdaHack.Common.Kind as Kind
import Game.LambdaHack.Common.Level
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
import Game.LambdaHack.Server.DungeonGen.Area
import Game.LambdaHack.Server.DungeonGen.AreaRnd
import Game.LambdaHack.Server.DungeonGen.Place
data Cave = Cave
{ dkind :: !(Kind.Id CaveKind)
, dmap :: !TileMapEM
, dplaces :: ![Place]
, dnight :: !Bool
}
deriving Show
buildCave :: Kind.COps
-> AbsDepth
-> AbsDepth
-> Kind.Id CaveKind
-> Rnd Cave
buildCave cops@Kind.COps{ cotile=cotile@Kind.Ops{opick}
, cocave=Kind.Ops{okind}
, coplace=Kind.Ops{okind=pokind} }
ldepth totalDepth dkind = do
let kc@CaveKind{..} = okind dkind
lgrid@(gx, gy) <- castDiceXY ldepth totalDepth cgrid
let fullArea = fromMaybe (assert `failure` kc)
$ toArea (0, 0, cxsize 1, cysize 1)
subFullArea = fromMaybe (assert `failure` kc)
$ toArea (1, 1, cxsize 2, cysize 2)
area | gx * gy == 1
|| couterFenceTile /= "basic outer fence" = subFullArea
| otherwise = fullArea
gs = grid lgrid area
(addedConnects, voidPlaces) <- do
if gx * gy > 1 then do
let fractionOfPlaces r = round $ r * fromIntegral (gx * gy)
cauxNum = fractionOfPlaces cauxConnects
addedC <- replicateM cauxNum (randomConnection lgrid)
let gridArea = fromMaybe (assert `failure` lgrid)
$ toArea (0, 0, gx 1, gy 1)
voidNum = fractionOfPlaces cmaxVoid
voidPl <- replicateM voidNum $ xyInArea gridArea
return (addedC, voidPl)
else return ([], [])
minPlaceSize <- castDiceXY ldepth totalDepth cminPlaceSize
maxPlaceSize <- castDiceXY ldepth totalDepth cmaxPlaceSize
places0 <- mapM (\ (i, r) -> do
let innerArea = fromMaybe (assert `failure` (i, r))
$ shrink r
r' <- if i `elem` voidPlaces
then fmap Left $ mkVoidRoom innerArea
else fmap Right $ mkRoom minPlaceSize
maxPlaceSize innerArea
return (i, r')) gs
fence <- buildFenceRnd cops couterFenceTile subFullArea
dnight <- chanceDice ldepth totalDepth cnightChance
darkCorTile <- fmap (fromMaybe $ assert `failure` cdarkCorTile)
$ opick cdarkCorTile (const True)
litCorTile <- fmap (fromMaybe $ assert `failure` clitCorTile)
$ opick clitCorTile (const True)
let pickedCorTile = if dnight then darkCorTile else litCorTile
addPl (m, pls, qls) (i, Left r) = return (m, pls, (i, Left r) : qls)
addPl (m, pls, qls) (i, Right r) = do
(tmap, place) <-
buildPlace cops kc dnight darkCorTile litCorTile ldepth totalDepth r
return (EM.union tmap m, place : pls, (i, Right (r, place)) : qls)
(lplaces, dplaces, qplaces0) <- foldM addPl (fence, [], []) places0
connects <- connectGrid lgrid
let allConnects = union connects addedConnects
qplaces = M.fromList qplaces0
cs <- mapM (\(p0, p1) -> do
let shrinkPlace (r, Place{qkind}) =
case shrink r of
Nothing -> (r, r)
Just sr ->
if pfence (pokind qkind) `elem` [FFloor, FGround]
then
case shrink sr of
Nothing -> (sr, r)
Just mergeArea -> (mergeArea, r)
else (sr, sr)
shrinkForFence = either (id &&& id) shrinkPlace
rr0 = shrinkForFence $ qplaces M.! p0
rr1 = shrinkForFence $ qplaces M.! p1
connectPlaces rr0 rr1) allConnects
let lcorridors = EM.unions (map (digCorridors pickedCorTile) cs)
lm = EM.union lplaces lcorridors
let f pos (t, cor) = do
rd <- chance cdoorChance
if not rd then
if Tile.isLit cotile cor then return cor
else do
let roomTileLit p =
case EM.lookup p lplaces of
Nothing -> False
Just tile -> Tile.isLit cotile tile
vic = vicinity cxsize cysize pos
if any roomTileLit vic
then return litCorTile
else return cor
else do
ro <- chance copenChance
doorClosedId <- Tile.revealAs cotile t
if not ro then return $! doorClosedId
else do
doorOpenId <- Tile.openTo cotile doorClosedId
return $! doorOpenId
mergeCor _ pl cor =
let hidden = Tile.hideAs cotile pl
in if hidden == pl then Nothing else Just (hidden, cor)
intersectionCombine combine =
EM.mergeWithKey combine (const EM.empty) (const EM.empty)
interCor = intersectionCombine mergeCor lplaces lcorridors
doorMap <- mapWithKeyM f interCor
let dmap = EM.union doorMap lm
cave = Cave
{ dkind
, dmap
, dplaces
, dnight
}
return $! cave
digCorridors :: Kind.Id 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