{-# LANGUAGE RankNTypes #-}
module Game.LambdaHack.Server.DungeonGen.Place
( Place(..), TileMapEM, buildPlace, isChancePos, buildFenceRnd
#ifdef EXPOSE_INTERNAL
, placeCheck, interiorArea, olegend, 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.EnumSet as ES
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 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
placeCheck :: Area
-> PlaceKind
-> Bool
placeCheck :: Area -> PlaceKind -> Bool
placeCheck r :: Area
r pk :: PlaceKind
pk@PlaceKind{..} =
case PlaceKind -> Area -> Maybe Area
interiorArea PlaceKind
pk Area
r of
Nothing -> Bool
False
Just area :: Area
area ->
let (_, xspan :: Int
xspan, yspan :: Int
yspan) = Area -> (Point, Int, Int)
spanArea Area
area
dxcorner :: Int
dxcorner = case [Text]
ptopLeft of [] -> 0 ; l :: Text
l : _ -> Text -> Int
T.length Text
l
dycorner :: Int
dycorner = [Text] -> Int
forall a. [a] -> Int
length [Text]
ptopLeft
wholeOverlapped :: a -> a -> Bool
wholeOverlapped d :: a
d dcorner :: a
dcorner = a
d a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> 1 Bool -> Bool -> Bool
&& a
dcorner a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> 1 Bool -> Bool -> Bool
&&
(a
d a -> a -> a
forall a. Num a => a -> a -> a
- 1) a -> a -> a
forall a. Integral a => a -> a -> a
`mod` (2 a -> a -> a
forall a. Num a => a -> a -> a
* (a
dcorner a -> a -> a
forall a. Num a => a -> a -> a
- 1)) a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== 0
largeEnough :: Bool
largeEnough = Int
xspan Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
dxcorner Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1 Bool -> Bool -> Bool
&& Int
yspan Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
dycorner Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
in case Cover
pcover of
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
CStretch -> Bool
largeEnough
CReflect -> Bool
largeEnough
CVerbatim -> Bool
True
CMirror -> Bool
True
interiorArea :: PlaceKind -> Area -> Maybe Area
interiorArea :: PlaceKind -> Area -> Maybe Area
interiorArea kr :: PlaceKind
kr r :: Area
r =
let requiredForFence :: Int
requiredForFence = case PlaceKind -> Fence
pfence PlaceKind
kr of
FWall -> 1
FFloor -> 1
FGround -> 1
FNone -> 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 x0 :: Int
x0 y0 :: Int
y0, xspan :: Int
xspan, yspan :: 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 -> PlaceKind -> String
forall v. Show v => String -> v -> String
`showFailure` PlaceKind
kr
l :: Text
l : _ -> 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` 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` 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
- 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
- 1)
else case Int
requiredForFence of
0 -> Area -> Maybe Area
forall a. a -> Maybe a
Just Area
r
1 -> Area -> Maybe Area
shrink Area
r
_ -> String -> Maybe Area
forall a. HasCallStack => String -> a
error (String -> Maybe Area) -> String -> Maybe Area
forall a b. (a -> b) -> a -> b
$ "" 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 :: COps -> ContentData PlaceKind
coplace :: ContentData PlaceKind
coplace, TileSpeedup
coTileSpeedup :: COps -> TileSpeedup
coTileSpeedup :: TileSpeedup
coTileSpeedup}
kc :: CaveKind
kc@CaveKind{..} dnight :: Bool
dnight darkCorTile :: ContentId TileKind
darkCorTile litCorTile :: ContentId TileKind
litCorTile
levelDepth :: AbsDepth
levelDepth@(Dice.AbsDepth ldepth :: Int
ldepth)
totalDepth :: AbsDepth
totalDepth@(Dice.AbsDepth tdepth :: Int
tdepth)
dsecret :: Word32
dsecret r :: Area
r minnerArea :: Maybe Area
minnerArea mplaceGroup :: 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 (placeGroup :: GroupName PlaceKind
placeGroup, q :: 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
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 (\(_, (_, kind :: 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 "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)) ()
(qkind :: ContentId PlaceKind
qkind, kr :: 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
< 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
< 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 (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
let qlegend :: GroupName TileKind
qlegend = if Bool
dark then GroupName TileKind
clegendDarkTile else GroupName TileKind
clegendLitTile
Area
rBetter <- case Maybe Area
minnerArea of
Just innerArea :: 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
let requiredForFence :: Int
requiredForFence = case PlaceKind -> Fence
pfence PlaceKind
kr of
FWall -> 1
FFloor -> 1
FGround -> 1
FNone -> 0
sizeBetter :: (Int, Int)
sizeBetter = ( 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))
, 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 -> Rnd Area
mkRoom (Int, Int)
sizeBetter (Int, Int)
sizeBetter Area
innerArea
_ -> Area -> Rnd 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 -> (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
override :: [(Char, GroupName TileKind)]
override = if Bool
dark then PlaceKind -> [(Char, GroupName TileKind)]
poverrideDark PlaceKind
kr else PlaceKind -> [(Char, GroupName TileKind)]
poverrideLit PlaceKind
kr
(overrideOneIn :: EnumMap Char (Int, Int, ContentId TileKind)
overrideOneIn, overDefault :: EnumMap Char (ContentId TileKind)
overDefault) <- COps
-> [(Char, GroupName TileKind)]
-> Rnd
(EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind))
pover COps
cops [(Char, GroupName TileKind)]
override
(legendOneIn :: EnumMap Char (Int, Int, ContentId TileKind)
legendOneIn, legend :: EnumMap Char (ContentId TileKind)
legend) <- COps
-> GroupName TileKind
-> Rnd
(EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind))
olegend COps
cops GroupName TileKind
qlegend
EnumMap Point Char
cmap <- Area -> PlaceKind -> Rnd (EnumMap Point Char)
tilePlace Area
qarea PlaceKind
kr
let mOneIn :: EM.EnumMap Char (Int, Int, ContentId TileKind)
mOneIn :: EnumMap Char (Int, Int, ContentId TileKind)
mOneIn = EnumMap Char (Int, Int, ContentId TileKind)
-> EnumMap Char (Int, Int, ContentId TileKind)
-> EnumMap Char (Int, Int, ContentId TileKind)
forall k a. EnumMap k a -> EnumMap k a -> EnumMap k a
EM.union EnumMap Char (Int, Int, ContentId TileKind)
overrideOneIn EnumMap Char (Int, Int, ContentId TileKind)
legendOneIn
m :: EM.EnumMap Char (ContentId TileKind)
m :: EnumMap Char (ContentId TileKind)
m = EnumMap Char (ContentId TileKind)
-> EnumMap Char (ContentId TileKind)
-> EnumMap Char (ContentId TileKind)
forall k a. EnumMap k a -> EnumMap k a -> EnumMap k a
EM.union EnumMap Char (ContentId TileKind)
overDefault EnumMap Char (ContentId TileKind)
legend
lookupOneIn :: Point -> Char -> ContentId TileKind
lookupOneIn :: Point -> Char -> ContentId TileKind
lookupOneIn xy :: Point
xy c :: Char
c = case Char
-> EnumMap Char (Int, Int, ContentId TileKind)
-> Maybe (Int, Int, ContentId TileKind)
forall k a. Enum k => k -> EnumMap k a -> Maybe a
EM.lookup Char
c EnumMap Char (Int, Int, ContentId TileKind)
mOneIn of
Just (k :: Int
k, n :: Int
n, tk :: ContentId TileKind
tk) | Int -> Int -> Word32 -> Point -> Bool
isChancePos Int
k Int
n Word32
dsecret Point
xy -> ContentId TileKind
tk
_ -> ContentId TileKind
-> Char -> EnumMap Char (ContentId TileKind) -> ContentId TileKind
forall k a. Enum k => a -> k -> EnumMap k a -> a
EM.findWithDefault (String -> ContentId TileKind
forall a. HasCallStack => String -> a
error (String -> ContentId TileKind) -> String -> ContentId TileKind
forall a b. (a -> b) -> a -> b
$ "" String
-> (Char, EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind))
-> String
forall v. Show v => String -> v -> String
`showFailure` (Char
c, EnumMap Char (Int, Int, ContentId TileKind)
mOneIn, EnumMap Char (ContentId TileKind)
m)) Char
c EnumMap Char (ContentId TileKind)
m
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
$! $WPlace :: ContentId PlaceKind -> Area -> TileMapEM -> TileMapEM -> Place
Place {..}
isChancePos :: Int -> Int -> Word32 -> Point -> Bool
isChancePos :: Int -> Int -> Word32 -> Point -> Bool
isChancePos k' :: Int
k' n' :: Int
n' dsecret :: Word32
dsecret (Point x' :: Int
x' y' :: Int
y') = Int
k' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0 Bool -> Bool -> Bool
&& Int
n' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 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
== 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
/= 0
olegend :: COps -> GroupName TileKind
-> Rnd ( EM.EnumMap Char (Int, Int, ContentId TileKind)
, EM.EnumMap Char (ContentId TileKind) )
olegend :: COps
-> GroupName TileKind
-> Rnd
(EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind))
olegend COps{ContentData TileKind
cotile :: COps -> ContentData TileKind
cotile :: ContentData TileKind
cotile} cgroup :: GroupName TileKind
cgroup =
let getSymbols :: EnumSet Char -> p -> p -> TileKind -> EnumSet Char
getSymbols !EnumSet Char
acc _ _ !TileKind
tk = Char -> EnumSet Char -> EnumSet Char
forall k. Enum k => k -> EnumSet k -> EnumSet k
ES.insert (TileKind -> Char
TK.tsymbol TileKind
tk) EnumSet Char
acc
symbols :: EnumSet Char
symbols = ContentData TileKind
-> GroupName TileKind
-> (EnumSet Char
-> Int -> ContentId TileKind -> TileKind -> EnumSet Char)
-> EnumSet Char
-> EnumSet Char
forall a b.
ContentData a
-> GroupName a -> (b -> Int -> ContentId a -> a -> b) -> b -> b
ofoldlGroup' ContentData TileKind
cotile GroupName TileKind
cgroup EnumSet Char
-> Int -> ContentId TileKind -> TileKind -> EnumSet Char
forall p p. EnumSet Char -> p -> p -> TileKind -> EnumSet Char
getSymbols EnumSet Char
forall k. EnumSet k
ES.empty
getLegend :: Char
-> Rnd
(EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind))
-> Rnd
(EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind))
getLegend s :: Char
s !Rnd
(EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind))
acc = do
(mOneIn :: EnumMap Char (Int, Int, ContentId TileKind)
mOneIn, m :: EnumMap Char (ContentId TileKind)
m) <- Rnd
(EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind))
acc
let p :: (Bool -> Bool) -> TileKind -> Bool
p f :: Bool -> Bool
f t :: TileKind
t = TileKind -> Char
TK.tsymbol TileKind
t Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
s Bool -> Bool -> Bool
&& Bool -> Bool
f (Feature -> TileKind -> Bool
Tile.kindHasFeature Feature
TK.Spice TileKind
t)
ContentId TileKind
tk <- (Maybe (ContentId TileKind) -> ContentId TileKind)
-> StateT SMGen Identity (Maybe (ContentId TileKind))
-> StateT SMGen Identity (ContentId TileKind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ContentId TileKind
-> Maybe (ContentId TileKind) -> ContentId TileKind
forall a. a -> Maybe a -> a
fromMaybe (ContentId TileKind
-> Maybe (ContentId TileKind) -> ContentId TileKind)
-> ContentId TileKind
-> Maybe (ContentId TileKind)
-> ContentId TileKind
forall a b. (a -> b) -> a -> b
$ String -> ContentId TileKind
forall a. HasCallStack => String -> a
error (String -> ContentId TileKind) -> String -> ContentId TileKind
forall a b. (a -> b) -> a -> b
$ "" String -> (GroupName TileKind, Char) -> String
forall v. Show v => String -> v -> String
`showFailure` (GroupName TileKind
cgroup, Char
s))
(StateT SMGen Identity (Maybe (ContentId TileKind))
-> StateT SMGen Identity (ContentId TileKind))
-> StateT SMGen Identity (Maybe (ContentId TileKind))
-> StateT SMGen Identity (ContentId TileKind)
forall a b. (a -> b) -> a -> b
$ ContentData TileKind
-> GroupName TileKind
-> (TileKind -> Bool)
-> StateT SMGen Identity (Maybe (ContentId TileKind))
forall a.
Show a =>
ContentData a
-> GroupName a -> (a -> Bool) -> Rnd (Maybe (ContentId a))
opick ContentData TileKind
cotile GroupName TileKind
cgroup ((Bool -> Bool) -> TileKind -> Bool
p Bool -> Bool
not)
Maybe (ContentId TileKind)
mtkSpice <- ContentData TileKind
-> GroupName TileKind
-> (TileKind -> Bool)
-> StateT SMGen Identity (Maybe (ContentId TileKind))
forall a.
Show a =>
ContentData a
-> GroupName a -> (a -> Bool) -> Rnd (Maybe (ContentId a))
opick ContentData TileKind
cotile GroupName TileKind
cgroup ((Bool -> Bool) -> TileKind -> Bool
p Bool -> Bool
forall a. a -> a
id)
(EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind))
-> Rnd
(EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind))
forall (m :: * -> *) a. Monad m => a -> m a
return ((EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind))
-> Rnd
(EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind)))
-> (EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind))
-> Rnd
(EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind))
forall a b. (a -> b) -> a -> b
$! case Maybe (ContentId TileKind)
mtkSpice of
Nothing -> (EnumMap Char (Int, Int, ContentId TileKind)
mOneIn, Char
-> ContentId TileKind
-> EnumMap Char (ContentId TileKind)
-> EnumMap Char (ContentId TileKind)
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert Char
s ContentId TileKind
tk EnumMap Char (ContentId TileKind)
m)
Just tkSpice :: ContentId TileKind
tkSpice ->
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 (Char
-> (Int, Int, ContentId TileKind)
-> EnumMap Char (Int, Int, ContentId TileKind)
-> EnumMap Char (Int, Int, ContentId TileKind)
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert Char
s (Int
k, Int
n, ContentId TileKind
tkSpice) EnumMap Char (Int, Int, ContentId TileKind)
mOneIn, Char
-> ContentId TileKind
-> EnumMap Char (ContentId TileKind)
-> EnumMap Char (ContentId TileKind)
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert Char
s ContentId TileKind
tk EnumMap Char (ContentId TileKind)
m)
legend :: Rnd
(EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind))
legend = (Char
-> Rnd
(EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind))
-> Rnd
(EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind)))
-> Rnd
(EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind))
-> EnumSet Char
-> Rnd
(EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind))
forall k b. Enum k => (k -> b -> b) -> b -> EnumSet k -> b
ES.foldr' Char
-> Rnd
(EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind))
-> Rnd
(EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind))
getLegend ((EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind))
-> Rnd
(EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind))
forall (m :: * -> *) a. Monad m => a -> m a
return (EnumMap Char (Int, Int, ContentId TileKind)
forall k a. EnumMap k a
EM.empty, EnumMap Char (ContentId TileKind)
forall k a. EnumMap k a
EM.empty)) EnumSet Char
symbols
in Rnd
(EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind))
legend
pover :: COps -> [(Char, GroupName TileKind)]
-> Rnd ( EM.EnumMap Char (Int, Int, ContentId TileKind)
, EM.EnumMap Char (ContentId TileKind) )
pover :: COps
-> [(Char, GroupName TileKind)]
-> Rnd
(EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind))
pover COps{ContentData TileKind
cotile :: ContentData TileKind
cotile :: COps -> ContentData TileKind
cotile} poverride :: [(Char, GroupName TileKind)]
poverride =
let getLegend :: (Char, GroupName TileKind)
-> Rnd
(EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind))
-> Rnd
(EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind))
getLegend (s :: Char
s, cgroup :: GroupName TileKind
cgroup) acc :: Rnd
(EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind))
acc = do
(mOneIn :: EnumMap Char (Int, Int, ContentId TileKind)
mOneIn, m :: EnumMap Char (ContentId TileKind)
m) <- Rnd
(EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind))
acc
Maybe (ContentId TileKind)
mtkSpice <- ContentData TileKind
-> GroupName TileKind
-> (TileKind -> Bool)
-> StateT SMGen Identity (Maybe (ContentId TileKind))
forall a.
Show a =>
ContentData a
-> GroupName a -> (a -> Bool) -> Rnd (Maybe (ContentId a))
opick ContentData TileKind
cotile GroupName TileKind
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
-> (Char, GroupName TileKind, [(Char, GroupName TileKind)])
-> String
forall v. Show v => String -> v -> String
`showFailure` (Char
s, GroupName TileKind
cgroup, [(Char, GroupName TileKind)]
poverride))
(Maybe (ContentId TileKind) -> ContentId TileKind)
-> StateT SMGen Identity (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)
-> StateT SMGen Identity (Maybe (ContentId TileKind))
forall a.
Show a =>
ContentData a
-> GroupName a -> (a -> Bool) -> Rnd (Maybe (ContentId a))
opick ContentData TileKind
cotile GroupName TileKind
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)
(EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind))
-> Rnd
(EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind))
forall (m :: * -> *) a. Monad m => a -> m a
return ((EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind))
-> Rnd
(EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind)))
-> (EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind))
-> Rnd
(EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind))
forall a b. (a -> b) -> a -> b
$! case Maybe (ContentId TileKind)
mtkSpice of
Nothing -> (EnumMap Char (Int, Int, ContentId TileKind)
mOneIn, Char
-> ContentId TileKind
-> EnumMap Char (ContentId TileKind)
-> EnumMap Char (ContentId TileKind)
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert Char
s ContentId TileKind
tk EnumMap Char (ContentId TileKind)
m)
Just tkSpice :: ContentId TileKind
tkSpice ->
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 (Char
-> (Int, Int, ContentId TileKind)
-> EnumMap Char (Int, Int, ContentId TileKind)
-> EnumMap Char (Int, Int, ContentId TileKind)
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert Char
s (Int
k, Int
n, ContentId TileKind
tkSpice) EnumMap Char (Int, Int, ContentId TileKind)
mOneIn, Char
-> ContentId TileKind
-> EnumMap Char (ContentId TileKind)
-> EnumMap Char (ContentId TileKind)
forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EM.insert Char
s ContentId TileKind
tk EnumMap Char (ContentId TileKind)
m)
in ((Char, GroupName TileKind)
-> Rnd
(EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind))
-> Rnd
(EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind)))
-> Rnd
(EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind))
-> [(Char, GroupName TileKind)]
-> Rnd
(EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind))
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Char, GroupName TileKind)
-> Rnd
(EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind))
-> Rnd
(EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind))
getLegend ((EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind))
-> Rnd
(EnumMap Char (Int, Int, ContentId TileKind),
EnumMap Char (ContentId TileKind))
forall (m :: * -> *) a. Monad m => a -> m a
return (EnumMap Char (Int, Int, ContentId TileKind)
forall k a. EnumMap k a
EM.empty, EnumMap Char (ContentId TileKind)
forall k a. EnumMap k a
EM.empty)) [(Char, GroupName TileKind)]
poverride
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}
dnight :: Bool
dnight darkCorTile :: ContentId TileKind
darkCorTile litCorTile :: ContentId TileKind
litCorTile dark :: Bool
dark fence :: Fence
fence qarea :: 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 -> GroupName TileKind -> String
forall v. Show v => String -> v -> String
`showFailure` GroupName TileKind
cwallTile)
(Maybe (ContentId TileKind) -> ContentId TileKind)
-> StateT SMGen Identity (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)
-> StateT SMGen Identity (Maybe (ContentId TileKind))
forall a.
Show a =>
ContentData a
-> GroupName a -> (a -> Bool) -> Rnd (Maybe (ContentId a))
opick ContentData TileKind
cotile GroupName TileKind
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 -> GroupName TileKind -> String
forall v. Show v => String -> v -> String
`showFailure` GroupName TileKind
ccornerTile)
(Maybe (ContentId TileKind) -> ContentId TileKind)
-> StateT SMGen Identity (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)
-> StateT SMGen Identity (Maybe (ContentId TileKind))
forall a.
Show a =>
ContentData a
-> GroupName a -> (a -> Bool) -> Rnd (Maybe (ContentId a))
opick ContentData TileKind
cotile GroupName TileKind
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
FWall -> ContentId TileKind -> ContentId TileKind -> Area -> TileMapEM
buildFenceMap ContentId TileKind
qFWall ContentId TileKind
qFCorner Area
qarea
FFloor -> ContentId TileKind -> ContentId TileKind -> Area -> TileMapEM
buildFenceMap ContentId TileKind
qFFloor ContentId TileKind
qFFloor Area
qarea
FGround -> ContentId TileKind -> ContentId TileKind -> Area -> TileMapEM
buildFenceMap ContentId TileKind
qFGround ContentId TileKind
qFGround Area
qarea
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 wallId :: ContentId TileKind
wallId cornerId :: ContentId TileKind
cornerId area :: Area
area =
let (x0 :: Int
x0, y0 :: Int
y0, x1 :: Int
x1, y1 :: 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
-1, Int
x1Int -> Int -> Int
forall a. Num a => a -> a -> a
+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
-1, Int
y1Int -> Int -> Int
forall a. Num a => a -> a -> a
+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
-1, Int
x1Int -> Int -> Int
forall a. Num a => a -> a -> a
+1], Int
y <- [Int
y0Int -> Int -> Int
forall a. Num a => a -> a -> a
-1, Int
y1Int -> Int -> Int
forall a. Num a => a -> a -> a
+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 :: ContentData TileKind
cotile :: COps -> ContentData TileKind
cotile}
cfenceTileN :: GroupName TileKind
cfenceTileN cfenceTileE :: GroupName TileKind
cfenceTileE cfenceTileS :: GroupName TileKind
cfenceTileS cfenceTileW :: GroupName TileKind
cfenceTileW area :: Area
area = do
let (x0 :: Int
x0, y0 :: Int
y0, x1 :: Int
x1, y1 :: 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 couterFenceTile :: GroupName TileKind
couterFenceTile (xf :: Int
xf, yf :: Int
yf) = do
let isCorner :: Int -> Int -> Bool
isCorner x :: Int
x y :: 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
-1, Int
x1Int -> Int -> Int
forall a. Num a => a -> a -> a
+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
-1, Int
y1Int -> Int -> Int
forall a. Num a => a -> a -> a
+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 -> GroupName TileKind -> String
forall v. Show v => String -> v -> String
`showFailure` GroupName TileKind
tileGroup)
(Maybe (ContentId TileKind) -> ContentId TileKind)
-> StateT SMGen Identity (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)
-> StateT SMGen Identity (Maybe (ContentId TileKind))
forall a.
Show a =>
ContentData a
-> GroupName a -> (a -> Bool) -> Rnd (Maybe (ContentId a))
opick ContentData TileKind
cotile GroupName TileKind
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
-1) | Int
x <- [Int
x0Int -> Int -> Int
forall a. Num a => a -> a -> a
-1..Int
x1Int -> Int -> Int
forall a. Num a => a -> a -> a
+1]]
pointListE :: [(Int, Int)]
pointListE = [(Int
x1Int -> Int -> Int
forall a. Num a => a -> a -> a
+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
+1) | Int
x <- [Int
x0Int -> Int -> Int
forall a. Num a => a -> a -> a
-1..Int
x1Int -> Int -> Int
forall a. Num a => a -> a -> a
+1]]
pointListW :: [(Int, Int)]
pointListW = [(Int
x0Int -> Int -> Int
forall a. Num a => a -> a -> a
-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
tilePlace :: Area
-> PlaceKind
-> Rnd (EM.EnumMap Point Char)
tilePlace :: Area -> PlaceKind -> Rnd (EnumMap Point Char)
tilePlace area :: Area
area pl :: PlaceKind
pl@PlaceKind{..} = do
let (Point x0 :: Int
x0 y0 :: Int
y0, xspan :: Int
xspan, yspan :: 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 -> (Area, PlaceKind) -> String
forall v. Show v => String -> v -> String
`showFailure` (Area
area, PlaceKind
pl)
l :: Text
l : _ -> Text -> Int
T.length Text
l
(dx :: Int
dx, dy :: 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 (x2 :: Int
x2, y2 :: 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 f :: Int -> ShowS
f g :: Int -> [String] -> [String]
g =
let tileInterior :: (Int, String) -> [(Point, Char)]
tileInterior (y :: Int
y, row :: 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` 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
/= '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` 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 d :: Int
d pat :: [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` 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` 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
CAlternate -> do
let tile :: Int -> [a] -> [a]
tile :: Int -> [a] -> [a]
tile _ [] = String -> [a]
forall a. HasCallStack => String -> a
error (String -> [a]) -> String -> [a]
forall a b. (a -> b) -> a -> b
$ "nothing to tile" String -> PlaceKind -> String
forall v. Show v => String -> v -> String
`showFailure` PlaceKind
pl
tile d :: Int
d pat :: [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
CStretch -> do
let stretch :: Int -> [a] -> [a]
stretch :: Int -> [a] -> [a]
stretch _ [] = String -> [a]
forall a. HasCallStack => String -> a
error (String -> [a]) -> String -> [a]
forall a b. (a -> b) -> a -> b
$ "nothing to stretch" String -> PlaceKind -> String
forall v. Show v => String -> v -> String
`showFailure` PlaceKind
pl
stretch d :: Int
d pat :: [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
CReflect -> do
let reflect :: Int -> [a] -> [a]
reflect :: Int -> [a] -> [a]
reflect d :: Int
d pat :: [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
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 ((String -> Int -> String) -> Int -> ShowS
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> Int -> String
forall a b. a -> b -> a
const) (([String] -> Int -> [String]) -> Int -> [String] -> [String]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [String] -> Int -> [String]
forall a b. a -> b -> a
const)
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 (\_ l :: String
l -> ShowS
mirror1 String
l) (\_ l :: [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