1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
|
{-# 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
|