From 1af67d9ca76e49198b8b8137e9fd24dfa4812203 Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Sat, 13 Nov 2021 10:44:05 -0500 Subject: feat(gs/xanthous): Add a Husk creature, with limited generation 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 Tested-by: BuildkiteCI --- .../xanthous/src/Xanthous/Entities/Creature.hs | 23 ++++++-- .../xanthous/src/Xanthous/Entities/RawTypes.hs | 68 ++++++++++++++++++---- .../xanthous/src/Xanthous/Entities/Raws/husk.yaml | 23 ++++++++ .../grfn/xanthous/src/Xanthous/Generators/Level.hs | 2 +- .../src/Xanthous/Generators/Level/LevelContents.hs | 21 ++++--- users/grfn/xanthous/src/Xanthous/Util.hs | 8 +++ users/grfn/xanthous/test/Spec.hs | 2 + .../test/Xanthous/Entities/RawTypesSpec.hs | 28 +++++++++ users/grfn/xanthous/xanthous.cabal | 1 + 9 files changed, 152 insertions(+), 24 deletions(-) create mode 100644 users/grfn/xanthous/src/Xanthous/Entities/Raws/husk.yaml create mode 100644 users/grfn/xanthous/test/Xanthous/Entities/RawTypesSpec.hs (limited to 'users/grfn') diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Creature.hs b/users/grfn/xanthous/src/Xanthous/Entities/Creature.hs index f23cf25b43..98dd4dd833 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 b0fb5e086e..761350b01a 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 0000000000..c6f2784fa5 --- /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 ac97159f42..fc57402e7d 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 3cad569336..fcca118743 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 2f9606b29c..6678cffe6a 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 c8b0ef0079..8082605386 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 0000000000..f5feb8a506 --- /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 9cf6636d7a..e23f3968ee 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 -- cgit 1.4.1