{-# LANGUAGE TupleSections #-}
module Game.LambdaHack.Server.DungeonGen
( FreshDungeon(..), dungeonGen
#ifdef EXPOSE_INTERNAL
, 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
Nothing -> TileMap -> Rnd TileMap
forall (m :: * -> *) a. Monad m => a -> m a
return TileMap
converted1
Just pickPassable :: Rnd (ContentId TileKind)
pickPassable -> do
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)
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
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
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
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)
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
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 []
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
[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
[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
[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
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
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
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
rx :: X
rx = 9
ry :: X
ry = 6
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
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
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
#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
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
}
data FreshDungeon = FreshDungeon
{ FreshDungeon -> Dungeon
freshDungeon :: Dungeon
, FreshDungeon -> AbsDepth
freshTotalDepth :: Dice.AbsDepth
}
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) ()
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) <-
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{..}