module Game.LambdaHack.Place
( TileMapXY, Place(..), placeValid, buildFence, buildPlace
) where
import Data.Binary
import qualified Data.Map as M
import qualified Data.List as L
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import Game.LambdaHack.Utils.Assert
import Game.LambdaHack.Content.PlaceKind
import qualified Game.LambdaHack.Kind as Kind
import Game.LambdaHack.Area
import Game.LambdaHack.PointXY
import Game.LambdaHack.Misc
import Game.LambdaHack.Msg()
import Game.LambdaHack.Content.TileKind
import Game.LambdaHack.Random
import Game.LambdaHack.Content.CaveKind
data Place = Place
{ qkind :: !(Kind.Id PlaceKind)
, qarea :: !Area
, qseen :: !Bool
, qlegend :: !Text
, qsolidFence :: !(Kind.Id TileKind)
, qhollowFence :: !(Kind.Id TileKind)
}
deriving Show
instance Binary Place where
put Place{..} = do
put qkind
put qarea
put qseen
put qlegend
put qsolidFence
put qhollowFence
get = do
qkind <- get
qarea <- get
qseen <- get
qlegend <- get
qsolidFence <- get
qhollowFence <- get
return Place{..}
type TileMapXY = M.Map PointXY (Kind.Id TileKind)
placeValid :: Area
-> PlaceKind
-> Bool
placeValid r PlaceKind{..} =
let (x0, y0, x1, y1) = expandFence pfence r
dx = x1 x0 + 1
dy = y1 y0 + 1
dxcorner = case ptopLeft of [] -> 0 ; l : _ -> T.length l
dycorner = L.length ptopLeft
wholeOverlapped d dcorner = d > 1 && dcorner > 1 &&
(d 1) `mod` (2 * (dcorner 1)) == 0
in case pcover of
CAlternate -> wholeOverlapped dx dxcorner &&
wholeOverlapped dy dycorner
_ -> dx >= 2 * dxcorner 1 &&
dy >= 2 * dycorner 1
expandFence :: Fence -> Area -> Area
expandFence fence r = case fence of
FWall -> r
FFloor -> expand r (1)
FNone -> expand r 1
buildPlace :: Kind.COps
-> CaveKind
-> Kind.Id TileKind
-> Int
-> Int
-> Area
-> Rnd (TileMapXY, Place)
buildPlace Kind.COps{ cotile=cotile@Kind.Ops{opick=opick}
, coplace=Kind.Ops{okind=pokind, opick=popick} }
CaveKind{..} qhollowFence ln depth r
= assert (not (trivialArea r) `blame` r) $ do
qsolidFence <- opick cfillerTile (const True)
dark <- chanceDeep ln depth cdarkChance
qkind <- popick (T.pack "rogue") (placeValid r)
let kr = pokind qkind
qlegend = if dark then cdarkLegendTile else clitLegendTile
qseen = False
qarea = expandFence (pfence kr) r
place = assert (validArea qarea `blame` qarea) $
Place{..}
legend <- olegend cotile qlegend
let xlegend = M.insert 'X' qhollowFence legend
return (digPlace place kr xlegend, place)
olegend :: Kind.Ops TileKind -> Text -> Rnd (M.Map Char (Kind.Id TileKind))
olegend Kind.Ops{ofoldrWithKey, opick} group =
let getSymbols _ tk acc =
maybe acc (const $ S.insert (tsymbol tk) acc)
(L.lookup group $ tfreq tk)
symbols = ofoldrWithKey getSymbols S.empty
getLegend s acc = do
m <- acc
tk <- opick group $ (== s) . tsymbol
return $ M.insert s tk m
legend = S.fold getLegend (return M.empty) symbols
in legend
buildFence :: Kind.Id TileKind -> Area -> TileMapXY
buildFence fenceId (x0, y0, x1, y1) =
M.fromList $ [ (PointXY (x, y), fenceId)
| x <- [x01, x1+1], y <- [y0..y1] ] ++
[ (PointXY (x, y), fenceId)
| x <- [x01..x1+1], y <- [y01, y1+1] ]
digPlace :: Place
-> PlaceKind
-> M.Map Char (Kind.Id TileKind)
-> TileMapXY
digPlace Place{..} kr legend =
let fence = case pfence kr of
FWall -> buildFence qsolidFence qarea
FFloor -> buildFence qhollowFence qarea
FNone -> M.empty
in M.union (M.map (legend M.!) $ tilePlace qarea kr) fence
tilePlace :: Area
-> PlaceKind
-> M.Map PointXY Char
tilePlace (x0, y0, x1, y1) pl@PlaceKind{..} =
let dx = x1 x0 + 1
dy = y1 y0 + 1
fromX (x, y) = L.map PointXY $ L.zip [x..] (repeat y)
fillInterior :: (forall a. Int -> [a] -> [a]) -> [(PointXY, Char)]
fillInterior f =
let tileInterior (y, row) = L.zip (fromX (x0, y)) $ f dx row
reflected = L.zip [y0..] $ f dy $ map T.unpack ptopLeft
in L.concatMap tileInterior reflected
tileReflect :: Int -> [a] -> [a]
tileReflect d pat =
let lstart = L.take (d `divUp` 2) pat
lend = L.take (d `div` 2) pat
in lstart ++ L.reverse lend
interior = case pcover of
CAlternate ->
let tile :: Int -> [a] -> [a]
tile _ [] = assert `failure` pl
tile d pat =
L.take d (L.cycle $ L.init pat ++ L.init (L.reverse pat))
in fillInterior tile
CStretch ->
let stretch :: Int -> [a] -> [a]
stretch _ [] = assert `failure` pl
stretch d pat = tileReflect d (pat ++ L.repeat (L.last pat))
in fillInterior stretch
CReflect ->
let reflect :: Int -> [a] -> [a]
reflect d pat = tileReflect d (L.cycle pat)
in fillInterior reflect
in M.fromList interior