{-# LANGUAGE RankNTypes #-}
module Game.LambdaHack.Server.DungeonGen.Place
( Place(..), TileMapEM, placeCheck, buildPlace, isChancePos, buildFenceRnd
#ifdef EXPOSE_INTERNAL
, interiorArea, olegend, ooverride, buildFence, tilePlace
#endif
) where
import Prelude ()
import Game.LambdaHack.Common.Prelude
import Data.Binary
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 qualified Game.LambdaHack.Common.Dice as Dice
import Game.LambdaHack.Common.Frequency
import Game.LambdaHack.Common.Kind
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.Point
import Game.LambdaHack.Common.Random
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 Game.LambdaHack.Server.DungeonGen.Area
data Place = Place
{ qkind :: ContentId PlaceKind
, qarea :: Area
, qseen :: Bool
, qlegend :: GroupName TileKind
, qFWall :: ContentId TileKind
, qFFloor :: ContentId TileKind
, qFGround :: ContentId TileKind
}
deriving Show
type TileMapEM = EM.EnumMap Point (ContentId TileKind)
placeCheck :: Area
-> PlaceKind
-> Bool
placeCheck r pk@PlaceKind{..} =
case interiorArea pk 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 -> True
CMirror -> True
interiorArea :: PlaceKind -> Area -> Maybe Area
interiorArea kr r =
let requiredForFence = case pfence kr of
FWall -> 1
FFloor -> 1
FGround -> 1
FNone -> 0
in if pcover kr `elem` [CVerbatim, CMirror]
then let (x0, y0, x1, y1) = fromArea r
dx = case ptopLeft kr of
[] -> error $ "" `showFailure` kr
l : _ -> T.length l
dy = length $ ptopLeft kr
mx = (x1 - x0 + 1 - dx) `div` 2
my = (y1 - y0 + 1 - dy) `div` 2
in if mx < requiredForFence || my < requiredForFence
then Nothing
else toArea (x0 + mx, y0 + my, x0 + mx + dx - 1, y0 + my + dy - 1)
else case requiredForFence of
0 -> Just r
1 -> shrink r
_ -> error $ "" `showFailure` kr
buildPlace :: COps
-> CaveKind
-> Bool
-> ContentId TileKind
-> ContentId TileKind
-> Dice.AbsDepth
-> Dice.AbsDepth
-> Int
-> Area
-> Maybe (GroupName PlaceKind)
-> Rnd (TileMapEM, Place)
buildPlace cops@COps{cotile, coplace}
CaveKind{..} dnight darkCorTile litCorTile
ldepth@(Dice.AbsDepth ld) totalDepth@(Dice.AbsDepth depth) dsecret
r mplaceGroup = do
qFWall <- fromMaybe (error $ "" `showFailure` cfillerTile)
<$> opick cotile cfillerTile (const True)
let findInterval x1y1 [] = (x1y1, (11, 0))
findInterval !x1y1 ((!x, !y) : rest) =
if fromIntegral ld * 10 <= x * fromIntegral depth
then (x1y1, (x, y))
else findInterval (x, y) rest
linearInterpolation !dataset =
let ((x1, y1), (x2, y2)) = findInterval (0, 0) dataset
in ceiling
$ fromIntegral y1
+ fromIntegral (y2 - y1)
* (fromIntegral ld * 10 - x1 * fromIntegral depth)
/ ((x2 - x1) * fromIntegral depth)
f !placeGroup !q !acc !p !pk !kind =
let rarity = linearInterpolation (prarity kind)
in (q * p * rarity, ((pk, kind), placeGroup)) : acc
g (placeGroup, q) = ofoldlGroup' coplace placeGroup (f placeGroup q) []
pfreq = case mplaceGroup of
Nothing -> cplaceFreq
Just placeGroup -> [(placeGroup, 1)]
placeFreq = concatMap g pfreq
checkedFreq = filter (\(_, ((_, kind), _)) -> placeCheck r kind) placeFreq
freq = toFreq ("buildPlace" <+> tshow (map fst checkedFreq)) checkedFreq
let !_A = assert (not (nullFreq freq) `blame` (placeFreq, checkedFreq, r)) ()
((qkind, kr), _) <- frequency freq
dark <- if cpassable && pfence kr `elem` [FFloor, FGround]
then return dnight
else chanceDice ldepth totalDepth cdarkChance
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 (error $ "" `showFailure` (kr, r)) $ interiorArea kr r
place = Place {..}
(overrideOneIn, override) <- ooverride cops (poverride kr)
(legendOneIn, legend) <- olegend cops qlegend
(legendLitOneIn, legendLit) <- olegend cops clegendLitTile
let xlegend = ( EM.union overrideOneIn legendOneIn
, EM.union override legend )
xlegendLit = ( EM.union overrideOneIn legendLitOneIn
, EM.union override legendLit )
cmap <- tilePlace qarea kr
let 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 = lookupOneIn xlegendLit xy c
| otherwise = lookupOneIn xlegend xy c
lookupOneIn :: ( EM.EnumMap Char (Int, ContentId TileKind)
, EM.EnumMap Char (ContentId TileKind) )
-> Point -> Char
-> ContentId TileKind
lookupOneIn (mOneIn, m) xy c = case EM.lookup c mOneIn of
Just (oneInChance, tk) ->
if isChancePos oneInChance dsecret xy
then tk
else EM.findWithDefault (error $ "" `showFailure` (c, mOneIn, m)) c m
Nothing -> EM.findWithDefault (error $ "" `showFailure` (c, mOneIn, m))
c m
interior = case pfence kr of
FNone | not dnight -> EM.mapWithKey digDay cmap
_ -> EM.mapWithKey (lookupOneIn xlegend) cmap
return (EM.union interior fence, place)
isChancePos :: Int -> Int -> Point -> Bool
isChancePos c dsecret (Point x y) =
c > 0 && (dsecret `Bits.rotateR` x `Bits.xor` y + x) `mod` c == 0
olegend :: COps -> GroupName TileKind
-> Rnd ( EM.EnumMap Char (Int, ContentId TileKind)
, EM.EnumMap Char (ContentId TileKind) )
olegend COps{cotile} cgroup =
let getSymbols !acc _ !tk =
maybe acc (const $ ES.insert (TK.tsymbol tk) acc)
(lookup cgroup $ TK.tfreq tk)
symbols = ofoldlWithKey' cotile getSymbols ES.empty
getLegend s !acc = do
(mOneIn, m) <- acc
let p f t = TK.tsymbol t == s && f (Tile.kindHasFeature TK.Spice t)
tk <- fmap (fromMaybe $ error $ "" `showFailure` (cgroup, s))
$ opick cotile cgroup (p not)
mtkSpice <- opick cotile cgroup (p id)
return $! case mtkSpice of
Nothing -> (mOneIn, EM.insert s tk m)
Just tkSpice ->
let n = fromJust (lookup cgroup (TK.tfreq (okind cotile tk)))
k = fromJust (lookup cgroup (TK.tfreq (okind cotile tkSpice)))
oneIn = (n + k) `divUp` k
in (EM.insert s (oneIn, tkSpice) mOneIn, EM.insert s tk m)
legend = ES.foldr' getLegend (return (EM.empty, EM.empty)) symbols
in legend
ooverride :: COps -> [(Char, GroupName TileKind)]
-> Rnd ( EM.EnumMap Char (Int, ContentId TileKind)
, EM.EnumMap Char (ContentId TileKind) )
ooverride COps{cotile} poverride =
let getLegend (s, cgroup) acc = do
(mOneIn, m) <- acc
mtkSpice <- opick cotile cgroup (Tile.kindHasFeature TK.Spice)
tk <- fromMaybe (error $ "" `showFailure` (s, cgroup, poverride))
<$> opick cotile cgroup (not . Tile.kindHasFeature TK.Spice)
return $! case mtkSpice of
Nothing -> (mOneIn, EM.insert s tk m)
Just tkSpice ->
let n = fromJust (lookup cgroup (TK.tfreq (okind cotile tk)))
k = fromJust (lookup cgroup (TK.tfreq (okind cotile tkSpice)))
oneIn = (n + k) `divUp` k
in (EM.insert s (oneIn, tkSpice) mOneIn, EM.insert s tk m)
in foldr getLegend (return (EM.empty, EM.empty)) poverride
buildFence :: ContentId TileKind -> Area -> TileMapEM
buildFence fenceId area =
let (x0, y0, x1, y1) = fromArea area
in EM.fromList $ [ (Point x y, fenceId)
| x <- [x0-1, x1+1], y <- [y0..y1] ] ++
[ (Point x y, fenceId)
| x <- [x0-1..x1+1], y <- [y0-1, y1+1] ]
buildFenceRnd :: COps -> GroupName TileKind -> Area -> Rnd TileMapEM
buildFenceRnd COps{cotile} couterFenceTile area = do
let (x0, y0, x1, y1) = fromArea area
fenceIdRnd (xf, yf) = do
let isCorner x y = x `elem` [x0-1, x1+1] && y `elem` [y0-1, y1+1]
tileGroup | isCorner xf yf = "basic outer fence"
| otherwise = couterFenceTile
fenceId <- fromMaybe (error $ "" `showFailure` tileGroup)
<$> opick cotile tileGroup (const True)
return (Point xf yf, fenceId)
pointList = [ (x, y) | x <- [x0-1, x1+1], y <- [y0..y1] ]
++ [ (x, y) | x <- [x0-1..x1+1], y <- [y0-1, y1+1] ]
fenceList <- mapM fenceIdRnd pointList
return $! EM.fromList fenceList
tilePlace :: Area
-> PlaceKind
-> Rnd (EM.EnumMap Point Char)
tilePlace area pl@PlaceKind{..} = do
let (x0, y0, x1, y1) = fromArea area
xwidth = x1 - x0 + 1
ywidth = y1 - y0 + 1
dxcorner = case ptopLeft of
[] -> error $ "" `showFailure` (area, pl)
l : _ -> T.length l
(dx, dy) = assert (xwidth >= dxcorner && ywidth >= length ptopLeft
`blame` (area, pl))
(xwidth, ywidth)
fromX (x2, y2) = map (`Point` y2) [x2..]
fillInterior :: (Int -> String -> String)
-> (Int -> [String] -> [String])
-> [(Point, Char)]
fillInterior f g =
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 gy = g dy $ map T.unpack ptopLeft
yStart = y0 + ((ywidth - length gy) `div` 2)
in zip [yStart..] gy
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 -> do
let tile :: Int -> [a] -> [a]
tile _ [] = error $ "nothing to tile" `showFailure` pl
tile d pat = take d (cycle $ init pat ++ init (reverse pat))
return $! fillInterior tile tile
CStretch -> do
let stretch :: Int -> [a] -> [a]
stretch _ [] = error $ "nothing to stretch" `showFailure` pl
stretch d pat = tileReflect d (pat ++ repeat (last pat))
return $! fillInterior stretch stretch
CReflect -> do
let reflect :: Int -> [a] -> [a]
reflect d pat = tileReflect d (cycle pat)
return $! fillInterior reflect reflect
CVerbatim -> return $! fillInterior (flip const) (flip const)
CMirror -> do
mirror1 <- oneOf [id, reverse]
mirror2 <- oneOf [id, reverse]
return $! fillInterior (\_ l -> mirror1 l) (\_ l -> mirror2 l)
return $! 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{..}