{-# 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 qualified Game.LambdaHack.Definition.DefsInternal as DefsInternal
import Game.LambdaHack.Server.DungeonGen.AreaRnd
import Game.LambdaHack.Server.DungeonGen.Cave
import Game.LambdaHack.Server.DungeonGen.Place
import Game.LambdaHack.Server.ServerOptions
convertTileMaps :: COps -> Bool -> Rnd (ContentId TileKind)
-> Maybe (Rnd (ContentId TileKind)) -> Area -> TileMapEM
-> Rnd TileMap
convertTileMaps :: COps
-> Bool
-> Rnd (ContentId TileKind)
-> Maybe (Rnd (ContentId TileKind))
-> Area
-> TileMapEM
-> Rnd TileMap
convertTileMaps COps{ corule :: COps -> RuleContent
corule=RuleContent{Int
rWidthMax :: Int
rWidthMax :: RuleContent -> Int
rWidthMax, Int
rHeightMax :: Int
rHeightMax :: RuleContent -> Int
rHeightMax}
, ContentData TileKind
cotile :: ContentData TileKind
cotile :: COps -> ContentData TileKind
cotile
, TileSpeedup
coTileSpeedup :: TileSpeedup
coTileSpeedup :: COps -> TileSpeedup
coTileSpeedup }
Bool
areAllWalkable Rnd (ContentId TileKind)
cdefTile Maybe (Rnd (ContentId TileKind))
mpickPassable Area
darea TileMapEM
ltile = do
let outerId :: ContentId TileKind
outerId = ContentData TileKind -> GroupName TileKind -> ContentId TileKind
forall a. Show a => ContentData a -> GroupName a -> ContentId a
ouniqGroup ContentData TileKind
cotile GroupName TileKind
TK.S_UNKNOWN_OUTER_FENCE
runCdefTile :: (SM.SMGen, (Int, [(Int, ContentId TileKind)]))
-> ( ContentId TileKind
, (SM.SMGen, (Int, [(Int, ContentId TileKind)])) )
runCdefTile :: (SMGen, (Int, [(Int, ContentId TileKind)]))
-> (ContentId TileKind,
(SMGen, (Int, [(Int, ContentId TileKind)])))
runCdefTile (SMGen
gen1, (Int
pI, [(Int, ContentId TileKind)]
assocs)) =
let p :: Point
p = Int -> Point
forall a. Enum a => Int -> a
toEnum Int
pI
in if Area -> Point -> Bool
inside Area
darea Point
p
then case [(Int, ContentId TileKind)]
assocs of
(Int
p2, ContentId TileKind
t2) : [(Int, ContentId TileKind)]
rest | Int
p2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
pI -> (ContentId TileKind
t2, (SMGen
gen1, (Int
pI Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, [(Int, ContentId TileKind)]
rest)))
[(Int, ContentId TileKind)]
_ -> let (ContentId TileKind
tile, SMGen
gen2) = Rnd (ContentId TileKind) -> SMGen -> (ContentId TileKind, SMGen)
forall s a. State s a -> s -> (a, s)
St.runState Rnd (ContentId TileKind)
cdefTile SMGen
gen1
in (ContentId TileKind
tile, (SMGen
gen2, (Int
pI Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, [(Int, ContentId TileKind)]
assocs)))
else (ContentId TileKind
outerId, (SMGen
gen1, (Int
pI Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, [(Int, ContentId TileKind)]
assocs)))
runUnfold :: SMGen -> (TileMap, SMGen)
runUnfold SMGen
gen =
let (SMGen
gen1, SMGen
gen2) = SMGen -> (SMGen, SMGen)
SM.splitSMGen SMGen
gen
in (Int
-> Int
-> ((SMGen, (Int, [(Int, ContentId TileKind)]))
-> (ContentId TileKind,
(SMGen, (Int, [(Int, ContentId TileKind)]))))
-> (SMGen, (Int, [(Int, ContentId TileKind)]))
-> TileMap
forall c b.
UnboxRepClass c =>
Int -> Int -> (b -> (c, b)) -> b -> Array c
PointArray.unfoldrNA
Int
rWidthMax Int
rHeightMax (SMGen, (Int, [(Int, ContentId TileKind)]))
-> (ContentId TileKind,
(SMGen, (Int, [(Int, ContentId TileKind)])))
runCdefTile
(SMGen
gen1, (Int
0, IntMap (ContentId TileKind) -> [(Int, ContentId TileKind)]
forall a. IntMap a -> [(Int, a)]
IM.assocs (IntMap (ContentId TileKind) -> [(Int, ContentId TileKind)])
-> IntMap (ContentId TileKind) -> [(Int, ContentId TileKind)]
forall a b. (a -> b) -> a -> b
$ TileMapEM -> IntMap (ContentId TileKind)
forall k a. EnumMap k a -> IntMap a
EM.enumMapToIntMap TileMapEM
ltile)), SMGen
gen2)
TileMap
converted1 <- (SMGen -> (TileMap, SMGen)) -> Rnd TileMap
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
St.state SMGen -> (TileMap, SMGen)
runUnfold
case Maybe (Rnd (ContentId TileKind))
mpickPassable of
Maybe (Rnd (ContentId TileKind))
_ | Bool
areAllWalkable -> TileMap -> Rnd TileMap
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return TileMap
converted1
Maybe (Rnd (ContentId TileKind))
Nothing -> TileMap -> Rnd TileMap
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return TileMap
converted1
Just Rnd (ContentId TileKind)
pickPassable -> do
let passes :: Point -> TileMap -> Bool
passes Point
p TileMap
array =
TileSpeedup -> ContentId TileKind -> Bool
Tile.isWalkable TileSpeedup
coTileSpeedup (TileMap
array TileMap -> Point -> ContentId TileKind
forall c. UnboxRepClass c => Array c -> Point -> c
PointArray.! Point
p)
blocksHorizontal :: Point -> TileMap -> Bool
blocksHorizontal (Point Int
x Int
y) TileMap
array =
Bool -> Bool
not (Point -> TileMap -> Bool
passes (Int -> Int -> Point
Point (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
y) TileMap
array
Bool -> Bool -> Bool
|| Point -> TileMap -> Bool
passes (Int -> Int -> Point
Point (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int
y) TileMap
array)
blocksVertical :: Point -> TileMap -> Bool
blocksVertical (Point Int
x Int
y) TileMap
array =
Bool -> Bool
not (Point -> TileMap -> Bool
passes (Int -> Int -> Point
Point Int
x (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) TileMap
array
Bool -> Bool -> Bool
|| Point -> TileMap -> Bool
passes (Int -> Int -> Point
Point Int
x (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) TileMap
array)
activeArea :: Area
activeArea = Area -> Maybe Area -> Area
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Area
forall a. HasCallStack => [Char] -> a
error ([Char] -> Area) -> [Char] -> Area
forall a b. (a -> b) -> a -> b
$ [Char]
"" [Char] -> Area -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` Area
darea) (Maybe Area -> Area) -> Maybe Area -> Area
forall a b. (a -> b) -> a -> b
$ Area -> Maybe Area
shrink Area
darea
connect :: (Point -> Bool)
-> (Point -> TileMap -> Bool)
-> ContentId TileKind
-> TileMap
-> TileMap
connect Point -> Bool
included Point -> TileMap -> Bool
blocks ContentId TileKind
walkableTile TileMap
array =
let g :: Point -> ContentId TileKind -> ContentId TileKind
g Point
p ContentId TileKind
c = if Area -> Point -> Bool
inside Area
activeArea Point
p
Bool -> Bool -> Bool
&& Point -> Bool
included Point
p
Bool -> Bool -> Bool
&& Bool -> Bool
not (TileSpeedup -> ContentId TileKind -> Bool
Tile.isEasyOpen TileSpeedup
coTileSpeedup ContentId TileKind
c)
Bool -> Bool -> Bool
&& Point
p Point -> TileMapEM -> Bool
forall k a. Enum k => k -> EnumMap k a -> Bool
`EM.notMember` TileMapEM
ltile
Bool -> Bool -> Bool
&& Point -> TileMap -> Bool
blocks Point
p TileMap
array
then ContentId TileKind
walkableTile
else ContentId TileKind
c
in (Point -> ContentId TileKind -> ContentId TileKind)
-> TileMap -> TileMap
forall c d.
(UnboxRepClass c, UnboxRepClass d) =>
(Point -> c -> d) -> Array c -> Array d
PointArray.imapA Point -> ContentId TileKind -> ContentId TileKind
g TileMap
array
ContentId TileKind
walkable2 <- Rnd (ContentId TileKind)
pickPassable
let converted2 :: TileMap
converted2 = (Point -> Bool)
-> (Point -> TileMap -> Bool)
-> ContentId TileKind
-> TileMap
-> TileMap
connect (Int -> Bool
forall a. Integral a => a -> Bool
even (Int -> Bool) -> (Point -> Int) -> Point -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point -> Int
px) Point -> TileMap -> Bool
blocksHorizontal ContentId TileKind
walkable2 TileMap
converted1
ContentId TileKind
walkable3 <- Rnd (ContentId TileKind)
pickPassable
let converted3 :: TileMap
converted3 = (Point -> Bool)
-> (Point -> TileMap -> Bool)
-> ContentId TileKind
-> TileMap
-> TileMap
connect (Int -> Bool
forall a. Integral a => a -> Bool
even (Int -> Bool) -> (Point -> Int) -> Point -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point -> Int
py) Point -> TileMap -> Bool
blocksVertical ContentId TileKind
walkable3 TileMap
converted2
ContentId TileKind
walkable4 <- Rnd (ContentId TileKind)
pickPassable
let converted4 :: TileMap
converted4 =
(Point -> Bool)
-> (Point -> TileMap -> Bool)
-> ContentId TileKind
-> TileMap
-> TileMap
connect (Int -> Bool
forall a. Integral a => a -> Bool
odd (Int -> Bool) -> (Point -> Int) -> Point -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point -> Int
px) Point -> TileMap -> Bool
blocksHorizontal ContentId TileKind
walkable4 TileMap
converted3
ContentId TileKind
walkable5 <- Rnd (ContentId TileKind)
pickPassable
let converted5 :: TileMap
converted5 =
(Point -> Bool)
-> (Point -> TileMap -> Bool)
-> ContentId TileKind
-> TileMap
-> TileMap
connect (Int -> Bool
forall a. Integral a => a -> Bool
odd (Int -> Bool) -> (Point -> Int) -> Point -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point -> Int
py) Point -> TileMap -> Bool
blocksVertical ContentId TileKind
walkable5 TileMap
converted4
TileMap -> Rnd TileMap
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return TileMap
converted5
buildTileMap :: COps -> Cave -> Rnd TileMap
buildTileMap :: COps -> Cave -> Rnd TileMap
buildTileMap cops :: COps
cops@COps{ContentData TileKind
cotile :: COps -> ContentData TileKind
cotile :: ContentData TileKind
cotile, ContentData CaveKind
cocave :: ContentData CaveKind
cocave :: COps -> ContentData CaveKind
cocave} Cave{ContentId CaveKind
dkind :: ContentId CaveKind
dkind :: Cave -> ContentId CaveKind
dkind, Area
darea :: Area
darea :: Cave -> Area
darea, TileMapEM
dmap :: TileMapEM
dmap :: Cave -> TileMapEM
dmap} = do
let CaveKind{Bool
cpassable :: Bool
cpassable :: CaveKind -> Bool
cpassable, GroupName TileKind
cdefTile :: GroupName TileKind
cdefTile :: CaveKind -> GroupName TileKind
cdefTile} = ContentData CaveKind -> ContentId CaveKind -> CaveKind
forall a. ContentData a -> ContentId a -> a
okind ContentData CaveKind
cocave ContentId CaveKind
dkind
pickDefTile :: Rnd (ContentId TileKind)
pickDefTile = ContentId TileKind
-> Maybe (ContentId TileKind) -> ContentId TileKind
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> ContentId TileKind
forall a. HasCallStack => [Char] -> a
error ([Char] -> ContentId TileKind) -> [Char] -> ContentId TileKind
forall a b. (a -> b) -> a -> b
$ [Char]
"" [Char] -> GroupName TileKind -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` GroupName TileKind
cdefTile)
(Maybe (ContentId TileKind) -> ContentId TileKind)
-> StateT SMGen Identity (Maybe (ContentId TileKind))
-> Rnd (ContentId TileKind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContentData TileKind
-> GroupName TileKind
-> (TileKind -> Bool)
-> StateT SMGen Identity (Maybe (ContentId TileKind))
forall a.
Show a =>
ContentData a
-> GroupName a -> (a -> Bool) -> Rnd (Maybe (ContentId a))
opick ContentData TileKind
cotile GroupName TileKind
cdefTile (Bool -> TileKind -> Bool
forall a b. a -> b -> a
const Bool
True)
wcond :: TileKind -> Bool
wcond = TileKind -> Bool
Tile.isEasyOpenKind
mpickPassable :: Maybe (Rnd (ContentId TileKind))
mpickPassable =
if Bool
cpassable
then Rnd (ContentId TileKind) -> Maybe (Rnd (ContentId TileKind))
forall a. a -> Maybe a
Just (Rnd (ContentId TileKind) -> Maybe (Rnd (ContentId TileKind)))
-> Rnd (ContentId TileKind) -> Maybe (Rnd (ContentId TileKind))
forall a b. (a -> b) -> a -> b
$ ContentId TileKind
-> Maybe (ContentId TileKind) -> ContentId TileKind
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> ContentId TileKind
forall a. HasCallStack => [Char] -> a
error ([Char] -> ContentId TileKind) -> [Char] -> ContentId TileKind
forall a b. (a -> b) -> a -> b
$ [Char]
"" [Char] -> GroupName TileKind -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` GroupName TileKind
cdefTile)
(Maybe (ContentId TileKind) -> ContentId TileKind)
-> StateT SMGen Identity (Maybe (ContentId TileKind))
-> Rnd (ContentId TileKind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContentData TileKind
-> GroupName TileKind
-> (TileKind -> Bool)
-> StateT SMGen Identity (Maybe (ContentId TileKind))
forall a.
Show a =>
ContentData a
-> GroupName a -> (a -> Bool) -> Rnd (Maybe (ContentId a))
opick ContentData TileKind
cotile GroupName TileKind
cdefTile TileKind -> Bool
wcond
else Maybe (Rnd (ContentId TileKind))
forall a. Maybe a
Nothing
nwcond :: TileKind -> Bool
nwcond = Bool -> Bool
not (Bool -> Bool) -> (TileKind -> Bool) -> TileKind -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Feature -> TileKind -> Bool
Tile.kindHasFeature Feature
TK.Walkable
Bool
areAllWalkable <- Maybe (ContentId TileKind) -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe (ContentId TileKind) -> Bool)
-> StateT SMGen Identity (Maybe (ContentId TileKind))
-> StateT SMGen Identity Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContentData TileKind
-> GroupName TileKind
-> (TileKind -> Bool)
-> StateT SMGen Identity (Maybe (ContentId TileKind))
forall a.
Show a =>
ContentData a
-> GroupName a -> (a -> Bool) -> Rnd (Maybe (ContentId a))
opick ContentData TileKind
cotile GroupName TileKind
cdefTile TileKind -> Bool
nwcond
COps
-> Bool
-> Rnd (ContentId TileKind)
-> Maybe (Rnd (ContentId TileKind))
-> Area
-> TileMapEM
-> Rnd TileMap
convertTileMaps COps
cops Bool
areAllWalkable Rnd (ContentId TileKind)
pickDefTile Maybe (Rnd (ContentId TileKind))
mpickPassable Area
darea TileMapEM
dmap
anchorDown :: Y
anchorDown :: Int
anchorDown = Int
5
buildLevel :: COps -> ServerOptions
-> LevelId -> ContentId CaveKind -> CaveKind -> Int -> Int
-> Dice.AbsDepth -> [(Point, Text)]
-> Rnd (Level, [(Point, Text)])
buildLevel :: COps
-> ServerOptions
-> LevelId
-> ContentId CaveKind
-> CaveKind
-> Int
-> Int
-> AbsDepth
-> [(Point, Text)]
-> Rnd (Level, [(Point, Text)])
buildLevel cops :: COps
cops@COps{ContentData PlaceKind
coplace :: ContentData PlaceKind
coplace :: COps -> ContentData PlaceKind
coplace, corule :: COps -> RuleContent
corule=RuleContent{Int
[Char]
[Text]
(Text, Config)
Version
ItemSymbolsUsedInEngine
rWidthMax :: RuleContent -> Int
rHeightMax :: RuleContent -> Int
rtitle :: [Char]
rWidthMax :: Int
rHeightMax :: Int
rexeVersion :: Version
rcfgUIName :: [Char]
rcfgUIDefault :: (Text, Config)
rwriteSaveClips :: Int
rleadLevelClips :: Int
rscoresFileName :: [Char]
rnearby :: Int
rstairWordCarried :: [Text]
ritemSymbols :: ItemSymbolsUsedInEngine
rtitle :: RuleContent -> [Char]
rexeVersion :: RuleContent -> Version
rcfgUIName :: RuleContent -> [Char]
rcfgUIDefault :: RuleContent -> (Text, Config)
rwriteSaveClips :: RuleContent -> Int
rleadLevelClips :: RuleContent -> Int
rscoresFileName :: RuleContent -> [Char]
rnearby :: RuleContent -> Int
rstairWordCarried :: RuleContent -> [Text]
ritemSymbols :: RuleContent -> ItemSymbolsUsedInEngine
..}} ServerOptions
serverOptions
LevelId
lid ContentId CaveKind
dkind CaveKind
kc Int
doubleDownStairs Int
singleDownStairs
AbsDepth
totalDepth [(Point, Text)]
stairsFromUp = do
let d :: Int
d = if CaveKind -> Bool
cfenceApart CaveKind
kc then Int
1 else Int
0
ldepth :: AbsDepth
ldepth = Int -> AbsDepth
Dice.AbsDepth (Int -> AbsDepth) -> Int -> AbsDepth
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a. Num a => a -> a
abs (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ LevelId -> Int
forall a. Enum a => a -> Int
fromEnum LevelId
lid
darea :: Area
darea =
let ([Int]
lxPrev, [Int]
lyPrev) = [(Int, Int)] -> ([Int], [Int])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Int, Int)] -> ([Int], [Int])) -> [(Int, Int)] -> ([Int], [Int])
forall a b. (a -> b) -> a -> b
$ ((Point, Text) -> (Int, Int)) -> [(Point, Text)] -> [(Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map ((Point -> Int
px (Point -> Int) -> (Point -> Int) -> Point -> (Int, Int)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Point -> Int
py) (Point -> (Int, Int))
-> ((Point, Text) -> Point) -> (Point, Text) -> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point, Text) -> Point
forall a b. (a, b) -> a
fst) [(Point, Text)]
stairsFromUp
lxMin :: Int
lxMin = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0
(Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ -Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum (Int
rWidthMax Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
lxPrev)
lxMax :: Int
lxMax = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
rWidthMax Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
(Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Int
0 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
lxPrev)
lyMin :: Int
lyMin = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0
(Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ -Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum (Int
rHeightMax Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
lyPrev)
lyMax :: Int
lyMax = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
rHeightMax Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
(Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Int
0 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
lyPrev)
xspan :: Int
xspan = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (Int
lxMax Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
lxMin Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ CaveKind -> Int
cXminSize CaveKind
kc
yspan :: Int
yspan = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (Int
lyMax Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
lyMin Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ CaveKind -> Int
cYminSize CaveKind
kc
x0 :: Int
x0 = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
lxMin (Int
rWidthMax Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
xspan)
y0 :: Int
y0 = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
lyMin (Int
rHeightMax Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
yspan)
in Area -> Maybe Area -> Area
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Area
forall a. HasCallStack => [Char] -> a
error ([Char] -> Area) -> [Char] -> Area
forall a b. (a -> b) -> a -> b
$ [Char]
"" [Char] -> CaveKind -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` CaveKind
kc)
(Maybe Area -> Area) -> Maybe Area -> Area
forall a b. (a -> b) -> a -> b
$ (Int, Int, Int, Int) -> Maybe Area
toArea (Int
x0, Int
y0, Int
x0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
xspan Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Int
y0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
yspan Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
([(Point, Text)]
lstairsDouble, [(Point, Text)]
lstairsSingleUp) = Int -> [(Point, Text)] -> ([(Point, Text)], [(Point, Text)])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
doubleDownStairs [(Point, Text)]
stairsFromUp
pstairsSingleUp :: [Point]
pstairsSingleUp = ((Point, Text) -> Point) -> [(Point, Text)] -> [Point]
forall a b. (a -> b) -> [a] -> [b]
map (Point, Text) -> Point
forall a b. (a, b) -> a
fst [(Point, Text)]
lstairsSingleUp
pstairsDouble :: [Point]
pstairsDouble = ((Point, Text) -> Point) -> [(Point, Text)] -> [Point]
forall a b. (a -> b) -> [a] -> [b]
map (Point, Text) -> Point
forall a b. (a, b) -> a
fst [(Point, Text)]
lstairsDouble
pallUpStairs :: [Point]
pallUpStairs = [Point]
pstairsDouble [Point] -> [Point] -> [Point]
forall a. [a] -> [a] -> [a]
++ [Point]
pstairsSingleUp
boot :: [Point]
boot = let (Int
x0, Int
y0, Int
x1, Int
y1) = Area -> (Int, Int, Int, Int)
fromArea Area
darea
in [Either Point Point] -> [Point]
forall a b. [Either a b] -> [b]
rights ([Either Point Point] -> [Point])
-> [Either Point Point] -> [Point]
forall a b. (a -> b) -> a -> b
$ (Point -> Either Point Point) -> [Point] -> [Either Point Point]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> [Point] -> Point -> Either Point Point
snapToStairList Int
0 [Point]
pallUpStairs)
[ Int -> Int -> Point
Point (Int
x0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
d) (Int
y0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
d)
, Int -> Int -> Point
Point (Int
x1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
d) (Int
y1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
anchorDown Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ]
[(Point, Freqs PlaceKind)]
fixedEscape <- case CaveKind -> Freqs PlaceKind
cescapeFreq CaveKind
kc of
[] -> [(Point, Freqs PlaceKind)]
-> StateT SMGen Identity [(Point, Freqs PlaceKind)]
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return []
Freqs PlaceKind
escapeFreq -> do
Maybe Point
mepos <- Text
-> Bool
-> ServerOptions
-> LevelId
-> CaveKind
-> Area
-> [Point]
-> [Point]
-> Rnd (Maybe Point)
placeDownStairs Text
"escape" Bool
True ServerOptions
serverOptions LevelId
lid
CaveKind
kc Area
darea [Point]
pallUpStairs [Point]
boot
case Maybe Point
mepos of
Just Point
epos -> [(Point, Freqs PlaceKind)]
-> StateT SMGen Identity [(Point, Freqs PlaceKind)]
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Point
epos, Freqs PlaceKind
escapeFreq)]
Maybe Point
Nothing -> [(Point, Freqs PlaceKind)]
-> StateT SMGen Identity [(Point, Freqs PlaceKind)]
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return []
let pescape :: [Point]
pescape = ((Point, Freqs PlaceKind) -> Point)
-> [(Point, Freqs PlaceKind)] -> [Point]
forall a b. (a -> b) -> [a] -> [b]
map (Point, Freqs PlaceKind) -> Point
forall a b. (a, b) -> a
fst [(Point, Freqs PlaceKind)]
fixedEscape
pallUpAndEscape :: [Point]
pallUpAndEscape = [Point]
pescape [Point] -> [Point] -> [Point]
forall a. [a] -> [a] -> [a]
++ [Point]
pallUpStairs
addSingleDown :: [Point] -> Int -> Rnd [Point]
addSingleDown :: [Point] -> Int -> Rnd [Point]
addSingleDown [Point]
acc Int
0 = [Point] -> Rnd [Point]
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return [Point]
acc
addSingleDown [Point]
acc Int
k = do
Maybe Point
mpos <- Text
-> Bool
-> ServerOptions
-> LevelId
-> CaveKind
-> Area
-> [Point]
-> [Point]
-> Rnd (Maybe Point)
placeDownStairs Text
"stairs" Bool
False ServerOptions
serverOptions LevelId
lid
CaveKind
kc Area
darea ([Point]
pallUpAndEscape [Point] -> [Point] -> [Point]
forall a. [a] -> [a] -> [a]
++ [Point]
acc) [Point]
boot
case Maybe Point
mpos of
Just Point
pos -> [Point] -> Int -> Rnd [Point]
addSingleDown (Point
pos Point -> [Point] -> [Point]
forall a. a -> [a] -> [a]
: [Point]
acc) (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
Maybe Point
Nothing -> [Point] -> Rnd [Point]
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return [Point]
acc
[Point]
pstairsSingleDown <- [Point] -> Int -> Rnd [Point]
addSingleDown [] Int
singleDownStairs
let freqDouble :: Text -> Freqs PlaceKind
freqDouble Text
carried =
((GroupName PlaceKind, Int) -> Bool)
-> Freqs PlaceKind -> Freqs PlaceKind
forall a. (a -> Bool) -> [a] -> [a]
filter (\(GroupName PlaceKind
gn, Int
_) ->
Text
carried Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Text -> [Text]
T.words (GroupName PlaceKind -> Text
forall c. GroupName c -> Text
DefsInternal.fromGroupName GroupName PlaceKind
gn))
(Freqs PlaceKind -> Freqs PlaceKind)
-> Freqs PlaceKind -> Freqs PlaceKind
forall a b. (a -> b) -> a -> b
$ CaveKind -> Freqs PlaceKind
cstairFreq CaveKind
kc Freqs PlaceKind -> Freqs PlaceKind -> Freqs PlaceKind
forall a. [a] -> [a] -> [a]
++ CaveKind -> Freqs PlaceKind
cstairAllowed CaveKind
kc
fixedStairsDouble :: [(Point, Freqs PlaceKind)]
fixedStairsDouble = ((Point, Text) -> (Point, Freqs PlaceKind))
-> [(Point, Text)] -> [(Point, Freqs PlaceKind)]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Freqs PlaceKind)
-> (Point, Text) -> (Point, Freqs PlaceKind)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second Text -> Freqs PlaceKind
freqDouble) [(Point, Text)]
lstairsDouble
freqUp :: Text -> Freqs PlaceKind
freqUp Text
carried = (Text -> Text) -> Freqs PlaceKind -> Freqs PlaceKind
forall c. (Text -> Text) -> Freqs c -> Freqs c
renameFreqs (Text -> Text -> Text
<+> Text
"up") (Freqs PlaceKind -> Freqs PlaceKind)
-> Freqs PlaceKind -> Freqs PlaceKind
forall a b. (a -> b) -> a -> b
$ Text -> Freqs PlaceKind
freqDouble Text
carried
fixedStairsUp :: [(Point, Freqs PlaceKind)]
fixedStairsUp = ((Point, Text) -> (Point, Freqs PlaceKind))
-> [(Point, Text)] -> [(Point, Freqs PlaceKind)]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Freqs PlaceKind)
-> (Point, Text) -> (Point, Freqs PlaceKind)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second Text -> Freqs PlaceKind
freqUp) [(Point, Text)]
lstairsSingleUp
freqDown :: Freqs PlaceKind
freqDown = (Text -> Text) -> Freqs PlaceKind -> Freqs PlaceKind
forall c. (Text -> Text) -> Freqs c -> Freqs c
renameFreqs (Text -> Text -> Text
<+> Text
"down") (Freqs PlaceKind -> Freqs PlaceKind)
-> Freqs PlaceKind -> Freqs PlaceKind
forall a b. (a -> b) -> a -> b
$ CaveKind -> Freqs PlaceKind
cstairFreq CaveKind
kc
fixedStairsDown :: [(Point, Freqs PlaceKind)]
fixedStairsDown = (Point -> (Point, Freqs PlaceKind))
-> [Point] -> [(Point, Freqs PlaceKind)]
forall a b. (a -> b) -> [a] -> [b]
map (, Freqs PlaceKind
freqDown) [Point]
pstairsSingleDown
pallExits :: [Point]
pallExits = [Point]
pallUpAndEscape [Point] -> [Point] -> [Point]
forall a. [a] -> [a] -> [a]
++ [Point]
pstairsSingleDown
fixedCenters :: EnumMap Point (Freqs PlaceKind)
fixedCenters = [(Point, Freqs PlaceKind)] -> EnumMap Point (Freqs PlaceKind)
forall k a. Enum k => [(k, a)] -> EnumMap k a
EM.fromList ([(Point, Freqs PlaceKind)] -> EnumMap Point (Freqs PlaceKind))
-> [(Point, Freqs PlaceKind)] -> EnumMap Point (Freqs PlaceKind)
forall a b. (a -> b) -> a -> b
$
[(Point, Freqs PlaceKind)]
fixedEscape [(Point, Freqs PlaceKind)]
-> [(Point, Freqs PlaceKind)] -> [(Point, Freqs PlaceKind)]
forall a. [a] -> [a] -> [a]
++ [(Point, Freqs PlaceKind)]
fixedStairsDouble [(Point, Freqs PlaceKind)]
-> [(Point, Freqs PlaceKind)] -> [(Point, Freqs PlaceKind)]
forall a. [a] -> [a] -> [a]
++ [(Point, Freqs PlaceKind)]
fixedStairsUp [(Point, Freqs PlaceKind)]
-> [(Point, Freqs PlaceKind)] -> [(Point, Freqs PlaceKind)]
forall a. [a] -> [a] -> [a]
++ [(Point, Freqs PlaceKind)]
fixedStairsDown
[Point]
bootExtra <- if EnumMap Point (Freqs PlaceKind) -> Bool
forall k a. EnumMap k a -> Bool
EM.null EnumMap Point (Freqs PlaceKind)
fixedCenters then do
Maybe Point
mpointExtra <-
Text
-> Bool
-> ServerOptions
-> LevelId
-> CaveKind
-> Area
-> [Point]
-> [Point]
-> Rnd (Maybe Point)
placeDownStairs Text
"extra boot" Bool
False ServerOptions
serverOptions LevelId
lid
CaveKind
kc Area
darea [Point]
pallExits [Point]
boot
[Point] -> Rnd [Point]
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Point] -> Rnd [Point]) -> [Point] -> Rnd [Point]
forall a b. (a -> b) -> a -> b
$! Maybe Point -> [Point]
forall a. Maybe a -> [a]
maybeToList Maybe Point
mpointExtra
else [Point] -> Rnd [Point]
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return []
let posUp :: Point -> Point
posUp Point{Int
px :: Point -> Int
py :: Point -> Int
px :: Int
py :: Int
..} = Int -> Int -> Point
Point (Int
px Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int
py
posDn :: Point -> Point
posDn Point{Int
px :: Point -> Int
py :: Point -> Int
px :: Int
py :: Int
..} = Int -> Int -> Point
Point (Int
px Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
py
lstair :: ([Point], [Point])
lstair = ( (Point -> Point) -> [Point] -> [Point]
forall a b. (a -> b) -> [a] -> [b]
map Point -> Point
posUp ([Point] -> [Point]) -> [Point] -> [Point]
forall a b. (a -> b) -> a -> b
$ [Point]
pstairsDouble [Point] -> [Point] -> [Point]
forall a. [a] -> [a] -> [a]
++ [Point]
pstairsSingleUp
, (Point -> Point) -> [Point] -> [Point]
forall a b. (a -> b) -> [a] -> [b]
map Point -> Point
posDn ([Point] -> [Point]) -> [Point] -> [Point]
forall a b. (a -> b) -> a -> b
$ [Point]
pstairsDouble [Point] -> [Point] -> [Point]
forall a. [a] -> [a] -> [a]
++ [Point]
pstairsSingleDown )
(Int, Int)
cellSize <- AbsDepth -> AbsDepth -> DiceXY -> Rnd (Int, Int)
castDiceXY AbsDepth
ldepth AbsDepth
totalDepth (DiceXY -> Rnd (Int, Int)) -> DiceXY -> Rnd (Int, Int)
forall a b. (a -> b) -> a -> b
$ CaveKind -> DiceXY
ccellSize CaveKind
kc
let subArea :: Area
subArea = Area -> Maybe Area -> Area
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Area
forall a. HasCallStack => [Char] -> a
error ([Char] -> Area) -> [Char] -> Area
forall a b. (a -> b) -> a -> b
$ [Char]
"" [Char] -> CaveKind -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` CaveKind
kc) (Maybe Area -> Area) -> Maybe Area -> Area
forall a b. (a -> b) -> a -> b
$ Area -> Maybe Area
shrink Area
darea
area :: Area
area = if CaveKind -> Bool
cfenceApart CaveKind
kc then Area
subArea else Area
darea
((Int, Int)
lgr, EnumMap Point SpecialArea
gs) = EnumMap Point (Freqs PlaceKind)
-> [Point]
-> Area
-> (Int, Int)
-> ((Int, Int), EnumMap Point SpecialArea)
grid EnumMap Point (Freqs PlaceKind)
fixedCenters ([Point]
boot [Point] -> [Point] -> [Point]
forall a. [a] -> [a] -> [a]
++ [Point]
bootExtra) Area
area (Int, Int)
cellSize
Word32
dsecret <- Rnd Word32
randomWord32
Cave
cave <- COps
-> AbsDepth
-> AbsDepth
-> Area
-> Word32
-> ContentId CaveKind
-> (Int, Int)
-> EnumMap Point SpecialArea
-> [Point]
-> Rnd Cave
buildCave COps
cops AbsDepth
ldepth AbsDepth
totalDepth Area
darea Word32
dsecret ContentId CaveKind
dkind (Int, Int)
lgr EnumMap Point SpecialArea
gs [Point]
bootExtra
TileMap
cmap <- COps -> Cave -> Rnd TileMap
buildTileMap COps
cops Cave
cave
let !lvl :: Level
lvl = COps
-> Cave
-> AbsDepth
-> TileMap
-> ([Point], [Point])
-> [Point]
-> Level
levelFromCave COps
cops Cave
cave AbsDepth
ldepth TileMap
cmap ([Point], [Point])
lstair [Point]
pescape
stairCarried :: Point -> (Point, Text)
stairCarried Point
p0 =
let Place{ContentId PlaceKind
qkind :: ContentId PlaceKind
qkind :: Place -> ContentId PlaceKind
qkind} = Cave -> EnumMap Point Place
dstairs Cave
cave EnumMap Point Place -> Point -> Place
forall k a. Enum k => EnumMap k a -> k -> a
EM.! Point
p0
freq :: [([Text], Int)]
freq = ((GroupName PlaceKind, Int) -> ([Text], Int))
-> Freqs PlaceKind -> [([Text], Int)]
forall a b. (a -> b) -> [a] -> [b]
map ((GroupName PlaceKind -> [Text])
-> (GroupName PlaceKind, Int) -> ([Text], Int)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((GroupName PlaceKind -> [Text])
-> (GroupName PlaceKind, Int) -> ([Text], Int))
-> (GroupName PlaceKind -> [Text])
-> (GroupName PlaceKind, Int)
-> ([Text], Int)
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.words (Text -> [Text])
-> (GroupName PlaceKind -> Text) -> GroupName PlaceKind -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GroupName PlaceKind -> Text
forall a. Show a => a -> Text
tshow)
(PlaceKind -> Freqs PlaceKind
PK.pfreq (PlaceKind -> Freqs PlaceKind) -> PlaceKind -> Freqs PlaceKind
forall a b. (a -> b) -> a -> b
$ ContentData PlaceKind -> ContentId PlaceKind -> PlaceKind
forall a. ContentData a -> ContentId a -> a
okind ContentData PlaceKind
coplace ContentId PlaceKind
qkind)
carriedAll :: [Text]
carriedAll = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Text
t -> (([Text], Int) -> Bool) -> [([Text], Int)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\([Text]
ws, Int
_) -> Text
t Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
ws) [([Text], Int)]
freq)
[Text]
rstairWordCarried
in case [Text]
carriedAll of
[Text
t] -> (Point
p0, Text
t)
[Text]
_ -> [Char] -> (Point, Text)
forall a. HasCallStack => [Char] -> a
error ([Char] -> (Point, Text)) -> [Char] -> (Point, Text)
forall a b. (a -> b) -> a -> b
$ [Char]
"wrong carried stair word"
[Char] -> ([([Text], Int)], [Text], CaveKind) -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` ([([Text], Int)]
freq, [Text]
carriedAll, CaveKind
kc)
(Level, [(Point, Text)]) -> Rnd (Level, [(Point, Text)])
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Level
lvl, [(Point, Text)]
lstairsDouble [(Point, Text)] -> [(Point, Text)] -> [(Point, Text)]
forall a. [a] -> [a] -> [a]
++ (Point -> (Point, Text)) -> [Point] -> [(Point, Text)]
forall a b. (a -> b) -> [a] -> [b]
map Point -> (Point, Text)
stairCarried [Point]
pstairsSingleDown)
snapToStairList :: Int -> [Point] -> Point -> Either Point Point
snapToStairList :: Int -> [Point] -> Point -> Either Point Point
snapToStairList Int
_ [] Point
p = Point -> Either Point Point
forall a b. b -> Either a b
Right Point
p
snapToStairList Int
a (Point
pos : [Point]
rest) Point
p =
let nx :: Int
nx = if Point -> Int
px Point
pos Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Point -> Int
px Point
p Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
5 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
a Bool -> Bool -> Bool
|| Point -> Int
px Point
pos Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Point -> Int
px Point
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
5 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
a
then Point -> Int
px Point
p
else Point -> Int
px Point
pos
ny :: Int
ny = if Point -> Int
py Point
pos Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Point -> Int
py Point
p Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
a Bool -> Bool -> Bool
|| Point -> Int
py Point
pos Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Point -> Int
py Point
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
a
then Point -> Int
py Point
p
else Point -> Int
py Point
pos
np :: Point
np = Int -> Int -> Point
Point Int
nx Int
ny
in if Point
np Point -> Point -> Bool
forall a. Eq a => a -> a -> Bool
== Point
pos then Point -> Either Point Point
forall a b. a -> Either a b
Left Point
np else Int -> [Point] -> Point -> Either Point Point
snapToStairList Int
a [Point]
rest Point
np
placeDownStairs :: Text -> Bool -> ServerOptions -> LevelId
-> CaveKind -> Area -> [Point] -> [Point]
-> Rnd (Maybe Point)
placeDownStairs :: Text
-> Bool
-> ServerOptions
-> LevelId
-> CaveKind
-> Area
-> [Point]
-> [Point]
-> Rnd (Maybe Point)
placeDownStairs Text
object Bool
cornerPermitted ServerOptions
serverOptions LevelId
lid
CaveKind{Int
cminStairDist :: Int
cminStairDist :: CaveKind -> Int
cminStairDist, Bool
cfenceApart :: CaveKind -> Bool
cfenceApart :: Bool
cfenceApart} Area
darea [Point]
ps [Point]
boot = do
let dist :: Int -> Point -> Bool
dist Int
cmin Point
p = (Point -> Bool) -> [Point] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Point
pos -> Point -> Point -> Int
chessDist Point
p Point
pos Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
cmin) [Point]
ps
(Int
x0, Int
y0, Int
x1, Int
y1) = Area -> (Int, Int, Int, Int)
fromArea Area
darea
rx :: Int
rx = Int
9
ry :: Int
ry = Int
6
wx :: Int
wx = Int
x1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
x0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
wy :: Int
wy = Int
y1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
y0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
notInCornerEtc :: Point -> Bool
notInCornerEtc Point{Int
px :: Point -> Int
py :: Point -> Int
px :: Int
py :: Int
..} =
Bool
cornerPermitted
Bool -> Bool -> Bool
|| Int
wx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
rx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3 Bool -> Bool -> Bool
|| Int
wy Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
ry Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3
Bool -> Bool -> Bool
|| Int
px Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
x0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
wx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
3) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
3
Bool -> Bool -> Bool
&& Int
py Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
y0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
wy Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
3) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
3
inCorner :: Point -> Bool
inCorner Point{Int
px :: Point -> Int
py :: Point -> Int
px :: Int
py :: Int
..} = (Int
px Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
x0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
rx Bool -> Bool -> Bool
|| Int
px Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
x1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
rx)
Bool -> Bool -> Bool
&& (Int
py Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
y0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ry Bool -> Bool -> Bool
|| Int
py Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
y1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ry)
gpreference :: Point -> Bool
gpreference = if Bool
cornerPermitted then Point -> Bool
inCorner else Point -> Bool
notInCornerEtc
f :: Point -> Maybe Point
f Point
p = case Int -> [Point] -> Point -> Either Point Point
snapToStairList Int
0 [Point]
ps Point
p of
Left{} -> Maybe Point
forall a. Maybe a
Nothing
Right Point
np -> let nnp :: Point
nnp = (Point -> Point) -> (Point -> Point) -> Either Point Point -> Point
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Point -> Point
forall a. a -> a
id Point -> Point
forall a. a -> a
id (Either Point Point -> Point) -> Either Point Point -> Point
forall a b. (a -> b) -> a -> b
$ Int -> [Point] -> Point -> Either Point Point
snapToStairList Int
0 [Point]
boot Point
np
in if Point -> Bool
notInCornerEtc Point
nnp then Point -> Maybe Point
forall a. a -> Maybe a
Just Point
nnp else Maybe Point
forall a. Maybe a
Nothing
g :: Point -> Maybe Point
g Point
p = case Int -> [Point] -> Point -> Either Point Point
snapToStairList Int
2 [Point]
ps Point
p of
Left{} -> Maybe Point
forall a. Maybe a
Nothing
Right Point
np -> let nnp :: Point
nnp = (Point -> Point) -> (Point -> Point) -> Either Point Point -> Point
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Point -> Point
forall a. a -> a
id Point -> Point
forall a. a -> a
id (Either Point Point -> Point) -> Either Point Point -> Point
forall a b. (a -> b) -> a -> b
$ Int -> [Point] -> Point -> Either Point Point
snapToStairList Int
2 [Point]
boot Point
np
in if Point -> Bool
gpreference Point
nnp Bool -> Bool -> Bool
&& Int -> Point -> Bool
dist Int
cminStairDist Point
nnp
then Point -> Maybe Point
forall a. a -> Maybe a
Just Point
nnp
else Maybe Point
forall a. Maybe a
Nothing
focusArea :: Area
focusArea = let d :: Int
d = if Bool
cfenceApart then Int
1 else Int
0
in Area -> Maybe Area -> Area
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Area
forall a. HasCallStack => [Char] -> a
error ([Char] -> Area) -> [Char] -> Area
forall a b. (a -> b) -> a -> b
$ [Char]
"" [Char] -> Area -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` Area
darea)
(Maybe Area -> Area) -> Maybe Area -> Area
forall a b. (a -> b) -> a -> b
$ (Int, Int, Int, Int) -> Maybe Area
toArea ( Int
x0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
d, Int
y0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
d
, Int
x1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
d, Int
y1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
anchorDown Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 )
Maybe Point
mpos <- Area
-> (Point -> Maybe Point)
-> Int
-> (Point -> Maybe Point)
-> Rnd (Maybe Point)
findPointInArea Area
focusArea Point -> Maybe Point
g Int
500 Point -> Maybe Point
f
let !()
_ = if Maybe Point -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Point
mpos Bool -> Bool -> Bool
&& ServerOptions -> Bool
sdumpInitRngs ServerOptions
serverOptions
then IO () -> ()
forall a. IO a -> a
unsafePerformIO (IO () -> ()) -> IO () -> ()
forall a b. (a -> b) -> a -> b
$ do
Handle -> Text -> IO ()
T.hPutStrLn Handle
stdout (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
Text
"Failed to place" Text -> Text -> Text
<+> Text
object Text -> Text -> Text
<+> Text
"on level"
Text -> Text -> Text
<+> LevelId -> Text
forall a. Show a => a -> Text
tshow LevelId
lid Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", in" Text -> Text -> Text
<+> Area -> Text
forall a. Show a => a -> Text
tshow Area
darea
Handle -> IO ()
hFlush Handle
stdout
#ifdef WITH_EXPENSIVE_ASSERTIONS
[Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"possible, but unexpected; alarm!"
#endif
else ()
Maybe Point -> Rnd (Maybe Point)
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Point
mpos
levelFromCave :: COps -> Cave -> Dice.AbsDepth
-> TileMap -> ([Point], [Point]) -> [Point]
-> Level
levelFromCave :: COps
-> Cave
-> AbsDepth
-> TileMap
-> ([Point], [Point])
-> [Point]
-> Level
levelFromCave COps{TileSpeedup
coTileSpeedup :: COps -> TileSpeedup
coTileSpeedup :: TileSpeedup
coTileSpeedup} Cave{Bool
TileMapEM
EnumMap Point PlaceEntry
EnumMap Point Place
ContentId CaveKind
Area
dkind :: Cave -> ContentId CaveKind
darea :: Cave -> Area
dmap :: Cave -> TileMapEM
dstairs :: Cave -> EnumMap Point Place
dkind :: ContentId CaveKind
darea :: Area
dmap :: TileMapEM
dstairs :: EnumMap Point Place
dentry :: EnumMap Point PlaceEntry
dnight :: Bool
dentry :: Cave -> EnumMap Point PlaceEntry
dnight :: Cave -> Bool
..} AbsDepth
ldepth TileMap
ltile ([Point], [Point])
lstair [Point]
lescape =
let f :: Int -> ContentId TileKind -> Int
f Int
n ContentId TileKind
t | TileSpeedup -> ContentId TileKind -> Bool
Tile.isExplorable TileSpeedup
coTileSpeedup ContentId TileKind
t = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
| Bool
otherwise = Int
n
lexpl :: Int
lexpl = (Int -> ContentId TileKind -> Int) -> Int -> TileMap -> Int
forall c a. UnboxRepClass c => (a -> c -> a) -> a -> Array c -> a
PointArray.foldlA' Int -> ContentId TileKind -> Int
f Int
0 TileMap
ltile
in Level
{ lkind :: ContentId CaveKind
lkind = ContentId CaveKind
dkind
, AbsDepth
ldepth :: AbsDepth
ldepth :: AbsDepth
ldepth
, lfloor :: ItemFloor
lfloor = ItemFloor
forall k a. EnumMap k a
EM.empty
, lembed :: ItemFloor
lembed = ItemFloor
forall k a. EnumMap k a
EM.empty
, lbig :: BigActorMap
lbig = BigActorMap
forall k a. EnumMap k a
EM.empty
, lproj :: ProjectileMap
lproj = ProjectileMap
forall k a. EnumMap k a
EM.empty
, TileMap
ltile :: TileMap
ltile :: TileMap
ltile
, lentry :: EnumMap Point PlaceEntry
lentry = EnumMap Point PlaceEntry
dentry
, larea :: Area
larea = Area
darea
, lsmell :: SmellMap
lsmell = SmellMap
forall k a. EnumMap k a
EM.empty
, ([Point], [Point])
lstair :: ([Point], [Point])
lstair :: ([Point], [Point])
lstair
, [Point]
lescape :: [Point]
lescape :: [Point]
lescape
, lseen :: Int
lseen = Int
0
, Int
lexpl :: Int
lexpl :: Int
lexpl
, ltime :: Time
ltime = Time
timeZero
, lnight :: Bool
lnight = Bool
dnight
}
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 :: COps -> ContentData CaveKind
cocave :: ContentData CaveKind
cocave} ServerOptions
serverOptions Caves
caves = do
let shuffleSegment :: ([Int], [GroupName CaveKind])
-> Rnd [(Int, GroupName CaveKind)]
shuffleSegment :: ([Int], [GroupName CaveKind]) -> Rnd [(Int, GroupName CaveKind)]
shuffleSegment ([Int]
ns, [GroupName CaveKind]
l) = Bool
-> Rnd [(Int, GroupName CaveKind)]
-> Rnd [(Int, GroupName CaveKind)]
forall a. HasCallStack => Bool -> a -> a
assert ([Int] -> Int
forall a. [a] -> Int
length [Int]
ns Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [GroupName CaveKind] -> Int
forall a. [a] -> Int
length [GroupName CaveKind]
l) (Rnd [(Int, GroupName CaveKind)]
-> Rnd [(Int, GroupName CaveKind)])
-> Rnd [(Int, GroupName CaveKind)]
-> Rnd [(Int, GroupName CaveKind)]
forall a b. (a -> b) -> a -> b
$ do
[GroupName CaveKind]
lShuffled <- [GroupName CaveKind] -> Rnd [GroupName CaveKind]
forall a. Eq a => [a] -> Rnd [a]
shuffle [GroupName CaveKind]
l
[(Int, GroupName CaveKind)] -> Rnd [(Int, GroupName CaveKind)]
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Int, GroupName CaveKind)] -> Rnd [(Int, GroupName CaveKind)])
-> [(Int, GroupName CaveKind)] -> Rnd [(Int, GroupName CaveKind)]
forall a b. (a -> b) -> a -> b
$! [Int] -> [GroupName CaveKind] -> [(Int, GroupName CaveKind)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
ns [GroupName CaveKind]
lShuffled
[[(Int, GroupName CaveKind)]]
cavesShuffled <- (([Int], [GroupName CaveKind]) -> Rnd [(Int, GroupName CaveKind)])
-> Caves -> StateT SMGen Identity [[(Int, GroupName CaveKind)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ([Int], [GroupName CaveKind]) -> Rnd [(Int, GroupName CaveKind)]
shuffleSegment Caves
caves
let cavesFlat :: [(Int, GroupName CaveKind)]
cavesFlat = [[(Int, GroupName CaveKind)]] -> [(Int, GroupName CaveKind)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Int, GroupName CaveKind)]]
cavesShuffled
absKeys :: [Int]
absKeys = ((Int, GroupName CaveKind) -> Int)
-> [(Int, GroupName CaveKind)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int
forall a. Num a => a -> a
abs (Int -> Int)
-> ((Int, GroupName CaveKind) -> Int)
-> (Int, GroupName CaveKind)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, GroupName CaveKind) -> Int
forall a b. (a, b) -> a
fst) [(Int, GroupName CaveKind)]
cavesFlat
freshTotalDepth :: AbsDepth
freshTotalDepth = Int -> AbsDepth
Dice.AbsDepth (Int -> AbsDepth) -> Int -> AbsDepth
forall a b. (a -> b) -> a -> b
$ [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ Int
10 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
absKeys
getCaveKindNum :: (Int, GroupName CaveKind)
-> Rnd ((LevelId, ContentId CaveKind, CaveKind), Int)
getCaveKindNum :: (Int, GroupName CaveKind)
-> Rnd ((LevelId, ContentId CaveKind, CaveKind), Int)
getCaveKindNum (Int
ln, GroupName CaveKind
genName) = do
ContentId CaveKind
dkind <- ContentId CaveKind
-> Maybe (ContentId CaveKind) -> ContentId CaveKind
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> ContentId CaveKind
forall a. HasCallStack => [Char] -> a
error ([Char] -> ContentId CaveKind) -> [Char] -> ContentId CaveKind
forall a b. (a -> b) -> a -> b
$ [Char]
"" [Char] -> GroupName CaveKind -> [Char]
forall v. Show v => [Char] -> v -> [Char]
`showFailure` GroupName CaveKind
genName)
(Maybe (ContentId CaveKind) -> ContentId CaveKind)
-> StateT SMGen Identity (Maybe (ContentId CaveKind))
-> StateT SMGen Identity (ContentId CaveKind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContentData CaveKind
-> GroupName CaveKind
-> (CaveKind -> Bool)
-> StateT SMGen Identity (Maybe (ContentId CaveKind))
forall a.
Show a =>
ContentData a
-> GroupName a -> (a -> Bool) -> Rnd (Maybe (ContentId a))
opick ContentData CaveKind
cocave GroupName CaveKind
genName (Bool -> CaveKind -> Bool
forall a b. a -> b -> a
const Bool
True)
let kc :: CaveKind
kc = ContentData CaveKind -> ContentId CaveKind -> CaveKind
forall a. ContentData a -> ContentId a -> a
okind ContentData CaveKind
cocave ContentId CaveKind
dkind
ldepth :: AbsDepth
ldepth = Int -> AbsDepth
Dice.AbsDepth (Int -> AbsDepth) -> Int -> AbsDepth
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a. Num a => a -> a
abs Int
ln
Int
maxStairsNum <- AbsDepth -> AbsDepth -> Dice -> Rnd Int
castDice AbsDepth
ldepth AbsDepth
freshTotalDepth (Dice -> Rnd Int) -> Dice -> Rnd Int
forall a b. (a -> b) -> a -> b
$ CaveKind -> Dice
cmaxStairsNum CaveKind
kc
((LevelId, ContentId CaveKind, CaveKind), Int)
-> Rnd ((LevelId, ContentId CaveKind, CaveKind), Int)
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int -> LevelId
forall a. Enum a => Int -> a
toEnum Int
ln, ContentId CaveKind
dkind, CaveKind
kc), Int
maxStairsNum)
[((LevelId, ContentId CaveKind, CaveKind), Int)]
caveKindNums <- ((Int, GroupName CaveKind)
-> Rnd ((LevelId, ContentId CaveKind, CaveKind), Int))
-> [(Int, GroupName CaveKind)]
-> StateT
SMGen Identity [((LevelId, ContentId CaveKind, CaveKind), Int)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Int, GroupName CaveKind)
-> Rnd ((LevelId, ContentId CaveKind, CaveKind), Int)
getCaveKindNum [(Int, GroupName CaveKind)]
cavesFlat
let ([(LevelId, ContentId CaveKind, CaveKind)]
caveKinds, [Int]
caveNums) = [((LevelId, ContentId CaveKind, CaveKind), Int)]
-> ([(LevelId, ContentId CaveKind, CaveKind)], [Int])
forall a b. [(a, b)] -> ([a], [b])
unzip [((LevelId, ContentId CaveKind, CaveKind), Int)]
caveKindNums
caveNumNexts :: [(Int, Int)]
caveNumNexts = [Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
caveNums ([Int] -> [(Int, Int)]) -> [Int] -> [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
drop Int
1 [Int]
caveNums [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
0]
placeStairs :: ([(Int, Int, Int)], Int)
-> (Int, Int)
-> ([(Int, Int, Int)], Int)
placeStairs :: ([(Int, Int, Int)], Int) -> (Int, Int) -> ([(Int, Int, Int)], Int)
placeStairs ([(Int, Int, Int)]
acc, Int
nstairsFromUp) (Int
maxStairsNum, Int
maxStairsNumNext) =
let !_A1 :: ()
_A1 = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (Int
nstairsFromUp Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
maxStairsNum) ()
doubleKept :: Int
doubleKept =
[Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Int
1, Int
nstairsFromUp, Int
maxStairsNum, Int
maxStairsNumNext]
nstairsFromUp1 :: Int
nstairsFromUp1 = Int
nstairsFromUp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
doubleKept
maxStairsNum1 :: Int
maxStairsNum1 = Int
maxStairsNum Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
doubleKept
maxStairsNumNext1 :: Int
maxStairsNumNext1 = Int
maxStairsNumNext Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
doubleKept
singleDownStairs :: Int
singleDownStairs =
Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
maxStairsNumNext1 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
maxStairsNum1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
nstairsFromUp1
remainingNext :: Int
remainingNext = Int
maxStairsNumNext1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
singleDownStairs
doubleDownStairs :: Int
doubleDownStairs = Int
doubleKept
Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
nstairsFromUp1 Int
remainingNext
!_A2 :: ()
_A2 = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (Int
singleDownStairs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0) ()
!_A3 :: ()
_A3 = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (Int
doubleDownStairs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
doubleKept) ()
in ( (Int
nstairsFromUp, Int
doubleDownStairs, Int
singleDownStairs) (Int, Int, Int) -> [(Int, Int, Int)] -> [(Int, Int, Int)]
forall a. a -> [a] -> [a]
: [(Int, Int, Int)]
acc
, Int
doubleDownStairs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
singleDownStairs )
([(Int, Int, Int)]
caveStairs, Int
nstairsFromUpLast) = (([(Int, Int, Int)], Int)
-> (Int, Int) -> ([(Int, Int, Int)], Int))
-> ([(Int, Int, Int)], Int)
-> [(Int, Int)]
-> ([(Int, Int, Int)], Int)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([(Int, Int, Int)], Int) -> (Int, Int) -> ([(Int, Int, Int)], Int)
placeStairs ([], Int
0) [(Int, Int)]
caveNumNexts
caveZipped :: [((LevelId, ContentId CaveKind, CaveKind), (Int, Int, Int))]
caveZipped = Bool
-> [((LevelId, ContentId CaveKind, CaveKind), (Int, Int, Int))]
-> [((LevelId, ContentId CaveKind, CaveKind), (Int, Int, Int))]
forall a. HasCallStack => Bool -> a -> a
assert (Int
nstairsFromUpLast Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0)
([((LevelId, ContentId CaveKind, CaveKind), (Int, Int, Int))]
-> [((LevelId, ContentId CaveKind, CaveKind), (Int, Int, Int))])
-> [((LevelId, ContentId CaveKind, CaveKind), (Int, Int, Int))]
-> [((LevelId, ContentId CaveKind, CaveKind), (Int, Int, Int))]
forall a b. (a -> b) -> a -> b
$ [(LevelId, ContentId CaveKind, CaveKind)]
-> [(Int, Int, Int)]
-> [((LevelId, ContentId CaveKind, CaveKind), (Int, Int, Int))]
forall a b. [a] -> [b] -> [(a, b)]
zip [(LevelId, ContentId CaveKind, CaveKind)]
caveKinds ([(Int, Int, Int)] -> [(Int, Int, Int)]
forall a. [a] -> [a]
reverse [(Int, Int, Int)]
caveStairs)
placeCaveKind :: ([(LevelId, Level)], [(Point, Text)])
-> ( (LevelId, ContentId CaveKind, CaveKind)
, (Int, Int, Int) )
-> Rnd ([(LevelId, Level)], [(Point, Text)])
placeCaveKind :: ([(LevelId, Level)], [(Point, Text)])
-> ((LevelId, ContentId CaveKind, CaveKind), (Int, Int, Int))
-> Rnd ([(LevelId, Level)], [(Point, Text)])
placeCaveKind ([(LevelId, Level)]
lvls, [(Point, Text)]
stairsFromUp)
( (LevelId
lid, ContentId CaveKind
dkind, CaveKind
kc)
, (Int
nstairsFromUp, Int
doubleDownStairs, Int
singleDownStairs) ) = do
let !_A :: ()
_A = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert ([(Point, Text)] -> Int
forall a. [a] -> Int
length [(Point, Text)]
stairsFromUp Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
nstairsFromUp) ()
(Level
newLevel, [(Point, Text)]
ldown2) <-
COps
-> ServerOptions
-> LevelId
-> ContentId CaveKind
-> CaveKind
-> Int
-> Int
-> AbsDepth
-> [(Point, Text)]
-> Rnd (Level, [(Point, Text)])
buildLevel COps
cops ServerOptions
serverOptions
LevelId
lid ContentId CaveKind
dkind CaveKind
kc Int
doubleDownStairs Int
singleDownStairs
AbsDepth
freshTotalDepth [(Point, Text)]
stairsFromUp
([(LevelId, Level)], [(Point, Text)])
-> Rnd ([(LevelId, Level)], [(Point, Text)])
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ((LevelId
lid, Level
newLevel) (LevelId, Level) -> [(LevelId, Level)] -> [(LevelId, Level)]
forall a. a -> [a] -> [a]
: [(LevelId, Level)]
lvls, [(Point, Text)]
ldown2)
([(LevelId, Level)]
levels, [(Point, Text)]
stairsFromUpLast) <- (([(LevelId, Level)], [(Point, Text)])
-> ((LevelId, ContentId CaveKind, CaveKind), (Int, Int, Int))
-> Rnd ([(LevelId, Level)], [(Point, Text)]))
-> ([(LevelId, Level)], [(Point, Text)])
-> [((LevelId, ContentId CaveKind, CaveKind), (Int, Int, Int))]
-> Rnd ([(LevelId, Level)], [(Point, Text)])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> Rnd b) -> b -> t a -> Rnd b
foldlM' ([(LevelId, Level)], [(Point, Text)])
-> ((LevelId, ContentId CaveKind, CaveKind), (Int, Int, Int))
-> Rnd ([(LevelId, Level)], [(Point, Text)])
placeCaveKind ([], []) [((LevelId, ContentId CaveKind, CaveKind), (Int, Int, Int))]
caveZipped
let freshDungeon :: Dungeon
freshDungeon = Bool -> Dungeon -> Dungeon
forall a. HasCallStack => Bool -> a -> a
assert ([(Point, Text)] -> Bool
forall a. [a] -> Bool
null [(Point, Text)]
stairsFromUpLast) (Dungeon -> Dungeon) -> Dungeon -> Dungeon
forall a b. (a -> b) -> a -> b
$ [(LevelId, Level)] -> Dungeon
forall k a. Enum k => [(k, a)] -> EnumMap k a
EM.fromList [(LevelId, Level)]
levels
FreshDungeon -> Rnd FreshDungeon
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (FreshDungeon -> Rnd FreshDungeon)
-> FreshDungeon -> Rnd FreshDungeon
forall a b. (a -> b) -> a -> b
$! FreshDungeon{Dungeon
AbsDepth
freshDungeon :: Dungeon
freshTotalDepth :: AbsDepth
freshTotalDepth :: AbsDepth
freshDungeon :: Dungeon
..}