{-# 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           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{X
rXmax :: RuleContent -> X
rXmax :: X
rXmax, X
rYmax :: RuleContent -> X
rYmax :: X
rYmax}, ContentData TileKind
cotile :: COps -> ContentData TileKind
cotile :: ContentData TileKind
cotile, TileSpeedup
coTileSpeedup :: COps -> TileSpeedup
coTileSpeedup :: TileSpeedup
coTileSpeedup}
                areAllWalkable :: Bool
areAllWalkable cdefTile :: Rnd (ContentId TileKind)
cdefTile mpickPassable :: Maybe (Rnd (ContentId TileKind))
mpickPassable darea :: Area
darea ltile :: 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, (X, [(X, ContentId TileKind)]))
-> (ContentId TileKind, (SMGen, (X, [(X, ContentId TileKind)])))
runCdefTile (gen1 :: SMGen
gen1, (pI :: X
pI, assocs :: [(X, ContentId TileKind)]
assocs)) =
        let p :: Point
p = X -> Point
forall a. Enum a => X -> a
toEnum X
pI
        in if Point
p Point -> Area -> Bool
`inside` Area
darea
           then case [(X, ContentId TileKind)]
assocs of
             (p2 :: X
p2, t2 :: ContentId TileKind
t2) : rest :: [(X, ContentId TileKind)]
rest | X
p2 X -> X -> Bool
forall a. Eq a => a -> a -> Bool
== X
pI -> (ContentId TileKind
t2, (SMGen
gen1, (X
pI X -> X -> X
forall a. Num a => a -> a -> a
+ 1, [(X, ContentId TileKind)]
rest)))
             _ -> let (tile :: ContentId TileKind
tile, gen2 :: 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, (X
pI X -> X -> X
forall a. Num a => a -> a -> a
+ 1, [(X, ContentId TileKind)]
assocs)))
           else (ContentId TileKind
outerId, (SMGen
gen1, (X
pI X -> X -> X
forall a. Num a => a -> a -> a
+ 1, [(X, ContentId TileKind)]
assocs)))
      runUnfold :: SMGen -> (TileMap, SMGen)
runUnfold gen :: SMGen
gen =
        let (gen1 :: SMGen
gen1, gen2 :: SMGen
gen2) = SMGen -> (SMGen, SMGen)
SM.splitSMGen SMGen
gen
        in (X
-> X
-> ((SMGen, (X, [(X, ContentId TileKind)]))
    -> (ContentId TileKind, (SMGen, (X, [(X, ContentId TileKind)]))))
-> (SMGen, (X, [(X, ContentId TileKind)]))
-> TileMap
forall c b.
UnboxRepClass c =>
X -> X -> (b -> (c, b)) -> b -> Array c
PointArray.unfoldrNA
              X
rXmax X
rYmax (SMGen, (X, [(X, ContentId TileKind)]))
-> (ContentId TileKind, (SMGen, (X, [(X, ContentId TileKind)])))
runCdefTile
              (SMGen
gen1, (0, IntMap (ContentId TileKind) -> [(X, ContentId TileKind)]
forall a. IntMap a -> [(X, a)]
IM.assocs (IntMap (ContentId TileKind) -> [(X, ContentId TileKind)])
-> IntMap (ContentId TileKind) -> [(X, 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
    _ | Bool
areAllWalkable -> TileMap -> Rnd TileMap
forall (m :: * -> *) a. Monad m => a -> m a
return TileMap
converted1  -- all walkable; passes OK
    Nothing -> TileMap -> Rnd TileMap
forall (m :: * -> *) a. Monad m => a -> m a
return TileMap
converted1  -- no walkable tiles for filling the map
    Just pickPassable :: Rnd (ContentId TileKind)
pickPassable -> do  -- some tiles walkable, so ensure connectivity
      let passes :: Point -> TileMap -> Bool
passes p :: Point
p array :: 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 x :: X
x y :: X
y) array :: TileMap
array =
            Bool -> Bool
not (Point -> TileMap -> Bool
passes (X -> X -> Point
Point (X
x X -> X -> X
forall a. Num a => a -> a -> a
+ 1) X
y) TileMap
array
                 Bool -> Bool -> Bool
|| Point -> TileMap -> Bool
passes (X -> X -> Point
Point (X
x X -> X -> X
forall a. Num a => a -> a -> a
- 1) X
y) TileMap
array)
          blocksVertical :: Point -> TileMap -> Bool
blocksVertical (Point x :: X
x y :: X
y) array :: TileMap
array =
            Bool -> Bool
not (Point -> TileMap -> Bool
passes (X -> X -> Point
Point X
x (X
y X -> X -> X
forall a. Num a => a -> a -> a
+ 1)) TileMap
array
                 Bool -> Bool -> Bool
|| Point -> TileMap -> Bool
passes (X -> X -> Point
Point X
x (X
y X -> X -> X
forall a. Num a => a -> a -> a
- 1)) TileMap
array)
          xeven :: Point -> Bool
xeven Point{..} = X
px X -> X -> X
forall a. Integral a => a -> a -> a
`mod` 2 X -> X -> Bool
forall a. Eq a => a -> a -> Bool
== 0
          yeven :: Point -> Bool
yeven Point{..} = X
py X -> X -> X
forall a. Integral a => a -> a -> a
`mod` 2 X -> X -> Bool
forall a. Eq a => a -> a -> Bool
== 0
          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] -> 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 included :: Point -> Bool
included blocks :: Point -> TileMap -> Bool
blocks walkableTile :: ContentId TileKind
walkableTile array :: TileMap
array =
            let g :: Point -> ContentId TileKind -> ContentId TileKind
g p :: Point
p c :: ContentId TileKind
c = if Point
p Point -> Area -> Bool
`inside` Area
activeArea
                           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 Point -> Bool
xeven 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 Point -> Bool
yeven 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 (Bool -> Bool
not (Bool -> Bool) -> (Point -> Bool) -> Point -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point -> Bool
xeven) 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 (Bool -> Bool
not (Bool -> Bool) -> (Point -> Bool) -> Point -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point -> Bool
yeven) Point -> TileMap -> Bool
blocksVertical ContentId TileKind
walkable5 TileMap
converted4
      TileMap -> Rnd TileMap
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 :: ContentData TileKind
cotile :: COps -> ContentData TileKind
cotile, ContentData CaveKind
cocave :: COps -> ContentData CaveKind
cocave :: ContentData CaveKind
cocave} Cave{ContentId CaveKind
dkind :: Cave -> ContentId CaveKind
dkind :: ContentId CaveKind
dkind, Area
darea :: Cave -> Area
darea :: Area
darea, TileMapEM
dmap :: Cave -> TileMapEM
dmap :: TileMapEM
dmap} = do
  let CaveKind{Bool
cpassable :: CaveKind -> Bool
cpassable :: Bool
cpassable, GroupName TileKind
cdefTile :: CaveKind -> GroupName TileKind
cdefTile :: 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] -> 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] -> 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 :: X
anchorDown = 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
-> X
-> X
-> AbsDepth
-> [(Point, Text)]
-> Rnd (Level, [(Point, Text)])
buildLevel cops :: COps
cops@COps{ContentData PlaceKind
coplace :: COps -> ContentData PlaceKind
coplace :: ContentData PlaceKind
coplace, corule :: COps -> RuleContent
corule=RuleContent{..}} serverOptions :: ServerOptions
serverOptions
           lid :: LevelId
lid dkind :: ContentId CaveKind
dkind kc :: CaveKind
kc doubleDownStairs :: X
doubleDownStairs singleDownStairs :: X
singleDownStairs
           totalDepth :: AbsDepth
totalDepth stairsFromUp :: [(Point, Text)]
stairsFromUp = do
  let d :: X
d = if CaveKind -> Bool
cfenceApart CaveKind
kc then 1 else 0
      -- Simple rule for now: level @lid@ has depth (difficulty) @abs lid@.
      ldepth :: AbsDepth
ldepth = X -> AbsDepth
Dice.AbsDepth (X -> AbsDepth) -> X -> AbsDepth
forall a b. (a -> b) -> a -> b
$ X -> X
forall a. Num a => a -> a
abs (X -> X) -> X -> X
forall a b. (a -> b) -> a -> b
$ LevelId -> X
forall a. Enum a => a -> X
fromEnum LevelId
lid
      darea :: Area
darea =
        let (lxPrev :: [X]
lxPrev, lyPrev :: [X]
lyPrev) = [(X, X)] -> ([X], [X])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(X, X)] -> ([X], [X])) -> [(X, X)] -> ([X], [X])
forall a b. (a -> b) -> a -> b
$ ((Point, Text) -> (X, X)) -> [(Point, Text)] -> [(X, X)]
forall a b. (a -> b) -> [a] -> [b]
map ((Point -> X
px (Point -> X) -> (Point -> X) -> Point -> (X, X)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Point -> X
py) (Point -> (X, X))
-> ((Point, Text) -> Point) -> (Point, Text) -> (X, X)
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 :: X
lxMin = X -> X -> X
forall a. Ord a => a -> a -> a
max 0
                    (X -> X) -> X -> X
forall a b. (a -> b) -> a -> b
$ -4 X -> X -> X
forall a. Num a => a -> a -> a
- X
d X -> X -> X
forall a. Num a => a -> a -> a
+ [X] -> X
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum (X
rXmax X -> X -> X
forall a. Num a => a -> a -> a
- 1 X -> [X] -> [X]
forall a. a -> [a] -> [a]
: [X]
lxPrev)
            lxMax :: X
lxMax = X -> X -> X
forall a. Ord a => a -> a -> a
min (X
rXmax X -> X -> X
forall a. Num a => a -> a -> a
- 1)
                    (X -> X) -> X -> X
forall a b. (a -> b) -> a -> b
$ 4 X -> X -> X
forall a. Num a => a -> a -> a
+ X
d X -> X -> X
forall a. Num a => a -> a -> a
+ [X] -> X
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (0 X -> [X] -> [X]
forall a. a -> [a] -> [a]
: [X]
lxPrev)
            lyMin :: X
lyMin = X -> X -> X
forall a. Ord a => a -> a -> a
max 0
                    (X -> X) -> X -> X
forall a b. (a -> b) -> a -> b
$ -3 X -> X -> X
forall a. Num a => a -> a -> a
- X
d X -> X -> X
forall a. Num a => a -> a -> a
+ [X] -> X
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum (X
rYmax X -> X -> X
forall a. Num a => a -> a -> a
- 1 X -> [X] -> [X]
forall a. a -> [a] -> [a]
: [X]
lyPrev)
            lyMax :: X
lyMax = X -> X -> X
forall a. Ord a => a -> a -> a
min (X
rYmax X -> X -> X
forall a. Num a => a -> a -> a
- 1)
                    (X -> X) -> X -> X
forall a b. (a -> b) -> a -> b
$ 3 X -> X -> X
forall a. Num a => a -> a -> a
+ X
d X -> X -> X
forall a. Num a => a -> a -> a
+ [X] -> X
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (0 X -> [X] -> [X]
forall a. a -> [a] -> [a]
: [X]
lyPrev)
            -- Pick minimal cave size that fits all previous stairs.
            xspan :: X
xspan = X -> X -> X
forall a. Ord a => a -> a -> a
max (X
lxMax X -> X -> X
forall a. Num a => a -> a -> a
- X
lxMin X -> X -> X
forall a. Num a => a -> a -> a
+ 1) (X -> X) -> X -> X
forall a b. (a -> b) -> a -> b
$ CaveKind -> X
cXminSize CaveKind
kc
            yspan :: X
yspan = X -> X -> X
forall a. Ord a => a -> a -> a
max (X
lyMax X -> X -> X
forall a. Num a => a -> a -> a
- X
lyMin X -> X -> X
forall a. Num a => a -> a -> a
+ 1) (X -> X) -> X -> X
forall a b. (a -> b) -> a -> b
$ CaveKind -> X
cYminSize CaveKind
kc
            x0 :: X
x0 = X -> X -> X
forall a. Ord a => a -> a -> a
min X
lxMin (X
rXmax X -> X -> X
forall a. Num a => a -> a -> a
- X
xspan)
            y0 :: X
y0 = X -> X -> X
forall a. Ord a => a -> a -> a
min X
lyMin (X
rYmax X -> X -> X
forall a. Num a => a -> a -> a
- X
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] -> 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
$ (X, X, X, X) -> Maybe Area
toArea (X
x0, X
y0, X
x0 X -> X -> X
forall a. Num a => a -> a -> a
+ X
xspan X -> X -> X
forall a. Num a => a -> a -> a
- 1, X
y0 X -> X -> X
forall a. Num a => a -> a -> a
+ X
yspan X -> X -> X
forall a. Num a => a -> a -> a
- 1)
      (lstairsDouble :: [(Point, Text)]
lstairsDouble, lstairsSingleUp :: [(Point, Text)]
lstairsSingleUp) = X -> [(Point, Text)] -> ([(Point, Text)], [(Point, Text)])
forall a. X -> [a] -> ([a], [a])
splitAt X
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 (x0 :: X
x0, y0 :: X
y0, x1 :: X
x1, y1 :: X
y1) = Area -> (X, X, X, X)
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 (X -> [Point] -> Point -> Either Point Point
snapToStairList 0 [Point]
pallUpStairs)
                             [ X -> X -> Point
Point (X
x0 X -> X -> X
forall a. Num a => a -> a -> a
+ 4 X -> X -> X
forall a. Num a => a -> a -> a
+ X
d) (X
y0 X -> X -> X
forall a. Num a => a -> a -> a
+ 3 X -> X -> X
forall a. Num a => a -> a -> a
+ X
d)
                             , X -> X -> Point
Point (X
x1 X -> X -> X
forall a. Num a => a -> a -> a
- 4 X -> X -> X
forall a. Num a => a -> a -> a
- X
d) (X
y1 X -> X -> X
forall a. Num a => a -> a -> a
- X
anchorDown X -> X -> X
forall a. Num a => a -> a -> a
+ 1) ]
  [(Point, Freqs PlaceKind)]
fixedEscape <- case CaveKind -> Freqs PlaceKind
cescapeFreq CaveKind
kc of
    [] -> [(Point, Freqs PlaceKind)]
-> StateT SMGen Identity [(Point, Freqs PlaceKind)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    escapeFreq :: 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 "escape" Bool
True ServerOptions
serverOptions LevelId
lid
                               CaveKind
kc Area
darea [Point]
pallUpStairs [Point]
boot
      case Maybe Point
mepos of
        Just epos :: Point
epos -> [(Point, Freqs PlaceKind)]
-> StateT SMGen Identity [(Point, Freqs PlaceKind)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Point
epos, Freqs PlaceKind
escapeFreq)]
        Nothing -> [(Point, Freqs PlaceKind)]
-> StateT SMGen Identity [(Point, Freqs PlaceKind)]
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] -> X -> Rnd [Point]
addSingleDown acc :: [Point]
acc 0 = [Point] -> Rnd [Point]
forall (m :: * -> *) a. Monad m => a -> m a
return [Point]
acc
      addSingleDown acc :: [Point]
acc k :: X
k = do
        Maybe Point
mpos <- Text
-> Bool
-> ServerOptions
-> LevelId
-> CaveKind
-> Area
-> [Point]
-> [Point]
-> Rnd (Maybe Point)
placeDownStairs "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 pos :: Point
pos -> [Point] -> X -> Rnd [Point]
addSingleDown (Point
pos Point -> [Point] -> [Point]
forall a. a -> [a] -> [a]
: [Point]
acc) (X
k X -> X -> X
forall a. Num a => a -> a -> a
- 1)
          Nothing -> [Point] -> Rnd [Point]
forall (m :: * -> *) a. Monad m => a -> m a
return [Point]
acc  -- calling again won't change anything
  [Point]
pstairsSingleDown <- [Point] -> X -> Rnd [Point]
addSingleDown [] X
singleDownStairs
  let freqDouble :: Text -> Freqs PlaceKind
freqDouble carried :: Text
carried =
        ((GroupName PlaceKind, X) -> Bool)
-> Freqs PlaceKind -> Freqs PlaceKind
forall a. (a -> Bool) -> [a] -> [a]
filter (\(gn :: GroupName PlaceKind
gn, _) -> Text
carried Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Text -> [Text]
T.words (GroupName PlaceKind -> Text
forall a. GroupName a -> Text
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 (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 carried :: Text
carried =
        ((GroupName PlaceKind, X) -> (GroupName PlaceKind, X))
-> Freqs PlaceKind -> Freqs PlaceKind
forall a b. (a -> b) -> [a] -> [b]
map ((GroupName PlaceKind -> GroupName PlaceKind)
-> (GroupName PlaceKind, X) -> (GroupName PlaceKind, X)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (\gn :: GroupName PlaceKind
gn -> Text -> GroupName PlaceKind
forall a. Text -> GroupName a
GroupName (Text -> GroupName PlaceKind) -> Text -> GroupName PlaceKind
forall a b. (a -> b) -> a -> b
$ GroupName PlaceKind -> Text
forall a. GroupName a -> Text
fromGroupName GroupName PlaceKind
gn 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 (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 =
        ((GroupName PlaceKind, X) -> (GroupName PlaceKind, X))
-> Freqs PlaceKind -> Freqs PlaceKind
forall a b. (a -> b) -> [a] -> [b]
map ((GroupName PlaceKind -> GroupName PlaceKind)
-> (GroupName PlaceKind, X) -> (GroupName PlaceKind, X)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (\gn :: GroupName PlaceKind
gn -> Text -> GroupName PlaceKind
forall a. Text -> GroupName a
GroupName (Text -> GroupName PlaceKind) -> Text -> GroupName PlaceKind
forall a b. (a -> b) -> a -> b
$ GroupName PlaceKind -> Text
forall a. GroupName a -> Text
fromGroupName GroupName PlaceKind
gn 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 "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 (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 (m :: * -> *) a. Monad m => a -> m a
return []
  let posUp :: Point -> Point
posUp Point{..} = X -> X -> Point
Point (X
px X -> X -> X
forall a. Num a => a -> a -> a
- 1) X
py
      posDn :: Point -> Point
posDn Point{..} = X -> X -> Point
Point (X
px X -> X -> X
forall a. Num a => a -> a -> a
+ 1) X
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 )
  (X, X)
cellSize <- AbsDepth -> AbsDepth -> DiceXY -> Rnd (X, X)
castDiceXY AbsDepth
ldepth AbsDepth
totalDepth (DiceXY -> Rnd (X, X)) -> DiceXY -> Rnd (X, X)
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] -> 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
      (lgr :: (X, X)
lgr, gs :: EnumMap Point SpecialArea
gs) = EnumMap Point (Freqs PlaceKind)
-> [Point] -> Area -> (X, X) -> ((X, X), EnumMap Point SpecialArea)
grid EnumMap Point (Freqs PlaceKind)
fixedCenters ([Point]
boot [Point] -> [Point] -> [Point]
forall a. [a] -> [a] -> [a]
++ [Point]
bootExtra) Area
area (X, X)
cellSize
  Word32
dsecret <- Rnd Word32
randomWord32
  Cave
cave <- COps
-> AbsDepth
-> AbsDepth
-> Area
-> Word32
-> ContentId CaveKind
-> (X, X)
-> EnumMap Point SpecialArea
-> [Point]
-> Rnd Cave
buildCave COps
cops AbsDepth
ldepth AbsDepth
totalDepth Area
darea Word32
dsecret ContentId CaveKind
dkind (X, X)
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 p0 :: Point
p0 =
        let Place{ContentId PlaceKind
qkind :: Place -> ContentId PlaceKind
qkind :: 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], X)]
freq = ((GroupName PlaceKind, X) -> ([Text], X))
-> Freqs PlaceKind -> [([Text], X)]
forall a b. (a -> b) -> [a] -> [b]
map ((GroupName PlaceKind -> [Text])
-> (GroupName PlaceKind, X) -> ([Text], X)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((GroupName PlaceKind -> [Text])
 -> (GroupName PlaceKind, X) -> ([Text], X))
-> (GroupName PlaceKind -> [Text])
-> (GroupName PlaceKind, X)
-> ([Text], X)
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 (\t :: Text
t -> (([Text], X) -> Bool) -> [([Text], X)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(ws :: [Text]
ws, _) -> Text
t Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
ws) [([Text], X)]
freq)
                                [Text]
rstairWordCarried
        in case [Text]
carriedAll of
          [t :: Text
t] -> (Point
p0, Text
t)
          _ -> [Char] -> (Point, Text)
forall a. HasCallStack => [Char] -> a
error ([Char] -> (Point, Text)) -> [Char] -> (Point, Text)
forall a b. (a -> b) -> a -> b
$ "wrong carried stair word"
                       [Char] -> ([([Text], X)], [Text], CaveKind) -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` ([([Text], X)]
freq, [Text]
carriedAll, CaveKind
kc)
  (Level, [(Point, Text)]) -> Rnd (Level, [(Point, Text)])
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 :: X -> [Point] -> Point -> Either Point Point
snapToStairList _ [] p :: Point
p = Point -> Either Point Point
forall a b. b -> Either a b
Right Point
p
snapToStairList a :: X
a (pos :: Point
pos : rest :: [Point]
rest) p :: Point
p =
  let nx :: X
nx = if Point -> X
px Point
pos X -> X -> Bool
forall a. Ord a => a -> a -> Bool
> Point -> X
px Point
p X -> X -> X
forall a. Num a => a -> a -> a
+ 5 X -> X -> X
forall a. Num a => a -> a -> a
+ X
a Bool -> Bool -> Bool
|| Point -> X
px Point
pos X -> X -> Bool
forall a. Ord a => a -> a -> Bool
< Point -> X
px Point
p X -> X -> X
forall a. Num a => a -> a -> a
- 5 X -> X -> X
forall a. Num a => a -> a -> a
- X
a
           then Point -> X
px Point
p
           else Point -> X
px Point
pos
      ny :: X
ny = if Point -> X
py Point
pos X -> X -> Bool
forall a. Ord a => a -> a -> Bool
> Point -> X
py Point
p X -> X -> X
forall a. Num a => a -> a -> a
+ 3 X -> X -> X
forall a. Num a => a -> a -> a
+ X
a Bool -> Bool -> Bool
|| Point -> X
py Point
pos X -> X -> Bool
forall a. Ord a => a -> a -> Bool
< Point -> X
py Point
p X -> X -> X
forall a. Num a => a -> a -> a
- 3 X -> X -> X
forall a. Num a => a -> a -> a
- X
a
           then Point -> X
py Point
p
           else Point -> X
py Point
pos
      np :: Point
np = X -> X -> Point
Point X
nx X
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 X -> [Point] -> Point -> Either Point Point
snapToStairList X
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 object :: Text
object cornerPermitted :: Bool
cornerPermitted serverOptions :: ServerOptions
serverOptions lid :: LevelId
lid
                CaveKind{X
cminStairDist :: CaveKind -> X
cminStairDist :: X
cminStairDist, Bool
cfenceApart :: Bool
cfenceApart :: CaveKind -> Bool
cfenceApart} darea :: Area
darea ps :: [Point]
ps boot :: [Point]
boot = do
  let dist :: X -> Point -> Bool
dist cmin :: X
cmin p :: Point
p = (Point -> Bool) -> [Point] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\pos :: Point
pos -> Point -> Point -> X
chessDist Point
p Point
pos X -> X -> Bool
forall a. Ord a => a -> a -> Bool
> X
cmin) [Point]
ps
      (x0 :: X
x0, y0 :: X
y0, x1 :: X
x1, y1 :: X
y1) = Area -> (X, X, X, X)
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 :: X
rx = 9  -- enough to fit smallest stairs
      ry :: X
ry = 6  -- enough to fit smallest stairs
      wx :: X
wx = X
x1 X -> X -> X
forall a. Num a => a -> a -> a
- X
x0 X -> X -> X
forall a. Num a => a -> a -> a
+ 1
      wy :: X
wy = X
y1 X -> X -> X
forall a. Num a => a -> a -> a
- X
y0 X -> X -> X
forall a. Num a => a -> a -> a
+ 1
      notInCorner :: Point -> Bool
notInCorner Point{..} =
        Bool
cornerPermitted
        Bool -> Bool -> Bool
|| X
wx X -> X -> Bool
forall a. Ord a => a -> a -> Bool
< 3 X -> X -> X
forall a. Num a => a -> a -> a
* X
rx X -> X -> X
forall a. Num a => a -> a -> a
+ 3 Bool -> Bool -> Bool
|| X
wy X -> X -> Bool
forall a. Ord a => a -> a -> Bool
< 3 X -> X -> X
forall a. Num a => a -> a -> a
* X
ry X -> X -> X
forall a. Num a => a -> a -> a
+ 3  -- everything is a corner
        Bool -> Bool -> Bool
|| X
px X -> X -> Bool
forall a. Ord a => a -> a -> Bool
> X
x0 X -> X -> X
forall a. Num a => a -> a -> a
+ (X
wx X -> X -> X
forall a. Num a => a -> a -> a
- 3) X -> X -> X
forall a. Integral a => a -> a -> a
`div` 3
           Bool -> Bool -> Bool
&& X
py X -> X -> Bool
forall a. Ord a => a -> a -> Bool
> X
y0 X -> X -> X
forall a. Num a => a -> a -> a
+ (X
wy X -> X -> X
forall a. Num a => a -> a -> a
- 3) X -> X -> X
forall a. Integral a => a -> a -> a
`div` 3
      f :: Point -> Maybe Point
f p :: Point
p = case X -> [Point] -> Point -> Either Point Point
snapToStairList 0 [Point]
ps Point
p of
        Left{} -> Maybe Point
forall a. Maybe a
Nothing
        Right np :: 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
$ X -> [Point] -> Point -> Either Point Point
snapToStairList 0 [Point]
boot Point
np
                    in if Point -> Bool
notInCorner 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 p :: Point
p = case X -> [Point] -> Point -> Either Point Point
snapToStairList 2 [Point]
ps Point
p of
        Left{} -> Maybe Point
forall a. Maybe a
Nothing
        Right np :: 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
$ X -> [Point] -> Point -> Either Point Point
snapToStairList 2 [Point]
boot Point
np
                    in if Point -> Bool
notInCorner Point
nnp Bool -> Bool -> Bool
&& X -> Point -> Bool
dist X
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 :: X
d = if Bool
cfenceApart then 1 else 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] -> 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
$ (X, X, X, X) -> Maybe Area
toArea ( X
x0 X -> X -> X
forall a. Num a => a -> a -> a
+ 4 X -> X -> X
forall a. Num a => a -> a -> a
+ X
d, X
y0 X -> X -> X
forall a. Num a => a -> a -> a
+ 3 X -> X -> X
forall a. Num a => a -> a -> a
+ X
d
                              , X
x1 X -> X -> X
forall a. Num a => a -> a -> a
- 4 X -> X -> X
forall a. Num a => a -> a -> a
- X
d, X
y1 X -> X -> X
forall a. Num a => a -> a -> a
- X
anchorDown X -> X -> X
forall a. Num a => a -> a -> a
+ 1 )
  Maybe Point
mpos <- Area
-> (Point -> Maybe Point)
-> X
-> (Point -> Maybe Point)
-> Rnd (Maybe Point)
findPointInArea Area
focusArea Point -> Maybe Point
g 300 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
$
                "Failed to place" Text -> Text -> Text
<+> Text
object 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
<> ", 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 "possible, but unexpected; alarm!"
#endif
           else ()
  Maybe Point -> Rnd (Maybe Point)
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 :: TileSpeedup
coTileSpeedup :: COps -> TileSpeedup
coTileSpeedup} Cave{..} ldepth :: AbsDepth
ldepth ltile :: TileMap
ltile lstair :: ([Point], [Point])
lstair lescape :: [Point]
lescape =
  let f :: X -> ContentId TileKind -> X
f n :: X
n t :: ContentId TileKind
t | TileSpeedup -> ContentId TileKind -> Bool
Tile.isExplorable TileSpeedup
coTileSpeedup ContentId TileKind
t = X
n X -> X -> X
forall a. Num a => a -> a -> a
+ 1
            | Bool
otherwise = X
n
      lexpl :: X
lexpl = (X -> ContentId TileKind -> X) -> X -> TileMap -> X
forall c a. UnboxRepClass c => (a -> c -> a) -> a -> Array c -> a
PointArray.foldlA' X -> ContentId TileKind -> X
f 0 TileMap
ltile
  in $WLevel :: ContentId CaveKind
-> AbsDepth
-> ItemFloor
-> ItemFloor
-> BigActorMap
-> ProjectileMap
-> TileMap
-> EnumMap Point PlaceEntry
-> Area
-> SmellMap
-> ([Point], [Point])
-> [Point]
-> X
-> X
-> Time
-> Bool
-> Level
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 :: X
lseen = 0
       , X
lexpl :: X
lexpl :: X
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 :: ContentData CaveKind
cocave :: COps -> ContentData CaveKind
cocave} serverOptions :: ServerOptions
serverOptions caves :: Caves
caves = do
  let shuffleSegment :: ([Int], [GroupName CaveKind])
                     -> Rnd [(Int, GroupName CaveKind)]
      shuffleSegment :: ([X], [GroupName CaveKind]) -> Rnd [(X, GroupName CaveKind)]
shuffleSegment (ns :: [X]
ns, l :: [GroupName CaveKind]
l) = Bool
-> Rnd [(X, GroupName CaveKind)] -> Rnd [(X, GroupName CaveKind)]
forall a. HasCallStack => Bool -> a -> a
assert ([X] -> X
forall a. [a] -> X
length [X]
ns X -> X -> Bool
forall a. Eq a => a -> a -> Bool
== [GroupName CaveKind] -> X
forall a. [a] -> X
length [GroupName CaveKind]
l) (Rnd [(X, GroupName CaveKind)] -> Rnd [(X, GroupName CaveKind)])
-> Rnd [(X, GroupName CaveKind)] -> Rnd [(X, 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
        [(X, GroupName CaveKind)] -> Rnd [(X, GroupName CaveKind)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(X, GroupName CaveKind)] -> Rnd [(X, GroupName CaveKind)])
-> [(X, GroupName CaveKind)] -> Rnd [(X, GroupName CaveKind)]
forall a b. (a -> b) -> a -> b
$! [X] -> [GroupName CaveKind] -> [(X, GroupName CaveKind)]
forall a b. [a] -> [b] -> [(a, b)]
zip [X]
ns [GroupName CaveKind]
lShuffled
  [[(X, GroupName CaveKind)]]
cavesShuffled <- (([X], [GroupName CaveKind]) -> Rnd [(X, GroupName CaveKind)])
-> Caves -> StateT SMGen Identity [[(X, GroupName CaveKind)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([X], [GroupName CaveKind]) -> Rnd [(X, GroupName CaveKind)]
shuffleSegment Caves
caves
  let cavesFlat :: [(X, GroupName CaveKind)]
cavesFlat = [[(X, GroupName CaveKind)]] -> [(X, GroupName CaveKind)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(X, GroupName CaveKind)]]
cavesShuffled
      keys :: [X]
keys = ((X, GroupName CaveKind) -> X) -> [(X, GroupName CaveKind)] -> [X]
forall a b. (a -> b) -> [a] -> [b]
map (X, GroupName CaveKind) -> X
forall a b. (a, b) -> a
fst [(X, GroupName CaveKind)]
cavesFlat
      minD :: X
minD = [X] -> X
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [X]
keys
      maxD :: X
maxD = [X] -> X
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [X]
keys
      freshTotalDepth :: AbsDepth
freshTotalDepth = Bool -> AbsDepth -> AbsDepth
forall a. HasCallStack => Bool -> a -> a
assert (X -> X
forall a. Num a => a -> a
signum X
minD X -> X -> Bool
forall a. Eq a => a -> a -> Bool
== X -> X
forall a. Num a => a -> a
signum X
maxD)
                        (AbsDepth -> AbsDepth) -> AbsDepth -> AbsDepth
forall a b. (a -> b) -> a -> b
$ X -> AbsDepth
Dice.AbsDepth
                        (X -> AbsDepth) -> X -> AbsDepth
forall a b. (a -> b) -> a -> b
$ X -> X -> X
forall a. Ord a => a -> a -> a
max 10 (X -> X) -> X -> X
forall a b. (a -> b) -> a -> b
$ X -> X -> X
forall a. Ord a => a -> a -> a
max (X -> X
forall a. Num a => a -> a
abs X
minD) (X -> X
forall a. Num a => a -> a
abs X
maxD)
      getCaveKindNum :: (Int, GroupName CaveKind)
                     -> Rnd ((LevelId, ContentId CaveKind, CaveKind), Int)
      getCaveKindNum :: (X, GroupName CaveKind)
-> Rnd ((LevelId, ContentId CaveKind, CaveKind), X)
getCaveKindNum (ln :: X
ln, genName :: 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] -> 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 = X -> AbsDepth
Dice.AbsDepth (X -> AbsDepth) -> X -> AbsDepth
forall a b. (a -> b) -> a -> b
$ X -> X
forall a. Num a => a -> a
abs X
ln
        X
maxStairsNum <- AbsDepth -> AbsDepth -> Dice -> Rnd X
castDice AbsDepth
ldepth AbsDepth
freshTotalDepth (Dice -> Rnd X) -> Dice -> Rnd X
forall a b. (a -> b) -> a -> b
$ CaveKind -> Dice
cmaxStairsNum CaveKind
kc
        ((LevelId, ContentId CaveKind, CaveKind), X)
-> Rnd ((LevelId, ContentId CaveKind, CaveKind), X)
forall (m :: * -> *) a. Monad m => a -> m a
return ((X -> LevelId
forall a. Enum a => X -> a
toEnum X
ln, ContentId CaveKind
dkind, CaveKind
kc), X
maxStairsNum)
  [((LevelId, ContentId CaveKind, CaveKind), X)]
caveKindNums <- ((X, GroupName CaveKind)
 -> Rnd ((LevelId, ContentId CaveKind, CaveKind), X))
-> [(X, GroupName CaveKind)]
-> StateT
     SMGen Identity [((LevelId, ContentId CaveKind, CaveKind), X)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (X, GroupName CaveKind)
-> Rnd ((LevelId, ContentId CaveKind, CaveKind), X)
getCaveKindNum [(X, GroupName CaveKind)]
cavesFlat
  let (caveKinds :: [(LevelId, ContentId CaveKind, CaveKind)]
caveKinds, caveNums :: [X]
caveNums) = [((LevelId, ContentId CaveKind, CaveKind), X)]
-> ([(LevelId, ContentId CaveKind, CaveKind)], [X])
forall a b. [(a, b)] -> ([a], [b])
unzip [((LevelId, ContentId CaveKind, CaveKind), X)]
caveKindNums
      caveNumNexts :: [(X, X)]
caveNumNexts = [X] -> [X] -> [(X, X)]
forall a b. [a] -> [b] -> [(a, b)]
zip [X]
caveNums ([X] -> [(X, X)]) -> [X] -> [(X, X)]
forall a b. (a -> b) -> a -> b
$ X -> [X] -> [X]
forall a. X -> [a] -> [a]
drop 1 [X]
caveNums [X] -> [X] -> [X]
forall a. [a] -> [a] -> [a]
++ [0]
      placeStairs :: ([(Int, Int, Int)], Int)
                  -> (Int, Int)
                  -> ([(Int, Int, Int)], Int)
      placeStairs :: ([(X, X, X)], X) -> (X, X) -> ([(X, X, X)], X)
placeStairs (acc :: [(X, X, X)]
acc, nstairsFromUp :: X
nstairsFromUp) (maxStairsNum :: X
maxStairsNum, maxStairsNumNext :: X
maxStairsNumNext) =
        let !_A1 :: ()
_A1 = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (X
nstairsFromUp X -> X -> Bool
forall a. Ord a => a -> a -> Bool
<= X
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 :: X
doubleKept =
              [X] -> X
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [1, X
nstairsFromUp, X
maxStairsNum, X
maxStairsNumNext]
            nstairsFromUp1 :: X
nstairsFromUp1 = X
nstairsFromUp X -> X -> X
forall a. Num a => a -> a -> a
- X
doubleKept
            maxStairsNum1 :: X
maxStairsNum1 = X
maxStairsNum X -> X -> X
forall a. Num a => a -> a -> a
- X
doubleKept
            maxStairsNumNext1 :: X
maxStairsNumNext1 = X
maxStairsNumNext X -> X -> X
forall a. Num a => a -> a -> a
- X
doubleKept
            singleDownStairs :: X
singleDownStairs =
              X -> X -> X
forall a. Ord a => a -> a -> a
min X
maxStairsNumNext1 (X -> X) -> X -> X
forall a b. (a -> b) -> a -> b
$ X
maxStairsNum1 X -> X -> X
forall a. Num a => a -> a -> a
- X
nstairsFromUp1
            remainingNext :: X
remainingNext = X
maxStairsNumNext1 X -> X -> X
forall a. Num a => a -> a -> a
- X
singleDownStairs
            doubleDownStairs :: X
doubleDownStairs = X
doubleKept
                               X -> X -> X
forall a. Num a => a -> a -> a
+ X -> X -> X
forall a. Ord a => a -> a -> a
min X
nstairsFromUp1 X
remainingNext
            !_A2 :: ()
_A2 = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (X
singleDownStairs X -> X -> Bool
forall a. Ord a => a -> a -> Bool
>= 0) ()
            !_A3 :: ()
_A3 = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (X
doubleDownStairs X -> X -> Bool
forall a. Ord a => a -> a -> Bool
>= X
doubleKept) ()
        in ( (X
nstairsFromUp, X
doubleDownStairs, X
singleDownStairs) (X, X, X) -> [(X, X, X)] -> [(X, X, X)]
forall a. a -> [a] -> [a]
: [(X, X, X)]
acc
           , X
doubleDownStairs X -> X -> X
forall a. Num a => a -> a -> a
+ X
singleDownStairs )
      (caveStairs :: [(X, X, X)]
caveStairs, nstairsFromUpLast :: X
nstairsFromUpLast) = (([(X, X, X)], X) -> (X, X) -> ([(X, X, X)], X))
-> ([(X, X, X)], X) -> [(X, X)] -> ([(X, X, X)], X)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([(X, X, X)], X) -> (X, X) -> ([(X, X, X)], X)
placeStairs ([], 0) [(X, X)]
caveNumNexts
      caveZipped :: [((LevelId, ContentId CaveKind, CaveKind), (X, X, X))]
caveZipped = Bool
-> [((LevelId, ContentId CaveKind, CaveKind), (X, X, X))]
-> [((LevelId, ContentId CaveKind, CaveKind), (X, X, X))]
forall a. HasCallStack => Bool -> a -> a
assert (X
nstairsFromUpLast X -> X -> Bool
forall a. Eq a => a -> a -> Bool
== 0)
                   ([((LevelId, ContentId CaveKind, CaveKind), (X, X, X))]
 -> [((LevelId, ContentId CaveKind, CaveKind), (X, X, X))])
-> [((LevelId, ContentId CaveKind, CaveKind), (X, X, X))]
-> [((LevelId, ContentId CaveKind, CaveKind), (X, X, X))]
forall a b. (a -> b) -> a -> b
$ [(LevelId, ContentId CaveKind, CaveKind)]
-> [(X, X, X)]
-> [((LevelId, ContentId CaveKind, CaveKind), (X, X, X))]
forall a b. [a] -> [b] -> [(a, b)]
zip [(LevelId, ContentId CaveKind, CaveKind)]
caveKinds ([(X, X, X)] -> [(X, X, X)]
forall a. [a] -> [a]
reverse [(X, X, X)]
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), (X, X, X))
-> Rnd ([(LevelId, Level)], [(Point, Text)])
placeCaveKind (lvls :: [(LevelId, Level)]
lvls, stairsFromUp :: [(Point, Text)]
stairsFromUp)
                    ( (lid :: LevelId
lid, dkind :: ContentId CaveKind
dkind, kc :: CaveKind
kc)
                    , (nstairsFromUp :: X
nstairsFromUp, doubleDownStairs :: X
doubleDownStairs, singleDownStairs :: X
singleDownStairs) ) = do
        let !_A :: ()
_A = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert ([(Point, Text)] -> X
forall a. [a] -> X
length [(Point, Text)]
stairsFromUp X -> X -> Bool
forall a. Eq a => a -> a -> Bool
== X
nstairsFromUp) ()
        (newLevel :: Level
newLevel, ldown2 :: [(Point, Text)]
ldown2) <-
          -- lstairUp for the next level is lstairDown for the current level
          COps
-> ServerOptions
-> LevelId
-> ContentId CaveKind
-> CaveKind
-> X
-> X
-> AbsDepth
-> [(Point, Text)]
-> Rnd (Level, [(Point, Text)])
buildLevel COps
cops ServerOptions
serverOptions
                     LevelId
lid ContentId CaveKind
dkind CaveKind
kc X
doubleDownStairs X
singleDownStairs
                     AbsDepth
freshTotalDepth [(Point, Text)]
stairsFromUp
        ([(LevelId, Level)], [(Point, Text)])
-> Rnd ([(LevelId, Level)], [(Point, Text)])
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)
  (levels :: [(LevelId, Level)]
levels, stairsFromUpLast :: [(Point, Text)]
stairsFromUpLast) <- (([(LevelId, Level)], [(Point, Text)])
 -> ((LevelId, ContentId CaveKind, CaveKind), (X, X, X))
 -> Rnd ([(LevelId, Level)], [(Point, Text)]))
-> ([(LevelId, Level)], [(Point, Text)])
-> [((LevelId, ContentId CaveKind, CaveKind), (X, X, X))]
-> 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), (X, X, X))
-> Rnd ([(LevelId, Level)], [(Point, Text)])
placeCaveKind ([], []) [((LevelId, ContentId CaveKind, CaveKind), (X, X, X))]
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 (m :: * -> *) a. Monad m => a -> m a
return (FreshDungeon -> Rnd FreshDungeon)
-> FreshDungeon -> Rnd FreshDungeon
forall a b. (a -> b) -> a -> b
$! $WFreshDungeon :: Dungeon -> AbsDepth -> FreshDungeon
FreshDungeon{..}