feat(gs/xanthous): Add a Husk creature, with limited generation r/3061

Add a new "husk" creature raw, limited to only being generated on levels
>= 1, including support for actually doing that limiting.

These guys are gonna get daggers next!

Change-Id: Ic4b58dc7ee36b50ced60fec6912cd1b46269d55c
Reviewed-on: https://cl.tvl.fyi/c/depot/+/3868
Reviewed-by: grfn <grfn@gws.fyi>
Tested-by: BuildkiteCI

3 files changed, 99 insertions, 15 deletions

diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Creature.hs b/users/grfn/xanthous/src/Xanthous/Entities/Creature.hs
index f23cf25b4392..98dd4dd83331 100644
--- a/users/grfn/xanthous/src/Xanthous/Entities/Creature.hs
+++ b/users/grfn/xanthous/src/Xanthous/Entities/Creature.hs
@@ -11,6 +11,7 @@ module Xanthous.Entities.Creature
 
     -- ** Creature functions
   , newWithType
+  , newOnLevelWithType
   , damage
   , isDead
   , visionRadius
@@ -30,7 +31,6 @@ module Xanthous.Entities.Creature
 import           Xanthous.Prelude
 --------------------------------------------------------------------------------
 import           Test.QuickCheck
-import           Test.QuickCheck.Arbitrary.Generic
 import           Data.Aeson.Generic.DerivingVia
 import           Data.Aeson (ToJSON, FromJSON)
 import           Control.Monad.Random (MonadRandom)
@@ -43,20 +43,21 @@ import           Xanthous.Game.State
 import           Xanthous.Data
 import           Xanthous.Data.Entities
 import           Xanthous.Entities.Creature.Hippocampus
+import           Xanthous.Util.QuickCheck (GenericArbitrary(..))
 --------------------------------------------------------------------------------
 
 data Creature = Creature
-  { _creatureType :: !CreatureType
-  , _hitpoints    :: !Hitpoints
-  , _hippocampus  :: !Hippocampus
+  { _creatureType   :: !CreatureType
+  , _hitpoints      :: !Hitpoints
+  , _hippocampus    :: !Hippocampus
   }
   deriving stock (Eq, Show, Ord, Generic)
   deriving anyclass (NFData, CoArbitrary, Function)
   deriving Draw via DrawRawCharPriority "_creatureType" 1000 Creature
+  deriving Arbitrary via GenericArbitrary Creature
   deriving (ToJSON, FromJSON)
        via WithOptions '[ FieldLabelModifier '[Drop 1] ]
                        Creature
-instance Arbitrary Creature where arbitrary = genericArbitrary
 makeLenses ''Creature
 
 instance HasVisionRadius Creature where
@@ -75,6 +76,18 @@ instance Entity Creature where
 
 --------------------------------------------------------------------------------
 
+newOnLevelWithType
+  :: MonadRandom m
+  => Word -- ^ Level number, starting at 0
+  -> CreatureType
+  -> m (Maybe Creature)
+newOnLevelWithType levelNumber cType
+  | maybe True (canGenerate levelNumber) $ cType ^. generateParams
+  = Just <$> newWithType cType
+  | otherwise
+  = pure Nothing
+
+
 newWithType :: MonadRandom m => CreatureType -> m Creature
 newWithType _creatureType =
   let _hitpoints = _creatureType ^. maxHitpoints
diff --git a/users/grfn/xanthous/src/Xanthous/Entities/RawTypes.hs b/users/grfn/xanthous/src/Xanthous/Entities/RawTypes.hs
index b0fb5e086e26..761350b01ac0 100644
--- a/users/grfn/xanthous/src/Xanthous/Entities/RawTypes.hs
+++ b/users/grfn/xanthous/src/Xanthous/Entities/RawTypes.hs
@@ -10,6 +10,9 @@ module Xanthous.Entities.RawTypes
     -- * Creatures
   , CreatureType(..)
   , hostile
+    -- ** Generation parameters
+  , CreatureGenerateParams(..)
+  , canGenerate
     -- ** Language
   , LanguageName(..)
   , getLanguage
@@ -36,10 +39,13 @@ module Xanthous.Entities.RawTypes
   , HasEatMessage(..)
   , HasEdible(..)
   , HasFriendly(..)
+  , HasGenerateParams(..)
   , HasHitpointsHealed(..)
   , HasLanguage(..)
   , HasLongDescription(..)
   , HasMaxHitpoints(..)
+  , HasMaxLevel(..)
+  , HasMinLevel(..)
   , HasName(..)
   , HasSayVerb(..)
   , HasSpeed(..)
@@ -51,6 +57,7 @@ import Xanthous.Prelude
 import Test.QuickCheck
 import Data.Aeson.Generic.DerivingVia
 import Data.Aeson (ToJSON, FromJSON)
+import Data.Interval (Interval, lowerBound', upperBound')
 --------------------------------------------------------------------------------
 import Xanthous.Messages (Message(..))
 import Xanthous.Data (TicksPerTile, Hitpoints, Per, Grams, Cubic, Meters)
@@ -58,7 +65,7 @@ import Xanthous.Data.EntityChar
 import Xanthous.Util.QuickCheck
 import Xanthous.Generators.Speech (Language, gormlak, english)
 import Xanthous.Orphans ()
-import Data.Interval (Interval, lowerBound', upperBound')
+import Xanthous.Util (EqProp, EqEqProp(..))
 --------------------------------------------------------------------------------
 
 -- | Identifiers for languages that creatures can speak.
@@ -97,18 +104,59 @@ data Attack = Attack
                        Attack
 makeFieldsNoPrefix ''Attack
 
+data CreatureGenerateParams = CreatureGenerateParams
+  { -- | Minimum dungeon level at which to generate this creature
+    _minLevel :: !(Maybe Word)
+    -- | Maximum dungeon level at which to generate this creature
+  , _maxLevel :: !(Maybe Word)
+  }
+  deriving stock (Eq, Show, Ord, 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
+
+-- | Can a creature with these generate params be generated on this level?
+canGenerate
+  :: Word -- ^ Level number
+  -> CreatureGenerateParams
+  -> Bool
+canGenerate levelNumber gps = aboveLowerBound && belowUpperBound
+  where
+    aboveLowerBound = withinBound (>=) (gps ^. minLevel) levelNumber
+    belowUpperBound = withinBound (<=) (gps ^. maxLevel) levelNumber
+    withinBound cmp bound val = maybe True (cmp val) bound
+
+instance Semigroup CreatureGenerateParams where
+  (CreatureGenerateParams minl₁ maxl₁) <> (CreatureGenerateParams minl₂ maxl₂)
+    = CreatureGenerateParams (addWith min minl₁ minl₂) (addWith max maxl₁ maxl₂)
+    where
+      addWith _ Nothing Nothing  = Nothing
+      addWith _ Nothing (Just x)  = Just x
+      addWith _ (Just x) Nothing  = Just x
+      addWith f (Just x) (Just y) = Just (f x y)
+
+instance Monoid CreatureGenerateParams where
+  mempty = CreatureGenerateParams Nothing Nothing
+
+
 data CreatureType = CreatureType
-  { _name         :: !Text
-  , _description  :: !Text
-  , _char         :: !EntityChar
-  , _maxHitpoints :: !Hitpoints
-  , _friendly     :: !Bool
-  , _speed        :: !TicksPerTile
-  , _language     :: !(Maybe LanguageName)
+  { _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)
+    _sayVerb        :: !(Maybe Text)
   , -- | The creature's natural attacks
-    _attacks       :: !(NonNull (Vector Attack))
+    _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)
diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Raws/husk.yaml b/users/grfn/xanthous/src/Xanthous/Entities/Raws/husk.yaml
new file mode 100644
index 000000000000..c6f2784fa5c6
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Entities/Raws/husk.yaml
@@ -0,0 +1,23 @@
+Creature:
+  name: husk
+  description: an empty husk of some humanoid creature
+  longDescription: |
+    An empty husk of a humanoid creature. All semblance of sentience has long
+    left its eyes; instead it shambles about aimlessly, always hungering for the
+    warmth of life.
+  char:
+    char: h
+    style:
+      foreground: black
+  maxHitpoints: 6
+  speed: 110
+  friendly: false
+  attacks:
+  - description:
+      - swings its arms at you
+      - elbows you
+    damage: 1
+  - description: kicks you
+    damage: 2
+  generateParams:
+    minLevel: 1