{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DuplicateRecordFields #-}
--------------------------------------------------------------------------------
module Xanthous.Entities.RawTypes
(
EntityRaw(..)
, _Creature
, _Item
-- * Creatures
, CreatureType(..)
, hostile
-- ** Generation parameters
, CreatureGenerateParams(..)
, canGenerate
-- ** Language
, LanguageName(..)
, getLanguage
-- ** Attacks
, Attack(..)
-- * Items
, ItemType(..)
-- ** Item sub-types
-- *** Edible
, EdibleItem(..)
, isEdible
-- *** Wieldable
, WieldableItem(..)
, isWieldable
-- * Lens classes
, HasAttackMessage(..)
, HasAttacks(..)
, HasChance(..)
, HasChar(..)
, HasCreatureAttackMessage(..)
, HasDamage(..)
, HasDensity(..)
, HasDescription(..)
, HasEatMessage(..)
, HasEdible(..)
, HasEntityName(..)
, HasEquippedItem(..)
, HasFriendly(..)
, HasGenerateParams(..)
, HasHitpointsHealed(..)
, HasLanguage(..)
, HasLevelRange(..)
, HasLongDescription(..)
, HasMaxHitpoints(..)
, HasName(..)
, HasSayVerb(..)
, HasSpeed(..)
, HasVolume(..)
, HasWieldable(..)
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
import Test.QuickCheck
import Data.Aeson.Generic.DerivingVia
import Data.Aeson (ToJSON, FromJSON)
import Data.Interval (Interval, lowerBound', upperBound')
import qualified Data.Interval as Interval
--------------------------------------------------------------------------------
import Xanthous.Messages (Message(..))
import Xanthous.Data (TicksPerTile, Hitpoints, Per, Grams, Cubic, Meters)
import Xanthous.Data.EntityChar
import Xanthous.Util.QuickCheck
import Xanthous.Generators.Speech (Language, gormlak, english)
import Xanthous.Orphans ()
import Xanthous.Util (EqProp, EqEqProp(..))
--------------------------------------------------------------------------------
-- | Identifiers for languages that creatures can speak.
--
-- Non-verbal or non-sentient creatures have Nothing as their language
--
-- At some point, we will likely want to make languages be defined in data files
-- somewhere, and reference them that way instead.
data LanguageName = Gormlak | English
deriving stock (Show, Eq, Ord, Generic, Enum, Bounded)
deriving anyclass (NFData, CoArbitrary, Function)
deriving Arbitrary via GenericArbitrary LanguageName
deriving (ToJSON, FromJSON)
via WithOptions '[ AllNullaryToStringTag 'True ]
LanguageName
-- | Resolve a 'LanguageName' into an actual 'Language'
getLanguage :: LanguageName -> Language
getLanguage Gormlak = gormlak
getLanguage English = english
-- | Natural attacks for creature types
data Attack = Attack
{ -- | the @{{creature}}@ @{{description}}@
_description :: !Message
-- | Damage dealt
, _damage :: !Hitpoints
}
deriving stock (Show, Eq, Ord, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
deriving Arbitrary via GenericArbitrary Attack
deriving (ToJSON, FromJSON)
via WithOptions '[ FieldLabelModifier '[Drop 1]
, OmitNothingFields 'True
]
Attack
makeFieldsNoPrefix ''Attack
-- | Description for generating an item equipped to a creature
data CreatureEquippedItem = CreatureEquippedItem
{ -- | Name of the entity type to generate
_entityName :: !Text
-- | Chance of generating the item when generating the creature
--
-- A chance of 1.0 will always generate the item
, _chance :: !Double
}
deriving stock (Show, Eq, Ord, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
deriving Arbitrary via GenericArbitrary CreatureEquippedItem
deriving (ToJSON, FromJSON)
via WithOptions '[ FieldLabelModifier '[Drop 1]
, OmitNothingFields 'True
]
CreatureEquippedItem
makeFieldsNoPrefix ''CreatureEquippedItem
data CreatureGenerateParams = CreatureGenerateParams
{ -- | Range of dungeon levels at which to generate this creature
_levelRange :: !(Interval Word)
-- | Item equipped to the creature
, _equippedItem :: !(Maybe CreatureEquippedItem)
}
deriving stock (Eq, Show, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
deriving Arbitrary via GenericArbitrary CreatureGenerateParams
deriving EqProp via EqEqProp CreatureGenerateParams
deriving (ToJSON, FromJSON)
via WithOptions '[ FieldLabelModifier '[Drop 1] ]
CreatureGenerateParams
makeFieldsNoPrefix ''CreatureGenerateParams
instance Ord CreatureGenerateParams where
compare
= (compare `on` lowerBound' . _levelRange)
<> (compare `on` upperBound' . _levelRange)
<> (compare `on` _equippedItem)
-- | Can a creature with these generate params be generated on this level?
canGenerate
:: Word -- ^ Level number
-> CreatureGenerateParams
-> Bool
canGenerate levelNumber gps = Interval.member levelNumber $ gps ^. levelRange
data CreatureType = CreatureType
{ _name :: !Text
, _description :: !Text
, _char :: !EntityChar
, _maxHitpoints :: !Hitpoints
, _friendly :: !Bool
, _speed :: !TicksPerTile
, _language :: !(Maybe LanguageName)
, -- | The verb, in present tense, for when the creature says something
_sayVerb :: !(Maybe Text)
, -- | The creature's natural attacks
_attacks :: !(NonNull (Vector Attack))
-- | Parameters for generating the creature in levels
, _generateParams :: !(Maybe CreatureGenerateParams)
}
deriving stock (Show, Eq, Ord, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
deriving Arbitrary via GenericArbitrary CreatureType
deriving (ToJSON, FromJSON)
via WithOptions '[ FieldLabelModifier '[Drop 1]
, OmitNothingFields 'True
]
CreatureType
makeFieldsNoPrefix ''CreatureType
hostile :: Lens' CreatureType Bool
hostile = friendly . involuted not
--------------------------------------------------------------------------------
data EdibleItem = EdibleItem
{ _hitpointsHealed :: !Int
, _eatMessage :: !(Maybe Message)
}
deriving stock (Show, Eq, Ord, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
deriving Arbitrary via GenericArbitrary EdibleItem
deriving (ToJSON, FromJSON)
via WithOptions '[ FieldLabelModifier '[Drop 1] ]
EdibleItem
makeFieldsNoPrefix ''EdibleItem
data WieldableItem = WieldableItem
{ _damage :: !Hitpoints
-- | Message to use when the character is using this item to attack a
-- creature.
--
-- Grammatically, this should be of the form "slash at the
-- {{creature.creatureType.name}} with your dagger"
--
-- = Parameters
--
-- [@creature@ (type: 'Creature')] The creature being attacked
, _attackMessage :: !(Maybe Message)
-- | Message to use when a creature is using this item to attack the
-- character.
--
-- Grammatically, should be of the form "The creature slashes you with its
-- dagger".
--
-- = Parameters
--
-- [@creature@ (type: 'Creature')] The creature doing the attacking
-- [@item@ (type: 'Item')] The item itself
, _creatureAttackMessage :: !(Maybe Message)
}
deriving stock (Show, Eq, Ord, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
deriving Arbitrary via GenericArbitrary WieldableItem
deriving (ToJSON, FromJSON)
via WithOptions '[ FieldLabelModifier '[Drop 1] ]
WieldableItem
makeFieldsNoPrefix ''WieldableItem
--------------------------------------------------------------------------------
data ItemType = ItemType
{ _name :: !Text
, _description :: !Text
, _longDescription :: !Text
, _char :: !EntityChar
, _density :: !(Interval (Grams `Per` Cubic Meters))
, _volume :: !(Interval (Cubic Meters))
, _edible :: !(Maybe EdibleItem)
, _wieldable :: !(Maybe WieldableItem)
}
deriving stock (Show, Eq, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
deriving Arbitrary via GenericArbitrary ItemType
deriving (ToJSON, FromJSON)
via WithOptions '[ FieldLabelModifier '[Drop 1] ]
ItemType
makeFieldsNoPrefix ''ItemType
instance Ord ItemType where
compare x y
= compareOf name x y
<> compareOf description x y
<> compareOf longDescription x y
<> compareOf char x y
<> compareOf (density . to extractInterval) x y
<> compareOf (volume . to extractInterval) x y
<> compareOf edible x y
<> compareOf wieldable x y
where
compareOf l = comparing (view l)
extractInterval = lowerBound' &&& upperBound'
-- | Can this item be eaten?
isEdible :: ItemType -> Bool
isEdible = has $ edible . _Just
-- | Can this item be used as a weapon?
isWieldable :: ItemType -> Bool
isWieldable = has $ wieldable . _Just
--------------------------------------------------------------------------------
data EntityRaw
= Creature !CreatureType
| Item !ItemType
deriving stock (Show, Eq, Generic)
deriving anyclass (NFData)
deriving Arbitrary via GenericArbitrary EntityRaw
deriving (FromJSON)
via WithOptions '[ SumEnc ObjWithSingleField ]
EntityRaw
makePrisms ''EntityRaw
