{-# LANGUAGE DeriveGeneric #-}
module Game.LambdaHack.Content.TileKind
( TileKind(..), Feature(..)
, makeData
, isUknownSpace, unknownId
, isSuspectKind, isOpenableKind, isClosableKind
, talterForStairs, floorSymbol
#ifdef EXPOSE_INTERNAL
, validateSingle, validateAll
, validateDups, hardwiredTileGroups
#endif
) where
import Prelude ()
import Game.LambdaHack.Core.Prelude
import Control.DeepSeq
import Data.Binary
import qualified Data.Char as Char
import Data.Hashable
import GHC.Generics (Generic)
import Game.LambdaHack.Content.ItemKind (ItemKind)
import Game.LambdaHack.Definition.Color
import Game.LambdaHack.Definition.ContentData
import Game.LambdaHack.Definition.Defs
data TileKind = TileKind
{ tsymbol :: Char
, tname :: Text
, tfreq :: Freqs TileKind
, tcolor :: Color
, tcolor2 :: Color
, talter :: Word8
, tfeature :: [Feature]
}
deriving Show
data Feature =
Embed (GroupName ItemKind)
| OpenTo (GroupName TileKind)
| CloseTo (GroupName TileKind)
| ChangeTo (GroupName TileKind)
| HideAs (GroupName TileKind)
| BuildAs (GroupName TileKind)
| RevealAs (GroupName TileKind)
| ObscureAs (GroupName TileKind)
| Walkable
| Clear
| Dark
| OftenItem
| VeryOftenItem
| OftenActor
| NoItem
| NoActor
| ConsideredByAI
| Trail
| Spice
deriving (Show, Eq, Ord, Generic)
instance Binary Feature
instance Hashable Feature
instance NFData Feature
validateSingle :: TileKind -> [Text]
validateSingle t@TileKind{..} =
[ "suspect tile is walkable" | Walkable `elem` tfeature
&& isSuspectKind t ]
++ [ "openable tile is open" | Walkable `elem` tfeature
&& isOpenableKind t ]
++ [ "closable tile is closed" | Walkable `notElem` tfeature
&& isClosableKind t ]
++ [ "walkable tile is considered for triggering by AI"
| Walkable `elem` tfeature
&& ConsideredByAI `elem` tfeature ]
++ [ "trail tile not walkable" | Walkable `notElem` tfeature
&& Trail `elem` tfeature ]
++ [ "OftenItem and NoItem on a tile" | OftenItem `elem` tfeature
&& NoItem `elem` tfeature ]
++ [ "OftenActor and NoActor on a tile" | OftenItem `elem` tfeature
&& NoItem `elem` tfeature ]
++ (let f :: Feature -> Bool
f OpenTo{} = True
f CloseTo{} = True
f ChangeTo{} = True
f _ = False
ts = filter f tfeature
in [ "more than one OpenTo, CloseTo and ChangeTo specification"
| length ts > 1 ])
++ (let f :: Feature -> Bool
f HideAs{} = True
f _ = False
ts = filter f tfeature
in ["more than one HideAs specification" | length ts > 1])
++ (let f :: Feature -> Bool
f BuildAs{} = True
f _ = False
ts = filter f tfeature
in ["more than one BuildAs specification" | length ts > 1])
++ concatMap (validateDups t)
[ Walkable, Clear, Dark, OftenItem, OftenActor, NoItem, NoActor
, ConsideredByAI, Trail, Spice ]
validateDups :: TileKind -> Feature -> [Text]
validateDups TileKind{..} feat =
let ts = filter (== feat) tfeature
in ["more than one" <+> tshow feat <+> "specification" | length ts > 1]
validateAll :: ContentData ItemKind -> [TileKind] -> ContentData TileKind
-> [Text]
validateAll coitem content cotile =
let g :: Feature -> Maybe (GroupName TileKind)
g (OpenTo grp) = Just grp
g (CloseTo grp) = Just grp
g (ChangeTo grp) = Just grp
g (HideAs grp) = Just grp
g (BuildAs grp) = Just grp
g (RevealAs grp) = Just grp
g (ObscureAs grp) = Just grp
g _ = Nothing
missingTileGroups =
[ (tname k, absGroups)
| k <- content
, let grps = mapMaybe g $ tfeature k
absGroups = filter (not . omemberGroup cotile) grps
, not $ null absGroups
]
h :: Feature -> Maybe (GroupName ItemKind)
h (Embed grp) = Just grp
h _ = Nothing
missingItemGroups =
[ (tname k, absGroups)
| k <- content
, let grps = mapMaybe h $ tfeature k
absGroups = filter (not . omemberGroup coitem) grps
, not $ null absGroups
]
missingHardwiredGroups =
filter (not . omemberGroup cotile) hardwiredTileGroups
in [ "unknown tile (the first) should be the unknown one"
| talter (head content) /= 1 || tname (head content) /= "unknown space" ]
++ [ "no tile other than the unknown (the first) should require skill 1"
| all (\tk -> talter tk == 1) (tail content) ]
++ [ "only unknown tile may have talter 1"
| any ((== 1) . talter) $ tail content ]
++ [ "mentioned tile groups not in content:" <+> tshow missingTileGroups
| not $ null missingTileGroups ]
++ [ "embedded item groups not in content:" <+> tshow missingItemGroups
| not $ null missingItemGroups ]
++ [ "hardwired groups not in content:" <+> tshow missingHardwiredGroups
| not $ null missingHardwiredGroups ]
hardwiredTileGroups :: [GroupName TileKind]
hardwiredTileGroups =
[ "unknown space", "legendLit", "legendDark", "unknown outer fence"
, "basic outer fence" ]
isUknownSpace :: ContentId TileKind -> Bool
{-# INLINE isUknownSpace #-}
isUknownSpace tt = toContentId 0 == tt
unknownId :: ContentId TileKind
{-# INLINE unknownId #-}
unknownId = toContentId 0
isSuspectKind :: TileKind -> Bool
isSuspectKind t =
let getTo RevealAs{} = True
getTo ObscureAs{} = True
getTo _ = False
in any getTo $ tfeature t
isOpenableKind :: TileKind -> Bool
isOpenableKind t =
let getTo OpenTo{} = True
getTo _ = False
in any getTo $ tfeature t
isClosableKind :: TileKind -> Bool
isClosableKind t =
let getTo CloseTo{} = True
getTo _ = False
in any getTo $ tfeature t
talterForStairs :: Word8
talterForStairs = 3
floorSymbol :: Char.Char
floorSymbol = Char.chr 183
makeData :: ContentData ItemKind -> [TileKind] -> ContentData TileKind
makeData coitem =
makeContentData "TileKind" tname tfreq validateSingle (validateAll coitem)