module Game.LambdaHack.Server.DungeonGen.Cave
( TileMapXY, ItemFloorXY, Cave(..), buildCave
) where
import Control.Arrow ((&&&))
import Control.Monad
import qualified Data.EnumMap.Strict as EM
import qualified Data.List as L
import Data.Maybe
import qualified Game.LambdaHack.Common.Feature as F
import Game.LambdaHack.Common.Item
import qualified Game.LambdaHack.Common.Kind as Kind
import Game.LambdaHack.Common.PointXY
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 hiding (TileMapXY)
import qualified Game.LambdaHack.Server.DungeonGen.Place as Place
import Control.Exception.Assert.Sugar
type TileMapXY = Place.TileMapXY
type ItemFloorXY = EM.EnumMap PointXY (Item, Int)
data Cave = Cave
{ dkind :: !(Kind.Id CaveKind)
, dmap :: !TileMapXY
, ditem :: !ItemFloorXY
, 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
, ouniqGroup }
, cocave=Kind.Ops{okind}
, coplace=Kind.Ops{okind=pokind} }
ln depth ci = do
let kc@CaveKind{..} = okind ci
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 == 1 || gy == 1 = 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
let hardRockId = ouniqGroup "outer fence"
fence = buildFence hardRockId 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 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 = L.union connects addedConnects
qplaces = EM.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 EM.! p0
rr1 = shrinkForFence $ qplaces EM.! p1
connectPlaces rr0 rr1) allConnects
let lcorridors = EM.unions (L.map (digCorridors pickedCorTile) cs)
lm = EM.unionWith (mergeCorridor cotile) lcorridors lplaces
let f l (p, t) =
if not $ Tile.hasFeature cotile F.Suspect t
then return l
else do
rd <- chance cdoorChance
if not rd then
return $ EM.insert p pickedCorTile l
else do
ro <- chance copenChance
doorClosedId <- Tile.revealAs cotile t
if not ro then
return $ EM.insert p doorClosedId l
else do
doorOpenId <- Tile.openTo cotile doorClosedId
return $ EM.insert p doorOpenId l
dmap <- foldM f lm (EM.assocs lm)
let cave = Cave
{ dkind = ci
, ditem = EM.empty
, dmap
, dplaces
, dnight
}
return cave
digCorridors :: Kind.Id TileKind -> Corridor -> TileMapXY
digCorridors tile (p1:p2:ps) =
EM.union corPos (digCorridors tile (p2:ps))
where
corXY = fromTo p1 p2
corPos = EM.fromList $ L.zip corXY (repeat tile)
digCorridors _ _ = EM.empty
mergeCorridor :: Kind.Ops TileKind -> Kind.Id TileKind -> Kind.Id TileKind
-> Kind.Id TileKind
mergeCorridor cotile _ = Tile.hideAs cotile