    {-# LANGUAGE TupleSections #-}
    -- | The dungeon generation routine. It creates empty dungeons, without
    -- actors and without items, either lying on the floor or embedded inside tiles.
    module Game.LambdaHack.Server.DungeonGen
      ( FreshDungeon(..), dungeonGen
    #ifdef EXPOSE_INTERNAL
        -- * Internal operations
      , convertTileMaps, buildTileMap, anchorDown, buildLevel
      , snapToStairList, placeDownStairs, levelFromCave
    #endif
      ) where

    import Prelude ()

    import Game.LambdaHack.Core.Prelude

    import qualified Control.Monad.Trans.State.Strict as St
    import           Data.Either (rights)
    import qualified Data.EnumMap.Strict as EM
    import qualified Data.IntMap.Strict as IM
    import qualified Data.Text as T
    import qualified Data.Text.IO as T
    import           System.IO (hFlush, stdout)
    import           System.IO.Unsafe (unsafePerformIO)
    import qualified System.Random.SplitMix32 as SM

    import           Game.LambdaHack.Common.Area
    import           Game.LambdaHack.Common.Kind
    import           Game.LambdaHack.Common.Level
    import           Game.LambdaHack.Common.Point
    import qualified Game.LambdaHack.Common.PointArray as PointArray
    import qualified Game.LambdaHack.Common.Tile as Tile
    import           Game.LambdaHack.Common.Time
    import           Game.LambdaHack.Common.Types
    import           Game.LambdaHack.Content.CaveKind
    import           Game.LambdaHack.Content.ModeKind
    import qualified Game.LambdaHack.Content.PlaceKind as PK
    import           Game.LambdaHack.Content.RuleKind
    import           Game.LambdaHack.Content.TileKind (TileKind)
    import qualified Game.LambdaHack.Content.TileKind as TK
    import qualified Game.LambdaHack.Core.Dice as Dice
    import           Game.LambdaHack.Core.Random
    import           Game.LambdaHack.Definition.Defs
    import qualified Game.LambdaHack.Definition.DefsInternal as DefsInternal
    import           Game.LambdaHack.Server.DungeonGen.AreaRnd
    import           Game.LambdaHack.Server.DungeonGen.Cave
    import           Game.LambdaHack.Server.DungeonGen.Place
    import           Game.LambdaHack.Server.ServerOptions

    convertTileMaps :: COps -> Bool -> Rnd (ContentId TileKind)
                    -> Maybe (Rnd (ContentId TileKind)) -> Area -> TileMapEM
                    -> Rnd TileMap
    convertTileMaps :: COps
    -> Bool
    -> Rnd (ContentId TileKind)
    -> Maybe (Rnd (ContentId TileKind))
    -> Area
    -> TileMapEM
    -> Rnd TileMap
    convertTileMaps COps{ corule :: COps -> RuleContent
    corule=RuleContent{Int
    rWidthMax :: Int
    rWidthMax :: RuleContent -> Int
    rWidthMax, Int
    rHeightMax :: Int
    rHeightMax :: RuleContent -> Int
    rHeightMax}
                        , ContentData TileKind
    cotile :: ContentData TileKind
    cotile :: COps -> ContentData TileKind
    cotile
                        , TileSpeedup
    coTileSpeedup :: TileSpeedup
    coTileSpeedup :: COps -> TileSpeedup
    coTileSpeedup }
                    Bool
    areAllWalkable Rnd (ContentId TileKind)
    cdefTile Maybe (Rnd (ContentId TileKind))
    mpickPassable Area
    darea TileMapEM
    ltile = do
      let outerId :: ContentId TileKind
    outerId = ContentData TileKind -> GroupName TileKind -> ContentId TileKind
    forall a. Show a => ContentData a -> GroupName a -> ContentId a
    ouniqGroup ContentData TileKind
    cotile GroupName TileKind
    TK.S_UNKNOWN_OUTER_FENCE
          runCdefTile :: (SM.SMGen, (Int, [(Int, ContentId TileKind)]))
                      -> ( ContentId TileKind
                         , (SM.SMGen, (Int, [(Int, ContentId TileKind)])) )
          runCdefTile :: (SMGen, (Int, [(Int, ContentId TileKind)]))
    -> (ContentId TileKind,
        (SMGen, (Int, [(Int, ContentId TileKind)])))
    runCdefTile (SMGen
    gen1, (Int
    pI, [(Int, ContentId TileKind)]
    assocs)) =
            let p :: Point
    p = Int -> Point
    forall a. Enum a => Int -> a
    toEnum Int
    pI
            in if Area -> Point -> Bool
    inside Area
    darea Point
    p
               then case [(Int, ContentId TileKind)]
    assocs of
                 (Int
    p2, ContentId TileKind
    t2) : [(Int, ContentId TileKind)]
    rest | Int
    p2 Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    pI -> (ContentId TileKind
    t2, (SMGen
    gen1, (Int
    pI Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1, [(Int, ContentId TileKind)]
    rest)))
                 [(Int, ContentId TileKind)]
    _ -> let (ContentId TileKind
    tile, SMGen
    gen2) = Rnd (ContentId TileKind) -> SMGen -> (ContentId TileKind, SMGen)
    forall s a. State s a -> s -> (a, s)
    St.runState Rnd (ContentId TileKind)
    cdefTile SMGen
    gen1
                      in (ContentId TileKind
    tile, (SMGen
    gen2, (Int
    pI Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1, [(Int, ContentId TileKind)]
    assocs)))
               else (ContentId TileKind
    outerId, (SMGen
    gen1, (Int
    pI Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1, [(Int, ContentId TileKind)]
    assocs)))
          runUnfold :: SMGen -> (TileMap, SMGen)
    runUnfold SMGen
    gen =
            let (SMGen
    gen1, SMGen
    gen2) = SMGen -> (SMGen, SMGen)
    SM.splitSMGen SMGen
    gen
            in (Int
    -> Int
    -> ((SMGen, (Int, [(Int, ContentId TileKind)]))
        -> (ContentId TileKind,
            (SMGen, (Int, [(Int, ContentId TileKind)]))))
    -> (SMGen, (Int, [(Int, ContentId TileKind)]))
    -> TileMap
    forall c b.
    UnboxRepClass c =>
    Int -> Int -> (b -> (c, b)) -> b -> Array c
    PointArray.unfoldrNA
                  Int
    rWidthMax Int
    rHeightMax (SMGen, (Int, [(Int, ContentId TileKind)]))
    -> (ContentId TileKind,
        (SMGen, (Int, [(Int, ContentId TileKind)])))
    runCdefTile
                  (SMGen
    gen1, (Int
    0, IntMap (ContentId TileKind) -> [(Int, ContentId TileKind)]
    forall a. IntMap a -> [(Int, a)]
    IM.assocs (IntMap (ContentId TileKind) -> [(Int, ContentId TileKind)])
    -> IntMap (ContentId TileKind) -> [(Int, ContentId TileKind)]
    forall a b. (a -> b) -> a -> b
    $ TileMapEM -> IntMap (ContentId TileKind)
    forall k a. EnumMap k a -> IntMap a
    EM.enumMapToIntMap TileMapEM
    ltile)), SMGen
    gen2)
      converted1 <- (SMGen -> (TileMap, SMGen)) -> Rnd TileMap
    forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
    St.state SMGen -> (TileMap, SMGen)
    runUnfold
      case mpickPassable of
        Maybe (Rnd (ContentId TileKind))
    _ | Bool
    areAllWalkable -> TileMap -> Rnd TileMap
    forall a. a -> StateT SMGen Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return TileMap
    converted1  -- all walkable; passes OK
        Maybe (Rnd (ContentId TileKind))
    Nothing -> TileMap -> Rnd TileMap
    forall a. a -> StateT SMGen Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return TileMap
    converted1  -- no walkable tiles for filling the map
        Just Rnd (ContentId TileKind)
    pickPassable -> do  -- some tiles walkable, so ensure connectivity
          let passes :: Point -> TileMap -> Bool
    passes Point
    p TileMap
    array =
                TileSpeedup -> ContentId TileKind -> Bool
    Tile.isWalkable TileSpeedup
    coTileSpeedup (TileMap
    array TileMap -> Point -> ContentId TileKind
    forall c. UnboxRepClass c => Array c -> Point -> c
    PointArray.! Point
    p)
              -- If no point blocks on both ends, then I can eventually go
              -- from bottom to top of the map and from left to right
              -- unless there are disconnected areas inside rooms).
              blocksHorizontal :: Point -> TileMap -> Bool
    blocksHorizontal (Point Int
    x Int
    y) TileMap
    array =
                Bool -> Bool
    not (Point -> TileMap -> Bool
    passes (Int -> Int -> Point
    Point (Int
    x Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1) Int
    y) TileMap
    array
                     Bool -> Bool -> Bool
    || Point -> TileMap -> Bool
    passes (Int -> Int -> Point
    Point (Int
    x Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1) Int
    y) TileMap
    array)
              blocksVertical :: Point -> TileMap -> Bool
    blocksVertical (Point Int
    x Int
    y) TileMap
    array =
                Bool -> Bool
    not (Point -> TileMap -> Bool
    passes (Int -> Int -> Point
    Point Int
    x (Int
    y Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1)) TileMap
    array
                     Bool -> Bool -> Bool
    || Point -> TileMap -> Bool
    passes (Int -> Int -> Point
    Point Int
    x (Int
    y Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1)) TileMap
    array)
              activeArea :: Area
    activeArea = Area -> Maybe Area -> Area
    forall a. a -> Maybe a -> a
    fromMaybe ([Char] -> Area
    forall a. HasCallStack => [Char] -> a
    error ([Char] -> Area) -> [Char] -> Area
    forall a b. (a -> b) -> a -> b
    $ [Char]
    "" [Char] -> Area -> [Char]
    forall v. Show v => [Char] -> v -> [Char]
    `showFailure` Area
    darea) (Maybe Area -> Area) -> Maybe Area -> Area
    forall a b. (a -> b) -> a -> b
    $ Area -> Maybe Area
    shrink Area
    darea
              connect :: (Point -> Bool)
    -> (Point -> TileMap -> Bool)
    -> ContentId TileKind
    -> TileMap
    -> TileMap
    connect Point -> Bool
    included Point -> TileMap -> Bool
    blocks ContentId TileKind
    walkableTile TileMap
    array =
                let g :: Point -> ContentId TileKind -> ContentId TileKind
    g Point
    p ContentId TileKind
    c = if Area -> Point -> Bool
    inside Area
    activeArea Point
    p
                               Bool -> Bool -> Bool
    && Point -> Bool
    included Point
    p
                               Bool -> Bool -> Bool
    && Bool -> Bool
    not (TileSpeedup -> ContentId TileKind -> Bool
    Tile.isEasyOpen TileSpeedup
    coTileSpeedup ContentId TileKind
    c)
                               Bool -> Bool -> Bool
    && Point
    p Point -> TileMapEM -> Bool
    forall k a. Enum k => k -> EnumMap k a -> Bool
    `EM.notMember` TileMapEM
    ltile
                               Bool -> Bool -> Bool
    && Point -> TileMap -> Bool
    blocks Point
    p TileMap
    array
                            then ContentId TileKind
    walkableTile
                            else ContentId TileKind
    c
                in (Point -> ContentId TileKind -> ContentId TileKind)
    -> TileMap -> TileMap
    forall c d.
    (UnboxRepClass c, UnboxRepClass d) =>
    (Point -> c -> d) -> Array c -> Array d
    PointArray.imapA Point -> ContentId TileKind -> ContentId TileKind
    g TileMap
    array
          walkable2 <- Rnd (ContentId TileKind)
    pickPassable
          let converted2 = (Point -> Bool)
    -> (Point -> TileMap -> Bool)
    -> ContentId TileKind
    -> TileMap
    -> TileMap
    connect (Int -> Bool
    forall a. Integral a => a -> Bool
    even (Int -> Bool) -> (Point -> Int) -> Point -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Point -> Int
    px) Point -> TileMap -> Bool
    blocksHorizontal ContentId TileKind
    walkable2 TileMap
    converted1
          walkable3 <- pickPassable
          let converted3 = (Point -> Bool)
    -> (Point -> TileMap -> Bool)
    -> ContentId TileKind
    -> TileMap
    -> TileMap
    connect (Int -> Bool
    forall a. Integral a => a -> Bool
    even (Int -> Bool) -> (Point -> Int) -> Point -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Point -> Int
    py) Point -> TileMap -> Bool
    blocksVertical ContentId TileKind
    walkable3 TileMap
    converted2
          walkable4 <- pickPassable
          let converted4 =
                (Point -> Bool)
    -> (Point -> TileMap -> Bool)
    -> ContentId TileKind
    -> TileMap
    -> TileMap
    connect (Int -> Bool
    forall a. Integral a => a -> Bool
    odd (Int -> Bool) -> (Point -> Int) -> Point -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Point -> Int
    px) Point -> TileMap -> Bool
    blocksHorizontal ContentId TileKind
    walkable4 TileMap
    converted3
          walkable5 <- pickPassable
          let converted5 =
                (Point -> Bool)
    -> (Point -> TileMap -> Bool)
    -> ContentId TileKind
    -> TileMap
    -> TileMap
    connect (Int -> Bool
    forall a. Integral a => a -> Bool
    odd (Int -> Bool) -> (Point -> Int) -> Point -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Point -> Int
    py) Point -> TileMap -> Bool
    blocksVertical ContentId TileKind
    walkable5 TileMap
    converted4
          return converted5

    buildTileMap :: COps -> Cave -> Rnd TileMap
    buildTileMap :: COps -> Cave -> Rnd TileMap
    buildTileMap cops :: COps
    cops@COps{ContentData TileKind
    cotile :: COps -> ContentData TileKind
    cotile :: ContentData TileKind
    cotile, ContentData CaveKind
    cocave :: ContentData CaveKind
    cocave :: COps -> ContentData CaveKind
    cocave} Cave{ContentId CaveKind
    dkind :: ContentId CaveKind
    dkind :: Cave -> ContentId CaveKind
    dkind, Area
    darea :: Area
    darea :: Cave -> Area
    darea, TileMapEM
    dmap :: TileMapEM
    dmap :: Cave -> TileMapEM
    dmap} = do
      let CaveKind{Bool
    cpassable :: Bool
    cpassable :: CaveKind -> Bool
    cpassable, GroupName TileKind
    cdefTile :: GroupName TileKind
    cdefTile :: CaveKind -> GroupName TileKind
    cdefTile} = ContentData CaveKind -> ContentId CaveKind -> CaveKind
    forall a. ContentData a -> ContentId a -> a
    okind ContentData CaveKind
    cocave ContentId CaveKind
    dkind
          pickDefTile :: Rnd (ContentId TileKind)
    pickDefTile = ContentId TileKind
    -> Maybe (ContentId TileKind) -> ContentId TileKind
    forall a. a -> Maybe a -> a
    fromMaybe ([Char] -> ContentId TileKind
    forall a. HasCallStack => [Char] -> a
    error ([Char] -> ContentId TileKind) -> [Char] -> ContentId TileKind
    forall a b. (a -> b) -> a -> b
    $ [Char]
    "" [Char] -> GroupName TileKind -> [Char]
    forall v. Show v => [Char] -> v -> [Char]
    `showFailure` GroupName TileKind
    cdefTile)
                        (Maybe (ContentId TileKind) -> ContentId TileKind)
    -> StateT SMGen Identity (Maybe (ContentId TileKind))
    -> Rnd (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
    cdefTile (Bool -> TileKind -> Bool
    forall a b. a -> b -> a
    const Bool
    True)
          wcond :: TileKind -> Bool
    wcond = TileKind -> Bool
    Tile.isEasyOpenKind
          mpickPassable :: Maybe (Rnd (ContentId TileKind))
    mpickPassable =
            if Bool
    cpassable
            then Rnd (ContentId TileKind) -> Maybe (Rnd (ContentId TileKind))
    forall a. a -> Maybe a
    Just (Rnd (ContentId TileKind) -> Maybe (Rnd (ContentId TileKind)))
    -> Rnd (ContentId TileKind) -> Maybe (Rnd (ContentId TileKind))
    forall a b. (a -> b) -> a -> b
    $ ContentId TileKind
    -> Maybe (ContentId TileKind) -> ContentId TileKind
    forall a. a -> Maybe a -> a
    fromMaybe ([Char] -> ContentId TileKind
    forall a. HasCallStack => [Char] -> a
    error ([Char] -> ContentId TileKind) -> [Char] -> ContentId TileKind
    forall a b. (a -> b) -> a -> b
    $ [Char]
    "" [Char] -> GroupName TileKind -> [Char]
    forall v. Show v => [Char] -> v -> [Char]
    `showFailure` GroupName TileKind
    cdefTile)
                        (Maybe (ContentId TileKind) -> ContentId TileKind)
    -> StateT SMGen Identity (Maybe (ContentId TileKind))
    -> Rnd (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
    cdefTile TileKind -> Bool
    wcond
            else Maybe (Rnd (ContentId TileKind))
    forall a. Maybe a
    Nothing
          nwcond :: TileKind -> Bool
    nwcond = Bool -> Bool
    not (Bool -> Bool) -> (TileKind -> Bool) -> TileKind -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Feature -> TileKind -> Bool
    Tile.kindHasFeature Feature
    TK.Walkable
      areAllWalkable <- Maybe (ContentId TileKind) -> Bool
    forall a. Maybe a -> Bool
    isNothing (Maybe (ContentId TileKind) -> Bool)
    -> StateT SMGen Identity (Maybe (ContentId TileKind))
    -> StateT SMGen Identity Bool
    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
    cdefTile TileKind -> Bool
    nwcond
      convertTileMaps cops areAllWalkable pickDefTile mpickPassable darea dmap

    anchorDown :: Y
    anchorDown :: Int
    anchorDown = Int
    5  -- not 4, asymmetric vs up, for staircase variety;
                    -- symmetry kept for @cfenceApart@ caves, to save real estate

    -- Create a level from a cave.
    buildLevel :: COps -> ServerOptions
               -> LevelId -> ContentId CaveKind -> CaveKind -> Int -> Int
               -> Dice.AbsDepth -> [(Point, Text)]
               -> Rnd (Level, [(Point, Text)])
    buildLevel :: COps
    -> ServerOptions
    -> LevelId
    -> ContentId CaveKind
    -> CaveKind
    -> Int
    -> Int
    -> AbsDepth
    -> [(Point, Text)]
    -> Rnd (Level, [(Point, Text)])
    buildLevel cops :: COps
    cops@COps{ContentData PlaceKind
    coplace :: ContentData PlaceKind
    coplace :: COps -> ContentData PlaceKind
    coplace, corule :: COps -> RuleContent
    corule=RuleContent{Int
    [Char]
    [Text]
    (Text, Config)
    Version
    ItemSymbolsUsedInEngine
    rWidthMax :: RuleContent -> Int
    rHeightMax :: RuleContent -> Int
    rtitle :: [Char]
    rWidthMax :: Int
    rHeightMax :: Int
    rexeVersion :: Version
    rcfgUIName :: [Char]
    rcfgUIDefault :: (Text, Config)
    rwriteSaveClips :: Int
    rleadLevelClips :: Int
    rscoresFileName :: [Char]
    rnearby :: Int
    rstairWordCarried :: [Text]
    ritemSymbols :: ItemSymbolsUsedInEngine
    ritemSymbols :: RuleContent -> ItemSymbolsUsedInEngine
    rstairWordCarried :: RuleContent -> [Text]
    rnearby :: RuleContent -> Int
    rscoresFileName :: RuleContent -> [Char]
    rleadLevelClips :: RuleContent -> Int
    rwriteSaveClips :: RuleContent -> Int
    rcfgUIDefault :: RuleContent -> (Text, Config)
    rcfgUIName :: RuleContent -> [Char]
    rexeVersion :: RuleContent -> Version
    rtitle :: RuleContent -> [Char]
    ..}} ServerOptions
    serverOptions
               LevelId
    lid ContentId CaveKind
    dkind CaveKind
    kc Int
    doubleDownStairs Int
    singleDownStairs
               AbsDepth
    totalDepth [(Point, Text)]
    stairsFromUp = do
      let d :: Int
    d = if CaveKind -> Bool
    cfenceApart CaveKind
    kc then Int
    1 else Int
    0
          -- Simple rule for now: level @lid@ has depth (difficulty) @abs lid@.
          ldepth :: AbsDepth
    ldepth = Int -> AbsDepth
    Dice.AbsDepth (Int -> AbsDepth) -> Int -> AbsDepth
    forall a b. (a -> b) -> a -> b
    $ Int -> Int
    forall a. Num a => a -> a
    abs (Int -> Int) -> Int -> Int
    forall a b. (a -> b) -> a -> b
    $ LevelId -> Int
    forall a. Enum a => a -> Int
    fromEnum LevelId
    lid
          darea :: Area
    darea =
            let ([Int]
    lxPrev, [Int]
    lyPrev) = [(Int, Int)] -> ([Int], [Int])
    forall a b. [(a, b)] -> ([a], [b])
    unzip ([(Int, Int)] -> ([Int], [Int])) -> [(Int, Int)] -> ([Int], [Int])
    forall a b. (a -> b) -> a -> b
    $ ((Point, Text) -> (Int, Int)) -> [(Point, Text)] -> [(Int, Int)]
    forall a b. (a -> b) -> [a] -> [b]
    map ((Point -> Int
    px (Point -> Int) -> (Point -> Int) -> Point -> (Int, Int)
    forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
    forall (a :: * -> * -> *) b c c'.
    Arrow a =>
    a b c -> a b c' -> a b (c, c')
    &&& Point -> Int
    py) (Point -> (Int, Int))
    -> ((Point, Text) -> Point) -> (Point, Text) -> (Int, Int)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Point, Text) -> Point
    forall a b. (a, b) -> a
    fst) [(Point, Text)]
    stairsFromUp
                -- Stairs take some space, hence the additions.
                lxMin :: Int
    lxMin = Int -> Int -> Int
    forall a. Ord a => a -> a -> a
    max Int
    0
                        (Int -> Int) -> Int -> Int
    forall a b. (a -> b) -> a -> b
    $ -Int
    4 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    d Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + [Int] -> Int
    forall a. Ord a => [a] -> a
    forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
    minimum (Int
    rWidthMax Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1 Int -> [Int] -> [Int]
    forall a. a -> [a] -> [a]
    : [Int]
    lxPrev)
                lxMax :: Int
    lxMax = Int -> Int -> Int
    forall a. Ord a => a -> a -> a
    min (Int
    rWidthMax Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1)
                        (Int -> Int) -> Int -> Int
    forall a b. (a -> b) -> a -> b
    $ Int
    4 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    d Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + [Int] -> Int
    forall a. Ord a => [a] -> a
    forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
    maximum (Int
    0 Int -> [Int] -> [Int]
    forall a. a -> [a] -> [a]
    : [Int]
    lxPrev)
                lyMin :: Int
    lyMin = Int -> Int -> Int
    forall a. Ord a => a -> a -> a
    max Int
    0
                        (Int -> Int) -> Int -> Int
    forall a b. (a -> b) -> a -> b
    $ -Int
    3 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    d Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + [Int] -> Int
    forall a. Ord a => [a] -> a
    forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
    minimum (Int
    rHeightMax Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1 Int -> [Int] -> [Int]
    forall a. a -> [a] -> [a]
    : [Int]
    lyPrev)
                lyMax :: Int
    lyMax = Int -> Int -> Int
    forall a. Ord a => a -> a -> a
    min (Int
    rHeightMax Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1)
                        (Int -> Int) -> Int -> Int
    forall a b. (a -> b) -> a -> b
    $ Int
    3 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    d Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + [Int] -> Int
    forall a. Ord a => [a] -> a
    forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
    maximum (Int
    0 Int -> [Int] -> [Int]
    forall a. a -> [a] -> [a]
    : [Int]
    lyPrev)
                -- Pick minimal cave size that fits all previous stairs.
                xspan :: Int
    xspan = Int -> Int -> Int
    forall a. Ord a => a -> a -> a
    max (Int
    lxMax Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    lxMin Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1) (Int -> Int) -> Int -> Int
    forall a b. (a -> b) -> a -> b
    $ CaveKind -> Int
    cXminSize CaveKind
    kc
                yspan :: Int
    yspan = Int -> Int -> Int
    forall a. Ord a => a -> a -> a
    max (Int
    lyMax Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    lyMin Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1) (Int -> Int) -> Int -> Int
    forall a b. (a -> b) -> a -> b
    $ CaveKind -> Int
    cYminSize CaveKind
    kc
                x0 :: Int
    x0 = Int -> Int -> Int
    forall a. Ord a => a -> a -> a
    min Int
    lxMin (Int
    rWidthMax Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    xspan)
                y0 :: Int
    y0 = Int -> Int -> Int
    forall a. Ord a => a -> a -> a
    min Int
    lyMin (Int
    rHeightMax Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    yspan)
            in Area -> Maybe Area -> Area
    forall a. a -> Maybe a -> a
    fromMaybe ([Char] -> Area
    forall a. HasCallStack => [Char] -> a
    error ([Char] -> Area) -> [Char] -> Area
    forall a b. (a -> b) -> a -> b
    $ [Char]
    "" [Char] -> CaveKind -> [Char]
    forall v. Show v => [Char] -> v -> [Char]
    `showFailure` CaveKind
    kc)
               (Maybe Area -> Area) -> Maybe Area -> Area
    forall a b. (a -> b) -> a -> b
    $ (Int, Int, Int, Int) -> Maybe Area
    toArea (Int
    x0, Int
    y0, Int
    x0 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    xspan Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1, Int
    y0 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    yspan Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1)
          ([(Point, Text)]
    lstairsDouble, [(Point, Text)]
    lstairsSingleUp) = Int -> [(Point, Text)] -> ([(Point, Text)], [(Point, Text)])
    forall a. Int -> [a] -> ([a], [a])
    splitAt Int
    doubleDownStairs [(Point, Text)]
    stairsFromUp
          pstairsSingleUp :: [Point]
    pstairsSingleUp = ((Point, Text) -> Point) -> [(Point, Text)] -> [Point]
    forall a b. (a -> b) -> [a] -> [b]
    map (Point, Text) -> Point
    forall a b. (a, b) -> a
    fst [(Point, Text)]
    lstairsSingleUp
          pstairsDouble :: [Point]
    pstairsDouble = ((Point, Text) -> Point) -> [(Point, Text)] -> [Point]
    forall a b. (a -> b) -> [a] -> [b]
    map (Point, Text) -> Point
    forall a b. (a, b) -> a
    fst [(Point, Text)]
    lstairsDouble
          pallUpStairs :: [Point]
    pallUpStairs = [Point]
    pstairsDouble [Point] -> [Point] -> [Point]
    forall a. [a] -> [a] -> [a]
    ++ [Point]
    pstairsSingleUp
          boot :: [Point]
    boot = let (Int
    x0, Int
    y0, Int
    x1, Int
    y1) = Area -> (Int, Int, Int, Int)
    fromArea Area
    darea
                 in [Either Point Point] -> [Point]
    forall a b. [Either a b] -> [b]
    rights ([Either Point Point] -> [Point])
    -> [Either Point Point] -> [Point]
    forall a b. (a -> b) -> a -> b
    $ (Point -> Either Point Point) -> [Point] -> [Either Point Point]
    forall a b. (a -> b) -> [a] -> [b]
    map (Int -> [Point] -> Point -> Either Point Point
    snapToStairList Int
    0 [Point]
    pallUpStairs)
                                 [ Int -> Int -> Point
    Point (Int
    x0 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    4 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    d) (Int
    y0 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    3 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    d)
                                 , Int -> Int -> Point
    Point (Int
    x1 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    4 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    d) (Int
    y1 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    anchorDown Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1) ]
      fixedEscape <- case CaveKind -> Freqs PlaceKind
    cescapeFreq CaveKind
    kc of
        [] -> [(Point, Freqs PlaceKind)]
    -> StateT SMGen Identity [(Point, Freqs PlaceKind)]
    forall a. a -> StateT SMGen Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
        Freqs PlaceKind
    escapeFreq -> do
          -- Escapes don't extend to other levels, so corners not harmful
          -- (actually neither are the other restrictions inherited from stairs
          -- placement, but we respect them to keep a uniform visual layout).
          -- Allowing corners and generating before stars, because they are more
          -- important that stairs (except the first stairs, but they are guaranteed
          -- unless the level has no incoming stairs, but if so, plenty of space).
          mepos <- Text
    -> Bool
    -> ServerOptions
    -> LevelId
    -> CaveKind
    -> Area
    -> [Point]
    -> [Point]
    -> Rnd (Maybe Point)
    placeDownStairs Text
    "escape" Bool
    True ServerOptions
    serverOptions LevelId
    lid
                                   CaveKind
    kc Area
    darea [Point]
    pallUpStairs [Point]
    boot
          case mepos of
            Just Point
    epos -> [(Point, Freqs PlaceKind)]
    -> StateT SMGen Identity [(Point, Freqs PlaceKind)]
    forall a. a -> StateT SMGen Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [(Point
    epos, Freqs PlaceKind
    escapeFreq)]
            Maybe Point
    Nothing -> [(Point, Freqs PlaceKind)]
    -> StateT SMGen Identity [(Point, Freqs PlaceKind)]
    forall a. a -> StateT SMGen Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []  -- with some luck, there is an escape elsewhere
      let pescape = ((Point, Freqs PlaceKind) -> Point)
    -> [(Point, Freqs PlaceKind)] -> [Point]
    forall a b. (a -> b) -> [a] -> [b]
    map (Point, Freqs PlaceKind) -> Point
    forall a b. (a, b) -> a
    fst [(Point, Freqs PlaceKind)]
    fixedEscape
          pallUpAndEscape = [Point]
    pescape [Point] -> [Point] -> [Point]
    forall a. [a] -> [a] -> [a]
    ++ [Point]
    pallUpStairs
          addSingleDown :: [Point] -> Int -> Rnd [Point]
          addSingleDown [Point]
    acc Int
    0 = [Point] -> Rnd [Point]
    forall a. a -> StateT SMGen Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [Point]
    acc
          addSingleDown [Point]
    acc Int
    k = do
            mpos <- Text
    -> Bool
    -> ServerOptions
    -> LevelId
    -> CaveKind
    -> Area
    -> [Point]
    -> [Point]
    -> Rnd (Maybe Point)
    placeDownStairs Text
    "stairs" Bool
    False ServerOptions
    serverOptions LevelId
    lid
                                    CaveKind
    kc Area
    darea ([Point]
    pallUpAndEscape [Point] -> [Point] -> [Point]
    forall a. [a] -> [a] -> [a]
    ++ [Point]
    acc) [Point]
    boot
            case mpos of
              Just Point
    pos -> [Point] -> Int -> Rnd [Point]
    addSingleDown (Point
    pos Point -> [Point] -> [Point]
    forall a. a -> [a] -> [a]
    : [Point]
    acc) (Int
    k Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1)
              Maybe Point
    Nothing -> [Point] -> Rnd [Point]
    forall a. a -> StateT SMGen Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [Point]
    acc  -- calling again won't change anything
      pstairsSingleDown <- addSingleDown [] singleDownStairs
      let freqDouble Text
    carried =
            ((GroupName PlaceKind, Int) -> Bool)
    -> Freqs PlaceKind -> Freqs PlaceKind
    forall a. (a -> Bool) -> [a] -> [a]
    filter (\(GroupName PlaceKind
    gn, Int
    _) ->
                      Text
    carried Text -> [Text] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` Text -> [Text]
    T.words (GroupName PlaceKind -> Text
    forall c. GroupName c -> Text
    DefsInternal.fromGroupName GroupName PlaceKind
    gn))
            (Freqs PlaceKind -> Freqs PlaceKind)
    -> Freqs PlaceKind -> Freqs PlaceKind
    forall a b. (a -> b) -> a -> b
    $ CaveKind -> Freqs PlaceKind
    cstairFreq CaveKind
    kc Freqs PlaceKind -> Freqs PlaceKind -> Freqs PlaceKind
    forall a. [a] -> [a] -> [a]
    ++ CaveKind -> Freqs PlaceKind
    cstairAllowed CaveKind
    kc
          fixedStairsDouble = ((Point, Text) -> (Point, Freqs PlaceKind))
    -> [(Point, Text)] -> [(Point, Freqs PlaceKind)]
    forall a b. (a -> b) -> [a] -> [b]
    map ((Text -> Freqs PlaceKind)
    -> (Point, Text) -> (Point, Freqs PlaceKind)
    forall b c d. (b -> c) -> (d, b) -> (d, c)
    forall (a :: * -> * -> *) b c d.
    Arrow a =>
    a b c -> a (d, b) (d, c)
    second Text -> Freqs PlaceKind
    freqDouble) [(Point, Text)]
    lstairsDouble
          freqUp Text
    carried = (Text -> Text) -> Freqs PlaceKind -> Freqs PlaceKind
    forall c. (Text -> Text) -> Freqs c -> Freqs c
    renameFreqs (Text -> Text -> Text
    <+> Text
    "up") (Freqs PlaceKind -> Freqs PlaceKind)
    -> Freqs PlaceKind -> Freqs PlaceKind
    forall a b. (a -> b) -> a -> b
    $ Text -> Freqs PlaceKind
    freqDouble Text
    carried
          fixedStairsUp = ((Point, Text) -> (Point, Freqs PlaceKind))
    -> [(Point, Text)] -> [(Point, Freqs PlaceKind)]
    forall a b. (a -> b) -> [a] -> [b]
    map ((Text -> Freqs PlaceKind)
    -> (Point, Text) -> (Point, Freqs PlaceKind)
    forall b c d. (b -> c) -> (d, b) -> (d, c)
    forall (a :: * -> * -> *) b c d.
    Arrow a =>
    a b c -> a (d, b) (d, c)
    second Text -> Freqs PlaceKind
    freqUp) [(Point, Text)]
    lstairsSingleUp
          freqDown = (Text -> Text) -> Freqs PlaceKind -> Freqs PlaceKind
    forall c. (Text -> Text) -> Freqs c -> Freqs c
    renameFreqs (Text -> Text -> Text
    <+> Text
    "down") (Freqs PlaceKind -> Freqs PlaceKind)
    -> Freqs PlaceKind -> Freqs PlaceKind
    forall a b. (a -> b) -> a -> b
    $ CaveKind -> Freqs PlaceKind
    cstairFreq CaveKind
    kc
          fixedStairsDown = (Point -> (Point, Freqs PlaceKind))
    -> [Point] -> [(Point, Freqs PlaceKind)]
    forall a b. (a -> b) -> [a] -> [b]
    map (, Freqs PlaceKind
    freqDown) [Point]
    pstairsSingleDown
          pallExits = [Point]
    pallUpAndEscape [Point] -> [Point] -> [Point]
    forall a. [a] -> [a] -> [a]
    ++ [Point]
    pstairsSingleDown
          fixedCenters = [(Point, Freqs PlaceKind)] -> EnumMap Point (Freqs PlaceKind)
    forall k a. Enum k => [(k, a)] -> EnumMap k a
    EM.fromList ([(Point, Freqs PlaceKind)] -> EnumMap Point (Freqs PlaceKind))
    -> [(Point, Freqs PlaceKind)] -> EnumMap Point (Freqs PlaceKind)
    forall a b. (a -> b) -> a -> b
    $
            [(Point, Freqs PlaceKind)]
    fixedEscape [(Point, Freqs PlaceKind)]
    -> [(Point, Freqs PlaceKind)] -> [(Point, Freqs PlaceKind)]
    forall a. [a] -> [a] -> [a]
    ++ [(Point, Freqs PlaceKind)]
    fixedStairsDouble [(Point, Freqs PlaceKind)]
    -> [(Point, Freqs PlaceKind)] -> [(Point, Freqs PlaceKind)]
    forall a. [a] -> [a] -> [a]
    ++ [(Point, Freqs PlaceKind)]
    fixedStairsUp [(Point, Freqs PlaceKind)]
    -> [(Point, Freqs PlaceKind)] -> [(Point, Freqs PlaceKind)]
    forall a. [a] -> [a] -> [a]
    ++ [(Point, Freqs PlaceKind)]
    fixedStairsDown
      -- Avoid completely uniform levels (e.g., uniformly merged places).
      bootExtra <- if EM.null fixedCenters then do
                     mpointExtra <-
                       placeDownStairs "extra boot" False serverOptions lid
                                       kc darea pallExits boot
                     -- With sane content, @Nothing@ should never appear.
                     return $! maybeToList mpointExtra
                   else return []
      let posUp Point{Int
    px :: Point -> Int
    py :: Point -> Int
    px :: Int
    py :: Int
    ..} = Int -> Int -> Point
    Point (Int
    px Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1) Int
    py
          posDn Point{Int
    px :: Point -> Int
    py :: Point -> Int
    px :: Int
    py :: Int
    ..} = Int -> Int -> Point
    Point (Int
    px Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1) Int
    py
          -- This and other places ensure there is always a continuous
          -- staircase from bottom to top. This makes moving between empty
          -- level much less boring. For new levels, it may be blocked by enemies
          -- or not offer enough cover, so other staircases may be preferable.
          lstair = ( (Point -> Point) -> [Point] -> [Point]
    forall a b. (a -> b) -> [a] -> [b]
    map Point -> Point
    posUp ([Point] -> [Point]) -> [Point] -> [Point]
    forall a b. (a -> b) -> a -> b
    $ [Point]
    pstairsDouble [Point] -> [Point] -> [Point]
    forall a. [a] -> [a] -> [a]
    ++ [Point]
    pstairsSingleUp
                   , (Point -> Point) -> [Point] -> [Point]
    forall a b. (a -> b) -> [a] -> [b]
    map Point -> Point
    posDn ([Point] -> [Point]) -> [Point] -> [Point]
    forall a b. (a -> b) -> a -> b
    $ [Point]
    pstairsDouble [Point] -> [Point] -> [Point]
    forall a. [a] -> [a] -> [a]
    ++ [Point]
    pstairsSingleDown )
      cellSize <- castDiceXY ldepth totalDepth $ ccellSize kc
      let subArea = Area -> Maybe Area -> Area
    forall a. a -> Maybe a -> a
    fromMaybe ([Char] -> Area
    forall a. HasCallStack => [Char] -> a
    error ([Char] -> Area) -> [Char] -> Area
    forall a b. (a -> b) -> a -> b
    $ [Char]
    "" [Char] -> CaveKind -> [Char]
    forall v. Show v => [Char] -> v -> [Char]
    `showFailure` CaveKind
    kc) (Maybe Area -> Area) -> Maybe Area -> Area
    forall a b. (a -> b) -> a -> b
    $ Area -> Maybe Area
    shrink Area
    darea
          area = if CaveKind -> Bool
    cfenceApart CaveKind
    kc then Area
    subArea else Area
    darea
          (lgr, gs) = grid fixedCenters (boot ++ bootExtra) area cellSize
      dsecret <- randomWord32
      cave <- buildCave cops ldepth totalDepth darea dsecret dkind lgr gs bootExtra
      cmap <- buildTileMap cops cave
      -- The bang is needed to prevent caves memory drag until levels used.
      let !lvl = COps
    -> Cave
    -> AbsDepth
    -> TileMap
    -> ([Point], [Point])
    -> [Point]
    -> Level
    levelFromCave COps
    cops Cave
    cave AbsDepth
    ldepth TileMap
    cmap ([Point], [Point])
    lstair [Point]
    pescape
          stairCarried Point
    p0 =
            let Place{ContentId PlaceKind
    qkind :: ContentId PlaceKind
    qkind :: Place -> ContentId PlaceKind
    qkind} = Cave -> EnumMap Point Place
    dstairs Cave
    cave EnumMap Point Place -> Point -> Place
    forall k a. Enum k => EnumMap k a -> k -> a
    EM.! Point
    p0
                freq :: [([Text], Int)]
    freq = ((GroupName PlaceKind, Int) -> ([Text], Int))
    -> Freqs PlaceKind -> [([Text], Int)]
    forall a b. (a -> b) -> [a] -> [b]
    map ((GroupName PlaceKind -> [Text])
    -> (GroupName PlaceKind, Int) -> ([Text], Int)
    forall b c d. (b -> c) -> (b, d) -> (c, d)
    forall (a :: * -> * -> *) b c d.
    Arrow a =>
    a b c -> a (b, d) (c, d)
    first ((GroupName PlaceKind -> [Text])
     -> (GroupName PlaceKind, Int) -> ([Text], Int))
    -> (GroupName PlaceKind -> [Text])
    -> (GroupName PlaceKind, Int)
    -> ([Text], Int)
    forall a b. (a -> b) -> a -> b
    $ Text -> [Text]
    T.words (Text -> [Text])
    -> (GroupName PlaceKind -> Text) -> GroupName PlaceKind -> [Text]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . GroupName PlaceKind -> Text
    forall a. Show a => a -> Text
    tshow)
                           (PlaceKind -> Freqs PlaceKind
    PK.pfreq (PlaceKind -> Freqs PlaceKind) -> PlaceKind -> Freqs PlaceKind
    forall a b. (a -> b) -> a -> b
    $ ContentData PlaceKind -> ContentId PlaceKind -> PlaceKind
    forall a. ContentData a -> ContentId a -> a
    okind ContentData PlaceKind
    coplace ContentId PlaceKind
    qkind)
                carriedAll :: [Text]
    carriedAll = (Text -> Bool) -> [Text] -> [Text]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (\Text
    t -> (([Text], Int) -> Bool) -> [([Text], Int)] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (\([Text]
    ws, Int
    _) -> Text
    t Text -> [Text] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [Text]
    ws) [([Text], Int)]
    freq)
                                    [Text]
    rstairWordCarried
            in case [Text]
    carriedAll of
              [Text
    t] -> (Point
    p0, Text
    t)
              [Text]
    _ -> [Char] -> (Point, Text)
    forall a. HasCallStack => [Char] -> a
    error ([Char] -> (Point, Text)) -> [Char] -> (Point, Text)
    forall a b. (a -> b) -> a -> b
    $ [Char]
    "wrong carried stair word"
                           [Char] -> ([([Text], Int)], [Text], CaveKind) -> [Char]
    forall v. Show v => [Char] -> v -> [Char]
    `showFailure` ([([Text], Int)]
    freq, [Text]
    carriedAll, CaveKind
    kc)
      return (lvl, lstairsDouble ++ map stairCarried pstairsSingleDown)

    snapToStairList :: Int -> [Point] -> Point -> Either Point Point
    snapToStairList :: Int -> [Point] -> Point -> Either Point Point
    snapToStairList Int
    _ [] Point
    p = Point -> Either Point Point
    forall a b. b -> Either a b
    Right Point
    p
    snapToStairList Int
    a (Point
    pos : [Point]
    rest) Point
    p =
      let nx :: Int
    nx = if Point -> Int
    px Point
    pos Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Point -> Int
    px Point
    p Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    5 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    a Bool -> Bool -> Bool
    || Point -> Int
    px Point
    pos Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < Point -> Int
    px Point
    p Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    5 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    a
               then Point -> Int
    px Point
    p
               else Point -> Int
    px Point
    pos
          ny :: Int
    ny = if Point -> Int
    py Point
    pos Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Point -> Int
    py Point
    p Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    3 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    a Bool -> Bool -> Bool
    || Point -> Int
    py Point
    pos Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < Point -> Int
    py Point
    p Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    3 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    a
               then Point -> Int
    py Point
    p
               else Point -> Int
    py Point
    pos
          np :: Point
    np = Int -> Int -> Point
    Point Int
    nx Int
    ny
      in if Point
    np Point -> Point -> Bool
    forall a. Eq a => a -> a -> Bool
    == Point
    pos then Point -> Either Point Point
    forall a b. a -> Either a b
    Left Point
    np else Int -> [Point] -> Point -> Either Point Point
    snapToStairList Int
    a [Point]
    rest Point
    np

    -- Places yet another staircase (or escape), taking into account only
    -- the already existing stairs.
    placeDownStairs :: Text -> Bool -> ServerOptions -> LevelId
                    -> CaveKind -> Area -> [Point] -> [Point]
                    -> Rnd (Maybe Point)
    placeDownStairs :: Text
    -> Bool
    -> ServerOptions
    -> LevelId
    -> CaveKind
    -> Area
    -> [Point]
    -> [Point]
    -> Rnd (Maybe Point)
    placeDownStairs Text
    object Bool
    cornerPermitted ServerOptions
    serverOptions LevelId
    lid
                    CaveKind{Int
    cminStairDist :: Int
    cminStairDist :: CaveKind -> Int
    cminStairDist, Bool
    cfenceApart :: CaveKind -> Bool
    cfenceApart :: Bool
    cfenceApart} Area
    darea [Point]
    ps [Point]
    boot = do
      let dist :: Int -> Point -> Bool
    dist Int
    cmin Point
    p = (Point -> Bool) -> [Point] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all (\Point
    pos -> Point -> Point -> Int
    chessDist Point
    p Point
    pos Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    cmin) [Point]
    ps
          (Int
    x0, Int
    y0, Int
    x1, Int
    y1) = Area -> (Int, Int, Int, Int)
    fromArea Area
    darea
          -- Stairs in corners often enlarge next caves, so refrain from
          -- generating stairs, if only corner available (escapes special-cased).
          -- The bottom-right corner is exempt, becuase far from messages
          -- Also, avoid generating stairs at all on upper and left margins
          -- to keep subsequent small levels away from messages on top-right.
          rx :: Int
    rx = Int
    9  -- enough to fit smallest stairs
          ry :: Int
    ry = Int
    6  -- enough to fit smallest stairs
          wx :: Int
    wx = Int
    x1 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    x0 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1
          wy :: Int
    wy = Int
    y1 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    y0 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1
          notInCornerEtc :: Point -> Bool
    notInCornerEtc Point{Int
    px :: Point -> Int
    py :: Point -> Int
    px :: Int
    py :: Int
    ..} =
            Bool
    cornerPermitted
            Bool -> Bool -> Bool
    || Int
    wx Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < Int
    3 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    rx Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    3 Bool -> Bool -> Bool
    || Int
    wy Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < Int
    3 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    ry Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    3  -- everything is a corner
            Bool -> Bool -> Bool
    || Int
    px Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    x0 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + (Int
    wx Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    3) Int -> Int -> Int
    forall a. Integral a => a -> a -> a
    `div` Int
    3
               Bool -> Bool -> Bool
    && Int
    py Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    y0 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + (Int
    wy Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    3) Int -> Int -> Int
    forall a. Integral a => a -> a -> a
    `div` Int
    3
          inCorner :: Point -> Bool
    inCorner Point{Int
    px :: Point -> Int
    py :: Point -> Int
    px :: Int
    py :: Int
    ..} = (Int
    px Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Int
    x0 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    rx Bool -> Bool -> Bool
    || Int
    px Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Int
    x1 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    rx)
                               Bool -> Bool -> Bool
    && (Int
    py Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Int
    y0 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    ry Bool -> Bool -> Bool
    || Int
    py Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Int
    y1 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    ry)
          gpreference :: Point -> Bool
    gpreference = if Bool
    cornerPermitted then Point -> Bool
    inCorner else Point -> Bool
    notInCornerEtc
          f :: Point -> Maybe Point
    f Point
    p = case Int -> [Point] -> Point -> Either Point Point
    snapToStairList Int
    0 [Point]
    ps Point
    p of
            Left{} -> Maybe Point
    forall a. Maybe a
    Nothing
            Right Point
    np -> let nnp :: Point
    nnp = (Point -> Point) -> (Point -> Point) -> Either Point Point -> Point
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
    either Point -> Point
    forall a. a -> a
    id Point -> Point
    forall a. a -> a
    id (Either Point Point -> Point) -> Either Point Point -> Point
    forall a b. (a -> b) -> a -> b
    $ Int -> [Point] -> Point -> Either Point Point
    snapToStairList Int
    0 [Point]
    boot Point
    np
                        in if Point -> Bool
    notInCornerEtc Point
    nnp then Point -> Maybe Point
    forall a. a -> Maybe a
    Just Point
    nnp else Maybe Point
    forall a. Maybe a
    Nothing
          g :: Point -> Maybe Point
    g Point
    p = case Int -> [Point] -> Point -> Either Point Point
    snapToStairList Int
    2 [Point]
    ps Point
    p of
            Left{} -> Maybe Point
    forall a. Maybe a
    Nothing
            Right Point
    np -> let nnp :: Point
    nnp = (Point -> Point) -> (Point -> Point) -> Either Point Point -> Point
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
    either Point -> Point
    forall a. a -> a
    id Point -> Point
    forall a. a -> a
    id (Either Point Point -> Point) -> Either Point Point -> Point
    forall a b. (a -> b) -> a -> b
    $ Int -> [Point] -> Point -> Either Point Point
    snapToStairList Int
    2 [Point]
    boot Point
    np
                        in if Point -> Bool
    gpreference Point
    nnp Bool -> Bool -> Bool
    && Int -> Point -> Bool
    dist Int
    cminStairDist Point
    nnp
                           then Point -> Maybe Point
    forall a. a -> Maybe a
    Just Point
    nnp
                           else Maybe Point
    forall a. Maybe a
    Nothing
          focusArea :: Area
    focusArea = let d :: Int
    d = if Bool
    cfenceApart then Int
    1 else Int
    0
                      in Area -> Maybe Area -> Area
    forall a. a -> Maybe a -> a
    fromMaybe ([Char] -> Area
    forall a. HasCallStack => [Char] -> a
    error ([Char] -> Area) -> [Char] -> Area
    forall a b. (a -> b) -> a -> b
    $ [Char]
    "" [Char] -> Area -> [Char]
    forall v. Show v => [Char] -> v -> [Char]
    `showFailure` Area
    darea)
                         (Maybe Area -> Area) -> Maybe Area -> Area
    forall a b. (a -> b) -> a -> b
    $ (Int, Int, Int, Int) -> Maybe Area
    toArea ( Int
    x0 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    4 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    d, Int
    y0 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    3 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    d
                                  , Int
    x1 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    4 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    d, Int
    y1 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    anchorDown Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1 )
      mpos <- Area
    -> (Point -> Maybe Point)
    -> Int
    -> (Point -> Maybe Point)
    -> Rnd (Maybe Point)
    findPointInArea Area
    focusArea Point -> Maybe Point
    g Int
    500 Point -> Maybe Point
    f
      -- The message fits this debugging level:
      let !_ = if isNothing mpos && sdumpInitRngs serverOptions
               then unsafePerformIO $ do
                 T.hPutStrLn stdout $
                    "Failed to place" <+> object <+> "on level"
                    <+> tshow lid <> ", in" <+> tshow darea
                 hFlush stdout
    -- Not really expensive, but shouldn't disrupt normal testing nor play.
    #ifdef WITH_EXPENSIVE_ASSERTIONS
                 error "possible, but unexpected; alarm!"
    #endif
               else ()
      return mpos

    -- Build rudimentary level from a cave kind.
    levelFromCave :: COps -> Cave -> Dice.AbsDepth
                  -> TileMap -> ([Point], [Point]) -> [Point]
                  -> Level
    levelFromCave :: COps
    -> Cave
    -> AbsDepth
    -> TileMap
    -> ([Point], [Point])
    -> [Point]
    -> Level
    levelFromCave COps{TileSpeedup
    coTileSpeedup :: COps -> TileSpeedup
    coTileSpeedup :: TileSpeedup
    coTileSpeedup} Cave{Bool
    TileMapEM
    EnumMap Point PlaceEntry
    EnumMap Point Place
    ContentId CaveKind
    Area
    dkind :: Cave -> ContentId CaveKind
    darea :: Cave -> Area
    dmap :: Cave -> TileMapEM
    dstairs :: Cave -> EnumMap Point Place
    dkind :: ContentId CaveKind
    darea :: Area
    dmap :: TileMapEM
    dstairs :: EnumMap Point Place
    dentry :: EnumMap Point PlaceEntry
    dnight :: Bool
    dnight :: Cave -> Bool
    dentry :: Cave -> EnumMap Point PlaceEntry
    ..} AbsDepth
    ldepth TileMap
    ltile ([Point], [Point])
    lstair [Point]
    lescape =
      let f :: Int -> ContentId TileKind -> Int
    f Int
    n ContentId TileKind
    t | TileSpeedup -> ContentId TileKind -> Bool
    Tile.isExplorable TileSpeedup
    coTileSpeedup ContentId TileKind
    t = Int
    n Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1
                | Bool
    otherwise = Int
    n
          lexpl :: Int
    lexpl = (Int -> ContentId TileKind -> Int) -> Int -> TileMap -> Int
    forall c a. UnboxRepClass c => (a -> c -> a) -> a -> Array c -> a
    PointArray.foldlA' Int -> ContentId TileKind -> Int
    f Int
    0 TileMap
    ltile
      in Level
           { lkind :: ContentId CaveKind
    lkind = ContentId CaveKind
    dkind
           , AbsDepth
    ldepth :: AbsDepth
    ldepth :: AbsDepth
    ldepth
           , lfloor :: ItemFloor
    lfloor = ItemFloor
    forall k a. EnumMap k a
    EM.empty
           , lembed :: ItemFloor
    lembed = ItemFloor
    forall k a. EnumMap k a
    EM.empty
           , lbig :: BigActorMap
    lbig = BigActorMap
    forall k a. EnumMap k a
    EM.empty
           , lproj :: ProjectileMap
    lproj = ProjectileMap
    forall k a. EnumMap k a
    EM.empty
           , TileMap
    ltile :: TileMap
    ltile :: TileMap
    ltile
           , lentry :: EnumMap Point PlaceEntry
    lentry = EnumMap Point PlaceEntry
    dentry
           , larea :: Area
    larea = Area
    darea
           , lsmell :: SmellMap
    lsmell = SmellMap
    forall k a. EnumMap k a
    EM.empty
           , ([Point], [Point])
    lstair :: ([Point], [Point])
    lstair :: ([Point], [Point])
    lstair
           , [Point]
    lescape :: [Point]
    lescape :: [Point]
    lescape
           , lseen :: Int
    lseen = Int
    0
           , Int
    lexpl :: Int
    lexpl :: Int
    lexpl
           , ltime :: Time
    ltime = Time
    timeZero
           , lnight :: Bool
    lnight = Bool
    dnight
           }

    -- | Freshly generated and not yet populated dungeon.
    data FreshDungeon = FreshDungeon
      { FreshDungeon -> Dungeon
    freshDungeon    :: Dungeon        -- ^ maps for all levels
      , FreshDungeon -> AbsDepth
    freshTotalDepth :: Dice.AbsDepth  -- ^ absolute dungeon depth
      }

    -- | Generate the dungeon for a new game.
    dungeonGen :: COps -> ServerOptions -> Caves -> Rnd FreshDungeon
    dungeonGen :: COps -> ServerOptions -> Caves -> Rnd FreshDungeon
    dungeonGen cops :: COps
    cops@COps{ContentData CaveKind
    cocave :: COps -> ContentData CaveKind
    cocave :: ContentData CaveKind
    cocave} ServerOptions
    serverOptions Caves
    caves = do
      let shuffleSegment :: ([Int], [GroupName CaveKind])
                         -> Rnd [(Int, GroupName CaveKind)]
          shuffleSegment :: ([Int], [GroupName CaveKind]) -> Rnd [(Int, GroupName CaveKind)]
    shuffleSegment ([Int]
    ns, [GroupName CaveKind]
    l) = Bool
    -> Rnd [(Int, GroupName CaveKind)]
    -> Rnd [(Int, GroupName CaveKind)]
    forall a. HasCallStack => Bool -> a -> a
    assert ([Int] -> Int
    forall a. [a] -> Int
    length [Int]
    ns Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == [GroupName CaveKind] -> Int
    forall a. [a] -> Int
    length [GroupName CaveKind]
    l) (Rnd [(Int, GroupName CaveKind)]
     -> Rnd [(Int, GroupName CaveKind)])
    -> Rnd [(Int, GroupName CaveKind)]
    -> Rnd [(Int, GroupName CaveKind)]
    forall a b. (a -> b) -> a -> b
    $ do
            lShuffled <- [GroupName CaveKind] -> Rnd [GroupName CaveKind]
    forall a. Eq a => [a] -> Rnd [a]
    shuffle [GroupName CaveKind]
    l
            return $! zip ns lShuffled
      cavesShuffled <- (([Int], [GroupName CaveKind]) -> Rnd [(Int, GroupName CaveKind)])
    -> Caves -> StateT SMGen Identity [[(Int, GroupName CaveKind)]]
    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 ([Int], [GroupName CaveKind]) -> Rnd [(Int, GroupName CaveKind)]
    shuffleSegment Caves
    caves
      let cavesFlat = [[(Int, GroupName CaveKind)]] -> [(Int, GroupName CaveKind)]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat [[(Int, GroupName CaveKind)]]
    cavesShuffled
          absKeys = ((Int, GroupName CaveKind) -> Int)
    -> [(Int, GroupName CaveKind)] -> [Int]
    forall a b. (a -> b) -> [a] -> [b]
    map (Int -> Int
    forall a. Num a => a -> a
    abs (Int -> Int)
    -> ((Int, GroupName CaveKind) -> Int)
    -> (Int, GroupName CaveKind)
    -> Int
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Int, GroupName CaveKind) -> Int
    forall a b. (a, b) -> a
    fst) [(Int, GroupName CaveKind)]
    cavesFlat
          freshTotalDepth = Int -> AbsDepth
    Dice.AbsDepth (Int -> AbsDepth) -> Int -> AbsDepth
    forall a b. (a -> b) -> a -> b
    $ [Int] -> Int
    forall a. Ord a => [a] -> a
    forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
    maximum ([Int] -> Int) -> [Int] -> Int
    forall a b. (a -> b) -> a -> b
    $ Int
    10 Int -> [Int] -> [Int]
    forall a. a -> [a] -> [a]
    : [Int]
    absKeys
          getCaveKindNum :: (Int, GroupName CaveKind)
                         -> Rnd ((LevelId, ContentId CaveKind, CaveKind), Int)
          getCaveKindNum (Int
    ln, GroupName CaveKind
    genName) = do
            dkind <- ContentId CaveKind
    -> Maybe (ContentId CaveKind) -> ContentId CaveKind
    forall a. a -> Maybe a -> a
    fromMaybe ([Char] -> ContentId CaveKind
    forall a. HasCallStack => [Char] -> a
    error ([Char] -> ContentId CaveKind) -> [Char] -> ContentId CaveKind
    forall a b. (a -> b) -> a -> b
    $ [Char]
    "" [Char] -> GroupName CaveKind -> [Char]
    forall v. Show v => [Char] -> v -> [Char]
    `showFailure` GroupName CaveKind
    genName)
                     (Maybe (ContentId CaveKind) -> ContentId CaveKind)
    -> StateT SMGen Identity (Maybe (ContentId CaveKind))
    -> StateT SMGen Identity (ContentId CaveKind)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> ContentData CaveKind
    -> GroupName CaveKind
    -> (CaveKind -> Bool)
    -> StateT SMGen Identity (Maybe (ContentId CaveKind))
    forall a.
    Show a =>
    ContentData a
    -> GroupName a -> (a -> Bool) -> Rnd (Maybe (ContentId a))
    opick ContentData CaveKind
    cocave GroupName CaveKind
    genName (Bool -> CaveKind -> Bool
    forall a b. a -> b -> a
    const Bool
    True)
            let kc = ContentData CaveKind -> ContentId CaveKind -> CaveKind
    forall a. ContentData a -> ContentId a -> a
    okind ContentData CaveKind
    cocave ContentId CaveKind
    dkind
                ldepth = Int -> AbsDepth
    Dice.AbsDepth (Int -> AbsDepth) -> Int -> AbsDepth
    forall a b. (a -> b) -> a -> b
    $ Int -> Int
    forall a. Num a => a -> a
    abs Int
    ln
            maxStairsNum <- castDice ldepth freshTotalDepth $ cmaxStairsNum kc
            return ((toEnum ln, dkind, kc), maxStairsNum)
      caveKindNums <- mapM getCaveKindNum cavesFlat
      let (caveKinds, caveNums) = unzip caveKindNums
          caveNumNexts = [Int] -> [Int] -> [(Int, Int)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Int]
    caveNums ([Int] -> [(Int, Int)]) -> [Int] -> [(Int, Int)]
    forall a b. (a -> b) -> a -> b
    $ Int -> [Int] -> [Int]
    forall a. Int -> [a] -> [a]
    drop Int
    1 [Int]
    caveNums [Int] -> [Int] -> [Int]
    forall a. [a] -> [a] -> [a]
    ++ [Int
    0]
          placeStairs :: ([(Int, Int, Int)], Int)
                      -> (Int, Int)
                      -> ([(Int, Int, Int)], Int)
          placeStairs ([(Int, Int, Int)]
    acc, Int
    nstairsFromUp) (Int
    maxStairsNum, Int
    maxStairsNumNext) =
            let !_A1 :: ()
    _A1 = Bool -> () -> ()
    forall a. HasCallStack => Bool -> a -> a
    assert (Int
    nstairsFromUp Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Int
    maxStairsNum) ()
                -- Any stairs coming from above are kept and if they exceed
                -- @maxStairsNumNext@, the remainder ends here.
                -- If they don't exceed the minimum of @maxStairsNum@
                -- and @maxStairsNumNext@, the difference is filled up
                -- with single downstairs. The computation below maximizes
                -- the number of stairs at the cost of breaking some long
                -- staircases, except for the first one, which is always kept.
                -- Even without this exception, sometimes @maxStairsNum@
                -- could not be reached.
                doubleKept :: Int
    doubleKept =
                  [Int] -> Int
    forall a. Ord a => [a] -> a
    forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
    minimum [Int
    1, Int
    nstairsFromUp, Int
    maxStairsNum, Int
    maxStairsNumNext]
                nstairsFromUp1 :: Int
    nstairsFromUp1 = Int
    nstairsFromUp Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    doubleKept
                maxStairsNum1 :: Int
    maxStairsNum1 = Int
    maxStairsNum Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    doubleKept
                maxStairsNumNext1 :: Int
    maxStairsNumNext1 = Int
    maxStairsNumNext Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    doubleKept
                singleDownStairs :: Int
    singleDownStairs =
                  Int -> Int -> Int
    forall a. Ord a => a -> a -> a
    min Int
    maxStairsNumNext1 (Int -> Int) -> Int -> Int
    forall a b. (a -> b) -> a -> b
    $ Int
    maxStairsNum1 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    nstairsFromUp1
                remainingNext :: Int
    remainingNext = Int
    maxStairsNumNext1 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    singleDownStairs
                doubleDownStairs :: Int
    doubleDownStairs = Int
    doubleKept
                                   Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int -> Int -> Int
    forall a. Ord a => a -> a -> a
    min Int
    nstairsFromUp1 Int
    remainingNext
                !_A2 :: ()
    _A2 = Bool -> () -> ()
    forall a. HasCallStack => Bool -> a -> a
    assert (Int
    singleDownStairs Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Int
    0) ()
                !_A3 :: ()
    _A3 = Bool -> () -> ()
    forall a. HasCallStack => Bool -> a -> a
    assert (Int
    doubleDownStairs Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Int
    doubleKept) ()
            in ( (Int
    nstairsFromUp, Int
    doubleDownStairs, Int
    singleDownStairs) (Int, Int, Int) -> [(Int, Int, Int)] -> [(Int, Int, Int)]
    forall a. a -> [a] -> [a]
    : [(Int, Int, Int)]
    acc
               , Int
    doubleDownStairs Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    singleDownStairs )
          (caveStairs, nstairsFromUpLast) = foldl' placeStairs ([], 0) caveNumNexts
          caveZipped = Bool
    -> [((LevelId, ContentId CaveKind, CaveKind), (Int, Int, Int))]
    -> [((LevelId, ContentId CaveKind, CaveKind), (Int, Int, Int))]
    forall a. HasCallStack => Bool -> a -> a
    assert (Int
    nstairsFromUpLast Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    0)
                       ([((LevelId, ContentId CaveKind, CaveKind), (Int, Int, Int))]
     -> [((LevelId, ContentId CaveKind, CaveKind), (Int, Int, Int))])
    -> [((LevelId, ContentId CaveKind, CaveKind), (Int, Int, Int))]
    -> [((LevelId, ContentId CaveKind, CaveKind), (Int, Int, Int))]
    forall a b. (a -> b) -> a -> b
    $ [(LevelId, ContentId CaveKind, CaveKind)]
    -> [(Int, Int, Int)]
    -> [((LevelId, ContentId CaveKind, CaveKind), (Int, Int, Int))]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [(LevelId, ContentId CaveKind, CaveKind)]
    caveKinds ([(Int, Int, Int)] -> [(Int, Int, Int)]
    forall a. [a] -> [a]
    reverse [(Int, Int, Int)]
    caveStairs)
          placeCaveKind :: ([(LevelId, Level)], [(Point, Text)])
                         -> ( (LevelId, ContentId CaveKind, CaveKind)
                            , (Int, Int, Int) )
                         -> Rnd ([(LevelId, Level)], [(Point, Text)])
          placeCaveKind ([(LevelId, Level)]
    lvls, [(Point, Text)]
    stairsFromUp)
                        ( (LevelId
    lid, ContentId CaveKind
    dkind, CaveKind
    kc)
                        , (Int
    nstairsFromUp, Int
    doubleDownStairs, Int
    singleDownStairs) ) = do
            let !_A :: ()
    _A = Bool -> () -> ()
    forall a. HasCallStack => Bool -> a -> a
    assert ([(Point, Text)] -> Int
    forall a. [a] -> Int
    length [(Point, Text)]
    stairsFromUp Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    nstairsFromUp) ()
            (newLevel, ldown2) <-
              -- lstairUp for the next level is lstairDown for the current level
              COps
    -> ServerOptions
    -> LevelId
    -> ContentId CaveKind
    -> CaveKind
    -> Int
    -> Int
    -> AbsDepth
    -> [(Point, Text)]
    -> Rnd (Level, [(Point, Text)])
    buildLevel COps
    cops ServerOptions
    serverOptions
                         LevelId
    lid ContentId CaveKind
    dkind CaveKind
    kc Int
    doubleDownStairs Int
    singleDownStairs
                         AbsDepth
    freshTotalDepth [(Point, Text)]
    stairsFromUp
            return ((lid, newLevel) : lvls, ldown2)
      (levels, stairsFromUpLast) <- foldlM' placeCaveKind ([], []) caveZipped
      let freshDungeon = Bool -> Dungeon -> Dungeon
    forall a. HasCallStack => Bool -> a -> a
    assert ([(Point, Text)] -> Bool
    forall a. [a] -> Bool
    null [(Point, Text)]
    stairsFromUpLast) (Dungeon -> Dungeon) -> Dungeon -> Dungeon
    forall a b. (a -> b) -> a -> b
    $ [(LevelId, Level)] -> Dungeon
    forall k a. Enum k => [(k, a)] -> EnumMap k a
    EM.fromList [(LevelId, Level)]
    levels
      return $! FreshDungeon{..}