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
}
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) = 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
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
return (Level ad ia sx sy ls le li lm lrm ld lme lstairs ltime)
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 [p] = findLoc lmap p
findLocTry numTries lmap l = assert (numTries > 0) $
let search 0 = findLocTry numTries lmap (L.tail l)
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