-- | 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
cname :: CaveKind -> Text
cfreq :: CaveKind -> Freqs CaveKind
cXminSize :: CaveKind -> Y
cYminSize :: CaveKind -> Y
ccellSize :: CaveKind -> DiceXY
cminPlaceSize :: CaveKind -> DiceXY
cmaxPlaceSize :: CaveKind -> DiceXY
cdarkOdds :: CaveKind -> Dice
cnightOdds :: CaveKind -> Dice
cauxConnects :: CaveKind -> Rational
cmaxVoid :: CaveKind -> Rational
cdoorChance :: CaveKind -> Rational
copenChance :: CaveKind -> Rational
chidden :: CaveKind -> Y
cactorCoeff :: CaveKind -> Y
cactorFreq :: CaveKind -> Freqs ItemKind
citemNum :: CaveKind -> Dice
citemFreq :: CaveKind -> Freqs ItemKind
cplaceFreq :: CaveKind -> Freqs PlaceKind
cpassable :: CaveKind -> Bool
clabyrinth :: CaveKind -> Bool
cdefTile :: CaveKind -> GroupName TileKind
cdarkCorTile :: CaveKind -> GroupName TileKind
clitCorTile :: CaveKind -> GroupName TileKind
cwallTile :: CaveKind -> GroupName TileKind
ccornerTile :: CaveKind -> GroupName TileKind
cfenceTileN :: CaveKind -> GroupName TileKind
cfenceTileE :: CaveKind -> GroupName TileKind
cfenceTileS :: CaveKind -> GroupName TileKind
cfenceTileW :: CaveKind -> GroupName TileKind
cfenceApart :: CaveKind -> Bool
cminStairDist :: CaveKind -> Y
cmaxStairsNum :: CaveKind -> Dice
cescapeFreq :: CaveKind -> Freqs PlaceKind
cstairFreq :: CaveKind -> Freqs PlaceKind
cstairAllowed :: CaveKind -> Freqs PlaceKind
cskip :: CaveKind -> [Y]
cinitSleep :: CaveKind -> InitSleep
cdesc :: CaveKind -> Text
..} = ContentData CaveKind -> ContentId CaveKind -> CaveKind
forall a. ContentData a -> ContentId a -> a
okind ContentData CaveKind
cocave ContentId CaveKind
dkind
  ContentId TileKind
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)
  ContentId TileKind
litCorTile <- 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
clitCorTile)
                (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
clitCorTile (Bool -> TileKind -> Bool
forall a b. a -> b -> a
const Bool
True)
  Bool
dnight <- AbsDepth -> AbsDepth -> Dice -> Rnd Bool
oddsDice AbsDepth
ldepth AbsDepth
totalDepth Dice
cnightOdds
  let createPlaces :: StateT
  SMGen
  Identity
  (EnumSet Point, (Y, Y),
   (TileMapEM, EnumMap Point (Place, Area), EnumMap Point Place))
createPlaces = do
        (Y, Y)
minPlaceSize <- AbsDepth -> AbsDepth -> DiceXY -> Rnd (Y, Y)
castDiceXY AbsDepth
ldepth AbsDepth
totalDepth DiceXY
cminPlaceSize
        (Y, Y)
maxPlaceSize <- AbsDepth -> AbsDepth -> DiceXY -> Rnd (Y, Y)
castDiceXY AbsDepth
ldepth AbsDepth
totalDepth DiceXY
cmaxPlaceSize
        let mergeFixed :: EM.EnumMap Point SpecialArea
                       -> (Point, SpecialArea)
                       -> EM.EnumMap Point SpecialArea
            mergeFixed :: EnumMap Point SpecialArea
-> (Point, SpecialArea) -> 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
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
        EnumSet Point
voidPlaces <- do
          let gridArea :: Area
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 :: Y
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 -> Bool
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
          [Point]
reps <- Y -> StateT SMGen Identity Point -> StateT SMGen Identity [Point]
forall (m :: * -> *) a. Applicative m => Y -> m a -> m [a]
replicateM Y
voidNum (Area -> StateT SMGen Identity Point
pointInArea Area
gridArea)
                    -- repetitions are OK; variance is low anyway
          EnumSet Point -> StateT SMGen Identity (EnumSet Point)
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (EnumSet Point -> StateT SMGen Identity (EnumSet Point))
-> EnumSet Point -> StateT SMGen Identity (EnumSet Point)
forall a b. (a -> b) -> a -> b
$! [Point] -> EnumSet Point
forall k. Enum k => [k] -> EnumSet k
ES.fromList ([Point] -> EnumSet Point) -> [Point] -> EnumSet Point
forall a b. (a -> b) -> a -> b
$ (Point -> Bool) -> [Point] -> [Point]
forall a. (a -> Bool) -> [a] -> [a]
filter Point -> Bool
isOrdinaryArea [Point]
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
-> (TileMapEM, EnumMap Point (Place, Area), EnumMap Point Place)
-> (Point, SpecialArea)
-> Rnd
     (TileMapEM, EnumMap Point (Place, Area), 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
                    Area
qarea <- Area -> Rnd Area
mkVoidRoom Area
innerArea
                    let qkind :: ContentId PlaceKind
qkind = ContentId PlaceKind
deadEndId
                        qmap :: EnumMap k a
qmap = EnumMap k a
forall k a. EnumMap k a
EM.empty
                        qfence :: EnumMap k a
qfence = EnumMap k a
forall k a. EnumMap k a
EM.empty
                    (TileMapEM, EnumMap Point (Place, Area), EnumMap Point Place)
-> Rnd
     (TileMapEM, EnumMap Point (Place, Area), EnumMap Point Place)
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (TileMapEM
m, Point
-> (Place, Area)
-> EnumMap Point (Place, Area)
-> EnumMap Point (Place, Area)
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert Point
i (Place{TileMapEM
ContentId PlaceKind
Area
forall k a. EnumMap k a
qarea :: Area
qkind :: ContentId PlaceKind
qmap :: forall k a. EnumMap k a
qfence :: forall k a. EnumMap k a
qkind :: ContentId PlaceKind
qarea :: Area
qmap :: TileMapEM
qfence :: TileMapEM
..}, Area
ar) EnumMap Point (Place, Area)
qls, EnumMap Point Place
qstairs)
                  else do
                    Area
r <- (Y, Y) -> (Y, Y) -> Area -> Rnd Area
mkRoom (Y, Y)
minPlaceSize (Y, Y)
maxPlaceSize Area
innerArea
                    Place
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 (Area -> Maybe Area
forall a. a -> Maybe a
Just Area
innerArea) []
                    (TileMapEM, EnumMap Point (Place, Area), EnumMap Point Place)
-> Rnd
     (TileMapEM, EnumMap Point (Place, Area), EnumMap Point Place)
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ( [TileMapEM] -> TileMapEM
forall k a. [EnumMap k a] -> EnumMap k a
EM.unions [Place -> TileMapEM
qmap Place
place, Place -> TileMapEM
qfence Place
place, TileMapEM
m]
                           , Point
-> (Place, Area)
-> EnumMap Point (Place, Area)
-> EnumMap Point (Place, Area)
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert Point
i (Place
place, Area
ar) EnumMap Point (Place, Area)
qls
                           , EnumMap Point Place
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
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
                  (TileMapEM, EnumMap Point (Place, Area), EnumMap Point Place)
-> Rnd
     (TileMapEM, EnumMap Point (Place, Area), EnumMap Point Place)
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ( [TileMapEM] -> TileMapEM
forall k a. [EnumMap k a] -> EnumMap k a
EM.unions [Place -> TileMapEM
qmap Place
place, Place -> TileMapEM
qfence Place
place, TileMapEM
m]
                         , Point
-> (Place, Area)
-> EnumMap Point (Place, Area)
-> EnumMap Point (Place, Area)
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert Point
i (Place
place, Area
ar) EnumMap Point (Place, Area)
qls
                         , Point -> Place -> EnumMap Point Place -> EnumMap Point Place
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert Point
p Place
place EnumMap Point Place
qstairs )
                SpecialMerged SpecialArea
sp Point
p2 -> do
                  (TileMapEM
lplaces, EnumMap Point (Place, Area)
dplaces, EnumMap Point Place
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)
                  (TileMapEM, EnumMap Point (Place, Area), EnumMap Point Place)
-> Rnd
     (TileMapEM, EnumMap Point (Place, Area), EnumMap Point Place)
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ( TileMapEM
lplaces
                         , Point
-> (Place, Area)
-> EnumMap Point (Place, Area)
-> EnumMap Point (Place, Area)
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert Point
p2 (EnumMap Point (Place, Area)
dplaces EnumMap Point (Place, Area) -> Point -> (Place, Area)
forall k a. Enum k => EnumMap k a -> k -> a
EM.! Point
i) EnumMap Point (Place, Area)
dplaces
                         , EnumMap Point Place
dstairs )
        (TileMapEM, EnumMap Point (Place, Area), EnumMap Point Place)
places <- ((TileMapEM, EnumMap Point (Place, Area), EnumMap Point Place)
 -> (Point, SpecialArea)
 -> Rnd
      (TileMapEM, EnumMap Point (Place, Area), EnumMap Point Place))
-> (TileMapEM, EnumMap Point (Place, Area), EnumMap Point Place)
-> [(Point, SpecialArea)]
-> Rnd
     (TileMapEM, EnumMap Point (Place, Area), EnumMap Point Place)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> Rnd b) -> b -> t a -> Rnd b
foldlM' (Bool
-> (TileMapEM, EnumMap Point (Place, Area), EnumMap Point Place)
-> (Point, SpecialArea)
-> Rnd
     (TileMapEM, EnumMap Point (Place, Area), EnumMap Point Place)
decidePlace Bool
False) (TileMapEM
forall k a. EnumMap k a
EM.empty, EnumMap Point (Place, Area)
forall k a. EnumMap k a
EM.empty, EnumMap Point Place
forall k a. EnumMap k a
EM.empty)
                  ([(Point, SpecialArea)]
 -> Rnd
      (TileMapEM, EnumMap Point (Place, Area), EnumMap Point Place))
-> [(Point, SpecialArea)]
-> Rnd
     (TileMapEM, EnumMap Point (Place, Area), EnumMap Point Place)
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
gs2
        (EnumSet Point, (Y, Y),
 (TileMapEM, EnumMap Point (Place, Area), EnumMap Point Place))
-> StateT
     SMGen
     Identity
     (EnumSet Point, (Y, Y),
      (TileMapEM, EnumMap Point (Place, Area), EnumMap Point Place))
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (EnumSet Point
voidPlaces, (Y, Y)
lgr, (TileMapEM, EnumMap Point (Place, Area), EnumMap Point Place)
places)
  (EnumSet Point
voidPlaces, (Y, Y)
lgrid, (TileMapEM
lplaces, EnumMap Point (Place, Area)
dplaces, EnumMap Point Place
dstairs)) <- StateT
  SMGen
  Identity
  (EnumSet Point, (Y, Y),
   (TileMapEM, EnumMap Point (Place, Area), EnumMap Point Place))
createPlaces
  let lcorridorsFun :: Rnd ( EM.EnumMap Point ( ContentId TileKind
                                              , ContentId PlaceKind )
                           , TileMapEM )
      lcorridorsFun :: Rnd
  (EnumMap Point (ContentId TileKind, ContentId PlaceKind),
   TileMapEM)
lcorridorsFun = do
        [(Point, Point)]
connects <- EnumSet Point -> (Y, Y) -> Rnd [(Point, Point)]
connectGrid EnumSet Point
voidPlaces (Y, Y)
lgrid
        [(Point, Point)]
addedConnects <- do
          let cauxNum :: Y
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)
          [(Point, Point)]
cns <- ([(Point, Point)] -> (Point, Point))
-> [[(Point, Point)]] -> [(Point, Point)]
forall a b. (a -> b) -> [a] -> [b]
map [(Point, Point)] -> (Point, Point)
forall a. (?callStack::CallStack) => [a] -> a
head ([[(Point, Point)]] -> [(Point, Point)])
-> ([(Point, Point)] -> [[(Point, Point)]])
-> [(Point, Point)]
-> [(Point, Point)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Point, Point)] -> [[(Point, Point)]]
forall a. Eq a => [a] -> [[a]]
group ([(Point, Point)] -> [[(Point, Point)]])
-> ([(Point, Point)] -> [(Point, Point)])
-> [(Point, Point)]
-> [[(Point, Point)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Point, Point)] -> [(Point, Point)]
forall a. Ord a => [a] -> [a]
sort
                 ([(Point, Point)] -> [(Point, Point)])
-> Rnd [(Point, Point)] -> Rnd [(Point, Point)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Y -> StateT SMGen Identity (Point, Point) -> Rnd [(Point, Point)]
forall (m :: * -> *) a. Applicative m => Y -> m a -> m [a]
replicateM Y
cauxNum ((Y, Y) -> StateT SMGen Identity (Point, Point)
randomConnection (Y, Y)
lgrid)
          -- This allows connections through a single void room,
          -- if a non-void room on both ends.
          let notDeadEnd :: (Point, Point) -> Bool
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 -> Bool
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 -> Bool
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
          [(Point, Point)] -> Rnd [(Point, Point)]
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Point, Point)] -> Rnd [(Point, Point)])
-> [(Point, Point)] -> Rnd [(Point, Point)]
forall a b. (a -> b) -> a -> b
$! ((Point, Point) -> Bool) -> [(Point, Point)] -> [(Point, Point)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Point, Point) -> Bool
notDeadEnd [(Point, Point)]
cns
        let allConnects :: [(Point, Point)]
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, 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)
              Maybe Corridor
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)
              Maybe (ContentId PlaceKind, Corridor, ContentId PlaceKind)
-> Rnd (Maybe (ContentId PlaceKind, Corridor, ContentId PlaceKind))
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (ContentId PlaceKind, Corridor, ContentId PlaceKind)
 -> Rnd
      (Maybe (ContentId PlaceKind, Corridor, ContentId PlaceKind)))
-> Maybe (ContentId PlaceKind, Corridor, ContentId PlaceKind)
-> Rnd (Maybe (ContentId PlaceKind, Corridor, ContentId PlaceKind))
forall a b. (a -> b) -> a -> b
$! Corridor -> (ContentId PlaceKind, Corridor, ContentId PlaceKind)
savePlaces (Corridor -> (ContentId PlaceKind, Corridor, ContentId PlaceKind))
-> Maybe Corridor
-> Maybe (ContentId PlaceKind, Corridor, ContentId PlaceKind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Corridor
connected
        [(ContentId PlaceKind, Corridor, ContentId PlaceKind)]
cs <- [Maybe (ContentId PlaceKind, Corridor, ContentId PlaceKind)]
-> [(ContentId PlaceKind, Corridor, ContentId PlaceKind)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (ContentId PlaceKind, Corridor, ContentId PlaceKind)]
 -> [(ContentId PlaceKind, Corridor, ContentId PlaceKind)])
-> StateT
     SMGen
     Identity
     [Maybe (ContentId PlaceKind, Corridor, ContentId PlaceKind)]
-> StateT
     SMGen
     Identity
     [(ContentId PlaceKind, Corridor, ContentId PlaceKind)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Point, Point)
 -> Rnd
      (Maybe (ContentId PlaceKind, Corridor, ContentId PlaceKind)))
-> [(Point, Point)]
-> StateT
     SMGen
     Identity
     [Maybe (ContentId PlaceKind, Corridor, ContentId PlaceKind)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Point, Point)
-> Rnd (Maybe (ContentId PlaceKind, Corridor, ContentId PlaceKind))
connectPos [(Point, Point)]
allConnects
        let pickedCorTile :: ContentId TileKind
pickedCorTile = if Bool
dnight then ContentId TileKind
darkCorTile else ContentId TileKind
litCorTile
            digCorridorSection :: a -> Point -> Point -> EM.EnumMap Point a
            digCorridorSection :: forall a. a -> Point -> Point -> 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, Corridor, ContentId PlaceKind)
-> (EnumMap Point (ContentId TileKind, ContentId PlaceKind),
    TileMapEM)
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 )
            ([EnumMap Point (ContentId TileKind, ContentId PlaceKind)]
lplOuter, [TileMapEM]
lInner) = [(EnumMap Point (ContentId TileKind, ContentId PlaceKind),
  TileMapEM)]
-> ([EnumMap Point (ContentId TileKind, ContentId PlaceKind)],
    [TileMapEM])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(EnumMap Point (ContentId TileKind, ContentId PlaceKind),
   TileMapEM)]
 -> ([EnumMap Point (ContentId TileKind, ContentId PlaceKind)],
     [TileMapEM]))
-> [(EnumMap Point (ContentId TileKind, ContentId PlaceKind),
     TileMapEM)]
-> ([EnumMap Point (ContentId TileKind, ContentId PlaceKind)],
    [TileMapEM])
forall a b. (a -> b) -> a -> b
$ ((ContentId PlaceKind, Corridor, ContentId PlaceKind)
 -> (EnumMap Point (ContentId TileKind, ContentId PlaceKind),
     TileMapEM))
-> [(ContentId PlaceKind, Corridor, ContentId PlaceKind)]
-> [(EnumMap Point (ContentId TileKind, ContentId PlaceKind),
     TileMapEM)]
forall a b. (a -> b) -> [a] -> [b]
map (ContentId PlaceKind, Corridor, ContentId PlaceKind)
-> (EnumMap Point (ContentId TileKind, ContentId PlaceKind),
    TileMapEM)
digCorridor [(ContentId PlaceKind, Corridor, ContentId PlaceKind)]
cs
        (EnumMap Point (ContentId TileKind, ContentId PlaceKind),
 TileMapEM)
-> Rnd
     (EnumMap Point (ContentId TileKind, ContentId PlaceKind),
      TileMapEM)
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([EnumMap Point (ContentId TileKind, ContentId PlaceKind)]
-> EnumMap Point (ContentId TileKind, ContentId PlaceKind)
forall k a. [EnumMap k a] -> EnumMap k a
EM.unions [EnumMap Point (ContentId TileKind, ContentId PlaceKind)]
lplOuter, [TileMapEM] -> TileMapEM
forall k a. [EnumMap k a] -> EnumMap k a
EM.unions [TileMapEM]
lInner)
  (EnumMap Point (ContentId TileKind, ContentId PlaceKind)
lplcorOuter, TileMapEM
lcorInner) <- Rnd
  (EnumMap Point (ContentId TileKind, ContentId PlaceKind),
   TileMapEM)
lcorridorsFun
  -- The hacks below are instead of unionWithKeyM, which is costly.
  let mergeCor :: Point
-> ContentId TileKind
-> (ContentId TileKind, ContentId PlaceKind)
-> Maybe
     (ContentId TileKind, ContentId TileKind, ContentId PlaceKind)
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)
-> EnumMap k a -> EnumMap k b -> EnumMap k c
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 :: EnumMap
  Point (ContentId TileKind, ContentId TileKind, ContentId PlaceKind)
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
  TileMapEM
doorMap <- (TileMapEM
 -> (Point,
     (ContentId TileKind, ContentId TileKind, ContentId PlaceKind))
 -> Rnd TileMapEM)
-> TileMapEM
-> [(Point,
     (ContentId TileKind, ContentId TileKind, ContentId PlaceKind))]
-> Rnd TileMapEM
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> Rnd b) -> b -> t a -> Rnd b
foldlM' (COps
-> CaveKind
-> TileMapEM
-> ContentId TileKind
-> Word32
-> TileMapEM
-> (Point,
    (ContentId TileKind, ContentId TileKind, ContentId PlaceKind))
-> Rnd TileMapEM
pickOpening COps
cops CaveKind
kc TileMapEM
lplaces ContentId TileKind
litCorTile Word32
dsecret) TileMapEM
forall k a. EnumMap k a
EM.empty
                     (EnumMap
  Point (ContentId TileKind, ContentId TileKind, ContentId PlaceKind)
-> [(Point,
     (ContentId TileKind, ContentId TileKind, ContentId PlaceKind))]
forall k a. Enum k => EnumMap k a -> [(k, a)]
EM.assocs EnumMap
  Point (ContentId TileKind, ContentId TileKind, ContentId PlaceKind)
interCor)  -- very small
  let subArea :: Area
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
  TileMapEM
fence <- COps
-> GroupName TileKind
-> GroupName TileKind
-> GroupName TileKind
-> GroupName TileKind
-> Area
-> Rnd TileMapEM
buildFenceRnd COps
cops
                         GroupName TileKind
cfenceTileN GroupName TileKind
cfenceTileE GroupName TileKind
cfenceTileS GroupName TileKind
cfenceTileW Area
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
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
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 :: Point -> Bool
likelySecret = Area -> Point -> Bool
inside Area
sub3Area
      obscure :: Point
-> ContentId TileKind -> StateT SMGen Identity (ContentId TileKind)
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
  TileMapEM
lplacesObscured <- (Key (EnumMap Point)
 -> ContentId TileKind
 -> StateT SMGen Identity (ContentId TileKind))
-> TileMapEM -> Rnd TileMapEM
forall (t :: * -> *) (m :: * -> *) a b.
(TraversableWithKey t, Monad m) =>
(Key t -> a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(Key (EnumMap Point) -> a -> m b)
-> EnumMap Point a -> m (EnumMap Point b)
mapWithKeyM Key (EnumMap Point)
-> ContentId TileKind -> StateT SMGen Identity (ContentId TileKind)
Point
-> ContentId TileKind -> StateT SMGen Identity (ContentId TileKind)
obscure TileMapEM
lplaces
  let lcorOuter :: TileMapEM
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 -> EnumMap Point PlaceEntry
aroundFence Place{TileMapEM
ContentId PlaceKind
Area
qkind :: Place -> ContentId PlaceKind
qarea :: Place -> Area
qmap :: Place -> TileMapEM
qfence :: Place -> TileMapEM
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 -> EnumMap Point PlaceEntry
pickRepresentant Place{TileMapEM
ContentId PlaceKind
Area
qkind :: Place -> ContentId PlaceKind
qarea :: Place -> Area
qmap :: Place -> TileMapEM
qfence :: Place -> TileMapEM
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
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
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
  Cave -> Rnd Cave
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Cave -> Rnd Cave) -> Cave -> Rnd Cave
forall a b. (a -> b) -> a -> b
$! Cave {Bool
TileMapEM
EnumMap Point PlaceEntry
EnumMap Point Place
ContentId CaveKind
Area
dkind :: ContentId CaveKind
darea :: Area
dmap :: TileMapEM
dstairs :: EnumMap Point Place
dentry :: EnumMap Point PlaceEntry
dnight :: Bool
darea :: Area
dkind :: ContentId CaveKind
dnight :: Bool
dstairs :: EnumMap Point Place
dentry :: EnumMap Point PlaceEntry
dmap :: TileMapEM
..}

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
  ContentId TileKind
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.
      Bool
rd <- Rational -> Rnd Bool
chance Rational
cdoorChance
      if Bool
rd then do
        let hidden :: ContentId TileKind
hidden = ContentData TileKind -> ContentId TileKind -> ContentId TileKind
Tile.buildAs ContentData TileKind
cotile ContentId TileKind
pl
        ContentId TileKind
doorTrappedId <- ContentData TileKind
-> ContentId TileKind -> StateT SMGen Identity (ContentId TileKind)
Tile.revealAs ContentData TileKind
cotile ContentId TileKind
hidden
        let !_A :: ()
_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 TileSpeedup -> ContentId TileKind -> Bool
Tile.isOpenable TileSpeedup
coTileSpeedup ContentId TileKind
doorTrappedId then do  -- door created
          Bool
ro <- Rational -> Rnd Bool
chance Rational
copenChance
          if Bool
ro
          then ContentData TileKind
-> ContentId TileKind -> StateT SMGen Identity (ContentId TileKind)
Tile.openTo ContentData TileKind
cotile ContentId TileKind
doorTrappedId
          else if Y -> Y -> Word32 -> Point -> Bool
isChancePos Y
1 Y
chidden Word32
dsecret Point
pos
               then 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
doorTrappedId  -- server will hide it
               else do
                 ContentId TileKind
doorOpenId <- ContentData TileKind
-> ContentId TileKind -> StateT SMGen Identity (ContentId TileKind)
Tile.openTo ContentData TileKind
cotile ContentId TileKind
doorTrappedId
                 ContentData TileKind
-> ContentId TileKind -> StateT SMGen Identity (ContentId TileKind)
Tile.closeTo ContentData TileKind
cotile ContentId TileKind
doorOpenId  -- mail do nothing; OK
        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
doorTrappedId  -- assume this is what content enforces
      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
nicerCorridor
  TileMapEM -> Rnd TileMapEM
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (TileMapEM -> Rnd TileMapEM) -> TileMapEM -> Rnd TileMapEM
forall a b. (a -> b) -> a -> b
$! Point -> ContentId TileKind -> TileMapEM -> TileMapEM
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert Point
pos ContentId TileKind
newTile TileMapEM
acc