{-# 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)
  TileMap
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 Maybe (Rnd (ContentId TileKind))
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
      ContentId TileKind
walkable2 <- Rnd (ContentId TileKind)
pickPassable
      let converted2 :: TileMap
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
      ContentId TileKind
walkable3 <- Rnd (ContentId TileKind)
pickPassable
      let converted3 :: TileMap
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
      ContentId TileKind
walkable4 <- Rnd (ContentId TileKind)
pickPassable
      let converted4 :: TileMap
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
      ContentId TileKind
walkable5 <- Rnd (ContentId TileKind)
pickPassable
      let converted5 :: TileMap
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
      TileMap -> Rnd TileMap
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return TileMap
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
  Bool
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
  COps
-> Bool
-> Rnd (ContentId TileKind)
-> Maybe (Rnd (ContentId TileKind))
-> Area
-> TileMapEM
-> Rnd TileMap
convertTileMaps COps
cops Bool
areAllWalkable Rnd (ContentId TileKind)
pickDefTile Maybe (Rnd (ContentId TileKind))
mpickPassable Area
darea TileMapEM
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
rtitle :: RuleContent -> [Char]
rexeVersion :: RuleContent -> Version
rcfgUIName :: RuleContent -> [Char]
rcfgUIDefault :: RuleContent -> (Text, Config)
rwriteSaveClips :: RuleContent -> Int
rleadLevelClips :: RuleContent -> Int
rscoresFileName :: RuleContent -> [Char]
rnearby :: RuleContent -> Int
rstairWordCarried :: RuleContent -> [Text]
ritemSymbols :: RuleContent -> ItemSymbolsUsedInEngine
..}} 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) ]
  [(Point, Freqs PlaceKind)]
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).
      Maybe Point
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 Maybe Point
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]
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]
pallUpAndEscape = [Point]
pescape [Point] -> [Point] -> [Point]
forall a. [a] -> [a] -> [a]
++ [Point]
pallUpStairs
      addSingleDown :: [Point] -> Int -> Rnd [Point]
      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
        Maybe Point
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 Maybe Point
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
  [Point]
pstairsSingleDown <- [Point] -> Int -> Rnd [Point]
addSingleDown [] Int
singleDownStairs
  let freqDouble :: Text -> Freqs PlaceKind
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, Freqs PlaceKind)]
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 -> Freqs PlaceKind
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, Freqs PlaceKind)]
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 :: Freqs PlaceKind
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, Freqs PlaceKind)]
fixedStairsDown = (Point -> (Point, Freqs PlaceKind))
-> [Point] -> [(Point, Freqs PlaceKind)]
forall a b. (a -> b) -> [a] -> [b]
map (, Freqs PlaceKind
freqDown) [Point]
pstairsSingleDown
      pallExits :: [Point]
pallExits = [Point]
pallUpAndEscape [Point] -> [Point] -> [Point]
forall a. [a] -> [a] -> [a]
++ [Point]
pstairsSingleDown
      fixedCenters :: EnumMap Point (Freqs PlaceKind)
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).
  [Point]
bootExtra <- if EnumMap Point (Freqs PlaceKind) -> Bool
forall k a. EnumMap k a -> Bool
EM.null EnumMap Point (Freqs PlaceKind)
fixedCenters then do
                 Maybe Point
mpointExtra <-
                   Text
-> Bool
-> ServerOptions
-> LevelId
-> CaveKind
-> Area
-> [Point]
-> [Point]
-> Rnd (Maybe Point)
placeDownStairs Text
"extra boot" Bool
False ServerOptions
serverOptions LevelId
lid
                                   CaveKind
kc Area
darea [Point]
pallExits [Point]
boot
                 -- With sane content, @Nothing@ should never appear.
                 [Point] -> Rnd [Point]
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Point] -> Rnd [Point]) -> [Point] -> Rnd [Point]
forall a b. (a -> b) -> a -> b
$! Maybe Point -> [Point]
forall a. Maybe a -> [a]
maybeToList Maybe Point
mpointExtra
               else [Point] -> Rnd [Point]
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return []
  let posUp :: Point -> Point
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 -> Point
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])
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 )
  (Int, Int)
cellSize <- AbsDepth -> AbsDepth -> DiceXY -> Rnd (Int, Int)
castDiceXY AbsDepth
ldepth AbsDepth
totalDepth (DiceXY -> Rnd (Int, Int)) -> DiceXY -> Rnd (Int, Int)
forall a b. (a -> b) -> a -> b
$ CaveKind -> DiceXY
ccellSize CaveKind
kc
  let subArea :: Area
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 :: Area
area = if CaveKind -> Bool
cfenceApart CaveKind
kc then Area
subArea else Area
darea
      ((Int, Int)
lgr, EnumMap Point SpecialArea
gs) = EnumMap Point (Freqs PlaceKind)
-> [Point]
-> Area
-> (Int, Int)
-> ((Int, Int), EnumMap Point SpecialArea)
grid EnumMap Point (Freqs PlaceKind)
fixedCenters ([Point]
boot [Point] -> [Point] -> [Point]
forall a. [a] -> [a] -> [a]
++ [Point]
bootExtra) Area
area (Int, Int)
cellSize
  Word32
dsecret <- Rnd Word32
randomWord32
  Cave
cave <- COps
-> AbsDepth
-> AbsDepth
-> Area
-> Word32
-> ContentId CaveKind
-> (Int, Int)
-> EnumMap Point SpecialArea
-> [Point]
-> Rnd Cave
buildCave COps
cops AbsDepth
ldepth AbsDepth
totalDepth Area
darea Word32
dsecret ContentId CaveKind
dkind (Int, Int)
lgr EnumMap Point SpecialArea
gs [Point]
bootExtra
  TileMap
cmap <- COps -> Cave -> Rnd TileMap
buildTileMap COps
cops Cave
cave
  -- The bang is needed to prevent caves memory drag until levels used.
  let !lvl :: Level
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 -> (Point, Text)
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)
  (Level, [(Point, Text)]) -> Rnd (Level, [(Point, Text)])
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Level
lvl, [(Point, Text)]
lstairsDouble [(Point, Text)] -> [(Point, Text)] -> [(Point, Text)]
forall a. [a] -> [a] -> [a]
++ (Point -> (Point, Text)) -> [Point] -> [(Point, Text)]
forall a b. (a -> b) -> [a] -> [b]
map Point -> (Point, Text)
stairCarried [Point]
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 )
  Maybe Point
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 Maybe Point -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Point
mpos Bool -> Bool -> Bool
&& ServerOptions -> Bool
sdumpInitRngs ServerOptions
serverOptions
           then IO () -> ()
forall a. IO a -> a
unsafePerformIO (IO () -> ()) -> IO () -> ()
forall a b. (a -> b) -> a -> b
$ do
             Handle -> Text -> IO ()
T.hPutStrLn Handle
stdout (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
                Text
"Failed to place" Text -> Text -> Text
<+> Text
object Text -> Text -> Text
<+> Text
"on level"
                Text -> Text -> Text
<+> LevelId -> Text
forall a. Show a => a -> Text
tshow LevelId
lid Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", in" Text -> Text -> Text
<+> Area -> Text
forall a. Show a => a -> Text
tshow Area
darea
             Handle -> IO ()
hFlush Handle
stdout
-- Not really expensive, but shouldn't disrupt normal testing nor play.
#ifdef WITH_EXPENSIVE_ASSERTIONS
             [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"possible, but unexpected; alarm!"
#endif
           else ()
  Maybe Point -> Rnd (Maybe Point)
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Point
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
dentry :: Cave -> EnumMap Point PlaceEntry
dnight :: Cave -> Bool
..} 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
        [GroupName CaveKind]
lShuffled <- [GroupName CaveKind] -> Rnd [GroupName CaveKind]
forall a. Eq a => [a] -> Rnd [a]
shuffle [GroupName CaveKind]
l
        [(Int, GroupName CaveKind)] -> Rnd [(Int, GroupName CaveKind)]
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Int, GroupName CaveKind)] -> Rnd [(Int, GroupName CaveKind)])
-> [(Int, GroupName CaveKind)] -> Rnd [(Int, GroupName CaveKind)]
forall a b. (a -> b) -> a -> b
$! [Int] -> [GroupName CaveKind] -> [(Int, GroupName CaveKind)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
ns [GroupName CaveKind]
lShuffled
  [[(Int, GroupName CaveKind)]]
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)]
cavesFlat = [[(Int, GroupName CaveKind)]] -> [(Int, GroupName CaveKind)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Int, GroupName CaveKind)]]
cavesShuffled
      absKeys :: [Int]
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 :: AbsDepth
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, GroupName CaveKind)
-> Rnd ((LevelId, ContentId CaveKind, CaveKind), Int)
getCaveKindNum (Int
ln, GroupName CaveKind
genName) = do
        ContentId CaveKind
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 :: CaveKind
kc = ContentData CaveKind -> ContentId CaveKind -> CaveKind
forall a. ContentData a -> ContentId a -> a
okind ContentData CaveKind
cocave ContentId CaveKind
dkind
            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
ln
        Int
maxStairsNum <- AbsDepth -> AbsDepth -> Dice -> Rnd Int
castDice AbsDepth
ldepth AbsDepth
freshTotalDepth (Dice -> Rnd Int) -> Dice -> Rnd Int
forall a b. (a -> b) -> a -> b
$ CaveKind -> Dice
cmaxStairsNum CaveKind
kc
        ((LevelId, ContentId CaveKind, CaveKind), Int)
-> Rnd ((LevelId, ContentId CaveKind, CaveKind), Int)
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int -> LevelId
forall a. Enum a => Int -> a
toEnum Int
ln, ContentId CaveKind
dkind, CaveKind
kc), Int
maxStairsNum)
  [((LevelId, ContentId CaveKind, CaveKind), Int)]
caveKindNums <- ((Int, GroupName CaveKind)
 -> Rnd ((LevelId, ContentId CaveKind, CaveKind), Int))
-> [(Int, GroupName CaveKind)]
-> StateT
     SMGen Identity [((LevelId, ContentId CaveKind, CaveKind), Int)]
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 ((LevelId, ContentId CaveKind, CaveKind), Int)
getCaveKindNum [(Int, GroupName CaveKind)]
cavesFlat
  let ([(LevelId, ContentId CaveKind, CaveKind)]
caveKinds, [Int]
caveNums) = [((LevelId, ContentId CaveKind, CaveKind), Int)]
-> ([(LevelId, ContentId CaveKind, CaveKind)], [Int])
forall a b. [(a, b)] -> ([a], [b])
unzip [((LevelId, ContentId CaveKind, CaveKind), Int)]
caveKindNums
      caveNumNexts :: [(Int, Int)]
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)], 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 )
      ([(Int, Int, Int)]
caveStairs, Int
nstairsFromUpLast) = (([(Int, Int, Int)], Int)
 -> (Int, Int) -> ([(Int, Int, Int)], Int))
-> ([(Int, Int, Int)], Int)
-> [(Int, Int)]
-> ([(Int, Int, Int)], Int)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([(Int, Int, Int)], Int) -> (Int, Int) -> ([(Int, Int, Int)], Int)
placeStairs ([], Int
0) [(Int, Int)]
caveNumNexts
      caveZipped :: [((LevelId, ContentId CaveKind, CaveKind), (Int, Int, Int))]
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)], [(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) ()
        (Level
newLevel, [(Point, Text)]
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
        ([(LevelId, Level)], [(Point, Text)])
-> Rnd ([(LevelId, Level)], [(Point, Text)])
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ((LevelId
lid, Level
newLevel) (LevelId, Level) -> [(LevelId, Level)] -> [(LevelId, Level)]
forall a. a -> [a] -> [a]
: [(LevelId, Level)]
lvls, [(Point, Text)]
ldown2)
  ([(LevelId, Level)]
levels, [(Point, Text)]
stairsFromUpLast) <- (([(LevelId, Level)], [(Point, Text)])
 -> ((LevelId, ContentId CaveKind, CaveKind), (Int, Int, Int))
 -> Rnd ([(LevelId, Level)], [(Point, Text)]))
-> ([(LevelId, Level)], [(Point, Text)])
-> [((LevelId, ContentId CaveKind, CaveKind), (Int, Int, Int))]
-> Rnd ([(LevelId, Level)], [(Point, Text)])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> Rnd b) -> b -> t a -> Rnd b
foldlM' ([(LevelId, Level)], [(Point, Text)])
-> ((LevelId, ContentId CaveKind, CaveKind), (Int, Int, Int))
-> Rnd ([(LevelId, Level)], [(Point, Text)])
placeCaveKind ([], []) [((LevelId, ContentId CaveKind, CaveKind), (Int, Int, Int))]
caveZipped
  let freshDungeon :: Dungeon
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
  FreshDungeon -> Rnd FreshDungeon
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (FreshDungeon -> Rnd FreshDungeon)
-> FreshDungeon -> Rnd FreshDungeon
forall a b. (a -> b) -> a -> b
$! FreshDungeon{Dungeon
AbsDepth
freshDungeon :: Dungeon
freshTotalDepth :: AbsDepth
freshTotalDepth :: AbsDepth
freshDungeon :: Dungeon
..}