module Game.LambdaHack.Level
(
ActorDict, InvDict, SmellMap, SecretMap, ItemMap, TileMap, Level(..)
, updateActorDict, updateInv
, updateSmell, updateIMap, updateLMap, updateLRMap, dropItemsAt
, at, rememberAt, atI, rememberAtI
, accessible, openable, findLoc, findLocTry
) where
import Data.Binary
import qualified Data.List as L
import qualified Data.IntMap as IM
import Game.LambdaHack.Utils.Assert
import Game.LambdaHack.PointXY
import Game.LambdaHack.Point
import Game.LambdaHack.Actor
import Game.LambdaHack.Item
import Game.LambdaHack.Content.TileKind
import Game.LambdaHack.Content.RuleKind
import Game.LambdaHack.Random
import Game.LambdaHack.Tile
import qualified Game.LambdaHack.Feature as F
import qualified Game.LambdaHack.Kind as Kind
import Game.LambdaHack.Time
type ActorDict = IM.IntMap Actor
type InvDict = IM.IntMap [Item]
type SmellMap = IM.IntMap SmellTime
type SecretMap = IM.IntMap SecretTime
type ItemMap = IM.IntMap ([Item], [Item])
type TileMap = Kind.Array Point TileKind
data Level = Level
{ lactor :: ActorDict
, linv :: InvDict
, lxsize :: X
, lysize :: Y
, lsmell :: SmellMap
, lsecret :: SecretMap
, litem :: ItemMap
, lmap :: TileMap
, lrmap :: TileMap
, ldesc :: String
, lmeta :: String
, lstairs :: (Point, Point)
, ltime :: Time
, lclear :: Int
, lseen :: Int
}
deriving Show
updateActorDict :: (ActorDict -> ActorDict) -> Level -> Level
updateActorDict f lvl = lvl { lactor = f (lactor lvl) }
updateInv :: (InvDict -> InvDict) -> Level -> Level
updateInv f lvl = lvl { linv = f (linv lvl) }
updateSmell :: (SmellMap -> SmellMap) -> Level -> Level
updateSmell f lvl = lvl { lsmell = f (lsmell lvl) }
updateIMap :: (ItemMap -> ItemMap) -> Level -> Level
updateIMap f lvl = lvl { litem = f (litem lvl) }
updateLMap, updateLRMap :: (TileMap -> TileMap) -> Level -> Level
updateLMap f lvl = lvl { lmap = f (lmap lvl) }
updateLRMap f lvl = lvl { lrmap = f (lrmap lvl) }
dropItemsAt :: [Item] -> Point -> Level -> Level
dropItemsAt [] _loc = id
dropItemsAt items loc =
let joinItems = L.foldl' (\ acc i -> snd (joinItem i acc))
adj Nothing = Just (items, [])
adj (Just (i, ri)) = Just (joinItems items i, ri)
in updateIMap (IM.alter adj loc)
instance Binary Level where
put (Level ad ia sx sy ls le li lm lrm ld
lme lstairs ltime lclear lseen) = do
put ad
put ia
put sx
put sy
put ls
put le
put (assert
(IM.null (IM.filter (\ (is1, is2) ->
L.null is1 && L.null is2) li)
`blame` li) li)
put lm
put lrm
put ld
put lme
put lstairs
put ltime
put lclear
put lseen
get = do
ad <- get
ia <- get
sx <- get
sy <- get
ls <- get
le <- get
li <- get
lm <- get
lrm <- get
ld <- get
lme <- get
lstairs <- get
ltime <- get
lclear <- get
lseen <- get
return (Level ad ia sx sy ls le li lm lrm ld
lme lstairs ltime lclear lseen)
at, rememberAt :: Level -> Point -> Kind.Id TileKind
at Level{lmap} p = lmap Kind.! p
rememberAt Level{lrmap} p = lrmap Kind.! p
atI, rememberAtI :: Level -> Point -> [Item]
atI Level{litem} p = fst $ IM.findWithDefault ([], []) p litem
rememberAtI Level{litem} p = snd $ IM.findWithDefault ([], []) p litem
accessible :: Kind.COps -> Level -> Point -> Point -> Bool
accessible Kind.COps{ cotile=Kind.Ops{okind=okind}, corule}
lvl@Level{lxsize} sloc tloc =
let check = raccessible $ Kind.stdRuleset corule
src = okind $ lvl `at` sloc
tgt = okind $ lvl `at` tloc
in check lxsize sloc src tloc tgt
openable :: Kind.Ops TileKind -> Level -> SecretTime -> Point -> Bool
openable cops lvl@Level{lsecret} k target =
let tgt = lvl `at` target
in hasFeature cops F.Openable tgt ||
(hasFeature cops F.Hidden tgt &&
lsecret IM.! target <= k)
findLoc :: TileMap -> (Point -> Kind.Id TileKind -> Bool) -> Rnd Point
findLoc lmap p =
let search = do
loc <- randomR $ Kind.bounds lmap
let tile = lmap Kind.! loc
if p loc tile
then return loc
else search
in search
findLocTry :: Int
-> TileMap
-> [Point -> Kind.Id TileKind -> Bool]
-> Rnd Point
findLocTry _ lmap [] = findLoc lmap (const (const True))
findLocTry _ lmap [p] = findLoc lmap p
findLocTry numTries lmap l@(_ : tl) = assert (numTries > 0) $
let search 0 = findLocTry numTries lmap tl
search k = do
loc <- randomR $ Kind.bounds lmap
let tile = lmap Kind.! loc
if L.all (\ p -> p loc tile) l
then return loc
else search (k 1)
in search numTries