module Game.LambdaHack.Server.DungeonGen.Place
( TileMapEM, Place(..), placeCheck, buildFenceRnd, buildPlace
) where
import Control.Exception.Assert.Sugar
import Data.Binary
import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import Data.Maybe
import qualified Data.Text as T
import Game.LambdaHack.Common.Frequency
import qualified Game.LambdaHack.Common.Kind as Kind
import Game.LambdaHack.Common.Level
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.Msg
import Game.LambdaHack.Common.Point
import Game.LambdaHack.Common.Random
import Game.LambdaHack.Content.CaveKind
import Game.LambdaHack.Content.PlaceKind
import Game.LambdaHack.Content.TileKind
import Game.LambdaHack.Server.DungeonGen.Area
data Place = Place
{ qkind :: !(Kind.Id PlaceKind)
, qarea :: !Area
, qseen :: !Bool
, qlegend :: !GroupName
, qFWall :: !(Kind.Id TileKind)
, qFFloor :: !(Kind.Id TileKind)
, qFGround :: !(Kind.Id TileKind)
}
deriving Show
type TileMapEM = EM.EnumMap Point (Kind.Id TileKind)
placeCheck :: Area
-> PlaceKind
-> Bool
placeCheck r PlaceKind{..} =
case interiorArea pfence r of
Nothing -> False
Just area ->
let (x0, y0, x1, y1) = fromArea area
dx = x1 x0 + 1
dy = y1 y0 + 1
dxcorner = case ptopLeft of [] -> 0 ; l : _ -> T.length l
dycorner = length ptopLeft
wholeOverlapped d dcorner = d > 1 && dcorner > 1 &&
(d 1) `mod` (2 * (dcorner 1)) == 0
largeEnough = dx >= 2 * dxcorner 1 && dy >= 2 * dycorner 1
in case pcover of
CAlternate -> wholeOverlapped dx dxcorner &&
wholeOverlapped dy dycorner
CStretch -> largeEnough
CReflect -> largeEnough
CVerbatim -> dx >= dxcorner && dy >= dycorner
interiorArea :: Fence -> Area -> Maybe Area
interiorArea fence r = case fence of
FWall -> shrink r
FFloor -> shrink r
FGround -> shrink r
FNone -> Just r
buildPlace :: Kind.COps
-> CaveKind
-> Bool
-> Kind.Id TileKind
-> Kind.Id TileKind
-> AbsDepth
-> AbsDepth
-> Area
-> Rnd (TileMapEM, Place)
buildPlace cops@Kind.COps{ cotile=Kind.Ops{opick=opick}
, coplace=Kind.Ops{ofoldrGroup} }
CaveKind{..} dnight darkCorTile litCorTile
ldepth@(AbsDepth ld) totalDepth@(AbsDepth depth) r = do
qFWall <- fmap (fromMaybe $ assert `failure` cfillerTile)
$ opick cfillerTile (const True)
dark <- chanceDice ldepth totalDepth cdarkChance
let findInterval x1y1 [] = (x1y1, (11, 0))
findInterval x1y1 ((x, y) : rest) =
if ld * 10 <= x * depth
then (x1y1, (x, y))
else findInterval (x, y) rest
linearInterpolation dataset =
let ((x1, y1), (x2, y2)) = findInterval (0, 0) dataset
in y1 + (y2 y1) * (ld * 10 x1 * depth)
`divUp` ((x2 x1) * depth)
let f placeGroup q p pk kind acc =
let rarity = linearInterpolation (prarity kind)
in (q * p * rarity, ((pk, kind), placeGroup)) : acc
g (placeGroup, q) = ofoldrGroup placeGroup (f placeGroup q) []
placeFreq = concatMap g cplaceFreq
checkedFreq = filter (\(_, ((_, kind), _)) -> placeCheck r kind) placeFreq
freq = toFreq ("buildPlace ('" <> tshow ld <> ")") checkedFreq
assert (not (nullFreq freq) `blame` (placeFreq, checkedFreq, r)) skip
((qkind, kr), _) <- frequency freq
let qFFloor = if dark then darkCorTile else litCorTile
qFGround = if dnight then darkCorTile else litCorTile
qlegend = if dark then clegendDarkTile else clegendLitTile
qseen = False
qarea = fromMaybe (assert `failure` (kr, r)) $ interiorArea (pfence kr) r
place = Place {..}
override <- ooverride cops (poverride kr)
legend <- olegend cops qlegend
legendLit <- olegend cops clegendLitTile
let xlegend = EM.union override legend
xlegendLit = EM.union override legendLit
cmap = tilePlace qarea kr
fence = case pfence kr of
FWall -> buildFence qFWall qarea
FFloor -> buildFence qFFloor qarea
FGround -> buildFence qFGround qarea
FNone -> EM.empty
(x0, y0, x1, y1) = fromArea qarea
isEdge (Point x y) = x `elem` [x0, x1] || y `elem` [y0, y1]
digDay xy c | isEdge xy = xlegendLit EM.! c
| otherwise = xlegend EM.! c
interior = case pfence kr of
FNone | not dnight -> EM.mapWithKey digDay cmap
_ -> let lookupLegend x = fromMaybe (assert `failure` (qlegend, x))
$ EM.lookup x xlegend
in EM.map lookupLegend cmap
tmap = EM.union interior fence
return (tmap, place)
olegend :: Kind.COps -> GroupName
-> Rnd (EM.EnumMap Char (Kind.Id TileKind))
olegend Kind.COps{cotile=Kind.Ops{ofoldrWithKey, opick}} cgroup =
let getSymbols _ tk acc =
maybe acc (const $ ES.insert (tsymbol tk) acc)
(lookup cgroup $ tfreq tk)
symbols = ofoldrWithKey getSymbols ES.empty
getLegend s acc = do
m <- acc
tk <- fmap (fromMaybe $ assert `failure` (cgroup, s))
$ opick cgroup $ (== s) . tsymbol
return $! EM.insert s tk m
legend = ES.foldr getLegend (return EM.empty) symbols
in legend
ooverride :: Kind.COps -> [(Char, GroupName)]
-> Rnd (EM.EnumMap Char (Kind.Id TileKind))
ooverride Kind.COps{cotile=Kind.Ops{opick}} poverride =
let getLegend (s, cgroup) acc = do
m <- acc
tk <- fmap (fromMaybe $ assert `failure` (cgroup, s))
$ opick cgroup (const True)
return $! EM.insert s tk m
legend = foldr getLegend (return EM.empty) poverride
in legend
buildFence :: Kind.Id TileKind -> Area -> TileMapEM
buildFence fenceId area =
let (x0, y0, x1, y1) = fromArea area
in EM.fromList $ [ (Point x y, fenceId)
| x <- [x01, x1+1], y <- [y0..y1] ] ++
[ (Point x y, fenceId)
| x <- [x01..x1+1], y <- [y01, y1+1] ]
buildFenceRnd :: Kind.COps -> GroupName -> Area -> Rnd TileMapEM
buildFenceRnd Kind.COps{cotile=Kind.Ops{opick}} couterFenceTile area = do
let (x0, y0, x1, y1) = fromArea area
fenceIdRnd (xf, yf) = do
let isCorner x y = x `elem` [x01, x1+1] && y `elem` [y01, y1+1]
tileGroup | isCorner xf yf = "basic outer fence"
| otherwise = couterFenceTile
fenceId <- fmap (fromMaybe $ assert `failure` tileGroup)
$ opick tileGroup (const True)
return (Point xf yf, fenceId)
pointList = [ (x, y) | x <- [x01, x1+1], y <- [y0..y1] ]
++ [ (x, y) | x <- [x01..x1+1], y <- [y01, y1+1] ]
fenceList <- mapM fenceIdRnd pointList
return $! EM.fromList fenceList
tilePlace :: Area
-> PlaceKind
-> EM.EnumMap Point Char
tilePlace area pl@PlaceKind{..} =
let (x0, y0, x1, y1) = fromArea area
xwidth = x1 x0 + 1
ywidth = y1 y0 + 1
dxcorner = case ptopLeft of
[] -> assert `failure` (area, pl)
l : _ -> T.length l
(dx, dy) = assert (xwidth >= dxcorner && ywidth >= length ptopLeft
`blame` (area, pl))
(xwidth, ywidth)
fromX (x2, y2) =
zipWith (\x y -> Point x y) [x2..] (repeat y2)
fillInterior :: (forall a. Int -> [a] -> [a]) -> [(Point, Char)]
fillInterior f =
let tileInterior (y, row) =
let fx = f dx row
xStart = x0 + ((xwidth length fx) `div` 2)
in filter ((/= 'X') . snd) $ zip (fromX (xStart, y)) fx
reflected =
let fy = f dy $ map T.unpack ptopLeft
yStart = y0 + ((ywidth length fy) `div` 2)
in zip [yStart..] fy
in concatMap tileInterior reflected
tileReflect :: Int -> [a] -> [a]
tileReflect d pat =
let lstart = take (d `divUp` 2) pat
lend = take (d `div` 2) pat
in lstart ++ reverse lend
interior = case pcover of
CAlternate ->
let tile :: Int -> [a] -> [a]
tile _ [] = assert `failure` "nothing to tile" `twith` pl
tile d pat = take d (cycle $ init pat ++ init (reverse pat))
in fillInterior tile
CStretch ->
let stretch :: Int -> [a] -> [a]
stretch _ [] = assert `failure` "nothing to stretch" `twith` pl
stretch d pat = tileReflect d (pat ++ repeat (last pat))
in fillInterior stretch
CReflect ->
let reflect :: Int -> [a] -> [a]
reflect d pat = tileReflect d (cycle pat)
in fillInterior reflect
CVerbatim -> fillInterior $ curry snd
in EM.fromList interior
instance Binary Place where
put Place{..} = do
put qkind
put qarea
put qseen
put qlegend
put qFWall
put qFFloor
put qFGround
get = do
qkind <- get
qarea <- get
qseen <- get
qlegend <- get
qFWall <- get
qFFloor <- get
qFGround <- get
return $! Place{..}