module Game.LambdaHack.Common.Tile
( SmellTime
, kindHasFeature, hasFeature
, isClear, isLit, isWalkable, isPassableKind, isPassable, isDoor, isSuspect
, isExplorable, lookSimilar, speedup
, openTo, closeTo, causeEffects, revealAs, hideAs
, isOpenable, isClosable, isChangeable, isEscape, isStair
#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.Effect as Effect
import qualified Game.LambdaHack.Common.Feature as F
import qualified Game.LambdaHack.Common.Kind as Kind
import Game.LambdaHack.Common.Random
import Game.LambdaHack.Common.Time
import Game.LambdaHack.Content.TileKind
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 :: F.Feature -> TileKind -> Bool
kindHasFeature f t = f `elem` tfeature t
hasFeature :: Kind.Ops TileKind -> F.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 =
tsymbol t == tsymbol u &&
tname t == tname u &&
tcolor t == tcolor u &&
tcolor2 t == tcolor2 u
speedup :: Bool -> Kind.Ops TileKind -> TileSpeedup
speedup allClear cotile =
let isClearTab | allClear = createTab cotile
$ not . kindHasFeature F.Impenetrable
| otherwise = createTab cotile
$ kindHasFeature F.Clear
isLitTab = createTab cotile $ not . kindHasFeature F.Dark
isWalkableTab = createTab cotile $ kindHasFeature F.Walkable
isPassableTab = createTab cotile isPassableKind
isDoorTab = createTab cotile $ \tk ->
let getTo F.OpenTo{} = True
getTo F.CloseTo{} = True
getTo _ = False
in any getTo $ tfeature tk
isSuspectTab = createTab cotile $ kindHasFeature F.Suspect
isChangeableTab = createTab cotile $ \tk ->
let getTo F.ChangeTo{} = True
getTo _ = False
in any getTo $ tfeature tk
in TileSpeedup {..}
isPassableKind :: TileKind -> Bool
isPassableKind tk =
let getTo F.Walkable = True
getTo F.OpenTo{} = True
getTo F.ChangeTo{} = True
getTo F.Suspect = True
getTo _ = False
in any getTo $ tfeature tk
openTo :: Kind.Ops TileKind -> Kind.Id TileKind -> Rnd (Kind.Id TileKind)
openTo Kind.Ops{okind, opick} t = do
let getTo (F.OpenTo grp) acc = grp : acc
getTo _ acc = acc
case foldr getTo [] $ 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 (F.CloseTo grp) acc = grp : acc
getTo _ acc = acc
case foldr getTo [] $ tfeature $ okind t of
[] -> return t
groups -> do
grp <- oneOf groups
fmap (fromMaybe $ assert `failure` grp)
$ opick grp (const True)
causeEffects :: Kind.Ops TileKind -> Kind.Id TileKind -> [Effect.Effect Int]
causeEffects Kind.Ops{okind} t = do
let getTo (F.Cause eff) acc = eff : acc
getTo _ acc = acc
foldr getTo [] $ tfeature $ okind t
revealAs :: Kind.Ops TileKind -> Kind.Id TileKind -> Rnd (Kind.Id TileKind)
revealAs Kind.Ops{okind, opick} t = do
let getTo (F.RevealAs grp) acc = grp : acc
getTo _ acc = acc
case foldr getTo [] $ 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 (F.HideAs grp) _ = Just grp
getTo _ acc = acc
in case foldr getTo Nothing (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 F.OpenTo{} = True
getTo _ = False
in any getTo $ tfeature $ okind t
isClosable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool
isClosable Kind.Ops{okind} t =
let getTo F.CloseTo{} = True
getTo _ = False
in any getTo $ tfeature $ okind t
isEscape :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool
isEscape cotile t = let isEffectEscape Effect.Escape{} = True
isEffectEscape _ = False
in any isEffectEscape $ causeEffects cotile t
isStair :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool
isStair cotile t = let isEffectAscend Effect.Ascend{} = True
isEffectAscend _ = False
in any isEffectAscend $ causeEffects cotile t