{-# LANGUAGE RankNTypes #-}
module Game.LambdaHack.Server.DungeonGen.Place
( Place(..), TileMapEM, buildPlace, isChancePos, buildFenceRnd
#ifdef EXPOSE_INTERNAL
, 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
type TileMapEM = EM.EnumMap Point (ContentId TileKind)
data Place = Place
{ Place -> ContentId PlaceKind
qkind :: ContentId PlaceKind
, Place -> Area
qarea :: Area
, Place -> TileMapEM
qmap :: TileMapEM
, Place -> TileMapEM
qfence :: TileMapEM
}
deriving X -> Place -> ShowS
[Place] -> ShowS
Place -> String
(X -> Place -> ShowS)
-> (Place -> String) -> ([Place] -> ShowS) -> Show Place
forall a.
(X -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: X -> Place -> ShowS
showsPrec :: X -> Place -> ShowS
$cshow :: Place -> String
show :: Place -> String
$cshowList :: [Place] -> ShowS
showList :: [Place] -> ShowS
Show
placeCheck :: Area
-> PlaceKind
-> Bool
placeCheck :: Area -> PlaceKind -> Bool
placeCheck Area
r pk :: PlaceKind
pk@PlaceKind{Rarity
Freqs PlaceKind
[Text]
Text
EnumMap Char (GroupName TileKind)
Fence
Cover
pname :: Text
pfreq :: Freqs PlaceKind
prarity :: Rarity
pcover :: Cover
pfence :: Fence
ptopLeft :: [Text]
plegendDark :: EnumMap Char (GroupName TileKind)
plegendLit :: EnumMap Char (GroupName TileKind)
pname :: PlaceKind -> Text
pfreq :: PlaceKind -> Freqs PlaceKind
prarity :: PlaceKind -> Rarity
pcover :: PlaceKind -> Cover
pfence :: PlaceKind -> Fence
ptopLeft :: PlaceKind -> [Text]
plegendDark :: PlaceKind -> EnumMap Char (GroupName TileKind)
plegendLit :: PlaceKind -> EnumMap Char (GroupName TileKind)
..} =
case PlaceKind -> Area -> Maybe Area
interiorArea PlaceKind
pk Area
r of
Maybe Area
Nothing -> Bool
False
Just Area
area ->
let (Point
_, X
xspan, X
yspan) = Area -> (Point, X, X)
spanArea Area
area
dxcorner :: X
dxcorner = case [Text]
ptopLeft of [] -> X
0 ; Text
l : [Text]
_ -> Text -> X
T.length Text
l
dycorner :: X
dycorner = [Text] -> X
forall a. [a] -> X
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 = X
xspan X -> X -> Bool
forall a. Ord a => a -> a -> Bool
>= X
2 X -> X -> X
forall a. Num a => a -> a -> a
* X
dxcorner X -> X -> X
forall a. Num a => a -> a -> a
- X
1 Bool -> Bool -> Bool
&& X
yspan X -> X -> Bool
forall a. Ord a => a -> a -> Bool
>= X
2 X -> X -> X
forall a. Num a => a -> a -> a
* X
dycorner X -> X -> X
forall a. Num a => a -> a -> a
- X
1
in case Cover
pcover of
Cover
CAlternate -> X -> X -> Bool
forall {a}. Integral a => a -> a -> Bool
wholeOverlapped X
xspan X
dxcorner Bool -> Bool -> Bool
&&
X -> X -> Bool
forall {a}. Integral a => a -> a -> Bool
wholeOverlapped X
yspan X
dycorner
Cover
CStretch -> Bool
largeEnough
Cover
CReflect -> Bool
largeEnough
Cover
CVerbatim -> Bool
True
Cover
CMirror -> Bool
True
interiorArea :: PlaceKind -> Area -> Maybe Area
interiorArea :: PlaceKind -> Area -> Maybe Area
interiorArea PlaceKind
kr Area
r =
let requiredForFence :: X
requiredForFence = case PlaceKind -> Fence
pfence PlaceKind
kr of
Fence
FWall -> X
1
Fence
FFloor -> X
1
Fence
FGround -> X
1
Fence
FNone -> X
0
in if PlaceKind -> Cover
pcover PlaceKind
kr Cover -> [Cover] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Cover
CVerbatim, Cover
CMirror]
then let (Point X
x0 X
y0, X
xspan, X
yspan) = Area -> (Point, X, X)
spanArea Area
r
dx :: X
dx = case PlaceKind -> [Text]
ptopLeft PlaceKind
kr of
[] -> String -> X
forall a. HasCallStack => String -> a
error (String -> X) -> String -> X
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 -> X
T.length Text
l
dy :: X
dy = [Text] -> X
forall a. [a] -> X
length ([Text] -> X) -> [Text] -> X
forall a b. (a -> b) -> a -> b
$ PlaceKind -> [Text]
ptopLeft PlaceKind
kr
mx :: X
mx = (X
xspan X -> X -> X
forall a. Num a => a -> a -> a
- X
dx) X -> X -> X
forall a. Integral a => a -> a -> a
`div` X
2
my :: X
my = (X
yspan X -> X -> X
forall a. Num a => a -> a -> a
- X
dy) X -> X -> X
forall a. Integral a => a -> a -> a
`div` X
2
in if X
mx X -> X -> Bool
forall a. Ord a => a -> a -> Bool
< X
requiredForFence Bool -> Bool -> Bool
|| X
my X -> X -> Bool
forall a. Ord a => a -> a -> Bool
< X
requiredForFence
then Maybe Area
forall a. Maybe a
Nothing
else (X, X, X, X) -> Maybe Area
toArea (X
x0 X -> X -> X
forall a. Num a => a -> a -> a
+ X
mx, X
y0 X -> X -> X
forall a. Num a => a -> a -> a
+ X
my, X
x0 X -> X -> X
forall a. Num a => a -> a -> a
+ X
mx X -> X -> X
forall a. Num a => a -> a -> a
+ X
dx X -> X -> X
forall a. Num a => a -> a -> a
- X
1, X
y0 X -> X -> X
forall a. Num a => a -> a -> a
+ X
my X -> X -> X
forall a. Num a => a -> a -> a
+ X
dy X -> X -> X
forall a. Num a => a -> a -> a
- X
1)
else case X
requiredForFence of
X
0 -> Area -> Maybe Area
forall a. a -> Maybe a
Just Area
r
X
1 -> Area -> Maybe Area
shrink Area
r
X
_ -> 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
buildPlace :: COps
-> CaveKind
-> Bool
-> ContentId TileKind
-> ContentId TileKind
-> Dice.AbsDepth
-> Dice.AbsDepth
-> Word32
-> Area
-> Maybe Area
-> Freqs PlaceKind
-> 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 :: ContentData PlaceKind
coplace :: COps -> ContentData PlaceKind
coplace, TileSpeedup
coTileSpeedup :: TileSpeedup
coTileSpeedup :: COps -> TileSpeedup
coTileSpeedup}
kc :: CaveKind
kc@CaveKind{Bool
X
[X]
Freqs ItemKind
Freqs PlaceKind
Freqs CaveKind
Chance
Text
DiceXY
Dice
GroupName TileKind
InitSleep
cname :: Text
cfreq :: Freqs CaveKind
cXminSize :: X
cYminSize :: X
ccellSize :: DiceXY
cminPlaceSize :: DiceXY
cmaxPlaceSize :: DiceXY
cdarkOdds :: Dice
cnightOdds :: Dice
cauxConnects :: Chance
cmaxVoid :: Chance
cdoorChance :: Chance
copenChance :: Chance
chidden :: X
cactorCoeff :: X
cactorFreq :: Freqs ItemKind
citemNum :: Dice
citemFreq :: Freqs ItemKind
cplaceFreq :: Freqs PlaceKind
cpassable :: Bool
clabyrinth :: Bool
cdefTile :: GroupName TileKind
cdarkCorTile :: GroupName TileKind
clitCorTile :: GroupName TileKind
cwallTile :: GroupName TileKind
ccornerTile :: GroupName TileKind
cfenceTileN :: GroupName TileKind
cfenceTileE :: GroupName TileKind
cfenceTileS :: GroupName TileKind
cfenceTileW :: GroupName TileKind
cfenceApart :: Bool
cminStairDist :: X
cmaxStairsNum :: Dice
cescapeFreq :: Freqs PlaceKind
cstairFreq :: Freqs PlaceKind
cstairAllowed :: Freqs PlaceKind
cskip :: [X]
cinitSleep :: InitSleep
cdesc :: Text
cname :: CaveKind -> Text
cfreq :: CaveKind -> Freqs CaveKind
cXminSize :: CaveKind -> X
cYminSize :: CaveKind -> X
ccellSize :: CaveKind -> DiceXY
cminPlaceSize :: CaveKind -> DiceXY
cmaxPlaceSize :: CaveKind -> DiceXY
cdarkOdds :: CaveKind -> Dice
cnightOdds :: CaveKind -> Dice
cauxConnects :: CaveKind -> Chance
cmaxVoid :: CaveKind -> Chance
cdoorChance :: CaveKind -> Chance
copenChance :: CaveKind -> Chance
chidden :: CaveKind -> X
cactorCoeff :: CaveKind -> X
cactorFreq :: CaveKind -> Freqs ItemKind
citemNum :: CaveKind -> Dice
citemFreq :: CaveKind -> Freqs ItemKind
cplaceFreq :: CaveKind -> Freqs PlaceKind
cpassable :: CaveKind -> Bool
clabyrinth :: CaveKind -> Bool
cdefTile :: CaveKind -> GroupName TileKind
cdarkCorTile :: CaveKind -> GroupName TileKind
clitCorTile :: CaveKind -> GroupName TileKind
cwallTile :: CaveKind -> GroupName TileKind
ccornerTile :: CaveKind -> GroupName TileKind
cfenceTileN :: CaveKind -> GroupName TileKind
cfenceTileE :: CaveKind -> GroupName TileKind
cfenceTileS :: CaveKind -> GroupName TileKind
cfenceTileW :: CaveKind -> GroupName TileKind
cfenceApart :: CaveKind -> Bool
cminStairDist :: CaveKind -> X
cmaxStairsNum :: CaveKind -> Dice
cescapeFreq :: CaveKind -> Freqs PlaceKind
cstairFreq :: CaveKind -> Freqs PlaceKind
cstairAllowed :: CaveKind -> Freqs PlaceKind
cskip :: CaveKind -> [X]
cinitSleep :: CaveKind -> InitSleep
cdesc :: CaveKind -> Text
..} Bool
dnight ContentId TileKind
darkCorTile ContentId TileKind
litCorTile
levelDepth :: AbsDepth
levelDepth@(Dice.AbsDepth X
ldepth)
totalDepth :: AbsDepth
totalDepth@(Dice.AbsDepth X
tdepth)
Word32
dsecret Area
r Maybe Area
minnerArea Freqs PlaceKind
mplaceGroup = do
let f :: X
-> [(X, (ContentId PlaceKind, PlaceKind))]
-> X
-> ContentId PlaceKind
-> PlaceKind
-> [(X, (ContentId PlaceKind, PlaceKind))]
f !X
q ![(X, (ContentId PlaceKind, PlaceKind))]
acc !X
p !ContentId PlaceKind
pk !PlaceKind
kind =
let rarity :: X
rarity = X -> X -> Rarity -> X
linearInterpolation X
ldepth X
tdepth (PlaceKind -> Rarity
prarity PlaceKind
kind)
!fr :: X
fr = X
q X -> X -> X
forall a. Num a => a -> a -> a
* X
p X -> X -> X
forall a. Num a => a -> a -> a
* X
rarity
in (X
fr, (ContentId PlaceKind
pk, PlaceKind
kind)) (X, (ContentId PlaceKind, PlaceKind))
-> [(X, (ContentId PlaceKind, PlaceKind))]
-> [(X, (ContentId PlaceKind, PlaceKind))]
forall a. a -> [a] -> [a]
: [(X, (ContentId PlaceKind, PlaceKind))]
acc
g :: (GroupName PlaceKind, X) -> [(X, (ContentId PlaceKind, PlaceKind))]
g (GroupName PlaceKind
placeGroup, X
q) = ContentData PlaceKind
-> GroupName PlaceKind
-> ([(X, (ContentId PlaceKind, PlaceKind))]
-> X
-> ContentId PlaceKind
-> PlaceKind
-> [(X, (ContentId PlaceKind, PlaceKind))])
-> [(X, (ContentId PlaceKind, PlaceKind))]
-> [(X, (ContentId PlaceKind, PlaceKind))]
forall a b.
ContentData a
-> GroupName a -> (b -> X -> ContentId a -> a -> b) -> b -> b
ofoldlGroup' ContentData PlaceKind
coplace GroupName PlaceKind
placeGroup (X
-> [(X, (ContentId PlaceKind, PlaceKind))]
-> X
-> ContentId PlaceKind
-> PlaceKind
-> [(X, (ContentId PlaceKind, PlaceKind))]
f X
q) []
pfreq :: Freqs PlaceKind
pfreq = case Freqs PlaceKind
mplaceGroup of
[] -> Freqs PlaceKind
cplaceFreq
Freqs PlaceKind
_ -> Freqs PlaceKind
mplaceGroup
placeFreq :: [(X, (ContentId PlaceKind, PlaceKind))]
placeFreq = ((GroupName PlaceKind, X)
-> [(X, (ContentId PlaceKind, PlaceKind))])
-> Freqs PlaceKind -> [(X, (ContentId PlaceKind, PlaceKind))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (GroupName PlaceKind, X) -> [(X, (ContentId PlaceKind, PlaceKind))]
g Freqs PlaceKind
pfreq
checkedFreq :: [(X, (ContentId PlaceKind, PlaceKind))]
checkedFreq = ((X, (ContentId PlaceKind, PlaceKind)) -> Bool)
-> [(X, (ContentId PlaceKind, PlaceKind))]
-> [(X, (ContentId PlaceKind, PlaceKind))]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(X
_, (ContentId PlaceKind
_, PlaceKind
kind)) -> Area -> PlaceKind -> Bool
placeCheck Area
r PlaceKind
kind) [(X, (ContentId PlaceKind, PlaceKind))]
placeFreq
freq :: Frequency (ContentId PlaceKind, PlaceKind)
freq = Text
-> [(X, (ContentId PlaceKind, PlaceKind))]
-> Frequency (ContentId PlaceKind, PlaceKind)
forall a. Text -> [(X, a)] -> Frequency a
toFreq Text
"buildPlace" [(X, (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
-> ([(X, (ContentId PlaceKind, PlaceKind))],
[(X, (ContentId PlaceKind, PlaceKind))], Area)
-> Bool
forall v. Show v => Bool -> v -> Bool
`blame` ([(X, (ContentId PlaceKind, PlaceKind))]
placeFreq, [(X, (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 a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Cover
CVerbatim, Cover
CMirror]
Bool -> Bool -> Bool
&& ([Text] -> X
forall a. [a] -> X
length (PlaceKind -> [Text]
ptopLeft PlaceKind
kr) X -> X -> Bool
forall a. Ord a => a -> a -> Bool
< X
10
Bool -> Bool -> Bool
|| Text -> X
T.length ([Text] -> Text
forall a. HasCallStack => [a] -> a
head (PlaceKind -> [Text]
ptopLeft PlaceKind
kr)) X -> X -> Bool
forall a. Ord a => a -> a -> Bool
< X
10)
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)
Bool -> Bool -> Bool
&& (PlaceKind -> Fence
pfence PlaceKind
kr Fence -> [Fence] -> Bool
forall a. Eq a => a -> [a] -> 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 a. a -> StateT SMGen Identity a
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 a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Cover
CVerbatim, Cover
CMirror] -> do
let requiredForFence :: X
requiredForFence = case PlaceKind -> Fence
pfence PlaceKind
kr of
Fence
FWall -> X
1
Fence
FFloor -> X
1
Fence
FGround -> X
1
Fence
FNone -> X
0
sizeBetter :: (X, X)
sizeBetter = ( X
2 X -> X -> X
forall a. Num a => a -> a -> a
* X
requiredForFence
X -> X -> X
forall a. Num a => a -> a -> a
+ Text -> X
T.length ([Text] -> Text
forall a. HasCallStack => [a] -> a
head (PlaceKind -> [Text]
ptopLeft PlaceKind
kr))
, X
2 X -> X -> X
forall a. Num a => a -> a -> a
* X
requiredForFence
X -> X -> X
forall a. Num a => a -> a -> a
+ [Text] -> X
forall a. [a] -> X
length (PlaceKind -> [Text]
ptopLeft PlaceKind
kr) )
(X, X) -> (X, X) -> Area -> StateT SMGen Identity Area
mkRoom (X, X)
sizeBetter (X, X)
sizeBetter Area
innerArea
Maybe Area
_ -> Area -> StateT SMGen Identity Area
forall a. a -> StateT SMGen Identity a
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 (X, X, ContentId TileKind), ContentId TileKind)
mOneIn <- COps
-> EnumMap Char (GroupName TileKind)
-> Rnd
(EnumMap
Char (Maybe (X, X, 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 (X, X, ContentId TileKind), ContentId TileKind)
tktk = (Maybe (X, X, ContentId TileKind), ContentId TileKind)
-> Char
-> EnumMap
Char (Maybe (X, X, ContentId TileKind), ContentId TileKind)
-> (Maybe (X, X, ContentId TileKind), ContentId TileKind)
forall k a. Enum k => a -> k -> EnumMap k a -> a
EM.findWithDefault
(String -> (Maybe (X, X, ContentId TileKind), ContentId TileKind)
forall a. HasCallStack => String -> a
error (String -> (Maybe (X, X, ContentId TileKind), ContentId TileKind))
-> String -> (Maybe (X, X, ContentId TileKind), ContentId TileKind)
forall a b. (a -> b) -> a -> b
$ String
"" String
-> (Char,
EnumMap
Char (Maybe (X, X, ContentId TileKind), ContentId TileKind))
-> String
forall v. Show v => String -> v -> String
`showFailure` (Char
c, EnumMap Char (Maybe (X, X, ContentId TileKind), ContentId TileKind)
mOneIn)) Char
c EnumMap Char (Maybe (X, X, ContentId TileKind), ContentId TileKind)
mOneIn
in case (Maybe (X, X, ContentId TileKind), ContentId TileKind)
tktk of
(Just (X
k, X
n, ContentId TileKind
tkSpice), ContentId TileKind
_) | X -> X -> Word32 -> Point -> Bool
isChancePos X
k X
n Word32
dsecret Point
xy -> ContentId TileKind
tkSpice
(Maybe (X, X, 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 a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Place -> Rnd Place) -> Place -> Rnd Place
forall a b. (a -> b) -> a -> b
$! Place {TileMapEM
ContentId PlaceKind
Area
qkind :: ContentId PlaceKind
qarea :: Area
qmap :: TileMapEM
qfence :: TileMapEM
qkind :: ContentId PlaceKind
qarea :: Area
qmap :: TileMapEM
qfence :: TileMapEM
..}
isChancePos :: Int -> Int -> Word32 -> Point -> Bool
isChancePos :: X -> X -> Word32 -> Point -> Bool
isChancePos X
k' X
n' Word32
dsecret (Point X
x' X
y') = X
k' X -> X -> Bool
forall a. Ord a => a -> a -> Bool
> X
0 Bool -> Bool -> Bool
&& X
n' X -> X -> Bool
forall a. Ord a => a -> a -> Bool
> X
0 Bool -> Bool -> Bool
&&
let k :: Word32
k = X -> Word32
forall a. Enum a => X -> a
toEnum X
k'
n :: Word32
n = X -> Word32
forall a. Enum a => X -> a
toEnum X
n'
x :: Word32
x = X -> Word32
forall a. Enum a => X -> a
toEnum X
x'
y :: Word32
y = X -> Word32
forall a. Enum a => X -> a
toEnum X
y'
z :: Word32
z = Word32
dsecret Word32 -> X -> Word32
forall a. Bits a => a -> X -> a
`Bits.rotateR` X
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
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 (X, X, ContentId TileKind), ContentId TileKind))
pover COps{ContentData TileKind
cotile :: ContentData TileKind
cotile :: COps -> 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
-> (X, X, ContentId TileKind)
assignKN GroupName TileKind
cgroup ContentId TileKind
tk ContentId TileKind
tkSpice =
let n :: X
n = X -> Maybe X -> X
forall a. a -> Maybe a -> a
fromMaybe (String -> X
forall a. HasCallStack => String -> a
error (String -> X) -> String -> X
forall a b. (a -> b) -> a -> b
$ GroupName TileKind -> String
forall a. Show a => a -> String
show GroupName TileKind
cgroup)
(GroupName TileKind -> [(GroupName TileKind, X)] -> Maybe X
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup GroupName TileKind
cgroup (TileKind -> [(GroupName TileKind, X)]
TK.tfreq (ContentData TileKind -> ContentId TileKind -> TileKind
forall a. ContentData a -> ContentId a -> a
okind ContentData TileKind
cotile ContentId TileKind
tk)))
k :: X
k = X -> Maybe X -> X
forall a. a -> Maybe a -> a
fromMaybe (String -> X
forall a. HasCallStack => String -> a
error (String -> X) -> String -> X
forall a b. (a -> b) -> a -> b
$ GroupName TileKind -> String
forall a. Show a => a -> String
show GroupName TileKind
cgroup)
(GroupName TileKind -> [(GroupName TileKind, X)] -> Maybe X
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup GroupName TileKind
cgroup (TileKind -> [(GroupName TileKind, X)]
TK.tfreq (ContentData TileKind -> ContentId TileKind -> TileKind
forall a. ContentData a -> ContentId a -> a
okind ContentData TileKind
cotile ContentId TileKind
tkSpice)))
in (X
k, X
n, ContentId TileKind
tkSpice)
getLegend :: GroupName TileKind
-> Rnd ( Maybe (Int, Int, ContentId TileKind)
, ContentId TileKind )
getLegend :: GroupName TileKind
-> Rnd (Maybe (X, X, 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 (X, X, ContentId TileKind), ContentId TileKind)
-> Rnd (Maybe (X, X, ContentId TileKind), ContentId TileKind)
forall a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (GroupName TileKind
-> ContentId TileKind
-> ContentId TileKind
-> (X, X, ContentId TileKind)
assignKN GroupName TileKind
cgroup ContentId TileKind
tk (ContentId TileKind -> (X, X, ContentId TileKind))
-> Maybe (ContentId TileKind) -> Maybe (X, X, 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 (X, X, ContentId TileKind), ContentId TileKind))
-> EnumMap Char (GroupName TileKind)
-> Rnd
(EnumMap
Char (Maybe (X, X, ContentId TileKind), ContentId TileKind))
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) -> EnumMap Char a -> m (EnumMap Char b)
mapM GroupName TileKind
-> Rnd (Maybe (X, X, ContentId TileKind), ContentId TileKind)
getLegend EnumMap Char (GroupName TileKind)
plegend
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 :: COps -> ContentData TileKind
cotile :: ContentData TileKind
cotile} CaveKind{GroupName TileKind
ccornerTile :: CaveKind -> GroupName TileKind
ccornerTile :: GroupName TileKind
ccornerTile, GroupName TileKind
cwallTile :: CaveKind -> GroupName TileKind
cwallTile :: 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 a. a -> StateT SMGen Identity a
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
buildFenceMap :: ContentId TileKind -> ContentId TileKind -> Area -> TileMapEM
buildFenceMap :: ContentId TileKind -> ContentId TileKind -> Area -> TileMapEM
buildFenceMap ContentId TileKind
wallId ContentId TileKind
cornerId Area
area =
let (X
x0, X
y0, X
x1, X
y1) = Area -> (X, X, X, X)
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
$ [ (X -> X -> Point
Point X
x X
y, ContentId TileKind
wallId)
| X
x <- [X
x0X -> X -> X
forall a. Num a => a -> a -> a
-X
1, X
x1X -> X -> X
forall a. Num a => a -> a -> a
+X
1], X
y <- [X
y0..X
y1] ] [(Point, ContentId TileKind)]
-> [(Point, ContentId TileKind)] -> [(Point, ContentId TileKind)]
forall a. [a] -> [a] -> [a]
++
[ (X -> X -> Point
Point X
x X
y, ContentId TileKind
wallId)
| X
x <- [X
x0..X
x1], X
y <- [X
y0X -> X -> X
forall a. Num a => a -> a -> a
-X
1, X
y1X -> X -> X
forall a. Num a => a -> a -> a
+X
1] ] [(Point, ContentId TileKind)]
-> [(Point, ContentId TileKind)] -> [(Point, ContentId TileKind)]
forall a. [a] -> [a] -> [a]
++
[ (X -> X -> Point
Point X
x X
y, ContentId TileKind
cornerId)
| X
x <- [X
x0X -> X -> X
forall a. Num a => a -> a -> a
-X
1, X
x1X -> X -> X
forall a. Num a => a -> a -> a
+X
1], X
y <- [X
y0X -> X -> X
forall a. Num a => a -> a -> a
-X
1, X
y1X -> X -> X
forall a. Num a => a -> a -> a
+X
1] ]
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 :: COps -> ContentData TileKind
cotile :: ContentData TileKind
cotile}
GroupName TileKind
cfenceTileN GroupName TileKind
cfenceTileE GroupName TileKind
cfenceTileS GroupName TileKind
cfenceTileW Area
area = do
let (X
x0, X
y0, X
x1, X
y1) = Area -> (X, X, X, X)
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
-> (X, X) -> StateT SMGen Identity (Point, ContentId TileKind)
fenceIdRnd GroupName TileKind
couterFenceTile (X
xf, X
yf) = do
let isCorner :: X -> X -> Bool
isCorner X
x X
y = X
x X -> [X] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [X
x0X -> X -> X
forall a. Num a => a -> a -> a
-X
1, X
x1X -> X -> X
forall a. Num a => a -> a -> a
+X
1] Bool -> Bool -> Bool
&& X
y X -> [X] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [X
y0X -> X -> X
forall a. Num a => a -> a -> a
-X
1, X
y1X -> X -> X
forall a. Num a => a -> a -> a
+X
1]
tileGroup :: GroupName TileKind
tileGroup | X -> X -> Bool
isCorner X
xf X
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 a. a -> StateT SMGen Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (X -> X -> Point
Point X
xf X
yf, ContentId TileKind
fenceId)
pointListN :: [(X, X)]
pointListN = [(X
x, X
y0X -> X -> X
forall a. Num a => a -> a -> a
-X
1) | X
x <- [X
x0X -> X -> X
forall a. Num a => a -> a -> a
-X
1..X
x1X -> X -> X
forall a. Num a => a -> a -> a
+X
1]]
pointListE :: [(X, X)]
pointListE = [(X
x1X -> X -> X
forall a. Num a => a -> a -> a
+X
1, X
y) | X
y <- [X
y0..X
y1]]
pointListS :: [(X, X)]
pointListS = [(X
x, X
y1X -> X -> X
forall a. Num a => a -> a -> a
+X
1) | X
x <- [X
x0X -> X -> X
forall a. Num a => a -> a -> a
-X
1..X
x1X -> X -> X
forall a. Num a => a -> a -> a
+X
1]]
pointListW :: [(X, X)]
pointListW = [(X
x0X -> X -> X
forall a. Num a => a -> a -> a
-X
1, X
y) | X
y <- [X
y0..X
y1]]
[(Point, ContentId TileKind)]
fenceListN <- ((X, X) -> StateT SMGen Identity (Point, ContentId TileKind))
-> [(X, X)] -> StateT SMGen Identity [(Point, ContentId TileKind)]
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 (GroupName TileKind
-> (X, X) -> StateT SMGen Identity (Point, ContentId TileKind)
fenceIdRnd GroupName TileKind
cfenceTileN) [(X, X)]
pointListN
[(Point, ContentId TileKind)]
fenceListE <- ((X, X) -> StateT SMGen Identity (Point, ContentId TileKind))
-> [(X, X)] -> StateT SMGen Identity [(Point, ContentId TileKind)]
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 (GroupName TileKind
-> (X, X) -> StateT SMGen Identity (Point, ContentId TileKind)
fenceIdRnd GroupName TileKind
cfenceTileE) [(X, X)]
pointListE
[(Point, ContentId TileKind)]
fenceListS <- ((X, X) -> StateT SMGen Identity (Point, ContentId TileKind))
-> [(X, X)] -> StateT SMGen Identity [(Point, ContentId TileKind)]
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 (GroupName TileKind
-> (X, X) -> StateT SMGen Identity (Point, ContentId TileKind)
fenceIdRnd GroupName TileKind
cfenceTileS) [(X, X)]
pointListS
[(Point, ContentId TileKind)]
fenceListW <- ((X, X) -> StateT SMGen Identity (Point, ContentId TileKind))
-> [(X, X)] -> StateT SMGen Identity [(Point, ContentId TileKind)]
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 (GroupName TileKind
-> (X, X) -> StateT SMGen Identity (Point, ContentId TileKind)
fenceIdRnd GroupName TileKind
cfenceTileW) [(X, X)]
pointListW
TileMapEM -> Rnd TileMapEM
forall a. a -> StateT SMGen Identity a
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
tilePlace :: Area
-> PlaceKind
-> Rnd (EM.EnumMap Point Char)
tilePlace :: Area -> PlaceKind -> Rnd (EnumMap Point Char)
tilePlace Area
area pl :: PlaceKind
pl@PlaceKind{Rarity
Freqs PlaceKind
[Text]
Text
EnumMap Char (GroupName TileKind)
Fence
Cover
pname :: PlaceKind -> Text
pfreq :: PlaceKind -> Freqs PlaceKind
prarity :: PlaceKind -> Rarity
pcover :: PlaceKind -> Cover
pfence :: PlaceKind -> Fence
ptopLeft :: PlaceKind -> [Text]
plegendDark :: PlaceKind -> EnumMap Char (GroupName TileKind)
plegendLit :: PlaceKind -> EnumMap Char (GroupName TileKind)
pname :: Text
pfreq :: Freqs PlaceKind
prarity :: Rarity
pcover :: Cover
pfence :: Fence
ptopLeft :: [Text]
plegendDark :: EnumMap Char (GroupName TileKind)
plegendLit :: EnumMap Char (GroupName TileKind)
..} = do
let (Point X
x0 X
y0, X
xspan, X
yspan) = Area -> (Point, X, X)
spanArea Area
area
dxcorner :: X
dxcorner = case [Text]
ptopLeft of
[] -> String -> X
forall a. HasCallStack => String -> a
error (String -> X) -> String -> X
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 -> X
T.length Text
l
(X
dx, X
dy) = Bool -> (X, X) -> (X, X)
forall a. HasCallStack => Bool -> a -> a
assert (X
xspan X -> X -> Bool
forall a. Ord a => a -> a -> Bool
>= X
dxcorner Bool -> Bool -> Bool
&& X
yspan X -> X -> Bool
forall a. Ord a => a -> a -> Bool
>= [Text] -> X
forall a. [a] -> X
length [Text]
ptopLeft
Bool -> (Area, PlaceKind) -> Bool
forall v. Show v => Bool -> v -> Bool
`blame` (Area
area, PlaceKind
pl))
(X
xspan, X
yspan)
fromX :: (X, X) -> [Point]
fromX (X
x2, X
y2) = (X -> Point) -> [X] -> [Point]
forall a b. (a -> b) -> [a] -> [b]
map (X -> X -> Point
`Point` X
y2) [X
x2..]
fillInterior :: (Int -> String -> String)
-> (Int -> [String] -> [String])
-> [(Point, Char)]
fillInterior :: (X -> ShowS) -> (X -> [String] -> [String]) -> [(Point, Char)]
fillInterior X -> ShowS
f X -> [String] -> [String]
g =
let tileInterior :: (X, String) -> [(Point, Char)]
tileInterior (X
y, String
row) =
let fx :: String
fx = X -> ShowS
f X
dx String
row
xStart :: X
xStart = X
x0 X -> X -> X
forall a. Num a => a -> a -> a
+ ((X
xspan X -> X -> X
forall a. Num a => a -> a -> a
- String -> X
forall a. [a] -> X
length String
fx) X -> X -> X
forall a. Integral a => a -> a -> a
`div` X
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 ((X, X) -> [Point]
fromX (X
xStart, X
y)) String
fx
reflected :: [(X, String)]
reflected =
let gy :: [String]
gy = X -> [String] -> [String]
g X
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 :: X
yStart = X
y0 X -> X -> X
forall a. Num a => a -> a -> a
+ ((X
yspan X -> X -> X
forall a. Num a => a -> a -> a
- [String] -> X
forall a. [a] -> X
length [String]
gy) X -> X -> X
forall a. Integral a => a -> a -> a
`div` X
2)
in [X] -> [String] -> [(X, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [X
yStart..] [String]
gy
in ((X, String) -> [(Point, Char)])
-> [(X, String)] -> [(Point, Char)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (X, String) -> [(Point, Char)]
tileInterior [(X, String)]
reflected
tileReflect :: Int -> [a] -> [a]
tileReflect :: forall a. X -> [a] -> [a]
tileReflect X
d [a]
pat =
let lstart :: [a]
lstart = X -> [a] -> [a]
forall a. X -> [a] -> [a]
take (X
d X -> X -> X
forall a. Integral a => a -> a -> a
`divUp` X
2) [a]
pat
lend :: [a]
lend = X -> [a] -> [a]
forall a. X -> [a] -> [a]
take (X
d X -> X -> X
forall a. Integral a => a -> a -> a
`div` X
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 :: forall a. X -> [a] -> [a]
tile X
_ [] = 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 X
d [a]
pat = X -> [a] -> [a]
forall a. X -> [a] -> [a]
take X
d ([a] -> [a]
forall a. HasCallStack => [a] -> [a]
cycle ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ [a] -> [a]
forall a. HasCallStack => [a] -> [a]
init [a]
pat [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a] -> [a]
forall a. HasCallStack => [a] -> [a]
init ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
pat))
[(Point, Char)] -> StateT SMGen Identity [(Point, Char)]
forall a. a -> StateT SMGen Identity a
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
$! (X -> ShowS) -> (X -> [String] -> [String]) -> [(Point, Char)]
fillInterior X -> ShowS
forall a. X -> [a] -> [a]
tile X -> [String] -> [String]
forall a. X -> [a] -> [a]
tile
Cover
CStretch -> do
let stretch :: Int -> [a] -> [a]
stretch :: forall a. X -> [a] -> [a]
stretch X
_ [] = 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 X
d [a]
pat = X -> [a] -> [a]
forall a. X -> [a] -> [a]
tileReflect X
d ([a]
pat [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ a -> [a]
forall a. a -> [a]
repeat ([a] -> a
forall a. HasCallStack => [a] -> a
last [a]
pat))
[(Point, Char)] -> StateT SMGen Identity [(Point, Char)]
forall a. a -> StateT SMGen Identity a
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
$! (X -> ShowS) -> (X -> [String] -> [String]) -> [(Point, Char)]
fillInterior X -> ShowS
forall a. X -> [a] -> [a]
stretch X -> [String] -> [String]
forall a. X -> [a] -> [a]
stretch
Cover
CReflect -> do
let reflect :: Int -> [a] -> [a]
reflect :: forall a. X -> [a] -> [a]
reflect X
d [a]
pat = X -> [a] -> [a]
forall a. X -> [a] -> [a]
tileReflect X
d ([a] -> [a]
forall a. HasCallStack => [a] -> [a]
cycle [a]
pat)
[(Point, Char)] -> StateT SMGen Identity [(Point, Char)]
forall a. a -> StateT SMGen Identity a
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
$! (X -> ShowS) -> (X -> [String] -> [String]) -> [(Point, Char)]
fillInterior X -> ShowS
forall a. X -> [a] -> [a]
reflect X -> [String] -> [String]
forall a. X -> [a] -> [a]
reflect
Cover
CVerbatim -> [(Point, Char)] -> StateT SMGen Identity [(Point, Char)]
forall a. a -> StateT SMGen Identity a
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
$! (X -> ShowS) -> (X -> [String] -> [String]) -> [(Point, Char)]
fillInterior (\ X
_ String
x -> String
x) (\ X
_ [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 a. a -> StateT SMGen Identity a
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
$! (X -> ShowS) -> (X -> [String] -> [String]) -> [(Point, Char)]
fillInterior (\X
_ String
l -> ShowS
mirror1 String
l) (\X
_ [String]
l -> [String] -> [String]
mirror2 [String]
l)
EnumMap Point Char -> Rnd (EnumMap Point Char)
forall a. a -> StateT SMGen Identity a
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