{-# LANGUAGE RankNTypes #-}
-- | Generation of places from place kinds.
module Game.LambdaHack.Server.DungeonGen.Place
  ( Place(..), TileMapEM, buildPlace, isChancePos, buildFenceRnd
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , placeCheck, interiorArea, pover, buildFence, buildFenceMap
  , tilePlace
#endif
  ) where

import Prelude ()

import Game.LambdaHack.Core.Prelude

import qualified Data.Bits as Bits
import qualified Data.EnumMap.Strict as EM
import qualified Data.Text as T
import           Data.Word (Word32)

import           Game.LambdaHack.Common.Area
import           Game.LambdaHack.Common.Kind
import           Game.LambdaHack.Common.Point
import qualified Game.LambdaHack.Common.Tile as Tile
import           Game.LambdaHack.Content.CaveKind
import           Game.LambdaHack.Content.PlaceKind
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.Frequency
import           Game.LambdaHack.Core.Random
import           Game.LambdaHack.Definition.Defs
import           Game.LambdaHack.Server.DungeonGen.AreaRnd

-- | The map of tile kinds in a place (and generally anywhere in a cave).
-- The map is sparse. The default tile that eventually fills the empty spaces
-- is specified in the cave kind specification with @cdefTile@.
type TileMapEM = EM.EnumMap Point (ContentId TileKind)

-- | The parameters of a place. All are immutable and rolled and fixed
-- at the time when a place is generated.
data Place = Place
  { Place -> ContentId PlaceKind
qkind  :: ContentId PlaceKind
  , Place -> Area
qarea  :: Area
  , Place -> TileMapEM
qmap   :: TileMapEM
  , Place -> TileMapEM
qfence :: TileMapEM
  }
  deriving Int -> Place -> ShowS
[Place] -> ShowS
Place -> String
(Int -> Place -> ShowS)
-> (Place -> String) -> ([Place] -> ShowS) -> Show Place
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Place] -> ShowS
$cshowList :: [Place] -> ShowS
show :: Place -> String
$cshow :: Place -> String
showsPrec :: Int -> Place -> ShowS
$cshowsPrec :: Int -> Place -> ShowS
Show

-- | For @CAlternate@ tiling, require the place be comprised
-- of an even number of whole corners, with exactly one square
-- overlap between consecutive coners and no trimming.
-- For other tiling methods, check that the area is large enough for tiling
-- the corner twice in each direction, with a possible one row/column overlap.
placeCheck :: Area       -- ^ the area to fill
           -> PlaceKind  -- ^ the kind of place to construct
           -> Bool
placeCheck :: Area -> PlaceKind -> Bool
placeCheck Area
r pk :: PlaceKind
pk@PlaceKind{Rarity
Freqs PlaceKind
[Text]
EnumMap Char (GroupName TileKind)
Text
Fence
Cover
plegendLit :: PlaceKind -> EnumMap Char (GroupName TileKind)
plegendDark :: PlaceKind -> EnumMap Char (GroupName TileKind)
ptopLeft :: PlaceKind -> [Text]
pfence :: PlaceKind -> Fence
pcover :: PlaceKind -> Cover
prarity :: PlaceKind -> Rarity
pfreq :: PlaceKind -> Freqs PlaceKind
pname :: PlaceKind -> Text
plegendLit :: EnumMap Char (GroupName TileKind)
plegendDark :: EnumMap Char (GroupName TileKind)
ptopLeft :: [Text]
pfence :: Fence
pcover :: Cover
prarity :: Rarity
pfreq :: Freqs PlaceKind
pname :: Text
..} =
  case PlaceKind -> Area -> Maybe Area
interiorArea PlaceKind
pk Area
r of
    Maybe Area
Nothing -> Bool
False
    Just Area
area ->
      let (Point
_, Int
xspan, Int
yspan) = Area -> (Point, Int, Int)
spanArea Area
area
          dxcorner :: Int
dxcorner = case [Text]
ptopLeft of [] -> Int
0 ; Text
l : [Text]
_ -> Text -> Int
T.length Text
l
          dycorner :: Int
dycorner = [Text] -> Int
forall a. [a] -> Int
length [Text]
ptopLeft
          wholeOverlapped :: a -> a -> Bool
wholeOverlapped a
d a
dcorner = a
d a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
1 Bool -> Bool -> Bool
&& a
dcorner a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
1 Bool -> Bool -> Bool
&&
                                      (a
d a -> a -> a
forall a. Num a => a -> a -> a
- a
1) a -> a -> a
forall a. Integral a => a -> a -> a
`mod` (a
2 a -> a -> a
forall a. Num a => a -> a -> a
* (a
dcorner a -> a -> a
forall a. Num a => a -> a -> a
- a
1)) a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0
          largeEnough :: Bool
largeEnough = Int
xspan Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
dxcorner Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Bool -> Bool -> Bool
&& Int
yspan Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
dycorner Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
      in case Cover
pcover of
        Cover
CAlternate -> Int -> Int -> Bool
forall a. Integral a => a -> a -> Bool
wholeOverlapped Int
xspan Int
dxcorner Bool -> Bool -> Bool
&&
                      Int -> Int -> Bool
forall a. Integral a => a -> a -> Bool
wholeOverlapped Int
yspan Int
dycorner
        Cover
CStretch   -> Bool
largeEnough
        Cover
CReflect   -> Bool
largeEnough
        Cover
CVerbatim  -> Bool
True
        Cover
CMirror    -> Bool
True

-- | Calculate interior room area according to fence type, based on the
-- total area for the room and it's fence. This is used for checking
-- if the room fits in the area, for digging up the place and the fence
-- and for deciding if the room is dark or lit later in the dungeon
-- generation process.
interiorArea :: PlaceKind -> Area -> Maybe Area
interiorArea :: PlaceKind -> Area -> Maybe Area
interiorArea PlaceKind
kr Area
r =
  let requiredForFence :: Int
requiredForFence = case PlaceKind -> Fence
pfence PlaceKind
kr of
        Fence
FWall   -> Int
1
        Fence
FFloor  -> Int
1
        Fence
FGround -> Int
1
        Fence
FNone   -> Int
0
  in if PlaceKind -> Cover
pcover PlaceKind
kr Cover -> [Cover] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Cover
CVerbatim, Cover
CMirror]
     then let (Point Int
x0 Int
y0, Int
xspan, Int
yspan) = Area -> (Point, Int, Int)
spanArea Area
r
              dx :: Int
dx = case PlaceKind -> [Text]
ptopLeft PlaceKind
kr of
                [] -> String -> Int
forall a. HasCallStack => String -> a
error (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ String
"" String -> PlaceKind -> String
forall v. Show v => String -> v -> String
`showFailure` PlaceKind
kr
                Text
l : [Text]
_ -> Text -> Int
T.length Text
l
              dy :: Int
dy = [Text] -> Int
forall a. [a] -> Int
length ([Text] -> Int) -> [Text] -> Int
forall a b. (a -> b) -> a -> b
$ PlaceKind -> [Text]
ptopLeft PlaceKind
kr
              mx :: Int
mx = (Int
xspan Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
dx) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
              my :: Int
my = (Int
yspan Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
dy) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
          in if Int
mx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
requiredForFence Bool -> Bool -> Bool
|| Int
my Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
requiredForFence
             then Maybe Area
forall a. Maybe a
Nothing
             else (Int, Int, Int, Int) -> Maybe Area
toArea (Int
x0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
mx, Int
y0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
my, Int
x0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
mx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
dx 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
my Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
dy Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
     else case Int
requiredForFence of
       Int
0 -> Area -> Maybe Area
forall a. a -> Maybe a
Just Area
r
       Int
1 -> Area -> Maybe Area
shrink Area
r
       Int
_ -> String -> Maybe Area
forall a. HasCallStack => String -> a
error (String -> Maybe Area) -> String -> Maybe Area
forall a b. (a -> b) -> a -> b
$ String
"" String -> PlaceKind -> String
forall v. Show v => String -> v -> String
`showFailure` PlaceKind
kr

-- | Given a few parameters, roll and construct a 'Place' datastructure
-- and fill a cave section acccording to it.
buildPlace :: COps                -- ^ the game content
           -> CaveKind            -- ^ current cave kind
           -> Bool                -- ^ whether the cave is dark
           -> ContentId TileKind  -- ^ dark fence tile, if fence hollow
           -> ContentId TileKind  -- ^ lit fence tile, if fence hollow
           -> Dice.AbsDepth       -- ^ current level depth
           -> Dice.AbsDepth       -- ^ absolute depth
           -> Word32              -- ^ secret tile seed
           -> Area                -- ^ whole area of the place, fence included
           -> Maybe Area          -- ^ whole inner area of the grid cell
           -> Freqs PlaceKind     -- ^ optional fixed place freq
           -> Rnd Place
buildPlace :: COps
-> CaveKind
-> Bool
-> ContentId TileKind
-> ContentId TileKind
-> AbsDepth
-> AbsDepth
-> Word32
-> Area
-> Maybe Area
-> Freqs PlaceKind
-> Rnd Place
buildPlace cops :: COps
cops@COps{ContentData PlaceKind
coplace :: COps -> ContentData PlaceKind
coplace :: ContentData PlaceKind
coplace, TileSpeedup
coTileSpeedup :: COps -> TileSpeedup
coTileSpeedup :: TileSpeedup
coTileSpeedup}
           kc :: CaveKind
kc@CaveKind{Bool
Int
[Int]
Freqs ItemKind
Freqs PlaceKind
Freqs CaveKind
Chance
Text
DiceXY
Dice
GroupName TileKind
InitSleep
cdesc :: CaveKind -> Text
cinitSleep :: CaveKind -> InitSleep
cskip :: CaveKind -> [Int]
cstairAllowed :: CaveKind -> Freqs PlaceKind
cstairFreq :: CaveKind -> Freqs PlaceKind
cescapeFreq :: CaveKind -> Freqs PlaceKind
cmaxStairsNum :: CaveKind -> Dice
cminStairDist :: CaveKind -> Int
cfenceApart :: CaveKind -> Bool
cfenceTileW :: CaveKind -> GroupName TileKind
cfenceTileS :: CaveKind -> GroupName TileKind
cfenceTileE :: CaveKind -> GroupName TileKind
cfenceTileN :: CaveKind -> GroupName TileKind
ccornerTile :: CaveKind -> GroupName TileKind
cwallTile :: CaveKind -> GroupName TileKind
clitCorTile :: CaveKind -> GroupName TileKind
cdarkCorTile :: CaveKind -> GroupName TileKind
cdefTile :: CaveKind -> GroupName TileKind
clabyrinth :: CaveKind -> Bool
cpassable :: CaveKind -> Bool
cplaceFreq :: CaveKind -> Freqs PlaceKind
citemFreq :: CaveKind -> Freqs ItemKind
citemNum :: CaveKind -> Dice
cactorFreq :: CaveKind -> Freqs ItemKind
cactorCoeff :: CaveKind -> Int
chidden :: CaveKind -> Int
copenChance :: CaveKind -> Chance
cdoorChance :: CaveKind -> Chance
cmaxVoid :: CaveKind -> Chance
cauxConnects :: CaveKind -> Chance
cnightOdds :: CaveKind -> Dice
cdarkOdds :: CaveKind -> Dice
cmaxPlaceSize :: CaveKind -> DiceXY
cminPlaceSize :: CaveKind -> DiceXY
ccellSize :: CaveKind -> DiceXY
cYminSize :: CaveKind -> Int
cXminSize :: CaveKind -> Int
cfreq :: CaveKind -> Freqs CaveKind
cname :: CaveKind -> Text
cdesc :: Text
cinitSleep :: InitSleep
cskip :: [Int]
cstairAllowed :: Freqs PlaceKind
cstairFreq :: Freqs PlaceKind
cescapeFreq :: Freqs PlaceKind
cmaxStairsNum :: Dice
cminStairDist :: Int
cfenceApart :: Bool
cfenceTileW :: GroupName TileKind
cfenceTileS :: GroupName TileKind
cfenceTileE :: GroupName TileKind
cfenceTileN :: GroupName TileKind
ccornerTile :: GroupName TileKind
cwallTile :: GroupName TileKind
clitCorTile :: GroupName TileKind
cdarkCorTile :: GroupName TileKind
cdefTile :: GroupName TileKind
clabyrinth :: Bool
cpassable :: Bool
cplaceFreq :: Freqs PlaceKind
citemFreq :: Freqs ItemKind
citemNum :: Dice
cactorFreq :: Freqs ItemKind
cactorCoeff :: Int
chidden :: Int
copenChance :: Chance
cdoorChance :: Chance
cmaxVoid :: Chance
cauxConnects :: Chance
cnightOdds :: Dice
cdarkOdds :: Dice
cmaxPlaceSize :: DiceXY
cminPlaceSize :: DiceXY
ccellSize :: DiceXY
cYminSize :: Int
cXminSize :: Int
cfreq :: Freqs CaveKind
cname :: Text
..} Bool
dnight ContentId TileKind
darkCorTile ContentId TileKind
litCorTile
           levelDepth :: AbsDepth
levelDepth@(Dice.AbsDepth Int
ldepth)
           totalDepth :: AbsDepth
totalDepth@(Dice.AbsDepth Int
tdepth)
           Word32
dsecret Area
r Maybe Area
minnerArea Freqs PlaceKind
mplaceGroup = do
  let f :: Int
-> [(Int, (ContentId PlaceKind, PlaceKind))]
-> Int
-> ContentId PlaceKind
-> PlaceKind
-> [(Int, (ContentId PlaceKind, PlaceKind))]
f !Int
q ![(Int, (ContentId PlaceKind, PlaceKind))]
acc !Int
p !ContentId PlaceKind
pk !PlaceKind
kind =
        let rarity :: Int
rarity = Int -> Int -> Rarity -> Int
linearInterpolation Int
ldepth Int
tdepth (PlaceKind -> Rarity
prarity PlaceKind
kind)
            !fr :: Int
fr = Int
q Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
rarity
        in (Int
fr, (ContentId PlaceKind
pk, PlaceKind
kind)) (Int, (ContentId PlaceKind, PlaceKind))
-> [(Int, (ContentId PlaceKind, PlaceKind))]
-> [(Int, (ContentId PlaceKind, PlaceKind))]
forall a. a -> [a] -> [a]
: [(Int, (ContentId PlaceKind, PlaceKind))]
acc
      g :: (GroupName PlaceKind, Int)
-> [(Int, (ContentId PlaceKind, PlaceKind))]
g (GroupName PlaceKind
placeGroup, Int
q) = ContentData PlaceKind
-> GroupName PlaceKind
-> ([(Int, (ContentId PlaceKind, PlaceKind))]
    -> Int
    -> ContentId PlaceKind
    -> PlaceKind
    -> [(Int, (ContentId PlaceKind, PlaceKind))])
-> [(Int, (ContentId PlaceKind, PlaceKind))]
-> [(Int, (ContentId PlaceKind, PlaceKind))]
forall a b.
ContentData a
-> GroupName a -> (b -> Int -> ContentId a -> a -> b) -> b -> b
ofoldlGroup' ContentData PlaceKind
coplace GroupName PlaceKind
placeGroup (Int
-> [(Int, (ContentId PlaceKind, PlaceKind))]
-> Int
-> ContentId PlaceKind
-> PlaceKind
-> [(Int, (ContentId PlaceKind, PlaceKind))]
f Int
q) []
      pfreq :: Freqs PlaceKind
pfreq = case Freqs PlaceKind
mplaceGroup of
        [] -> Freqs PlaceKind
cplaceFreq
        Freqs PlaceKind
_ -> Freqs PlaceKind
mplaceGroup
      placeFreq :: [(Int, (ContentId PlaceKind, PlaceKind))]
placeFreq = ((GroupName PlaceKind, Int)
 -> [(Int, (ContentId PlaceKind, PlaceKind))])
-> Freqs PlaceKind -> [(Int, (ContentId PlaceKind, PlaceKind))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (GroupName PlaceKind, Int)
-> [(Int, (ContentId PlaceKind, PlaceKind))]
g Freqs PlaceKind
pfreq
      checkedFreq :: [(Int, (ContentId PlaceKind, PlaceKind))]
checkedFreq = ((Int, (ContentId PlaceKind, PlaceKind)) -> Bool)
-> [(Int, (ContentId PlaceKind, PlaceKind))]
-> [(Int, (ContentId PlaceKind, PlaceKind))]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Int
_, (ContentId PlaceKind
_, PlaceKind
kind)) -> Area -> PlaceKind -> Bool
placeCheck Area
r PlaceKind
kind) [(Int, (ContentId PlaceKind, PlaceKind))]
placeFreq
      freq :: Frequency (ContentId PlaceKind, PlaceKind)
freq = Text
-> [(Int, (ContentId PlaceKind, PlaceKind))]
-> Frequency (ContentId PlaceKind, PlaceKind)
forall a. Text -> [(Int, a)] -> Frequency a
toFreq Text
"buildPlace" [(Int, (ContentId PlaceKind, PlaceKind))]
checkedFreq
  let !_A :: ()
_A = Bool -> () -> ()
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (Frequency (ContentId PlaceKind, PlaceKind) -> Bool
forall a. Frequency a -> Bool
nullFreq Frequency (ContentId PlaceKind, PlaceKind)
freq) Bool
-> ([(Int, (ContentId PlaceKind, PlaceKind))],
    [(Int, (ContentId PlaceKind, PlaceKind))], Area)
-> Bool
forall a. Show a => Bool -> a -> Bool
`blame` ([(Int, (ContentId PlaceKind, PlaceKind))]
placeFreq, [(Int, (ContentId PlaceKind, PlaceKind))]
checkedFreq, Area
r)) ()
  (ContentId PlaceKind
qkind, PlaceKind
kr) <- Frequency (ContentId PlaceKind, PlaceKind)
-> Rnd (ContentId PlaceKind, PlaceKind)
forall a. Show a => Frequency a -> Rnd a
frequency Frequency (ContentId PlaceKind, PlaceKind)
freq
  let smallPattern :: Bool
smallPattern = PlaceKind -> Cover
pcover PlaceKind
kr Cover -> [Cover] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Cover
CVerbatim, Cover
CMirror]
                     Bool -> Bool -> Bool
&& ([Text] -> Int
forall a. [a] -> Int
length (PlaceKind -> [Text]
ptopLeft PlaceKind
kr) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
10
                         Bool -> Bool -> Bool
|| Text -> Int
T.length ([Text] -> Text
forall a. [a] -> a
head (PlaceKind -> [Text]
ptopLeft PlaceKind
kr)) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
10)
  -- Below we apply a heuristics to estimate if there are floor tiles
  -- in the place that are adjacent to floor tiles of the cave and so both
  -- should have the same lit condition.
  -- A false positive is walled staircases in LambdaHack, but it's OK.
  Bool
dark <- if Bool
cpassable
             Bool -> Bool -> Bool
&& Bool -> Bool
not (Bool
dnight Bool -> Bool -> Bool
&& TileSpeedup -> ContentId TileKind -> Bool
Tile.isLit TileSpeedup
coTileSpeedup ContentId TileKind
darkCorTile)
                  -- the colonnade can be illuminated just as the trail is
             Bool -> Bool -> Bool
&& (PlaceKind -> Fence
pfence PlaceKind
kr Fence -> [Fence] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Fence
FFloor, Fence
FGround]
                 Bool -> Bool -> Bool
|| PlaceKind -> Fence
pfence PlaceKind
kr Fence -> Fence -> Bool
forall a. Eq a => a -> a -> Bool
== Fence
FNone Bool -> Bool -> Bool
&& Bool
smallPattern)
          then Bool -> StateT SMGen Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
dnight
          else AbsDepth -> AbsDepth -> Dice -> StateT SMGen Identity Bool
oddsDice AbsDepth
levelDepth AbsDepth
totalDepth Dice
cdarkOdds
  Area
rBetter <- case Maybe Area
minnerArea of
    Just Area
innerArea | PlaceKind -> Cover
pcover PlaceKind
kr Cover -> [Cover] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Cover
CVerbatim, Cover
CMirror] -> do
      -- A hack: if a verbatim place was rolled, redo computing the area
      -- taking into account that often much smaller portion is taken by place.
      let requiredForFence :: Int
requiredForFence = case PlaceKind -> Fence
pfence PlaceKind
kr of
            Fence
FWall   -> Int
1
            Fence
FFloor  -> Int
1
            Fence
FGround -> Int
1
            Fence
FNone   -> Int
0
          sizeBetter :: (Int, Int)
sizeBetter = ( Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
requiredForFence
                         Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Text -> Int
T.length ([Text] -> Text
forall a. [a] -> a
head (PlaceKind -> [Text]
ptopLeft PlaceKind
kr))
                       , Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
requiredForFence
                         Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Text] -> Int
forall a. [a] -> Int
length (PlaceKind -> [Text]
ptopLeft PlaceKind
kr) )
      (Int, Int) -> (Int, Int) -> Area -> StateT SMGen Identity Area
mkRoom (Int, Int)
sizeBetter (Int, Int)
sizeBetter Area
innerArea
    Maybe Area
_ -> Area -> StateT SMGen Identity Area
forall (m :: * -> *) a. Monad m => a -> m a
return Area
r
  let qarea :: Area
qarea = Area -> Maybe Area -> Area
forall a. a -> Maybe a -> a
fromMaybe (String -> Area
forall a. HasCallStack => String -> a
error (String -> Area) -> String -> Area
forall a b. (a -> b) -> a -> b
$ String
"" String -> (PlaceKind, Area) -> String
forall v. Show v => String -> v -> String
`showFailure` (PlaceKind
kr, Area
r))
              (Maybe Area -> Area) -> Maybe Area -> Area
forall a b. (a -> b) -> a -> b
$ PlaceKind -> Area -> Maybe Area
interiorArea PlaceKind
kr Area
rBetter
      plegend :: EnumMap Char (GroupName TileKind)
plegend = if Bool
dark then PlaceKind -> EnumMap Char (GroupName TileKind)
plegendDark PlaceKind
kr else PlaceKind -> EnumMap Char (GroupName TileKind)
plegendLit PlaceKind
kr
  EnumMap
  Char (Maybe (Int, Int, ContentId TileKind), ContentId TileKind)
mOneIn <- COps
-> EnumMap Char (GroupName TileKind)
-> Rnd
     (EnumMap
        Char (Maybe (Int, Int, ContentId TileKind), ContentId TileKind))
pover COps
cops EnumMap Char (GroupName TileKind)
plegend
  EnumMap Point Char
cmap <- Area -> PlaceKind -> Rnd (EnumMap Point Char)
tilePlace Area
qarea PlaceKind
kr
  let lookupOneIn :: Point -> Char -> ContentId TileKind
      lookupOneIn :: Point -> Char -> ContentId TileKind
lookupOneIn Point
xy Char
c =
        let tktk :: (Maybe (Int, Int, ContentId TileKind), ContentId TileKind)
tktk = (Maybe (Int, Int, ContentId TileKind), ContentId TileKind)
-> Char
-> EnumMap
     Char (Maybe (Int, Int, ContentId TileKind), ContentId TileKind)
-> (Maybe (Int, Int, ContentId TileKind), ContentId TileKind)
forall k a. Enum k => a -> k -> EnumMap k a -> a
EM.findWithDefault
                     (String
-> (Maybe (Int, Int, ContentId TileKind), ContentId TileKind)
forall a. HasCallStack => String -> a
error (String
 -> (Maybe (Int, Int, ContentId TileKind), ContentId TileKind))
-> String
-> (Maybe (Int, Int, ContentId TileKind), ContentId TileKind)
forall a b. (a -> b) -> a -> b
$ String
"" String
-> (Char,
    EnumMap
      Char (Maybe (Int, Int, ContentId TileKind), ContentId TileKind))
-> String
forall v. Show v => String -> v -> String
`showFailure` (Char
c, EnumMap
  Char (Maybe (Int, Int, ContentId TileKind), ContentId TileKind)
mOneIn)) Char
c EnumMap
  Char (Maybe (Int, Int, ContentId TileKind), ContentId TileKind)
mOneIn
        in case (Maybe (Int, Int, ContentId TileKind), ContentId TileKind)
tktk of
          (Just (Int
k, Int
n, ContentId TileKind
tkSpice), ContentId TileKind
_) | Int -> Int -> Word32 -> Point -> Bool
isChancePos Int
k Int
n Word32
dsecret Point
xy -> ContentId TileKind
tkSpice
          (Maybe (Int, Int, ContentId TileKind)
_, ContentId TileKind
tk) -> ContentId TileKind
tk
      qmap :: TileMapEM
qmap = (Point -> Char -> ContentId TileKind)
-> EnumMap Point Char -> TileMapEM
forall k a b. Enum k => (k -> a -> b) -> EnumMap k a -> EnumMap k b
EM.mapWithKey Point -> Char -> ContentId TileKind
lookupOneIn EnumMap Point Char
cmap
  TileMapEM
qfence <- COps
-> CaveKind
-> Bool
-> ContentId TileKind
-> ContentId TileKind
-> Bool
-> Fence
-> Area
-> Rnd TileMapEM
buildFence COps
cops CaveKind
kc Bool
dnight ContentId TileKind
darkCorTile ContentId TileKind
litCorTile
                       Bool
dark (PlaceKind -> Fence
pfence PlaceKind
kr) Area
qarea
  Place -> Rnd Place
forall (m :: * -> *) a. Monad m => a -> m a
return (Place -> Rnd Place) -> Place -> Rnd Place
forall a b. (a -> b) -> a -> b
$! Place :: ContentId PlaceKind -> Area -> TileMapEM -> TileMapEM -> Place
Place {TileMapEM
ContentId PlaceKind
Area
qfence :: TileMapEM
qmap :: TileMapEM
qarea :: Area
qkind :: ContentId PlaceKind
qfence :: TileMapEM
qmap :: TileMapEM
qarea :: Area
qkind :: ContentId PlaceKind
..}

isChancePos :: Int -> Int -> Word32 -> Point -> Bool
isChancePos :: Int -> Int -> Word32 -> Point -> Bool
isChancePos Int
k' Int
n' Word32
dsecret (Point Int
x' Int
y') = Int
k' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Int
n' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&&
  let k :: Word32
k = Int -> Word32
forall a. Enum a => Int -> a
toEnum Int
k'
      n :: Word32
n = Int -> Word32
forall a. Enum a => Int -> a
toEnum Int
n'
      x :: Word32
x = Int -> Word32
forall a. Enum a => Int -> a
toEnum Int
x'
      y :: Word32
y = Int -> Word32
forall a. Enum a => Int -> a
toEnum Int
y'
      z :: Word32
z = Word32
dsecret Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`Bits.rotateR` Int
x' Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
`Bits.xor` Word32
y Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
x
  in if Word32
k Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
< Word32
n
     then Word32
z Word32 -> Word32 -> Word32
forall a. Integral a => a -> a -> a
`mod` ((Word32
n Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
k) Word32 -> Word32 -> Word32
forall a. Integral a => a -> a -> a
`divUp` Word32
k) Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0
     else Word32
z Word32 -> Word32 -> Word32
forall a. Integral a => a -> a -> a
`mod` ((Word32
n Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
k) Word32 -> Word32 -> Word32
forall a. Integral a => a -> a -> a
`divUp` Word32
n) Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32
0

-- This can't be optimized by memoization (storing these results per place),
-- because it would fix random assignment of tiles to groups
-- for all instances of a place throughout dungeon. Right now the assignment
-- is fixed for any single place instance and it's consistent and interesting.
-- Even fixing this per level would make levels less interesting.
--
-- This could be precomputed for groups that contain only one tile,
-- but for these, no random rolls are performed, so little would be saved.
pover :: COps -> EM.EnumMap Char (GroupName TileKind)
      -> Rnd ( EM.EnumMap Char ( Maybe (Int, Int, ContentId TileKind)
                               , ContentId TileKind ) )
pover :: COps
-> EnumMap Char (GroupName TileKind)
-> Rnd
     (EnumMap
        Char (Maybe (Int, Int, ContentId TileKind), ContentId TileKind))
pover COps{ContentData TileKind
cotile :: COps -> ContentData TileKind
cotile :: ContentData TileKind
cotile} EnumMap Char (GroupName TileKind)
plegend =
  let assignKN :: GroupName TileKind -> ContentId TileKind -> ContentId TileKind
               -> (Int, Int, ContentId TileKind)
      assignKN :: GroupName TileKind
-> ContentId TileKind
-> ContentId TileKind
-> (Int, Int, ContentId TileKind)
assignKN GroupName TileKind
cgroup ContentId TileKind
tk ContentId TileKind
tkSpice =
        -- Very likely that legends have spice.
        let n :: Int
n = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (String -> Int
forall a. HasCallStack => String -> a
error (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ GroupName TileKind -> String
forall a. Show a => a -> String
show GroupName TileKind
cgroup)
                          (GroupName TileKind -> [(GroupName TileKind, Int)] -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup GroupName TileKind
cgroup (TileKind -> [(GroupName TileKind, Int)]
TK.tfreq (ContentData TileKind -> ContentId TileKind -> TileKind
forall a. ContentData a -> ContentId a -> a
okind ContentData TileKind
cotile ContentId TileKind
tk)))
            k :: Int
k = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (String -> Int
forall a. HasCallStack => String -> a
error (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ GroupName TileKind -> String
forall a. Show a => a -> String
show GroupName TileKind
cgroup)
                          (GroupName TileKind -> [(GroupName TileKind, Int)] -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup GroupName TileKind
cgroup (TileKind -> [(GroupName TileKind, Int)]
TK.tfreq (ContentData TileKind -> ContentId TileKind -> TileKind
forall a. ContentData a -> ContentId a -> a
okind ContentData TileKind
cotile ContentId TileKind
tkSpice)))
        in (Int
k, Int
n, ContentId TileKind
tkSpice)
      getLegend :: GroupName TileKind
                -> Rnd ( Maybe (Int, Int, ContentId TileKind)
                       , ContentId TileKind )
      getLegend :: GroupName TileKind
-> Rnd (Maybe (Int, Int, ContentId TileKind), ContentId TileKind)
getLegend GroupName TileKind
cgroup = do
        Maybe (ContentId TileKind)
mtkSpice <- ContentData TileKind
-> GroupName TileKind
-> (TileKind -> Bool)
-> Rnd (Maybe (ContentId TileKind))
forall a.
Show a =>
ContentData a
-> GroupName a -> (a -> Bool) -> Rnd (Maybe (ContentId a))
opick ContentData TileKind
cotile GroupName TileKind
cgroup (Feature -> TileKind -> Bool
Tile.kindHasFeature Feature
TK.Spice)
        ContentId TileKind
tk <- ContentId TileKind
-> Maybe (ContentId TileKind) -> ContentId TileKind
forall a. a -> Maybe a -> a
fromMaybe (String -> ContentId TileKind
forall a. HasCallStack => String -> a
error (String -> ContentId TileKind) -> String -> ContentId TileKind
forall a b. (a -> b) -> a -> b
$ String
"" String
-> (GroupName TileKind, EnumMap Char (GroupName TileKind))
-> String
forall v. Show v => String -> v -> String
`showFailure` (GroupName TileKind
cgroup, EnumMap Char (GroupName TileKind)
plegend))
              (Maybe (ContentId TileKind) -> ContentId TileKind)
-> Rnd (Maybe (ContentId TileKind))
-> StateT SMGen Identity (ContentId TileKind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContentData TileKind
-> GroupName TileKind
-> (TileKind -> Bool)
-> Rnd (Maybe (ContentId TileKind))
forall a.
Show a =>
ContentData a
-> GroupName a -> (a -> Bool) -> Rnd (Maybe (ContentId a))
opick ContentData TileKind
cotile GroupName TileKind
cgroup (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.Spice)
        (Maybe (Int, Int, ContentId TileKind), ContentId TileKind)
-> Rnd (Maybe (Int, Int, ContentId TileKind), ContentId TileKind)
forall (m :: * -> *) a. Monad m => a -> m a
return (GroupName TileKind
-> ContentId TileKind
-> ContentId TileKind
-> (Int, Int, ContentId TileKind)
assignKN GroupName TileKind
cgroup ContentId TileKind
tk (ContentId TileKind -> (Int, Int, ContentId TileKind))
-> Maybe (ContentId TileKind)
-> Maybe (Int, Int, ContentId TileKind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (ContentId TileKind)
mtkSpice, ContentId TileKind
tk)
  in (GroupName TileKind
 -> Rnd (Maybe (Int, Int, ContentId TileKind), ContentId TileKind))
-> EnumMap Char (GroupName TileKind)
-> Rnd
     (EnumMap
        Char (Maybe (Int, Int, ContentId TileKind), ContentId TileKind))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GroupName TileKind
-> Rnd (Maybe (Int, Int, ContentId TileKind), ContentId TileKind)
getLegend EnumMap Char (GroupName TileKind)
plegend

-- | Construct a fence around a place.
buildFence :: COps -> CaveKind -> Bool
           -> ContentId TileKind -> ContentId TileKind
           -> Bool -> Fence -> Area
           -> Rnd TileMapEM
buildFence :: COps
-> CaveKind
-> Bool
-> ContentId TileKind
-> ContentId TileKind
-> Bool
-> Fence
-> Area
-> Rnd TileMapEM
buildFence COps{ContentData TileKind
cotile :: ContentData TileKind
cotile :: COps -> ContentData TileKind
cotile} CaveKind{GroupName TileKind
ccornerTile :: GroupName TileKind
ccornerTile :: CaveKind -> GroupName TileKind
ccornerTile, GroupName TileKind
cwallTile :: GroupName TileKind
cwallTile :: CaveKind -> GroupName TileKind
cwallTile}
           Bool
dnight ContentId TileKind
darkCorTile ContentId TileKind
litCorTile Bool
dark Fence
fence Area
qarea = do
  ContentId TileKind
qFWall <- ContentId TileKind
-> Maybe (ContentId TileKind) -> ContentId TileKind
forall a. a -> Maybe a -> a
fromMaybe (String -> ContentId TileKind
forall a. HasCallStack => String -> a
error (String -> ContentId TileKind) -> String -> ContentId TileKind
forall a b. (a -> b) -> a -> b
$ String
"" String -> GroupName TileKind -> String
forall v. Show v => String -> v -> String
`showFailure` GroupName TileKind
cwallTile)
            (Maybe (ContentId TileKind) -> ContentId TileKind)
-> Rnd (Maybe (ContentId TileKind))
-> StateT SMGen Identity (ContentId TileKind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContentData TileKind
-> GroupName TileKind
-> (TileKind -> Bool)
-> Rnd (Maybe (ContentId TileKind))
forall a.
Show a =>
ContentData a
-> GroupName a -> (a -> Bool) -> Rnd (Maybe (ContentId a))
opick ContentData TileKind
cotile GroupName TileKind
cwallTile (Bool -> TileKind -> Bool
forall a b. a -> b -> a
const Bool
True)
  ContentId TileKind
qFCorner <- ContentId TileKind
-> Maybe (ContentId TileKind) -> ContentId TileKind
forall a. a -> Maybe a -> a
fromMaybe (String -> ContentId TileKind
forall a. HasCallStack => String -> a
error (String -> ContentId TileKind) -> String -> ContentId TileKind
forall a b. (a -> b) -> a -> b
$ String
"" String -> GroupName TileKind -> String
forall v. Show v => String -> v -> String
`showFailure` GroupName TileKind
ccornerTile)
              (Maybe (ContentId TileKind) -> ContentId TileKind)
-> Rnd (Maybe (ContentId TileKind))
-> StateT SMGen Identity (ContentId TileKind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContentData TileKind
-> GroupName TileKind
-> (TileKind -> Bool)
-> Rnd (Maybe (ContentId TileKind))
forall a.
Show a =>
ContentData a
-> GroupName a -> (a -> Bool) -> Rnd (Maybe (ContentId a))
opick ContentData TileKind
cotile GroupName TileKind
ccornerTile (Bool -> TileKind -> Bool
forall a b. a -> b -> a
const Bool
True)
  let qFFloor :: ContentId TileKind
qFFloor = if Bool
dark then ContentId TileKind
darkCorTile else ContentId TileKind
litCorTile
      qFGround :: ContentId TileKind
qFGround = if Bool
dnight then ContentId TileKind
darkCorTile else ContentId TileKind
litCorTile
  TileMapEM -> Rnd TileMapEM
forall (m :: * -> *) a. Monad m => a -> m a
return (TileMapEM -> Rnd TileMapEM) -> TileMapEM -> Rnd TileMapEM
forall a b. (a -> b) -> a -> b
$! case Fence
fence of
    Fence
FWall -> ContentId TileKind -> ContentId TileKind -> Area -> TileMapEM
buildFenceMap ContentId TileKind
qFWall ContentId TileKind
qFCorner Area
qarea
    Fence
FFloor -> ContentId TileKind -> ContentId TileKind -> Area -> TileMapEM
buildFenceMap ContentId TileKind
qFFloor ContentId TileKind
qFFloor Area
qarea
    Fence
FGround -> ContentId TileKind -> ContentId TileKind -> Area -> TileMapEM
buildFenceMap ContentId TileKind
qFGround ContentId TileKind
qFGround Area
qarea
    Fence
FNone -> TileMapEM
forall k a. EnumMap k a
EM.empty

-- | Construct a fence around an area, with the given tile kind.
-- Corners have a different kind, e.g., to avoid putting doors there.
buildFenceMap :: ContentId TileKind -> ContentId TileKind -> Area -> TileMapEM
buildFenceMap :: ContentId TileKind -> ContentId TileKind -> Area -> TileMapEM
buildFenceMap ContentId TileKind
wallId ContentId TileKind
cornerId Area
area =
  let (Int
x0, Int
y0, Int
x1, Int
y1) = Area -> (Int, Int, Int, Int)
fromArea Area
area
  in [(Point, ContentId TileKind)] -> TileMapEM
forall k a. Enum k => [(k, a)] -> EnumMap k a
EM.fromList ([(Point, ContentId TileKind)] -> TileMapEM)
-> [(Point, ContentId TileKind)] -> TileMapEM
forall a b. (a -> b) -> a -> b
$ [ (Int -> Int -> Point
Point Int
x Int
y, ContentId TileKind
wallId)
                   | Int
x <- [Int
x0Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1, Int
x1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1], Int
y <- [Int
y0..Int
y1] ] [(Point, ContentId TileKind)]
-> [(Point, ContentId TileKind)] -> [(Point, ContentId TileKind)]
forall a. [a] -> [a] -> [a]
++
                   [ (Int -> Int -> Point
Point Int
x Int
y, ContentId TileKind
wallId)
                   | Int
x <- [Int
x0..Int
x1], Int
y <- [Int
y0Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1, Int
y1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1] ] [(Point, ContentId TileKind)]
-> [(Point, ContentId TileKind)] -> [(Point, ContentId TileKind)]
forall a. [a] -> [a] -> [a]
++
                   [ (Int -> Int -> Point
Point Int
x Int
y, ContentId TileKind
cornerId)
                   | Int
x <- [Int
x0Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1, Int
x1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1], Int
y <- [Int
y0Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1, Int
y1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1] ]

-- | Construct a fence around an area, with the given tile group.
buildFenceRnd :: COps
              -> GroupName TileKind -> GroupName TileKind
              -> GroupName TileKind -> GroupName TileKind
              -> Area
              -> Rnd TileMapEM
buildFenceRnd :: COps
-> GroupName TileKind
-> GroupName TileKind
-> GroupName TileKind
-> GroupName TileKind
-> Area
-> Rnd TileMapEM
buildFenceRnd COps{ContentData TileKind
cotile :: ContentData TileKind
cotile :: COps -> ContentData TileKind
cotile}
              GroupName TileKind
cfenceTileN GroupName TileKind
cfenceTileE GroupName TileKind
cfenceTileS GroupName TileKind
cfenceTileW Area
area = do
  let (Int
x0, Int
y0, Int
x1, Int
y1) = Area -> (Int, Int, Int, Int)
fromArea Area
area
      allTheSame :: Bool
allTheSame = (GroupName TileKind -> Bool) -> [GroupName TileKind] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (GroupName TileKind -> GroupName TileKind -> Bool
forall a. Eq a => a -> a -> Bool
== GroupName TileKind
cfenceTileN) [GroupName TileKind
cfenceTileE, GroupName TileKind
cfenceTileS, GroupName TileKind
cfenceTileW]
      fenceIdRnd :: GroupName TileKind
-> (Int, Int) -> StateT SMGen Identity (Point, ContentId TileKind)
fenceIdRnd GroupName TileKind
couterFenceTile (Int
xf, Int
yf) = do
        let isCorner :: Int -> Int -> Bool
isCorner Int
x Int
y = Int
x Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
x0Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1, Int
x1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1] Bool -> Bool -> Bool
&& Int
y Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
y0Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1, Int
y1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1]
            tileGroup :: GroupName TileKind
tileGroup | Int -> Int -> Bool
isCorner Int
xf Int
yf Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
allTheSame = GroupName TileKind
TK.S_BASIC_OUTER_FENCE
                      | Bool
otherwise = GroupName TileKind
couterFenceTile
        ContentId TileKind
fenceId <- ContentId TileKind
-> Maybe (ContentId TileKind) -> ContentId TileKind
forall a. a -> Maybe a -> a
fromMaybe (String -> ContentId TileKind
forall a. HasCallStack => String -> a
error (String -> ContentId TileKind) -> String -> ContentId TileKind
forall a b. (a -> b) -> a -> b
$ String
"" String -> GroupName TileKind -> String
forall v. Show v => String -> v -> String
`showFailure` GroupName TileKind
tileGroup)
                   (Maybe (ContentId TileKind) -> ContentId TileKind)
-> Rnd (Maybe (ContentId TileKind))
-> StateT SMGen Identity (ContentId TileKind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContentData TileKind
-> GroupName TileKind
-> (TileKind -> Bool)
-> Rnd (Maybe (ContentId TileKind))
forall a.
Show a =>
ContentData a
-> GroupName a -> (a -> Bool) -> Rnd (Maybe (ContentId a))
opick ContentData TileKind
cotile GroupName TileKind
tileGroup (Bool -> TileKind -> Bool
forall a b. a -> b -> a
const Bool
True)
        (Point, ContentId TileKind)
-> StateT SMGen Identity (Point, ContentId TileKind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Int -> Point
Point Int
xf Int
yf, ContentId TileKind
fenceId)
      pointListN :: [(Int, Int)]
pointListN = [(Int
x, Int
y0Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) | Int
x <- [Int
x0Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1..Int
x1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1]]
      pointListE :: [(Int, Int)]
pointListE = [(Int
x1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, Int
y) | Int
y <- [Int
y0..Int
y1]]
      pointListS :: [(Int, Int)]
pointListS = [(Int
x, Int
y1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) | Int
x <- [Int
x0Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1..Int
x1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1]]
      pointListW :: [(Int, Int)]
pointListW = [(Int
x0Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1, Int
y) | Int
y <- [Int
y0..Int
y1]]
  [(Point, ContentId TileKind)]
fenceListN <- ((Int, Int) -> StateT SMGen Identity (Point, ContentId TileKind))
-> [(Int, Int)]
-> StateT SMGen Identity [(Point, ContentId TileKind)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (GroupName TileKind
-> (Int, Int) -> StateT SMGen Identity (Point, ContentId TileKind)
fenceIdRnd GroupName TileKind
cfenceTileN) [(Int, Int)]
pointListN
  [(Point, ContentId TileKind)]
fenceListE <- ((Int, Int) -> StateT SMGen Identity (Point, ContentId TileKind))
-> [(Int, Int)]
-> StateT SMGen Identity [(Point, ContentId TileKind)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (GroupName TileKind
-> (Int, Int) -> StateT SMGen Identity (Point, ContentId TileKind)
fenceIdRnd GroupName TileKind
cfenceTileE) [(Int, Int)]
pointListE
  [(Point, ContentId TileKind)]
fenceListS <- ((Int, Int) -> StateT SMGen Identity (Point, ContentId TileKind))
-> [(Int, Int)]
-> StateT SMGen Identity [(Point, ContentId TileKind)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (GroupName TileKind
-> (Int, Int) -> StateT SMGen Identity (Point, ContentId TileKind)
fenceIdRnd GroupName TileKind
cfenceTileS) [(Int, Int)]
pointListS
  [(Point, ContentId TileKind)]
fenceListW <- ((Int, Int) -> StateT SMGen Identity (Point, ContentId TileKind))
-> [(Int, Int)]
-> StateT SMGen Identity [(Point, ContentId TileKind)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (GroupName TileKind
-> (Int, Int) -> StateT SMGen Identity (Point, ContentId TileKind)
fenceIdRnd GroupName TileKind
cfenceTileW) [(Int, Int)]
pointListW
  TileMapEM -> Rnd TileMapEM
forall (m :: * -> *) a. Monad m => a -> m a
return (TileMapEM -> Rnd TileMapEM) -> TileMapEM -> Rnd TileMapEM
forall a b. (a -> b) -> a -> b
$! [(Point, ContentId TileKind)] -> TileMapEM
forall k a. Enum k => [(k, a)] -> EnumMap k a
EM.fromList ([(Point, ContentId TileKind)] -> TileMapEM)
-> [(Point, ContentId TileKind)] -> TileMapEM
forall a b. (a -> b) -> a -> b
$ [(Point, ContentId TileKind)]
fenceListN [(Point, ContentId TileKind)]
-> [(Point, ContentId TileKind)] -> [(Point, ContentId TileKind)]
forall a. [a] -> [a] -> [a]
++ [(Point, ContentId TileKind)]
fenceListE [(Point, ContentId TileKind)]
-> [(Point, ContentId TileKind)] -> [(Point, ContentId TileKind)]
forall a. [a] -> [a] -> [a]
++ [(Point, ContentId TileKind)]
fenceListS [(Point, ContentId TileKind)]
-> [(Point, ContentId TileKind)] -> [(Point, ContentId TileKind)]
forall a. [a] -> [a] -> [a]
++ [(Point, ContentId TileKind)]
fenceListW

-- | Create a place by tiling patterns.
tilePlace :: Area                           -- ^ the area to fill
          -> PlaceKind                      -- ^ the place kind to construct
          -> Rnd (EM.EnumMap Point Char)
tilePlace :: Area -> PlaceKind -> Rnd (EnumMap Point Char)
tilePlace Area
area pl :: PlaceKind
pl@PlaceKind{Rarity
Freqs PlaceKind
[Text]
EnumMap Char (GroupName TileKind)
Text
Fence
Cover
plegendLit :: EnumMap Char (GroupName TileKind)
plegendDark :: EnumMap Char (GroupName TileKind)
ptopLeft :: [Text]
pfence :: Fence
pcover :: Cover
prarity :: Rarity
pfreq :: Freqs PlaceKind
pname :: Text
plegendLit :: PlaceKind -> EnumMap Char (GroupName TileKind)
plegendDark :: PlaceKind -> EnumMap Char (GroupName TileKind)
ptopLeft :: PlaceKind -> [Text]
pfence :: PlaceKind -> Fence
pcover :: PlaceKind -> Cover
prarity :: PlaceKind -> Rarity
pfreq :: PlaceKind -> Freqs PlaceKind
pname :: PlaceKind -> Text
..} = do
  let (Point Int
x0 Int
y0, Int
xspan, Int
yspan) = Area -> (Point, Int, Int)
spanArea Area
area
      dxcorner :: Int
dxcorner = case [Text]
ptopLeft of
        [] -> String -> Int
forall a. HasCallStack => String -> a
error (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ String
"" String -> (Area, PlaceKind) -> String
forall v. Show v => String -> v -> String
`showFailure` (Area
area, PlaceKind
pl)
        Text
l : [Text]
_ -> Text -> Int
T.length Text
l
      (Int
dx, Int
dy) = Bool -> (Int, Int) -> (Int, Int)
forall a. HasCallStack => Bool -> a -> a
assert (Int
xspan Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
dxcorner Bool -> Bool -> Bool
&& Int
yspan Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [Text] -> Int
forall a. [a] -> Int
length [Text]
ptopLeft
                         Bool -> (Area, PlaceKind) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` (Area
area, PlaceKind
pl))
                        (Int
xspan, Int
yspan)
      fromX :: (Int, Int) -> [Point]
fromX (Int
x2, Int
y2) = (Int -> Point) -> [Int] -> [Point]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Point
`Point` Int
y2) [Int
x2..]
      fillInterior :: (Int -> String -> String)
                   -> (Int -> [String] -> [String])
                   -> [(Point, Char)]
      fillInterior :: (Int -> ShowS) -> (Int -> [String] -> [String]) -> [(Point, Char)]
fillInterior Int -> ShowS
f Int -> [String] -> [String]
g =
        let tileInterior :: (Int, String) -> [(Point, Char)]
tileInterior (Int
y, String
row) =
              let fx :: String
fx = Int -> ShowS
f Int
dx String
row
                  xStart :: Int
xStart = Int
x0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ((Int
xspan Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
length String
fx) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2)
              in ((Point, Char) -> Bool) -> [(Point, Char)] -> [(Point, Char)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'X') (Char -> Bool) -> ((Point, Char) -> Char) -> (Point, Char) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point, Char) -> Char
forall a b. (a, b) -> b
snd) ([(Point, Char)] -> [(Point, Char)])
-> [(Point, Char)] -> [(Point, Char)]
forall a b. (a -> b) -> a -> b
$ [Point] -> String -> [(Point, Char)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Int, Int) -> [Point]
fromX (Int
xStart, Int
y)) String
fx
            reflected :: [(Int, String)]
reflected =
              let gy :: [String]
gy = Int -> [String] -> [String]
g Int
dy ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack [Text]
ptopLeft
                  yStart :: Int
yStart = Int
y0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ((Int
yspan Int -> Int -> Int
forall a. Num a => a -> a -> a
- [String] -> Int
forall a. [a] -> Int
length [String]
gy) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2)
              in [Int] -> [String] -> [(Int, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
yStart..] [String]
gy
        in ((Int, String) -> [(Point, Char)])
-> [(Int, String)] -> [(Point, Char)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int, String) -> [(Point, Char)]
tileInterior [(Int, String)]
reflected
      tileReflect :: Int -> [a] -> [a]
      tileReflect :: Int -> [a] -> [a]
tileReflect Int
d [a]
pat =
        let lstart :: [a]
lstart = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take (Int
d Int -> Int -> Int
forall a. Integral a => a -> a -> a
`divUp` Int
2) [a]
pat
            lend :: [a]
lend   = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take (Int
d Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div`   Int
2) [a]
pat
        in [a]
lstart [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a] -> [a]
forall a. [a] -> [a]
reverse [a]
lend
  [(Point, Char)]
interior <- case Cover
pcover of
    Cover
CAlternate -> do
      let tile :: Int -> [a] -> [a]
          tile :: Int -> [a] -> [a]
tile Int
_ []  = String -> [a]
forall a. HasCallStack => String -> a
error (String -> [a]) -> String -> [a]
forall a b. (a -> b) -> a -> b
$ String
"nothing to tile" String -> PlaceKind -> String
forall v. Show v => String -> v -> String
`showFailure` PlaceKind
pl
          tile Int
d [a]
pat = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
d ([a] -> [a]
forall a. [a] -> [a]
cycle ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ [a] -> [a]
forall a. [a] -> [a]
init [a]
pat [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a] -> [a]
forall a. [a] -> [a]
init ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
pat))
      [(Point, Char)] -> StateT SMGen Identity [(Point, Char)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Point, Char)] -> StateT SMGen Identity [(Point, Char)])
-> [(Point, Char)] -> StateT SMGen Identity [(Point, Char)]
forall a b. (a -> b) -> a -> b
$! (Int -> ShowS) -> (Int -> [String] -> [String]) -> [(Point, Char)]
fillInterior Int -> ShowS
forall a. Int -> [a] -> [a]
tile Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
tile
    Cover
CStretch -> do
      let stretch :: Int -> [a] -> [a]
          stretch :: Int -> [a] -> [a]
stretch Int
_ []  = String -> [a]
forall a. HasCallStack => String -> a
error (String -> [a]) -> String -> [a]
forall a b. (a -> b) -> a -> b
$ String
"nothing to stretch" String -> PlaceKind -> String
forall v. Show v => String -> v -> String
`showFailure` PlaceKind
pl
          stretch Int
d [a]
pat = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
tileReflect Int
d ([a]
pat [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ a -> [a]
forall a. a -> [a]
repeat ([a] -> a
forall a. [a] -> a
last [a]
pat))
      [(Point, Char)] -> StateT SMGen Identity [(Point, Char)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Point, Char)] -> StateT SMGen Identity [(Point, Char)])
-> [(Point, Char)] -> StateT SMGen Identity [(Point, Char)]
forall a b. (a -> b) -> a -> b
$! (Int -> ShowS) -> (Int -> [String] -> [String]) -> [(Point, Char)]
fillInterior Int -> ShowS
forall a. Int -> [a] -> [a]
stretch Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
stretch
    Cover
CReflect -> do
      let reflect :: Int -> [a] -> [a]
          reflect :: Int -> [a] -> [a]
reflect Int
d [a]
pat = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
tileReflect Int
d ([a] -> [a]
forall a. [a] -> [a]
cycle [a]
pat)
      [(Point, Char)] -> StateT SMGen Identity [(Point, Char)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Point, Char)] -> StateT SMGen Identity [(Point, Char)])
-> [(Point, Char)] -> StateT SMGen Identity [(Point, Char)]
forall a b. (a -> b) -> a -> b
$! (Int -> ShowS) -> (Int -> [String] -> [String]) -> [(Point, Char)]
fillInterior Int -> ShowS
forall a. Int -> [a] -> [a]
reflect Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
reflect
    Cover
CVerbatim -> [(Point, Char)] -> StateT SMGen Identity [(Point, Char)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Point, Char)] -> StateT SMGen Identity [(Point, Char)])
-> [(Point, Char)] -> StateT SMGen Identity [(Point, Char)]
forall a b. (a -> b) -> a -> b
$! (Int -> ShowS) -> (Int -> [String] -> [String]) -> [(Point, Char)]
fillInterior (\ Int
_ String
x -> String
x) (\ Int
_ [String]
x -> [String]
x)
    Cover
CMirror -> do
      ShowS
mirror1 <- [ShowS] -> Rnd ShowS
forall a. [a] -> Rnd a
oneOf [ShowS
forall a. a -> a
id, ShowS
forall a. [a] -> [a]
reverse]
      [String] -> [String]
mirror2 <- [[String] -> [String]] -> Rnd ([String] -> [String])
forall a. [a] -> Rnd a
oneOf [[String] -> [String]
forall a. a -> a
id, [String] -> [String]
forall a. [a] -> [a]
reverse]
      [(Point, Char)] -> StateT SMGen Identity [(Point, Char)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Point, Char)] -> StateT SMGen Identity [(Point, Char)])
-> [(Point, Char)] -> StateT SMGen Identity [(Point, Char)]
forall a b. (a -> b) -> a -> b
$! (Int -> ShowS) -> (Int -> [String] -> [String]) -> [(Point, Char)]
fillInterior (\Int
_ String
l -> ShowS
mirror1 String
l) (\Int
_ [String]
l -> [String] -> [String]
mirror2 [String]
l)
  EnumMap Point Char -> Rnd (EnumMap Point Char)
forall (m :: * -> *) a. Monad m => a -> m a
return (EnumMap Point Char -> Rnd (EnumMap Point Char))
-> EnumMap Point Char -> Rnd (EnumMap Point Char)
forall a b. (a -> b) -> a -> b
$! [(Point, Char)] -> EnumMap Point Char
forall k a. Enum k => [(k, a)] -> EnumMap k a
EM.fromList [(Point, Char)]
interior