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.List
import qualified Data.Map.Strict as M
import Data.Maybe
import qualified Data.Traversable as Traversable
import qualified Game.LambdaHack.Common.Kind as Kind
import Game.LambdaHack.Common.Point
import Game.LambdaHack.Common.Random
import qualified Game.LambdaHack.Common.Tile as Tile
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
-> Int
-> Int
-> Kind.Id CaveKind
-> Rnd Cave
buildCave cops@Kind.COps{ cotile=cotile@Kind.Ops{opick}
, cocave=Kind.Ops{okind}
, coplace=Kind.Ops{okind=pokind} }
ln depth dkind = do
let kc@CaveKind{..} = okind dkind
lgrid@(gx, gy) <- castDiceXY 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 cminPlaceSize
maxPlaceSize <- castDiceXY 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 <- chanceDeep ln depth 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 ln depth 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 -> case pfence $ pokind qkind of
FFloor ->
case shrink sr of
Nothing -> (sr, r)
Just mergeArea -> (mergeArea, r)
_ -> (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.unionWith (mergeCorridor cotile) lcorridors lplaces
let f t =
if not $ Tile.isSuspect cotile t
then return t
else do
rd <- chance cdoorChance
if not rd then
let cor = if Tile.isLit cotile t then litCorTile else darkCorTile
in 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
dmap <- Traversable.mapM f lm
let 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
mergeCorridor :: Kind.Ops TileKind -> Kind.Id TileKind -> Kind.Id TileKind
-> Kind.Id TileKind
mergeCorridor cotile _ = Tile.hideAs cotile