module Game.LambdaHack.Common.Tile
( SmellTime
, kindHasFeature, hasFeature
, isClear, isLit, isWalkable, isPassableKind, isPassable, isDoor, isSuspect
, isExplorable, lookSimilar, speedup
, openTo, closeTo, embedItems, causeEffects, revealAs, hideAs
, isOpenable, isClosable, isChangeable, isEscape, isStair, ascendTo
#ifdef EXPOSE_INTERNAL
, TileSpeedup(..), Tab, createTab, accessTab
#endif
) where
import Control.Exception.Assert.Sugar
import qualified Data.Array.Unboxed as A
import Data.Maybe
import qualified Game.LambdaHack.Common.Kind as Kind
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.Random
import Game.LambdaHack.Common.Time
import Game.LambdaHack.Content.ItemKind (ItemKind)
import qualified Game.LambdaHack.Content.ItemKind as IK
import Game.LambdaHack.Content.TileKind (TileKind)
import qualified Game.LambdaHack.Content.TileKind as TK
type SmellTime = Time
type instance Kind.Speedup TileKind = TileSpeedup
data TileSpeedup = TileSpeedup
{ isClearTab :: !Tab
, isLitTab :: !Tab
, isWalkableTab :: !Tab
, isPassableTab :: !Tab
, isDoorTab :: !Tab
, isSuspectTab :: !Tab
, isChangeableTab :: !Tab
}
newtype Tab = Tab (A.UArray (Kind.Id TileKind) Bool)
createTab :: Kind.Ops TileKind -> (TileKind -> Bool) -> Tab
createTab Kind.Ops{ofoldrWithKey, obounds} p =
let f _ k acc = p k : acc
clearAssocs = ofoldrWithKey f []
in Tab $ A.listArray obounds clearAssocs
accessTab :: Tab -> Kind.Id TileKind -> Bool
accessTab (Tab tab) ki = tab A.! ki
kindHasFeature :: TK.Feature -> TileKind -> Bool
kindHasFeature f t = f `elem` TK.tfeature t
hasFeature :: Kind.Ops TileKind -> TK.Feature -> Kind.Id TileKind -> Bool
hasFeature Kind.Ops{okind} f t = kindHasFeature f (okind t)
isClear :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool
isClear Kind.Ops{ospeedup = Just TileSpeedup{isClearTab}} =
\k -> accessTab isClearTab k
isClear cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile
isLit :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool
isLit Kind.Ops{ospeedup = Just TileSpeedup{isLitTab}} =
\k -> accessTab isLitTab k
isLit cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile
isWalkable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool
isWalkable Kind.Ops{ospeedup = Just TileSpeedup{isWalkableTab}} =
\k -> accessTab isWalkableTab k
isWalkable cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile
isPassable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool
isPassable Kind.Ops{ospeedup = Just TileSpeedup{isPassableTab}} =
\k -> accessTab isPassableTab k
isPassable cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile
isDoor :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool
isDoor Kind.Ops{ospeedup = Just TileSpeedup{isDoorTab}} =
\k -> accessTab isDoorTab k
isDoor cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile
isSuspect :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool
isSuspect Kind.Ops{ospeedup = Just TileSpeedup{isSuspectTab}} =
\k -> accessTab isSuspectTab k
isSuspect cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile
isChangeable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool
isChangeable Kind.Ops{ospeedup = Just TileSpeedup{isChangeableTab}} =
\k -> accessTab isChangeableTab k
isChangeable cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile
isExplorable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool
isExplorable cotile t =
(isWalkable cotile t || isClear cotile t) && not (isDoor cotile t)
lookSimilar :: TileKind -> TileKind -> Bool
lookSimilar t u =
TK.tsymbol t == TK.tsymbol u &&
TK.tname t == TK.tname u &&
TK.tcolor t == TK.tcolor u &&
TK.tcolor2 t == TK.tcolor2 u
speedup :: Bool -> Kind.Ops TileKind -> TileSpeedup
speedup allClear cotile =
let isClearTab | allClear = createTab cotile
$ not . kindHasFeature TK.Impenetrable
| otherwise = createTab cotile
$ kindHasFeature TK.Clear
isLitTab = createTab cotile $ not . kindHasFeature TK.Dark
isWalkableTab = createTab cotile $ kindHasFeature TK.Walkable
isPassableTab = createTab cotile isPassableKind
isDoorTab = createTab cotile $ \tk ->
let getTo TK.OpenTo{} = True
getTo TK.CloseTo{} = True
getTo _ = False
in any getTo $ TK.tfeature tk
isSuspectTab = createTab cotile $ kindHasFeature TK.Suspect
isChangeableTab = createTab cotile $ \tk ->
let getTo TK.ChangeTo{} = True
getTo _ = False
in any getTo $ TK.tfeature tk
in TileSpeedup {..}
isPassableKind :: TileKind -> Bool
isPassableKind tk =
let getTo TK.Walkable = True
getTo TK.OpenTo{} = True
getTo TK.ChangeTo{} = True
getTo TK.Suspect = True
getTo _ = False
in any getTo $ TK.tfeature tk
openTo :: Kind.Ops TileKind -> Kind.Id TileKind -> Rnd (Kind.Id TileKind)
openTo Kind.Ops{okind, opick} t = do
let getTo (TK.OpenTo grp) acc = grp : acc
getTo _ acc = acc
case foldr getTo [] $ TK.tfeature $ okind t of
[] -> return t
groups -> do
grp <- oneOf groups
fmap (fromMaybe $ assert `failure` grp)
$ opick grp (const True)
closeTo :: Kind.Ops TileKind -> Kind.Id TileKind -> Rnd (Kind.Id TileKind)
closeTo Kind.Ops{okind, opick} t = do
let getTo (TK.CloseTo grp) acc = grp : acc
getTo _ acc = acc
case foldr getTo [] $ TK.tfeature $ okind t of
[] -> return t
groups -> do
grp <- oneOf groups
fmap (fromMaybe $ assert `failure` grp)
$ opick grp (const True)
embedItems :: Kind.Ops TileKind -> Kind.Id TileKind -> [GroupName ItemKind]
embedItems Kind.Ops{okind} t =
let getTo (TK.Embed eff) acc = eff : acc
getTo _ acc = acc
in foldr getTo [] $ TK.tfeature $ okind t
causeEffects :: Kind.Ops TileKind -> Kind.Id TileKind -> [IK.Effect]
causeEffects Kind.Ops{okind} t =
let getTo (TK.Cause eff) acc = eff : acc
getTo _ acc = acc
in foldr getTo [] $ TK.tfeature $ okind t
revealAs :: Kind.Ops TileKind -> Kind.Id TileKind -> Rnd (Kind.Id TileKind)
revealAs Kind.Ops{okind, opick} t = do
let getTo (TK.RevealAs grp) acc = grp : acc
getTo _ acc = acc
case foldr getTo [] $ TK.tfeature $ okind t of
[] -> return t
groups -> do
grp <- oneOf groups
fmap (fromMaybe $ assert `failure` grp)
$ opick grp (const True)
hideAs :: Kind.Ops TileKind -> Kind.Id TileKind -> Kind.Id TileKind
hideAs Kind.Ops{okind, ouniqGroup} t =
let getTo (TK.HideAs grp) _ = Just grp
getTo _ acc = acc
in case foldr getTo Nothing (TK.tfeature (okind t)) of
Nothing -> t
Just grp -> ouniqGroup grp
isOpenable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool
isOpenable Kind.Ops{okind} t =
let getTo TK.OpenTo{} = True
getTo _ = False
in any getTo $ TK.tfeature $ okind t
isClosable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool
isClosable Kind.Ops{okind} t =
let getTo TK.CloseTo{} = True
getTo _ = False
in any getTo $ TK.tfeature $ okind t
isEscape :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool
isEscape cotile t = let isEffectEscape IK.Escape{} = True
isEffectEscape _ = False
in any isEffectEscape $ causeEffects cotile t
isStair :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool
isStair cotile t = let isEffectAscend IK.Ascend{} = True
isEffectAscend _ = False
in any isEffectAscend $ causeEffects cotile t
ascendTo :: Kind.Ops TileKind -> Kind.Id TileKind -> [Int]
ascendTo cotile t =
let getTo (IK.Ascend k) acc = k : acc
getTo _ acc = acc
in foldr getTo [] (causeEffects cotile t)