module Game.LambdaHack.Common.Tile
( SmellTime
, kindHasFeature, hasFeature
, isClear, isLit, isWalkable, isPassable, isDoor, isSuspect
, isExplorable, lookSimilar, speedup
, openTo, closeTo, causeEffects, revealAs, hideAs
, isOpenable, isClosable, isChangeable, isEscape, isStair
) where
import Control.Exception.Assert.Sugar
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
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 Kind.TileSpeedup{isClearTab}} =
\k -> Kind.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 Kind.TileSpeedup{isLitTab}} =
\k -> Kind.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 Kind.TileSpeedup{isWalkableTab}} =
\k -> Kind.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 Kind.TileSpeedup{isPassableTab}} =
\k -> Kind.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 Kind.TileSpeedup{isDoorTab}} =
\k -> Kind.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 Kind.TileSpeedup{isSuspectTab}} =
\k -> Kind.accessTab isSuspectTab k
isSuspect cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile
isExplorable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool
isExplorable cotile t =
isWalkable cotile t || isDoor cotile t || isChangeable 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 -> Kind.Speedup TileKind
speedup allClear cotile =
let isClearTab | allClear = Kind.createTab cotile
$ not . kindHasFeature F.Impenetrable
| otherwise = Kind.createTab cotile
$ kindHasFeature F.Clear
isLitTab = Kind.createTab cotile $ not . kindHasFeature F.Dark
isWalkableTab = Kind.createTab cotile $ kindHasFeature F.Walkable
isPassableTab = Kind.createTab cotile $ \tk ->
let getTo F.OpenTo{} = True
getTo F.Walkable = True
getTo _ = False
in any getTo $ tfeature tk
isDoorTab = Kind.createTab cotile $ \tk ->
let getTo F.OpenTo{} = True
getTo F.CloseTo{} = True
getTo _ = False
in any getTo $ tfeature tk
isSuspectTab = Kind.createTab cotile $ kindHasFeature F.Suspect
in Kind.TileSpeedup {..}
openTo :: Kind.Ops TileKind -> Kind.Id TileKind -> Rnd (Kind.Id TileKind)
openTo Kind.Ops{okind, opick} t = do
let getTo (F.OpenTo group) acc = group : acc
getTo _ acc = acc
case foldr getTo [] $ tfeature $ okind t of
[] -> return t
groups -> do
group <- oneOf groups
fmap (fromMaybe $ assert `failure` group)
$ opick group (const True)
closeTo :: Kind.Ops TileKind -> Kind.Id TileKind -> Rnd (Kind.Id TileKind)
closeTo Kind.Ops{okind, opick} t = do
let getTo (F.CloseTo group) acc = group : acc
getTo _ acc = acc
case foldr getTo [] $ tfeature $ okind t of
[] -> return t
groups -> do
group <- oneOf groups
fmap (fromMaybe $ assert `failure` group)
$ opick group (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 group) acc = group : acc
getTo _ acc = acc
case foldr getTo [] $ tfeature $ okind t of
[] -> return t
groups -> do
group <- oneOf groups
fmap (fromMaybe $ assert `failure` group)
$ opick group (const True)
hideAs :: Kind.Ops TileKind -> Kind.Id TileKind -> Kind.Id TileKind
hideAs Kind.Ops{okind, ouniqGroup} t =
let getTo (F.HideAs group) _ = Just group
getTo _ acc = acc
in case foldr getTo Nothing (tfeature (okind t)) of
Nothing -> t
Just group -> ouniqGroup group
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
isChangeable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool
isChangeable Kind.Ops{okind} t =
let getTo F.ChangeTo{} = 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