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

9 files changed, 152 insertions, 24 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
diff --git a/users/grfn/xanthous/src/Xanthous/Generators/Level.hs b/users/grfn/xanthous/src/Xanthous/Generators/Level.hs
index ac97159f422c..fc57402e7d8e 100644
--- a/users/grfn/xanthous/src/Xanthous/Generators/Level.hs
+++ b/users/grfn/xanthous/src/Xanthous/Generators/Level.hs
@@ -141,7 +141,7 @@ generateLevel gen ps dims num = do
   village <- generateVillage cells gen
   let _levelExtra = village
   _levelItems <- randomItems cells
-  _levelCreatures <- randomCreatures cells
+  _levelCreatures <- randomCreatures num cells
   _levelDoors <- randomDoors cells
   _levelCharacterPosition <- chooseCharacterPosition cells
   let upStaircase = _EntityMap # [(_levelCharacterPosition, UpStaircase)]
diff --git a/users/grfn/xanthous/src/Xanthous/Generators/Level/LevelContents.hs b/users/grfn/xanthous/src/Xanthous/Generators/Level/LevelContents.hs
index 3cad569336e1..fcca118743e9 100644
--- a/users/grfn/xanthous/src/Xanthous/Generators/Level/LevelContents.hs
+++ b/users/grfn/xanthous/src/Xanthous/Generators/Level/LevelContents.hs
@@ -39,7 +39,7 @@ chooseCharacterPosition :: MonadRandom m => Cells -> m Position
 chooseCharacterPosition = randomPosition
 
 randomItems :: MonadRandom m => Cells -> m (EntityMap Item)
-randomItems = randomEntities Item.newWithType (0.0004, 0.001)
+randomItems = randomEntities (fmap Identity . Item.newWithType) (0.0004, 0.001)
 
 placeDownStaircase :: MonadRandom m => Cells -> m (EntityMap Staircase)
 placeDownStaircase cells = do
@@ -76,8 +76,13 @@ randomDoors cells = do
     teeish (fmap not -> (Neighbors tl t tr l r _ b _ )) =
       and [tl, t, tr, b] && (and . fmap not) [l, r]
 
-randomCreatures :: MonadRandom m => Cells -> m (EntityMap Creature)
-randomCreatures = randomEntities Creature.newWithType (0.0007, 0.002)
+randomCreatures
+  :: MonadRandom m
+  => Word -- ^ Level number, starting at 0
+  -> Cells
+  -> m (EntityMap Creature)
+randomCreatures levelNumber
+  = randomEntities (Creature.newOnLevelWithType levelNumber) (0.0007, 0.002)
 
 tutorialMessage :: MonadRandom m
   => Cells
@@ -99,8 +104,8 @@ tutorialMessage cells characterPosition = do
             (circle (pos ^. _Position) dist)
 
 randomEntities
-  :: forall entity raw m. (MonadRandom m, RawType raw)
-  => (raw -> m entity)
+  :: forall entity raw m t. (MonadRandom m, RawType raw, Functor t, Foldable t)
+  => (raw -> m (t entity))
   -> (Float, Float)
   -> Cells
   -> m (EntityMap entity)
@@ -114,9 +119,9 @@ randomEntities newWithType sizeRange cells =
       entities <- for [0..numEntities] $ const $ do
         pos <- randomPosition cells
         raw <- choose raws
-        entity <- newWithType raw
-        pure (pos, entity)
-      pure $ _EntityMap # entities
+        entities <- newWithType raw
+        pure $ (pos, ) <$> entities
+      pure $ _EntityMap # (entities >>= toList)
 
 randomPosition :: MonadRandom m => Cells -> m Position
 randomPosition = fmap positionFromV2 . choose . impureNonNull . cellCandidates
diff --git a/users/grfn/xanthous/src/Xanthous/Util.hs b/users/grfn/xanthous/src/Xanthous/Util.hs
index 2f9606b29c50..6678cffe6a17 100644
--- a/users/grfn/xanthous/src/Xanthous/Util.hs
+++ b/users/grfn/xanthous/src/Xanthous/Util.hs
@@ -80,6 +80,14 @@ foldlMapM' f xs = foldr f' pure xs mempty
     let !b = mappend bl br
     k b
 
+-- | Returns whether the third argument is in the range given by the first two
+-- arguments, inclusive
+--
+-- >>> between (0 :: Int) 2 2
+-- True
+--
+-- >>> between (0 :: Int) 2 3
+-- False
 between
   :: Ord a
   => a -- ^ lower bound
diff --git a/users/grfn/xanthous/test/Spec.hs b/users/grfn/xanthous/test/Spec.hs
index c8b0ef0079f7..80826053866a 100644
--- a/users/grfn/xanthous/test/Spec.hs
+++ b/users/grfn/xanthous/test/Spec.hs
@@ -10,6 +10,7 @@ import qualified Xanthous.Data.MemoSpec
 import qualified Xanthous.Data.NestedMapSpec
 import qualified Xanthous.DataSpec
 import qualified Xanthous.Entities.RawsSpec
+import qualified Xanthous.Entities.RawTypesSpec
 import qualified Xanthous.Entities.CharacterSpec
 import qualified Xanthous.GameSpec
 import qualified Xanthous.Game.StateSpec
@@ -39,6 +40,7 @@ test = testGroup "Xanthous"
   , Xanthous.DataSpec.test
   , Xanthous.Entities.RawsSpec.test
   , Xanthous.Entities.CharacterSpec.test
+  , Xanthous.Entities.RawTypesSpec.test
   , Xanthous.GameSpec.test
   , Xanthous.Game.StateSpec.test
   , Xanthous.Game.PromptSpec.test
diff --git a/users/grfn/xanthous/test/Xanthous/Entities/RawTypesSpec.hs b/users/grfn/xanthous/test/Xanthous/Entities/RawTypesSpec.hs
new file mode 100644
index 000000000000..f5feb8a506db
--- /dev/null
+++ b/users/grfn/xanthous/test/Xanthous/Entities/RawTypesSpec.hs
@@ -0,0 +1,28 @@
+--------------------------------------------------------------------------------
+module Xanthous.Entities.RawTypesSpec (main, test) where
+--------------------------------------------------------------------------------
+import           Test.Prelude
+--------------------------------------------------------------------------------
+import           Xanthous.Entities.RawTypes
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = defaultMain test
+
+test :: TestTree
+test = testGroup "Xanthous.Entities.RawTypesSpec"
+  [ testGroup "CreatureGenerateParams"
+    [ testBatch $ monoid @CreatureGenerateParams mempty
+    , testGroup "canGenerate"
+      [ testProperty "no bounds" $ \level ->
+          let gps = CreatureGenerateParams Nothing Nothing
+          in canGenerate level gps
+      , testProperty "min bound" $ \level minB ->
+          let gps = CreatureGenerateParams (Just minB) Nothing
+          in canGenerate level gps === (level >= minB)
+      , testProperty "max bound" $ \level maxB ->
+          let gps = CreatureGenerateParams Nothing (Just maxB)
+          in canGenerate level gps === (level <= maxB)
+      ]
+    ]
+  ]
diff --git a/users/grfn/xanthous/xanthous.cabal b/users/grfn/xanthous/xanthous.cabal
index 9cf6636d7a74..e23f3968ee44 100644
--- a/users/grfn/xanthous/xanthous.cabal
+++ b/users/grfn/xanthous/xanthous.cabal
@@ -302,6 +302,7 @@ test-suite test
       Xanthous.DataSpec
       Xanthous.Entities.CharacterSpec
       Xanthous.Entities.RawsSpec
+      Xanthous.Entities.RawTypesSpec
       Xanthous.Game.PromptSpec
       Xanthous.Game.StateSpec
       Xanthous.GameSpec