/
Cave.hs
204 lines (187 loc) · 8.17 KB
/
Cave.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
-- | Generation of caves (not yet inhabited dungeon levels) from cave kinds.
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
-- | The map of tile kinds in a cave.
-- The map is sparse. The default tile that eventually fills the empty spaces
-- is specified in the cave kind specification with @cdefaultTile@.
type TileMapXY = Place.TileMapXY
-- | The map of starting secrecy strength of tiles in a cave.
-- The map is sparse. Unspecified tiles have secrecy strength of 0.
type SecretMapXY = M.Map PointXY Tile.SecretTime
-- | The map of starting items in tiles of a cave. The map is sparse.
-- Unspecified tiles have no starting items.
type ItemMapXY = M.Map PointXY Item
-- | The type of caves (not yet inhabited dungeon levels).
data Cave = Cave
{ dkind :: !(Kind.Id CaveKind) -- ^ the kind of the cave
, dmap :: TileMapXY -- ^ tile kinds in the cave
, dsecret :: SecretMapXY -- ^ secrecy strength of cave tiles
, ditem :: ItemMapXY -- ^ starting items in the cave
, dmeta :: String -- ^ debug information about the cave
, dplaces :: [Place] -- ^ places generated in the cave
}
deriving Show
{-
Rogue cave is generated by an algorithm inspired by the original Rogue,
as follows:
* The available area is divided into a grid, e.g, 3 by 3,
where each of the 9 grid cells has approximately the same size.
* In each of the 9 grid cells one room is placed at a random location
and with a random size, but larger than The minimum size,
e.g, 2 by 2 floor tiles.
* Rooms that are on horizontally or vertically adjacent grid cells
may be connected by a corridor. Corridors consist of 3 segments of straight
lines (either "horizontal, vertical, horizontal" or "vertical, horizontal,
vertical"). They end in openings in the walls of the room they connect.
It is possible that one or two of the 3 segments have length 0, such that
the resulting corridor is L-shaped or even a single straight line.
* Corridors are generated randomly in such a way that at least every room
on the grid is connected, and a few more might be. It is not sufficient
to always connect all adjacent rooms.
-}
-- TODO: fix identifier naming and split, after the code grows some more
-- | Cave generation by an algorithm inspired by the original Rogue,
buildCave :: Kind.COps -- ^ content definitions
-> Int -- ^ depth of the level to generate
-> Int -- ^ maximum depth of the dungeon
-> Kind.Id CaveKind -- ^ cave kind to use for generation
-> 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 -- no duplicates
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
-- Convert openings into doors, possibly.
(dmap, secretMap) <-
let f (l, le) (p, t) =
if Tile.hasFeature cotile F.Hidden t
then do
-- Openings have a certain chance to be doors;
-- doors have a certain chance to be open; and
-- closed doors have a certain chance to be hidden
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