module Game.LambdaHack.Cave
( TileMapXY, SecretMapXY, ItemMapXY, Cave(..), buildCave
) where
import Control.Monad
import qualified Data.Map as M
import qualified Data.List as L
import Data.Maybe
import Game.LambdaHack.Utils.Assert
import Game.LambdaHack.PointXY
import Game.LambdaHack.Area
import Game.LambdaHack.AreaRnd
import Game.LambdaHack.Item
import Game.LambdaHack.Random
import qualified Game.LambdaHack.Tile as Tile
import qualified Game.LambdaHack.Kind as Kind
import Game.LambdaHack.Content.CaveKind
import Game.LambdaHack.Content.TileKind
import qualified Game.LambdaHack.Feature as F
import Game.LambdaHack.Place hiding (TileMapXY)
import qualified Game.LambdaHack.Place as Place
import Game.LambdaHack.Misc
import Game.LambdaHack.Time
type TileMapXY = Place.TileMapXY
type SecretMapXY = M.Map PointXY Tile.SecretTime
type ItemMapXY = M.Map PointXY Item
data Cave = Cave
{ dkind :: !(Kind.Id CaveKind)
, dmap :: TileMapXY
, dsecret :: SecretMapXY
, ditem :: ItemMapXY
, dmeta :: String
, dplaces :: [Place]
}
deriving Show
buildCave :: Kind.COps
-> Int
-> Int
-> Kind.Id CaveKind
-> Rnd Cave
buildCave cops@Kind.COps{ cotile=cotile@Kind.Ops{okind=tokind, opick}
, cocave=Kind.Ops{okind} }
ln depth ci = do
let kc@CaveKind{..} = okind ci
lgrid@(gx, gy) <- rollDiceXY cgrid
lminplace <- rollDiceXY cminPlaceSize
let gs = grid lgrid (0, 0, cxsize 1, cysize 1)
mandatory1 <- replicateM (cnonVoidMin `div` 2) $
xyInArea (0, 0, gx `div` 3, gy 1)
mandatory2 <- replicateM (cnonVoidMin `divUp` 2) $
xyInArea (gx 1 (gx `div` 3), 0, gx 1, gy 1)
places0 <- mapM (\ (i, r) -> do
rv <- chance cvoidChance
r' <- if rv && i `notElem` (mandatory1 ++ mandatory2)
then mkVoidRoom r
else mkRoom lminplace r
return (i, r')) gs
connects <- connectGrid lgrid
addedConnects <-
if gx * gy > 1
then let caux = round $ cauxConnects * fromIntegral (gx * gy)
in replicateM caux (randomConnection lgrid)
else return []
let allConnects = L.union connects addedConnects
places = M.fromList places0
cs <- mapM (\ (p0, p1) -> do
let r0 = places M.! p0
r1 = places M.! p1
connectPlaces r0 r1) allConnects
wallId <- opick cfillerTile (const True)
let fenceBounds = (1, 1, cxsize 2, cysize 2)
fence = buildFence wallId fenceBounds
pickedCorTile <- opick ccorridorTile (const True)
let addPl (m, pls) (_, (x0, _, x1, _)) | x0 == x1 = return (m, pls)
addPl (m, pls) (_, r) = do
(tmap, place) <- buildPlace cops kc pickedCorTile ln depth r
return (M.union tmap m, place : pls)
(lplaces, dplaces) <- foldM addPl (fence, []) places0
let lcorridors = M.unions (L.map (digCorridors pickedCorTile) cs)
hiddenMap <- mapToHidden cotile chiddenTile
let lm = M.unionWith (mergeCorridor cotile hiddenMap) lcorridors lplaces
(dmap, secretMap) <-
let f (l, le) (p, t) =
if Tile.hasFeature cotile F.Hidden t
then do
rd <- chance cdoorChance
if not rd
then return (M.insert p pickedCorTile l, le)
else do
doorClosedId <- trigger cotile t
doorOpenId <- trigger cotile doorClosedId
ro <- chance copenChance
if ro
then return (M.insert p doorOpenId l, le)
else do
rs <- chance chiddenChance
if not rs
then return (M.insert p doorClosedId l, le)
else do
secret <- rollSecret (tokind t)
return (l, M.insert p secret le)
else return (l, le)
in foldM f (lm, M.empty) (M.toList lm)
let cave = Cave
{ dkind = ci
, dsecret = secretMap
, ditem = M.empty
, dmap
, dmeta = show allConnects
, dplaces
}
return cave
rollSecret :: TileKind -> Rnd Tile.SecretTime
rollSecret t = do
let getDice (F.Secret dice) _ = dice
getDice _ acc = acc
defaultDice = RollDice 5 2
d = foldr getDice defaultDice (tfeature t)
secretTurns <- rollDice d
return $ timeScale timeTurn secretTurns
trigger :: Kind.Ops TileKind -> Kind.Id TileKind -> Rnd (Kind.Id TileKind)
trigger Kind.Ops{okind, opick} t =
let getTo (F.ChangeTo group) _ = Just group
getTo _ acc = acc
in case foldr getTo Nothing (tfeature (okind t)) of
Nothing -> return t
Just group -> opick group (const True)
digCorridors :: Kind.Id TileKind -> Corridor -> TileMapXY
digCorridors tile (p1:p2:ps) =
M.union corPos (digCorridors tile (p2:ps))
where
corXY = fromTo p1 p2
corPos = M.fromList $ L.zip corXY (repeat tile)
digCorridors _ _ = M.empty
passable :: [F.Feature]
passable = [F.Walkable, F.Openable, F.Hidden]
mapToHidden :: Kind.Ops TileKind -> String
-> Rnd (M.Map (Kind.Id TileKind) (Kind.Id TileKind))
mapToHidden cotile@Kind.Ops{ofoldrWithKey, opick} chiddenTile =
let getHidden ti tk acc =
if Tile.canBeHidden cotile tk
then do
ti2 <- opick chiddenTile $ \ k -> Tile.kindHasFeature F.Hidden k
&& Tile.similar k tk
fmap (M.insert ti ti2) acc
else acc
in ofoldrWithKey getHidden (return M.empty)
mergeCorridor :: Kind.Ops TileKind
-> M.Map (Kind.Id TileKind) (Kind.Id TileKind)
-> Kind.Id TileKind -> Kind.Id TileKind -> Kind.Id TileKind
mergeCorridor cotile _ _ t
| L.any (\ f -> Tile.hasFeature cotile f t) passable = t
mergeCorridor _ hiddenMap u t =
fromMaybe (assert `failure` (u, hiddenMap, t)) $
M.lookup t hiddenMap