-- | Generation of caves (not yet inhabited dungeon levels) from cave kinds.
module Game.LambdaHack.Server.DungeonGen.Cave
  ( Cave(..), buildCave
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , pickOpening
#endif
  ) where

import Prelude ()

import Game.LambdaHack.Core.Prelude

import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import           Data.Key (mapWithKeyM)
import           Data.Word (Word32)

import           Game.LambdaHack.Common.Area
import           Game.LambdaHack.Common.Kind
import           Game.LambdaHack.Common.Point
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 (TileKind)
import qualified Game.LambdaHack.Core.Dice as Dice
import           Game.LambdaHack.Core.Random
import           Game.LambdaHack.Definition.Defs
import           Game.LambdaHack.Server.DungeonGen.AreaRnd
import           Game.LambdaHack.Server.DungeonGen.Place

-- | The type of caves (not yet inhabited dungeon levels).
data Cave = Cave
  { Cave -> ContentId CaveKind
dkind   :: ContentId CaveKind  -- ^ the kind of the cave
  , Cave -> Area
darea   :: Area                -- ^ map area of the cave
  , Cave -> TileMapEM
dmap    :: TileMapEM           -- ^ tile kinds in the cave
  , Cave -> EnumMap Point Place
dstairs :: EM.EnumMap Point Place
                                   -- ^ stair places indexed by their center
  , Cave -> EnumMap Point PlaceEntry
dentry  :: EM.EnumMap Point PlaceEntry
                                   -- ^ room entrances in the cave
  , Cave -> Bool
dnight  :: Bool                -- ^ whether the cave is dark
  }
  deriving Y -> Cave -> ShowS
[Cave] -> ShowS
Cave -> String
(Y -> Cave -> ShowS)
-> (Cave -> String) -> ([Cave] -> ShowS) -> Show Cave
forall a.
(Y -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Y -> Cave -> ShowS
showsPrec :: Y -> Cave -> ShowS
$cshow :: Cave -> String
show :: Cave -> String
$cshowList :: [Cave] -> ShowS
showList :: [Cave] -> ShowS
Show

{- |
Generate a cave using an algorithm inspired by the original Rogue,
as follows (in gross simplification):

* 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 some of the 9 grid cells a room is placed at a random position
  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, because not each cell holds a room.
-}
buildCave :: COps                -- ^ content definitions
          -> Dice.AbsDepth       -- ^ depth of the level to generate
          -> Dice.AbsDepth       -- ^ absolute depth
          -> Area                -- ^ map area of the cave
          -> Word32              -- ^ secret tile seed
          -> ContentId CaveKind  -- ^ cave kind to use for generation
          -> (X, Y)              -- ^ the dimensions of the grid of places
          -> EM.EnumMap Point SpecialArea  -- ^ pos of stairs, etc.
          -> [Point]             -- ^ boot positions to be treated as fixed
          -> Rnd Cave
buildCave :: COps
-> AbsDepth
-> AbsDepth
-> Area
-> Word32
-> ContentId CaveKind
-> (Y, Y)
-> EnumMap Point SpecialArea
-> [Point]
-> Rnd Cave
buildCave cops :: COps
cops@COps{ContentData CaveKind
cocave :: ContentData CaveKind
cocave :: COps -> ContentData CaveKind
cocave, ContentData PlaceKind
coplace :: ContentData PlaceKind
coplace :: COps -> ContentData PlaceKind
coplace, ContentData TileKind
cotile :: ContentData TileKind
cotile :: COps -> ContentData TileKind
cotile, TileSpeedup
coTileSpeedup :: TileSpeedup
coTileSpeedup :: COps -> TileSpeedup
coTileSpeedup}
          AbsDepth
ldepth AbsDepth
totalDepth Area
darea Word32
dsecret ContentId CaveKind
dkind lgr :: (Y, Y)
lgr@(Y
gx, Y
gy) EnumMap Point SpecialArea
gs [Point]
bootExtra = do
  let kc :: CaveKind
kc@CaveKind{Bool
Y
[Y]
Freqs ItemKind
Freqs PlaceKind
Freqs CaveKind
Rational
Text
DiceXY
Dice
GroupName TileKind
InitSleep
cname :: Text
cfreq :: Freqs CaveKind
cXminSize :: Y
cYminSize :: Y
ccellSize :: DiceXY
cminPlaceSize :: DiceXY
cmaxPlaceSize :: DiceXY
cdarkOdds :: Dice
cnightOdds :: Dice
cauxConnects :: Rational
cmaxVoid :: Rational
cdoorChance :: Rational
copenChance :: Rational
chidden :: Y
cactorCoeff :: Y
cactorFreq :: Freqs ItemKind
citemNum :: Dice
citemFreq :: Freqs ItemKind
cplaceFreq :: Freqs PlaceKind
cpassable :: Bool
clabyrinth :: Bool
cdefTile :: GroupName TileKind
cdarkCorTile :: GroupName TileKind
clitCorTile :: GroupName TileKind
cwallTile :: GroupName TileKind
ccornerTile :: GroupName TileKind
cfenceTileN :: GroupName TileKind
cfenceTileE :: GroupName TileKind
cfenceTileS :: GroupName TileKind
cfenceTileW :: GroupName TileKind
cfenceApart :: Bool
cminStairDist :: Y
cmaxStairsNum :: Dice
cescapeFreq :: Freqs PlaceKind
cstairFreq :: Freqs PlaceKind
cstairAllowed :: Freqs PlaceKind
cskip :: [Y]
cinitSleep :: InitSleep
cdesc :: Text
cdesc :: CaveKind -> Text
cinitSleep :: CaveKind -> InitSleep
cskip :: CaveKind -> [Y]
cstairAllowed :: CaveKind -> Freqs PlaceKind
cstairFreq :: CaveKind -> Freqs PlaceKind
cescapeFreq :: CaveKind -> Freqs PlaceKind
cmaxStairsNum :: CaveKind -> Dice
cminStairDist :: CaveKind -> Y
cfenceApart :: CaveKind -> Bool
cfenceTileW :: CaveKind -> GroupName TileKind
cfenceTileS :: CaveKind -> GroupName TileKind
cfenceTileE :: CaveKind -> GroupName TileKind
cfenceTileN :: CaveKind -> GroupName TileKind
ccornerTile :: CaveKind -> GroupName TileKind
cwallTile :: CaveKind -> GroupName TileKind
clitCorTile :: CaveKind -> GroupName TileKind
cdarkCorTile :: CaveKind -> GroupName TileKind
cdefTile :: CaveKind -> GroupName TileKind
clabyrinth :: CaveKind -> Bool
cpassable :: CaveKind -> Bool
cplaceFreq :: CaveKind -> Freqs PlaceKind
citemFreq :: CaveKind -> Freqs ItemKind
citemNum :: CaveKind -> Dice
cactorFreq :: CaveKind -> Freqs ItemKind
cactorCoeff :: CaveKind -> Y
chidden :: CaveKind -> Y
copenChance :: CaveKind -> Rational
cdoorChance :: CaveKind -> Rational
cmaxVoid :: CaveKind -> Rational
cauxConnects :: CaveKind -> Rational
cnightOdds :: CaveKind -> Dice
cdarkOdds :: CaveKind -> Dice
cmaxPlaceSize :: CaveKind -> DiceXY
cminPlaceSize :: CaveKind -> DiceXY
ccellSize :: CaveKind -> DiceXY
cYminSize :: CaveKind -> Y
cXminSize :: CaveKind -> Y
cfreq :: CaveKind -> Freqs CaveKind
cname :: CaveKind -> Text
..} = ContentData CaveKind -> ContentId CaveKind -> CaveKind
forall a. ContentData a -> ContentId a -> a
okind ContentData CaveKind
cocave ContentId CaveKind
dkind
  darkCorTile <- ContentId TileKind
-> Maybe (ContentId TileKind) -> ContentId TileKind
forall a. a -> Maybe a -> a
fromMaybe (String -> ContentId TileKind
forall a. (?callStack::CallStack) => String -> a
error (String -> ContentId TileKind) -> String -> ContentId TileKind
forall a b. (a -> b) -> a -> b
$ String
"" String -> GroupName TileKind -> String
forall v. Show v => String -> v -> String
`showFailure` GroupName TileKind
cdarkCorTile)
                 (Maybe (ContentId TileKind) -> ContentId TileKind)
-> StateT SMGen Identity (Maybe (ContentId TileKind))
-> StateT SMGen Identity (ContentId TileKind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContentData TileKind
-> GroupName TileKind
-> (TileKind -> Bool)
-> StateT SMGen Identity (Maybe (ContentId TileKind))
forall a.
Show a =>
ContentData a
-> GroupName a -> (a -> Bool) -> Rnd (Maybe (ContentId a))
opick ContentData TileKind
cotile GroupName TileKind
cdarkCorTile (Bool -> TileKind -> Bool
forall a b. a -> b -> a
const Bool
True)
  litCorTile <- fromMaybe (error $ "" `showFailure` clitCorTile)
                <$> opick cotile clitCorTile (const True)
  dnight <- oddsDice ldepth totalDepth cnightOdds
  let createPlaces = do
        minPlaceSize <- AbsDepth -> AbsDepth -> DiceXY -> Rnd (Y, Y)
castDiceXY AbsDepth
ldepth AbsDepth
totalDepth DiceXY
cminPlaceSize
        maxPlaceSize <- castDiceXY ldepth totalDepth cmaxPlaceSize
        let mergeFixed :: EM.EnumMap Point SpecialArea
                       -> (Point, SpecialArea)
                       -> EM.EnumMap Point SpecialArea
            mergeFixed !EnumMap Point SpecialArea
gs0 (!Point
i, !SpecialArea
special) =
              let mergeSpecial :: Area -> Point -> (Area -> SpecialArea) -> EnumMap Point SpecialArea
mergeSpecial Area
ar Point
p2 Area -> SpecialArea
f =
                    case Point -> EnumMap Point SpecialArea -> Maybe SpecialArea
forall k a. Enum k => k -> EnumMap k a -> Maybe a
EM.lookup Point
p2 EnumMap Point SpecialArea
gs0 of
                      Just (SpecialArea Area
ar2) ->
                        let aSum :: Area
aSum = Area -> Area -> Area
sumAreas Area
ar Area
ar2
                            sp :: SpecialArea
sp = SpecialArea -> Point -> SpecialArea
SpecialMerged (Area -> SpecialArea
f Area
aSum) Point
p2
                        in Point
-> SpecialArea
-> EnumMap Point SpecialArea
-> EnumMap Point SpecialArea
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert Point
i SpecialArea
sp (EnumMap Point SpecialArea -> EnumMap Point SpecialArea)
-> EnumMap Point SpecialArea -> EnumMap Point SpecialArea
forall a b. (a -> b) -> a -> b
$ Point -> EnumMap Point SpecialArea -> EnumMap Point SpecialArea
forall k a. Enum k => k -> EnumMap k a -> EnumMap k a
EM.delete Point
p2 EnumMap Point SpecialArea
gs0
                      Maybe SpecialArea
_ -> EnumMap Point SpecialArea
gs0
                  mergable :: X -> Y -> Maybe HV
                  mergable :: Y -> Y -> Maybe HV
mergable Y
x Y
y = case Point -> EnumMap Point SpecialArea -> Maybe SpecialArea
forall k a. Enum k => k -> EnumMap k a -> Maybe a
EM.lookup (Y -> Y -> Point
Point Y
x Y
y) EnumMap Point SpecialArea
gs0 of
                    Just (SpecialArea Area
ar) ->
                      let (Point
_, Y
xspan, Y
yspan) = Area -> (Point, Y, Y)
spanArea Area
ar
                          isFixed :: Point -> Bool
isFixed Point
p =
                            Point
p Point -> [Point] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Point]
bootExtra
                            Bool -> Bool -> Bool
|| case EnumMap Point SpecialArea
gs EnumMap Point SpecialArea -> Point -> SpecialArea
forall k a. Enum k => EnumMap k a -> k -> a
EM.! Point
p of
                                 SpecialFixed{} -> Bool
True
                                 SpecialArea
_ -> Bool
False
                      in if -- Limit (the aggresive) merging of normal places
                            -- and leave extra place for merging stairs.
                            | (Point -> Bool) -> [Point] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Point -> Bool
isFixed
                              ([Point] -> Bool) -> [Point] -> Bool
forall a b. (a -> b) -> a -> b
$ Y -> Y -> Point -> [Point]
vicinityCardinal Y
gx Y
gy (Y -> Y -> Point
Point Y
x Y
y) -> Maybe HV
forall a. Maybe a
Nothing
                            -- Bias: prefer extending vertically.
                            -- Not @-2@, but @-4@, to merge aggressively.
                            | Y
yspan Y -> Y -> Y
forall a. Num a => a -> a -> a
- Y
4 Y -> Y -> Bool
forall a. Ord a => a -> a -> Bool
< (Y, Y) -> Y
forall a b. (a, b) -> b
snd (Y, Y)
minPlaceSize -> HV -> Maybe HV
forall a. a -> Maybe a
Just HV
Vert
                            | Y
xspan Y -> Y -> Y
forall a. Num a => a -> a -> a
- Y
4 Y -> Y -> Bool
forall a. Ord a => a -> a -> Bool
< (Y, Y) -> Y
forall a b. (a, b) -> a
fst (Y, Y)
minPlaceSize -> HV -> Maybe HV
forall a. a -> Maybe a
Just HV
Horiz
                            | Bool
otherwise -> Maybe HV
forall a. Maybe a
Nothing
                    Maybe SpecialArea
_ -> Maybe HV
forall a. Maybe a
Nothing
              in case SpecialArea
special of
                SpecialArea Area
ar -> case Y -> Y -> Maybe HV
mergable (Point -> Y
px Point
i) (Point -> Y
py Point
i) of
                  Maybe HV
Nothing -> EnumMap Point SpecialArea
gs0
                  Just HV
hv -> case HV
hv of
                    -- Bias; vertical minimal sizes are smaller.
                    --
                    -- The commented out cases never happen, because @mergable@
                    -- is symmetric and we proceed top-left to bottom-right.
                    --
                    -- Vert | py i - 1 >= 0
                    --        && mergable (px i) (py i - 1) == Just Vert ->
                    --        mergeSpecial ar i{py = py i - 1} SpecialArea
                    HV
Vert | Point -> Y
py Point
i Y -> Y -> Y
forall a. Num a => a -> a -> a
+ Y
1 Y -> Y -> Bool
forall a. Ord a => a -> a -> Bool
< Y
gy
                           Bool -> Bool -> Bool
&& Y -> Y -> Maybe HV
mergable (Point -> Y
px Point
i) (Point -> Y
py Point
i Y -> Y -> Y
forall a. Num a => a -> a -> a
+ Y
1) Maybe HV -> Maybe HV -> Bool
forall a. Eq a => a -> a -> Bool
== HV -> Maybe HV
forall a. a -> Maybe a
Just HV
Vert ->
                           Area -> Point -> (Area -> SpecialArea) -> EnumMap Point SpecialArea
mergeSpecial Area
ar Point
i{py = py i + 1} Area -> SpecialArea
SpecialArea
                    -- Horiz | px i - 1 >= 0
                    --         && mergable (px i - 1) (py i) == Just Horiz ->
                    --         mergeSpecial ar i{px = px i - 1} SpecialArea
                    HV
Horiz | Point -> Y
px Point
i Y -> Y -> Y
forall a. Num a => a -> a -> a
+ Y
1 Y -> Y -> Bool
forall a. Ord a => a -> a -> Bool
< Y
gx
                            Bool -> Bool -> Bool
&& Y -> Y -> Maybe HV
mergable (Point -> Y
px Point
i Y -> Y -> Y
forall a. Num a => a -> a -> a
+ Y
1) (Point -> Y
py Point
i) Maybe HV -> Maybe HV -> Bool
forall a. Eq a => a -> a -> Bool
== HV -> Maybe HV
forall a. a -> Maybe a
Just HV
Horiz ->
                            Area -> Point -> (Area -> SpecialArea) -> EnumMap Point SpecialArea
mergeSpecial Area
ar Point
i{px = px i + 1} Area -> SpecialArea
SpecialArea
                    HV
_ -> EnumMap Point SpecialArea
gs0
                SpecialFixed Point
p Freqs PlaceKind
placeGroup Area
ar ->
                  -- If single merge is sufficient to extend the fixed place
                  -- to full size, and the merge is possible, we perform it.
                  -- An empty inner list signifies some merge is needed,
                  -- but not possible, and then we abort and don't waste space.
                  let (Y
x0, Y
y0, Y
x1, Y
y1) = Area -> (Y, Y, Y, Y)
fromArea Area
ar
                      dy :: Y
dy = Y
3  -- arbitrary, matches common content
                      dx :: Y
dx = Y
5  -- arbitrary, matches common content
                      vics :: [[Point]]
                      vics :: [[Point]]
vics = [ [Point
i {py = py i - 1} | Point -> Y
py Point
i Y -> Y -> Y
forall a. Num a => a -> a -> a
- Y
1 Y -> Y -> Bool
forall a. Ord a => a -> a -> Bool
>= Y
0]  -- possible
                             | Point -> Y
py Point
p Y -> Y -> Y
forall a. Num a => a -> a -> a
- Y
y0 Y -> Y -> Bool
forall a. Ord a => a -> a -> Bool
< Y
dy ]  -- needed
                             [[Point]] -> [[Point]] -> [[Point]]
forall a. [a] -> [a] -> [a]
++ [ [Point
i {py = py i + 1} | Point -> Y
py Point
i Y -> Y -> Y
forall a. Num a => a -> a -> a
+ Y
1 Y -> Y -> Bool
forall a. Ord a => a -> a -> Bool
< Y
gy]
                                | Y
y1 Y -> Y -> Y
forall a. Num a => a -> a -> a
- Point -> Y
py Point
p Y -> Y -> Bool
forall a. Ord a => a -> a -> Bool
< Y
dy ]
                             [[Point]] -> [[Point]] -> [[Point]]
forall a. [a] -> [a] -> [a]
++ [ [Point
i {px = px i - 1} | Point -> Y
px Point
i Y -> Y -> Y
forall a. Num a => a -> a -> a
- Y
1 Y -> Y -> Bool
forall a. Ord a => a -> a -> Bool
>= Y
0]
                                | Point -> Y
px Point
p Y -> Y -> Y
forall a. Num a => a -> a -> a
- Y
x0 Y -> Y -> Bool
forall a. Ord a => a -> a -> Bool
< Y
dx ]
                             [[Point]] -> [[Point]] -> [[Point]]
forall a. [a] -> [a] -> [a]
++ [ [Point
i {px = px i + 1} | Point -> Y
px Point
i Y -> Y -> Y
forall a. Num a => a -> a -> a
+ Y
1 Y -> Y -> Bool
forall a. Ord a => a -> a -> Bool
< Y
gx]
                                | Y
x1 Y -> Y -> Y
forall a. Num a => a -> a -> a
- Point -> Y
px Point
p Y -> Y -> Bool
forall a. Ord a => a -> a -> Bool
< Y
dx ]
                  in case [[Point]]
vics of
                    [[Point
p2]] -> Area -> Point -> (Area -> SpecialArea) -> EnumMap Point SpecialArea
mergeSpecial Area
ar Point
p2 (Point -> Freqs PlaceKind -> Area -> SpecialArea
SpecialFixed Point
p Freqs PlaceKind
placeGroup)
                    [[Point]]
_ -> EnumMap Point SpecialArea
gs0
                SpecialMerged{} -> String -> EnumMap Point SpecialArea
forall a. (?callStack::CallStack) => String -> a
error (String -> EnumMap Point SpecialArea)
-> String -> EnumMap Point SpecialArea
forall a b. (a -> b) -> a -> b
$ String
"" String
-> (EnumMap Point SpecialArea, EnumMap Point SpecialArea, Point)
-> String
forall v. Show v => String -> v -> String
`showFailure` (EnumMap Point SpecialArea
gs, EnumMap Point SpecialArea
gs0, Point
i)
            gs2 = (EnumMap Point SpecialArea
 -> (Point, SpecialArea) -> EnumMap Point SpecialArea)
-> EnumMap Point SpecialArea
-> [(Point, SpecialArea)]
-> EnumMap Point SpecialArea
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' EnumMap Point SpecialArea
-> (Point, SpecialArea) -> EnumMap Point SpecialArea
mergeFixed EnumMap Point SpecialArea
gs ([(Point, SpecialArea)] -> EnumMap Point SpecialArea)
-> [(Point, SpecialArea)] -> EnumMap Point SpecialArea
forall a b. (a -> b) -> a -> b
$ EnumMap Point SpecialArea -> [(Point, SpecialArea)]
forall k a. Enum k => EnumMap k a -> [(k, a)]
EM.assocs EnumMap Point SpecialArea
gs
        voidPlaces <- do
          let gridArea = Area -> Maybe Area -> Area
forall a. a -> Maybe a -> a
fromMaybe (String -> Area
forall a. (?callStack::CallStack) => String -> a
error (String -> Area) -> String -> Area
forall a b. (a -> b) -> a -> b
$ String
"" String -> (Y, Y) -> String
forall v. Show v => String -> v -> String
`showFailure` (Y, Y)
lgr)
                         (Maybe Area -> Area) -> Maybe Area -> Area
forall a b. (a -> b) -> a -> b
$ (Y, Y, Y, Y) -> Maybe Area
toArea (Y
0, Y
0, Y
gx Y -> Y -> Y
forall a. Num a => a -> a -> a
- Y
1, Y
gy Y -> Y -> Y
forall a. Num a => a -> a -> a
- Y
1)
              voidNum = Rational -> Y
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Rational -> Y) -> Rational -> Y
forall a b. (a -> b) -> a -> b
$
                Rational
cmaxVoid Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* (Y -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegralWrap :: Int -> Rational) (EnumMap Point SpecialArea -> Y
forall k a. EnumMap k a -> Y
EM.size EnumMap Point SpecialArea
gs2)
              isOrdinaryArea Point
p = case Point
p Point -> EnumMap Point SpecialArea -> Maybe SpecialArea
forall k a. Enum k => k -> EnumMap k a -> Maybe a
`EM.lookup` EnumMap Point SpecialArea
gs2 of
                Just SpecialArea{} -> Bool
True
                Maybe SpecialArea
_ -> Bool
False
          reps <- replicateM voidNum (pointInArea gridArea)
                    -- repetitions are OK; variance is low anyway
          return $! ES.fromList $ filter isOrdinaryArea reps
        let decidePlace :: Bool
                        -> ( TileMapEM
                           , EM.EnumMap Point (Place, Area)
                           , EM.EnumMap Point Place )
                        -> (Point, SpecialArea)
                        -> Rnd ( TileMapEM
                               , EM.EnumMap Point (Place, Area)
                               , EM.EnumMap Point Place )
            decidePlace Bool
noVoid (!TileMapEM
m, !EnumMap Point (Place, Area)
qls, !EnumMap Point Place
qstairs) (!Point
i, !SpecialArea
special) =
              case SpecialArea
special of
                SpecialArea Area
ar -> do
                  -- Reserved for corridors and the global fence.
                  let innerArea :: Area
innerArea = Area -> Maybe Area -> Area
forall a. a -> Maybe a -> a
fromMaybe (String -> Area
forall a. (?callStack::CallStack) => String -> a
error (String -> Area) -> String -> Area
forall a b. (a -> b) -> a -> b
$ String
"" String -> (Point, Area) -> String
forall v. Show v => String -> v -> String
`showFailure` (Point
i, Area
ar))
                                  (Maybe Area -> Area) -> Maybe Area -> Area
forall a b. (a -> b) -> a -> b
$ Area -> Maybe Area
shrink Area
ar
                      !_A0 :: Maybe Area
_A0 = Area -> Maybe Area
shrink Area
innerArea
                      !_A1 :: ()
_A1 = Bool -> () -> ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Maybe Area -> Bool
forall a. Maybe a -> Bool
isJust Maybe Area
_A0 Bool -> (Area, EnumMap Point SpecialArea, CaveKind) -> Bool
forall v. Show v => Bool -> v -> Bool
`blame` (Area
innerArea, EnumMap Point SpecialArea
gs, CaveKind
kc)) ()
                  if Bool -> Bool
not Bool
noVoid Bool -> Bool -> Bool
&& Point
i Point -> EnumSet Point -> Bool
forall k. Enum k => k -> EnumSet k -> Bool
`ES.member` EnumSet Point
voidPlaces
                  then do
                    qarea <- Area -> Rnd Area
mkVoidRoom Area
innerArea
                    let qkind = ContentId PlaceKind
deadEndId
                        qmap = EnumMap k a
forall k a. EnumMap k a
EM.empty
                        qfence = EnumMap k a
forall k a. EnumMap k a
EM.empty
                    return (m, EM.insert i (Place{..}, ar) qls, qstairs)
                  else do
                    r <- (Y, Y) -> (Y, Y) -> Area -> Rnd Area
mkRoom (Y, Y)
minPlaceSize (Y, Y)
maxPlaceSize Area
innerArea
                    place <- buildPlace cops kc dnight darkCorTile litCorTile
                                        ldepth totalDepth dsecret
                                        r (Just innerArea) []
                    return ( EM.unions [qmap place, qfence place, m]
                           , EM.insert i (place, ar) qls
                           , qstairs )
                SpecialFixed Point
p Freqs PlaceKind
placeFreq Area
ar -> do
                  -- Reserved for corridors and the global fence.
                  let innerArea :: Area
innerArea = Area -> Maybe Area -> Area
forall a. a -> Maybe a -> a
fromMaybe (String -> Area
forall a. (?callStack::CallStack) => String -> a
error (String -> Area) -> String -> Area
forall a b. (a -> b) -> a -> b
$ String
"" String -> (Point, Area) -> String
forall v. Show v => String -> v -> String
`showFailure` (Point
i, Area
ar))
                                  (Maybe Area -> Area) -> Maybe Area -> Area
forall a b. (a -> b) -> a -> b
$ Area -> Maybe Area
shrink Area
ar
                      !_A0 :: Maybe Area
_A0 = Area -> Maybe Area
shrink Area
innerArea
                      !_A1 :: ()
_A1 = Bool -> () -> ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Maybe Area -> Bool
forall a. Maybe a -> Bool
isJust Maybe Area
_A0 Bool -> (Area, EnumMap Point SpecialArea, CaveKind) -> Bool
forall v. Show v => Bool -> v -> Bool
`blame` (Area
innerArea, EnumMap Point SpecialArea
gs2, CaveKind
kc)) ()
                      !_A2 :: ()
_A2 = Bool -> () -> ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Area -> Point -> Bool
inside (Maybe Area -> Area
forall a. (?callStack::CallStack) => Maybe a -> a
fromJust Maybe Area
_A0) Point
p
                                     Bool -> (Point, Area, EnumMap Point SpecialArea) -> Bool
forall v. Show v => Bool -> v -> Bool
`blame` (Point
p, Area
innerArea, EnumMap Point SpecialArea
gs)) ()
                      r :: Area
r = (Y, Y) -> Area -> Point -> Area
mkFixed (Y, Y)
maxPlaceSize Area
innerArea Point
p
                      !_A3 :: ()
_A3 = Bool -> () -> ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Maybe Area -> Bool
forall a. Maybe a -> Bool
isJust (Area -> Maybe Area
shrink Area
r)
                                     Bool
-> (Area, Area, Point, Area, EnumMap Point SpecialArea,
    EnumMap Point SpecialArea, EnumMap Point (Place, Area), CaveKind)
-> Bool
forall v. Show v => Bool -> v -> Bool
`blame` ( Area
r, Area
ar, Point
p, Area
innerArea, EnumMap Point SpecialArea
gs
                                             , EnumMap Point SpecialArea
gs2, EnumMap Point (Place, Area)
qls, CaveKind
kc )) ()
                  place <- COps
-> CaveKind
-> Bool
-> ContentId TileKind
-> ContentId TileKind
-> AbsDepth
-> AbsDepth
-> Word32
-> Area
-> Maybe Area
-> Freqs PlaceKind
-> Rnd Place
buildPlace COps
cops CaveKind
kc Bool
dnight ContentId TileKind
darkCorTile ContentId TileKind
litCorTile
                             AbsDepth
ldepth AbsDepth
totalDepth Word32
dsecret Area
r Maybe Area
forall a. Maybe a
Nothing Freqs PlaceKind
placeFreq
                  return ( EM.unions [qmap place, qfence place, m]
                         , EM.insert i (place, ar) qls
                         , EM.insert p place qstairs )
                SpecialMerged SpecialArea
sp Point
p2 -> do
                  (lplaces, dplaces, dstairs) <-
                    Bool
-> (TileMapEM, EnumMap Point (Place, Area), EnumMap Point Place)
-> (Point, SpecialArea)
-> Rnd
     (TileMapEM, EnumMap Point (Place, Area), EnumMap Point Place)
decidePlace Bool
True (TileMapEM
m, EnumMap Point (Place, Area)
qls, EnumMap Point Place
qstairs) (Point
i, SpecialArea
sp)
                  return ( lplaces
                         , EM.insert p2 (dplaces EM.! i) dplaces
                         , dstairs )
        places <- foldlM' (decidePlace False) (EM.empty, EM.empty, EM.empty)
                  $ EM.assocs gs2
        return (voidPlaces, lgr, places)
  (voidPlaces, lgrid, (lplaces, dplaces, dstairs)) <- createPlaces
  let lcorridorsFun :: Rnd ( EM.EnumMap Point ( ContentId TileKind
                                              , ContentId PlaceKind )
                           , TileMapEM )
      lcorridorsFun = do
        connects <- EnumSet Point -> (Y, Y) -> Rnd [(Point, Point)]
connectGrid EnumSet Point
voidPlaces (Y, Y)
lgrid
        addedConnects <- do
          let cauxNum =
                Rational -> Y
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Rational -> Y) -> Rational -> Y
forall a b. (a -> b) -> a -> b
$ Rational
cauxConnects Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* (Y -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegralWrap :: Int -> Rational)
                                         ((Y -> Y -> Y) -> (Y, Y) -> Y
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Y -> Y -> Y
forall a. Num a => a -> a -> a
(*) (Y, Y)
lgrid)
          cns <- map head . group . sort
                 <$> replicateM cauxNum (randomConnection lgrid)
          -- This allows connections through a single void room,
          -- if a non-void room on both ends.
          let notDeadEnd (Point
p, Point
q) =
                if | Point
p Point -> EnumSet Point -> Bool
forall k. Enum k => k -> EnumSet k -> Bool
`ES.member` EnumSet Point
voidPlaces ->
                     Point
q Point -> EnumSet Point -> Bool
forall k. Enum k => k -> EnumSet k -> Bool
`ES.notMember` EnumSet Point
voidPlaces Bool -> Bool -> Bool
&& Point -> Bool
sndInCns Point
p
                   | Point
q Point -> EnumSet Point -> Bool
forall k. Enum k => k -> EnumSet k -> Bool
`ES.member` EnumSet Point
voidPlaces -> Point -> Bool
fstInCns Point
q
                   | Bool
otherwise -> Bool
True
              sndInCns Point
p = ((Point, Point) -> Bool) -> [(Point, Point)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Point
p0, Point
q0) ->
                Point
q0 Point -> Point -> Bool
forall a. Eq a => a -> a -> Bool
== Point
p Bool -> Bool -> Bool
&& Point
p0 Point -> EnumSet Point -> Bool
forall k. Enum k => k -> EnumSet k -> Bool
`ES.notMember` EnumSet Point
voidPlaces) [(Point, Point)]
cns
              fstInCns Point
q = ((Point, Point) -> Bool) -> [(Point, Point)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Point
p0, Point
q0) ->
                Point
p0 Point -> Point -> Bool
forall a. Eq a => a -> a -> Bool
== Point
q Bool -> Bool -> Bool
&& Point
q0 Point -> EnumSet Point -> Bool
forall k. Enum k => k -> EnumSet k -> Bool
`ES.notMember` EnumSet Point
voidPlaces) [(Point, Point)]
cns
          return $! filter notDeadEnd cns
        let allConnects = [(Point, Point)]
connects [(Point, Point)] -> [(Point, Point)] -> [(Point, Point)]
forall a. Eq a => [a] -> [a] -> [a]
`union` [(Point, Point)]
addedConnects
            connectPos :: (Point, Point)
                       -> Rnd (Maybe ( ContentId PlaceKind
                                     , Corridor
                                     , ContentId PlaceKind ))
            connectPos (Point
p0, Point
p1) = do
              let (Place
place0, Area
area0) = EnumMap Point (Place, Area)
dplaces EnumMap Point (Place, Area) -> Point -> (Place, Area)
forall k a. Enum k => EnumMap k a -> k -> a
EM.! Point
p0
                  (Place
place1, Area
area1) = EnumMap Point (Place, Area)
dplaces EnumMap Point (Place, Area) -> Point -> (Place, Area)
forall k a. Enum k => EnumMap k a -> k -> a
EM.! Point
p1
                  savePlaces :: Corridor -> (ContentId PlaceKind, Corridor, ContentId PlaceKind)
savePlaces Corridor
cor = (Place -> ContentId PlaceKind
qkind Place
place0, Corridor
cor, Place -> ContentId PlaceKind
qkind Place
place1)
              connected <- (Area, Fence, Area) -> (Area, Fence, Area) -> Rnd (Maybe Corridor)
connectPlaces
                (Place -> Area
qarea Place
place0, PlaceKind -> Fence
pfence (PlaceKind -> Fence) -> PlaceKind -> Fence
forall a b. (a -> b) -> a -> b
$ ContentData PlaceKind -> ContentId PlaceKind -> PlaceKind
forall a. ContentData a -> ContentId a -> a
okind ContentData PlaceKind
coplace (Place -> ContentId PlaceKind
qkind Place
place0), Area
area0)
                (Place -> Area
qarea Place
place1, PlaceKind -> Fence
pfence (PlaceKind -> Fence) -> PlaceKind -> Fence
forall a b. (a -> b) -> a -> b
$ ContentData PlaceKind -> ContentId PlaceKind -> PlaceKind
forall a. ContentData a -> ContentId a -> a
okind ContentData PlaceKind
coplace (Place -> ContentId PlaceKind
qkind Place
place1), Area
area1)
              return $! savePlaces <$> connected
        cs <- catMaybes <$> mapM connectPos allConnects
        let pickedCorTile = if Bool
dnight then ContentId TileKind
darkCorTile else ContentId TileKind
litCorTile
            digCorridorSection :: a -> Point -> Point -> EM.EnumMap Point a
            digCorridorSection a
a Point
p1 Point
p2 =
              [(Point, a)] -> EnumMap Point a
forall k a. Enum k => [(k, a)] -> EnumMap k a
EM.fromList ([(Point, a)] -> EnumMap Point a)
-> [(Point, a)] -> EnumMap Point a
forall a b. (a -> b) -> a -> b
$ [Point] -> [a] -> [(Point, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Point -> Point -> [Point]
fromTo Point
p1 Point
p2) (a -> [a]
forall a. a -> [a]
repeat a
a)
            digCorridor (ContentId PlaceKind
sqkind, (Point
p1, Point
p2, Point
p3, Point
p4), ContentId PlaceKind
tqkind) =
              ( EnumMap Point (ContentId TileKind, ContentId PlaceKind)
-> EnumMap Point (ContentId TileKind, ContentId PlaceKind)
-> EnumMap Point (ContentId TileKind, ContentId PlaceKind)
forall k a. EnumMap k a -> EnumMap k a -> EnumMap k a
EM.union ((ContentId TileKind, ContentId PlaceKind)
-> Point
-> Point
-> EnumMap Point (ContentId TileKind, ContentId PlaceKind)
forall a. a -> Point -> Point -> EnumMap Point a
digCorridorSection (ContentId TileKind
pickedCorTile, ContentId PlaceKind
sqkind) Point
p1 Point
p2)
                         ((ContentId TileKind, ContentId PlaceKind)
-> Point
-> Point
-> EnumMap Point (ContentId TileKind, ContentId PlaceKind)
forall a. a -> Point -> Point -> EnumMap Point a
digCorridorSection (ContentId TileKind
pickedCorTile, ContentId PlaceKind
tqkind) Point
p3 Point
p4)
              , ContentId TileKind -> Point -> Point -> TileMapEM
forall a. a -> Point -> Point -> EnumMap Point a
digCorridorSection ContentId TileKind
pickedCorTile Point
p2 Point
p3 )
            (lplOuter, lInner) = unzip $ map digCorridor cs
        return (EM.unions lplOuter, EM.unions lInner)
  (lplcorOuter, lcorInner) <- lcorridorsFun
  -- The hacks below are instead of unionWithKeyM, which is costly.
  let mergeCor Point
_ ContentId TileKind
pl (ContentId TileKind
cor, ContentId PlaceKind
pk) = if TileSpeedup -> ContentId TileKind -> Bool
Tile.isWalkable TileSpeedup
coTileSpeedup ContentId TileKind
pl
                                then Maybe (ContentId TileKind, ContentId TileKind, ContentId PlaceKind)
forall a. Maybe a
Nothing  -- tile already open
                                else (ContentId TileKind, ContentId TileKind, ContentId PlaceKind)
-> Maybe
     (ContentId TileKind, ContentId TileKind, ContentId PlaceKind)
forall a. a -> Maybe a
Just (ContentId TileKind
pl, ContentId TileKind
cor, ContentId PlaceKind
pk)
      {-# INLINE intersectionWithKeyMaybe #-}
      intersectionWithKeyMaybe k -> a -> b -> Maybe c
combine =
        (k -> a -> b -> Maybe c)
-> (EnumMap k a -> EnumMap k c)
-> (EnumMap k b -> EnumMap k c)
-> EnumMap k a
-> EnumMap k b
-> EnumMap k c
forall k a b c.
Enum k =>
(k -> a -> b -> Maybe c)
-> (EnumMap k a -> EnumMap k c)
-> (EnumMap k b -> EnumMap k c)
-> EnumMap k a
-> EnumMap k b
-> EnumMap k c
EM.mergeWithKey k -> a -> b -> Maybe c
combine (EnumMap k c -> EnumMap k a -> EnumMap k c
forall a b. a -> b -> a
const EnumMap k c
forall k a. EnumMap k a
EM.empty) (EnumMap k c -> EnumMap k b -> EnumMap k c
forall a b. a -> b -> a
const EnumMap k c
forall k a. EnumMap k a
EM.empty)
      interCor = (Point
 -> ContentId TileKind
 -> (ContentId TileKind, ContentId PlaceKind)
 -> Maybe
      (ContentId TileKind, ContentId TileKind, ContentId PlaceKind))
-> TileMapEM
-> EnumMap Point (ContentId TileKind, ContentId PlaceKind)
-> EnumMap
     Point (ContentId TileKind, ContentId TileKind, ContentId PlaceKind)
forall {k} {a} {b} {c}.
Enum k =>
(k -> a -> b -> Maybe c)
-> EnumMap k a -> EnumMap k b -> EnumMap k c
intersectionWithKeyMaybe Point
-> ContentId TileKind
-> (ContentId TileKind, ContentId PlaceKind)
-> Maybe
     (ContentId TileKind, ContentId TileKind, ContentId PlaceKind)
mergeCor TileMapEM
lplaces EnumMap Point (ContentId TileKind, ContentId PlaceKind)
lplcorOuter  -- fast
  doorMap <- foldlM' (pickOpening cops kc lplaces litCorTile dsecret) EM.empty
                     (EM.assocs interCor)  -- very small
  let subArea = Area -> Maybe Area -> Area
forall a. a -> Maybe a -> a
fromMaybe (String -> Area
forall a. (?callStack::CallStack) => String -> a
error (String -> Area) -> String -> Area
forall a b. (a -> b) -> a -> b
$ String
"" String -> CaveKind -> String
forall v. Show v => String -> v -> String
`showFailure` CaveKind
kc) (Maybe Area -> Area) -> Maybe Area -> Area
forall a b. (a -> b) -> a -> b
$ Area -> Maybe Area
shrink Area
darea
  fence <- buildFenceRnd cops
                         cfenceTileN cfenceTileE cfenceTileS cfenceTileW subArea
  -- The obscured tile, e.g., scratched wall, stays on the server forever,
  -- only the suspect variant on client gets replaced by this upon searching.
  let sub2Area = Area -> Maybe Area -> Area
forall a. a -> Maybe a -> a
fromMaybe (String -> Area
forall a. (?callStack::CallStack) => String -> a
error (String -> Area) -> String -> Area
forall a b. (a -> b) -> a -> b
$ String
"" String -> CaveKind -> String
forall v. Show v => String -> v -> String
`showFailure` CaveKind
kc) (Maybe Area -> Area) -> Maybe Area -> Area
forall a b. (a -> b) -> a -> b
$ Area -> Maybe Area
shrink Area
subArea
      sub3Area = Area -> Maybe Area -> Area
forall a. a -> Maybe a -> a
fromMaybe (String -> Area
forall a. (?callStack::CallStack) => String -> a
error (String -> Area) -> String -> Area
forall a b. (a -> b) -> a -> b
$ String
"" String -> CaveKind -> String
forall v. Show v => String -> v -> String
`showFailure` CaveKind
kc) (Maybe Area -> Area) -> Maybe Area -> Area
forall a b. (a -> b) -> a -> b
$ Area -> Maybe Area
shrink Area
sub2Area
      likelySecret = Area -> Point -> Bool
inside Area
sub3Area
      obscure Point
p ContentId TileKind
t = if Y -> Y -> Word32 -> Point -> Bool
isChancePos Y
1 Y
chidden Word32
dsecret Point
p Bool -> Bool -> Bool
&& Point -> Bool
likelySecret Point
p
                    then ContentData TileKind
-> ContentId TileKind -> StateT SMGen Identity (ContentId TileKind)
Tile.obscureAs ContentData TileKind
cotile ContentId TileKind
t
                    else ContentId TileKind -> StateT SMGen Identity (ContentId TileKind)
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ContentId TileKind
t
  lplacesObscured <- mapWithKeyM obscure lplaces
  let lcorOuter = ((ContentId TileKind, ContentId PlaceKind) -> ContentId TileKind)
-> EnumMap Point (ContentId TileKind, ContentId PlaceKind)
-> TileMapEM
forall a b k. (a -> b) -> EnumMap k a -> EnumMap k b
EM.map (ContentId TileKind, ContentId PlaceKind) -> ContentId TileKind
forall a b. (a, b) -> a
fst EnumMap Point (ContentId TileKind, ContentId PlaceKind)
lplcorOuter
      aroundFence Place{TileMapEM
ContentId PlaceKind
Area
qfence :: Place -> TileMapEM
qmap :: Place -> TileMapEM
qarea :: Place -> Area
qkind :: Place -> ContentId PlaceKind
qkind :: ContentId PlaceKind
qarea :: Area
qmap :: TileMapEM
qfence :: TileMapEM
..} =
        if PlaceKind -> Fence
pfence (ContentData PlaceKind -> ContentId PlaceKind -> PlaceKind
forall a. ContentData a -> ContentId a -> a
okind ContentData PlaceKind
coplace ContentId PlaceKind
qkind) Fence -> [Fence] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Fence
FFloor, Fence
FGround]
        then (ContentId TileKind -> PlaceEntry)
-> TileMapEM -> EnumMap Point PlaceEntry
forall a b k. (a -> b) -> EnumMap k a -> EnumMap k b
EM.map (PlaceEntry -> ContentId TileKind -> PlaceEntry
forall a b. a -> b -> a
const (PlaceEntry -> ContentId TileKind -> PlaceEntry)
-> PlaceEntry -> ContentId TileKind -> PlaceEntry
forall a b. (a -> b) -> a -> b
$ ContentId PlaceKind -> PlaceEntry
PAround ContentId PlaceKind
qkind) TileMapEM
qfence
        else EnumMap Point PlaceEntry
forall k a. EnumMap k a
EM.empty
      pickRepresentant Place{TileMapEM
ContentId PlaceKind
Area
qfence :: Place -> TileMapEM
qmap :: Place -> TileMapEM
qarea :: Place -> Area
qkind :: Place -> ContentId PlaceKind
qkind :: ContentId PlaceKind
qarea :: Area
qmap :: TileMapEM
qfence :: TileMapEM
..} =
        let (Point
representant, Y
_, Y
_) = Area -> (Point, Y, Y)
spanArea Area
qarea
        in Point -> PlaceEntry -> EnumMap Point PlaceEntry
forall k a. Enum k => k -> a -> EnumMap k a
EM.singleton Point
representant (PlaceEntry -> EnumMap Point PlaceEntry)
-> PlaceEntry -> EnumMap Point PlaceEntry
forall a b. (a -> b) -> a -> b
$ ContentId PlaceKind -> PlaceEntry
PExists ContentId PlaceKind
qkind
      dentry = [EnumMap Point PlaceEntry] -> EnumMap Point PlaceEntry
forall k a. [EnumMap k a] -> EnumMap k a
EM.unions ([EnumMap Point PlaceEntry] -> EnumMap Point PlaceEntry)
-> [EnumMap Point PlaceEntry] -> EnumMap Point PlaceEntry
forall a b. (a -> b) -> a -> b
$
        [((ContentId TileKind, ContentId TileKind, ContentId PlaceKind)
 -> PlaceEntry)
-> EnumMap
     Point (ContentId TileKind, ContentId TileKind, ContentId PlaceKind)
-> EnumMap Point PlaceEntry
forall a b k. (a -> b) -> EnumMap k a -> EnumMap k b
EM.map (\(ContentId TileKind
_, ContentId TileKind
_, ContentId PlaceKind
pk) -> ContentId PlaceKind -> PlaceEntry
PEntry ContentId PlaceKind
pk) EnumMap
  Point (ContentId TileKind, ContentId TileKind, ContentId PlaceKind)
interCor]
        [EnumMap Point PlaceEntry]
-> [EnumMap Point PlaceEntry] -> [EnumMap Point PlaceEntry]
forall a. [a] -> [a] -> [a]
++ ((Place, Area) -> EnumMap Point PlaceEntry)
-> [(Place, Area)] -> [EnumMap Point PlaceEntry]
forall a b. (a -> b) -> [a] -> [b]
map (\(Place
place, Area
_) -> Place -> EnumMap Point PlaceEntry
aroundFence Place
place) (EnumMap Point (Place, Area) -> [(Place, Area)]
forall k a. EnumMap k a -> [a]
EM.elems EnumMap Point (Place, Area)
dplaces)
        [EnumMap Point PlaceEntry]
-> [EnumMap Point PlaceEntry] -> [EnumMap Point PlaceEntry]
forall a. [a] -> [a] -> [a]
++ -- for @FNone@ fences with walkable tiles on the edges
           -- that may have no intersection with corridots,
           -- particularly if @X@ is used
           ((Place, Area) -> EnumMap Point PlaceEntry)
-> [(Place, Area)] -> [EnumMap Point PlaceEntry]
forall a b. (a -> b) -> [a] -> [b]
map (\(Place
place, Area
_) -> Place -> EnumMap Point PlaceEntry
pickRepresentant Place
place) (EnumMap Point (Place, Area) -> [(Place, Area)]
forall k a. EnumMap k a -> [a]
EM.elems EnumMap Point (Place, Area)
dplaces)
      dmap = [TileMapEM] -> TileMapEM
forall k a. [EnumMap k a] -> EnumMap k a
EM.unions [TileMapEM
doorMap, TileMapEM
lplacesObscured, TileMapEM
lcorOuter, TileMapEM
lcorInner, TileMapEM
fence]
        -- order matters
  return $! Cave {..}

pickOpening :: COps -> CaveKind -> TileMapEM -> ContentId TileKind -> Word32
            -> EM.EnumMap Point (ContentId TileKind)
            -> ( Point
               , (ContentId TileKind, ContentId TileKind, ContentId PlaceKind) )
            -> Rnd (EM.EnumMap Point (ContentId TileKind))
pickOpening :: COps
-> CaveKind
-> TileMapEM
-> ContentId TileKind
-> Word32
-> TileMapEM
-> (Point,
    (ContentId TileKind, ContentId TileKind, ContentId PlaceKind))
-> Rnd TileMapEM
pickOpening COps{ContentData TileKind
cotile :: COps -> ContentData TileKind
cotile :: ContentData TileKind
cotile, TileSpeedup
coTileSpeedup :: COps -> TileSpeedup
coTileSpeedup :: TileSpeedup
coTileSpeedup}
            CaveKind{Rational
cdoorChance :: CaveKind -> Rational
cdoorChance :: Rational
cdoorChance, Rational
copenChance :: CaveKind -> Rational
copenChance :: Rational
copenChance, Y
chidden :: CaveKind -> Y
chidden :: Y
chidden}
            TileMapEM
lplaces ContentId TileKind
litCorTile Word32
dsecret
            !TileMapEM
acc (Point
pos, (ContentId TileKind
pl, ContentId TileKind
cor, ContentId PlaceKind
_)) = do
  let nicerCorridor :: ContentId TileKind
nicerCorridor =
        if TileSpeedup -> ContentId TileKind -> Bool
Tile.isLit TileSpeedup
coTileSpeedup ContentId TileKind
cor then ContentId TileKind
cor
        else -- If any cardinally adjacent walkable room tile is lit,
             -- make the opening lit, as well.
             let roomTileLit :: Point -> Bool
roomTileLit Point
p =
                   case Point -> TileMapEM -> Maybe (ContentId TileKind)
forall k a. Enum k => k -> EnumMap k a -> Maybe a
EM.lookup Point
p TileMapEM
lplaces of
                     Maybe (ContentId TileKind)
Nothing -> Bool
False
                     Just ContentId TileKind
tile -> TileSpeedup -> ContentId TileKind -> Bool
Tile.isWalkable TileSpeedup
coTileSpeedup ContentId TileKind
tile
                                  Bool -> Bool -> Bool
&& TileSpeedup -> ContentId TileKind -> Bool
Tile.isLit TileSpeedup
coTileSpeedup ContentId TileKind
tile
                 vic :: [Point]
vic = Point -> [Point]
vicinityCardinalUnsafe Point
pos
             in if (Point -> Bool) -> [Point] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Point -> Bool
roomTileLit [Point]
vic then ContentId TileKind
litCorTile else ContentId TileKind
cor
      vicAll :: [Point]
vicAll = Point -> [Point]
vicinityUnsafe Point
pos
      vicNewTiles :: [ContentId TileKind]
vicNewTiles = (Point -> Maybe (ContentId TileKind))
-> [Point] -> [ContentId TileKind]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Point -> TileMapEM -> Maybe (ContentId TileKind)
forall k a. Enum k => k -> EnumMap k a -> Maybe a
`EM.lookup` TileMapEM
acc) [Point]
vicAll
  newTile <- case [ContentId TileKind]
vicNewTiles of
    ContentId TileKind
vicNewTile : [ContentId TileKind]
_ -> ContentId TileKind -> StateT SMGen Identity (ContentId TileKind)
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ContentId TileKind
vicNewTile  -- disallow a door beside an opening
    [] -> do
      -- Openings have a certain chance to be doors and doors have a certain
      -- chance to be open.
      rd <- Rational -> Rnd Bool
chance Rational
cdoorChance
      if rd then do
        let hidden = ContentData TileKind -> ContentId TileKind -> ContentId TileKind
Tile.buildAs ContentData TileKind
cotile ContentId TileKind
pl
        doorTrappedId <- Tile.revealAs cotile hidden
        let !_A = Bool -> () -> ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (ContentData TileKind -> ContentId TileKind -> ContentId TileKind
Tile.buildAs ContentData TileKind
cotile ContentId TileKind
doorTrappedId ContentId TileKind -> ContentId TileKind -> Bool
forall a. Eq a => a -> a -> Bool
== ContentId TileKind
doorTrappedId) ()
        -- Not all solid tiles can hide a door (or any other openable tile),
        -- so @doorTrappedId@ may in fact not be a door at all, hence the check.
        if Tile.isOpenable coTileSpeedup doorTrappedId then do  -- door created
          ro <- chance copenChance
          if ro
          then Tile.openTo cotile doorTrappedId
          else if isChancePos 1 chidden dsecret pos
               then return doorTrappedId  -- server will hide it
               else do
                 doorOpenId <- Tile.openTo cotile doorTrappedId
                 Tile.closeTo cotile doorOpenId  -- mail do nothing; OK
        else return doorTrappedId  -- assume this is what content enforces
      else return nicerCorridor
  return $! EM.insert pos newTile acc