{-# LANGUAGE TypeFamilies #-}
module Game.LambdaHack.Common.Level
(
Dungeon, dungeonBounds, ascendInBranch, whereTo
, ItemFloor, BigActorMap, ProjectileMap, TileMap, SmellMap, Level(..)
, updateFloor, updateEmbed, updateBigMap, updateProjMap
, updateTile, updateEntry, updateSmell
, at
, posToBigLvl, occupiedBigLvl, posToProjsLvl, occupiedProjLvl, posToAidsLvl
, findPosTry, findPosTry2, nearbyFreePoints
, sortEmbeds
#ifdef EXPOSE_INTERNAL
, EntryMap
, nearbyPassablePoints, assertSparseItems, assertSparseProjectiles
#endif
) where
import Prelude ()
import Game.LambdaHack.Core.Prelude
import Data.Binary
import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import Game.LambdaHack.Common.Area
import Game.LambdaHack.Common.Item
import Game.LambdaHack.Common.Kind
import qualified Game.LambdaHack.Common.Tile as Tile
import Game.LambdaHack.Common.Time
import Game.LambdaHack.Common.Types
import Game.LambdaHack.Common.Vector
import Game.LambdaHack.Content.CaveKind (CaveKind)
import qualified Game.LambdaHack.Content.ItemKind as IK
import Game.LambdaHack.Content.PlaceKind
import Game.LambdaHack.Content.RuleKind
import Game.LambdaHack.Content.TileKind (TileKind)
import qualified Game.LambdaHack.Core.Dice as Dice
import Game.LambdaHack.Common.Point
import qualified Game.LambdaHack.Common.PointArray as PointArray
import Game.LambdaHack.Core.Random
import Game.LambdaHack.Definition.Defs
type Dungeon = EM.EnumMap LevelId Level
dungeonBounds :: Dungeon -> (LevelId, LevelId)
dungeonBounds dungeon
| Just ((s, _), _) <- EM.minViewWithKey dungeon
, Just ((e, _), _) <- EM.maxViewWithKey dungeon
= (s, e)
dungeonBounds dungeon = error $ "empty dungeon" `showFailure` dungeon
ascendInBranch :: Dungeon -> Bool -> LevelId -> [LevelId]
ascendInBranch dungeon up lid =
let (minD, maxD) = dungeonBounds dungeon
ln = max minD $ min maxD $ toEnum $ fromEnum lid + if up then 1 else -1
in case EM.lookup ln dungeon of
Just _ | ln /= lid -> [ln]
_ | ln == lid -> []
_ -> ascendInBranch dungeon up ln
whereTo :: LevelId
-> Point
-> Bool
-> Dungeon
-> [(LevelId, Point)]
whereTo lid pos up dungeon =
let lvl = dungeon EM.! lid
li = case elemIndex pos $ fst $ lstair lvl of
Just ifst -> assert up [ifst]
Nothing -> case elemIndex pos $ snd $ lstair lvl of
Just isnd -> assert (not up) [isnd]
Nothing ->
let forcedPoss = (if up then fst else snd) (lstair lvl)
in [0 .. length forcedPoss - 1]
in case ascendInBranch dungeon up lid of
[] -> []
ln : _ -> let lvlDest = dungeon EM.! ln
stairsDest = (if up then snd else fst) (lstair lvlDest)
posAtIndex i = case drop i stairsDest of
[] -> error $ "not enough stairs:" `showFailure` (ln, i + 1)
p : _ -> (ln, p)
in map posAtIndex li
type ItemFloor = EM.EnumMap Point ItemBag
type BigActorMap = EM.EnumMap Point ActorId
type ProjectileMap = EM.EnumMap Point [ActorId]
type TileMap = PointArray.Array (ContentId TileKind)
type SmellMap = EM.EnumMap Point Time
type EntryMap = EM.EnumMap Point PlaceEntry
data Level = Level
{ lkind :: ContentId CaveKind
, ldepth :: Dice.AbsDepth
, lfloor :: ItemFloor
, lembed :: ItemFloor
, lbig :: BigActorMap
, lproj :: ProjectileMap
, ltile :: TileMap
, lentry :: EntryMap
, larea :: Area
, lsmell :: SmellMap
, lstair :: ([Point], [Point])
, lescape :: [Point]
, lseen :: Int
, lexpl :: Int
, ltime :: Time
, lnight :: Bool
}
deriving (Show, Eq)
assertSparseItems :: ItemFloor -> ItemFloor
assertSparseItems m =
assert (EM.null (EM.filter EM.null m)
`blame` "null floors found" `swith` m) m
assertSparseProjectiles :: ProjectileMap -> ProjectileMap
assertSparseProjectiles m =
assert (EM.null (EM.filter null m)
`blame` "null projectile lists found" `swith` m) m
updateFloor :: (ItemFloor -> ItemFloor) -> Level -> Level
updateFloor f lvl = lvl {lfloor = f (lfloor lvl)}
updateEmbed :: (ItemFloor -> ItemFloor) -> Level -> Level
updateEmbed f lvl = lvl {lembed = f (lembed lvl)}
updateBigMap :: (BigActorMap -> BigActorMap) -> Level -> Level
updateBigMap f lvl = lvl {lbig = f (lbig lvl)}
updateProjMap :: (ProjectileMap -> ProjectileMap) -> Level -> Level
updateProjMap f lvl = lvl {lproj = f (lproj lvl)}
updateTile :: (TileMap -> TileMap) -> Level -> Level
updateTile f lvl = lvl {ltile = f (ltile lvl)}
updateEntry :: (EntryMap -> EntryMap) -> Level -> Level
updateEntry f lvl = lvl {lentry = f (lentry lvl)}
updateSmell :: (SmellMap -> SmellMap) -> Level -> Level
updateSmell f lvl = lvl {lsmell = f (lsmell lvl)}
at :: Level -> Point -> ContentId TileKind
{-# INLINE at #-}
at Level{ltile} p = ltile PointArray.! p
posToBigLvl :: Point -> Level -> Maybe ActorId
{-# INLINE posToBigLvl #-}
posToBigLvl pos lvl = EM.lookup pos $ lbig lvl
occupiedBigLvl :: Point -> Level -> Bool
{-# INLINE occupiedBigLvl #-}
occupiedBigLvl pos lvl = pos `EM.member` lbig lvl
posToProjsLvl :: Point -> Level -> [ActorId]
{-# INLINE posToProjsLvl #-}
posToProjsLvl pos lvl = EM.findWithDefault [] pos $ lproj lvl
occupiedProjLvl :: Point -> Level -> Bool
{-# INLINE occupiedProjLvl #-}
occupiedProjLvl pos lvl = pos `EM.member` lproj lvl
posToAidsLvl :: Point -> Level -> [ActorId]
{-# INLINE posToAidsLvl #-}
posToAidsLvl pos lvl = maybeToList (posToBigLvl pos lvl)
++ posToProjsLvl pos lvl
findPosTry :: Int
-> Level
-> (Point -> ContentId TileKind -> Bool)
-> [Point -> ContentId TileKind -> Bool]
-> Rnd (Maybe Point)
{-# INLINE findPosTry #-}
findPosTry numTries lvl m = findPosTry2 numTries lvl m [] undefined
findPosTry2 :: Int
-> Level
-> (Point -> ContentId TileKind -> Bool)
-> [Point -> ContentId TileKind -> Bool]
-> (Point -> ContentId TileKind -> Bool)
-> [Point -> ContentId TileKind -> Bool]
-> Rnd (Maybe Point)
{-# INLINE findPosTry2 #-}
findPosTry2 numTries Level{ltile, larea} m0 l g r =
assert (numTries > 0) $
let (Point x0 y0, xspan, yspan) = spanArea larea
accomodate :: Rnd (Maybe Point)
-> (Point -> ContentId TileKind -> Bool)
-> [Point -> ContentId TileKind -> Bool]
-> Rnd (Maybe Point)
{-# INLINE accomodate #-}
accomodate fallback m = go
where
go :: [Point -> ContentId TileKind -> Bool]
-> Rnd (Maybe Point)
go [] = fallback
go (hd : tl) = search numTries
where
search 0 = go tl
search !k = do
pxyRelative <- randomR (0, xspan * yspan - 1)
let Point{..} = punindex xspan pxyRelative
pos = Point (x0 + px) (y0 + py)
tile = ltile PointArray.! pos
if m pos tile && hd pos tile
then return $ Just pos
else search (k - 1)
rAndOnceOnlym0 = r ++ [\_ _ -> True]
in accomodate (accomodate (return Nothing) m0 rAndOnceOnlym0)
(\pos tile -> m0 pos tile && g pos tile)
l
nearbyPassablePoints :: COps -> Level -> Point -> [Point]
nearbyPassablePoints cops@COps{corule=RuleContent{rXmax, rYmax}} lvl start =
let passable p = Tile.isEasyOpen (coTileSpeedup cops) (lvl `at` p)
passableVic p = filter passable $ vicinityBounded rXmax rYmax p
siftSingle :: Point
-> (ES.EnumSet Point, [Point])
-> (ES.EnumSet Point, [Point])
siftSingle current (seen, sameDistance) =
if current `ES.member` seen
then (seen, sameDistance)
else (ES.insert current seen, current : sameDistance)
siftVicinity :: Point
-> (ES.EnumSet Point, [Point])
-> (ES.EnumSet Point, [Point])
siftVicinity current seenAndSameDistance =
let vic = passableVic current
in foldr siftSingle seenAndSameDistance vic
siftNearby :: (ES.EnumSet Point, [Point]) -> [Point]
siftNearby (seen, sameDistance) =
sameDistance
++ case foldr siftVicinity (seen, []) sameDistance of
(_, []) -> []
(seen2, sameDistance2) -> siftNearby (seen2, sameDistance2)
in siftNearby (ES.singleton start, [start])
nearbyFreePoints :: COps -> Level -> (ContentId TileKind -> Bool) -> Point
-> [Point]
nearbyFreePoints cops lvl f start =
let good p = f (lvl `at` p)
&& Tile.isWalkable (coTileSpeedup cops) (lvl `at` p)
&& null (posToAidsLvl p lvl)
in filter good $ nearbyPassablePoints cops lvl start
sortEmbeds :: COps -> (ItemId -> IK.ItemKind) -> ContentId TileKind -> ItemBag
-> [(ItemId, ItemQuant)]
sortEmbeds COps{cotile} getKind tk embedBag =
let itemKindList = map (\(iid, kit) -> (getKind iid, (iid, kit)))
(EM.assocs embedBag)
grpList = Tile.embeddedItems cotile tk
f grp (itemKind, _) = fromMaybe 0 (lookup grp $ IK.ifreq itemKind) > 0
in map snd $ mapMaybe (\grp -> find (f grp) itemKindList) grpList
instance Binary Level where
put Level{..} = do
put lkind
put ldepth
put (assertSparseItems lfloor)
put (assertSparseItems lembed)
put lbig
put (assertSparseProjectiles lproj)
put ltile
put lentry
put larea
put lsmell
put lstair
put lescape
put lseen
put lexpl
put ltime
put lnight
get = do
lkind <- get
ldepth <- get
lfloor <- get
lembed <- get
lbig <- get
lproj <- get
ltile <- get
lentry <- get
larea <- get
lsmell <- get
lstair <- get
lescape <- get
lseen <- get
lexpl <- get
ltime <- get
lnight <- get
return $! Level{..}