diff options
Diffstat (limited to 'users/grfn/xanthous/src')
6 files changed, 121 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 |