diff options
Diffstat (limited to 'users')
11 files changed, 163 insertions, 96 deletions
diff --git a/users/grfn/xanthous/src/Xanthous/App/Prompt.hs b/users/grfn/xanthous/src/Xanthous/App/Prompt.hs index 0397e590e760..799281a1c2fd 100644 --- a/users/grfn/xanthous/src/Xanthous/App/Prompt.hs +++ b/users/grfn/xanthous/src/Xanthous/App/Prompt.hs @@ -30,7 +30,7 @@ import Xanthous.Game.Prompt import Xanthous.Game.State import qualified Xanthous.Messages as Messages import qualified Xanthous.Data.EntityMap as EntityMap -import Xanthous.Entities.Creature (creatureType) +import Xanthous.Entities.Creature (creatureType, Creature) import Xanthous.Entities.RawTypes (hostile) import qualified Linear.Metric as Metric -------------------------------------------------------------------------------- @@ -218,7 +218,7 @@ nearestEnemyPosition = do ^.. folded . _2 . positioned - . _SomeEntity + . _SomeEntity @Creature . creatureType . filtered (view hostile) . to (const (distance charPos p, p)) diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Character.hs b/users/grfn/xanthous/src/Xanthous/Entities/Character.hs index b86e9e17d3f9..d405cb40d3eb 100644 --- a/users/grfn/xanthous/src/Xanthous/Entities/Character.hs +++ b/users/grfn/xanthous/src/Xanthous/Entities/Character.hs @@ -6,7 +6,7 @@ module Xanthous.Entities.Character ( -- * Character datatype Character(..) , characterName - , inventory + , HasInventory(..) , characterDamage , characterHitpoints' , characterHitpoints @@ -163,7 +163,7 @@ data Character = Character deriving (ToJSON, FromJSON) via WithOptions '[ FieldLabelModifier '[Drop 1] ] Character -makeLenses ''Character +makeFieldsNoPrefix ''Character characterHitpoints :: Character -> Hitpoints characterHitpoints = views characterHitpoints' floor diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Common.hs b/users/grfn/xanthous/src/Xanthous/Entities/Common.hs index 1444f3ce1639..becd1b1ef62e 100644 --- a/users/grfn/xanthous/src/Xanthous/Entities/Common.hs +++ b/users/grfn/xanthous/src/Xanthous/Entities/Common.hs @@ -8,6 +8,7 @@ module Xanthous.Entities.Common ( -- * Inventory Inventory(..) + , HasInventory(..) , backpack , wielded , items @@ -191,6 +192,10 @@ instance Semigroup Inventory where instance Monoid Inventory where mempty = Inventory mempty $ Hands Nothing Nothing +class HasInventory s a | s -> a where + inventory :: Lens' s a + {-# MINIMAL inventory #-} + -- | Representation for where in the inventory an item might be data InventoryPosition = Backpack @@ -224,7 +229,7 @@ itemsWithPosition :: Fold Inventory (InventoryPosition, Item) itemsWithPosition = folding $ (<>) <$> backpackItems <*> handItems where backpackItems = toListOf $ backpack . folded . to (Backpack ,) - handItems inventory = case inventory ^. wielded of + handItems inv = case inv ^. wielded of DoubleHanded i -> pure (BothHands, i ^. wieldedItem) Hands l r -> (l ^.. folded . wieldedItem . to (LeftHand ,)) <> (r ^.. folded . wieldedItem . to (RightHand ,)) diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Creature.hs b/users/grfn/xanthous/src/Xanthous/Entities/Creature.hs index 98dd4dd83331..3af2cafe3349 100644 --- a/users/grfn/xanthous/src/Xanthous/Entities/Creature.hs +++ b/users/grfn/xanthous/src/Xanthous/Entities/Creature.hs @@ -8,10 +8,9 @@ module Xanthous.Entities.Creature , creatureType , hitpoints , hippocampus + , inventory -- ** Creature functions - , newWithType - , newOnLevelWithType , damage , isDead , visionRadius @@ -33,7 +32,6 @@ import Xanthous.Prelude import Test.QuickCheck import Data.Aeson.Generic.DerivingVia import Data.Aeson (ToJSON, FromJSON) -import Control.Monad.Random (MonadRandom) -------------------------------------------------------------------------------- import Xanthous.AI.Gormlak import Xanthous.Entities.RawTypes hiding @@ -44,12 +42,14 @@ import Xanthous.Data import Xanthous.Data.Entities import Xanthous.Entities.Creature.Hippocampus import Xanthous.Util.QuickCheck (GenericArbitrary(..)) +import Xanthous.Entities.Common (Inventory) -------------------------------------------------------------------------------- data Creature = Creature { _creatureType :: !CreatureType , _hitpoints :: !Hitpoints , _hippocampus :: !Hippocampus + , _inventory :: !Inventory } deriving stock (Eq, Show, Ord, Generic) deriving anyclass (NFData, CoArbitrary, Function) @@ -58,7 +58,7 @@ data Creature = Creature deriving (ToJSON, FromJSON) via WithOptions '[ FieldLabelModifier '[Drop 1] ] Creature -makeLenses ''Creature +makeFieldsNoPrefix ''Creature instance HasVisionRadius Creature where visionRadius = const 50 -- TODO @@ -76,24 +76,6 @@ 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 - _hippocampus = initialHippocampus - in pure Creature {..} - damage :: Hitpoints -> Creature -> Creature damage amount = hitpoints %~ \hp -> if hp <= amount diff --git a/users/grfn/xanthous/src/Xanthous/Entities/RawTypes.hs b/users/grfn/xanthous/src/Xanthous/Entities/RawTypes.hs index 761350b01ac0..8453a0533610 100644 --- a/users/grfn/xanthous/src/Xanthous/Entities/RawTypes.hs +++ b/users/grfn/xanthous/src/Xanthous/Entities/RawTypes.hs @@ -30,22 +30,24 @@ module Xanthous.Entities.RawTypes , isWieldable -- * Lens classes - , HasAttacks(..) , HasAttackMessage(..) + , HasAttacks(..) + , HasChance(..) , HasChar(..) , HasDamage(..) , HasDensity(..) , HasDescription(..) , HasEatMessage(..) , HasEdible(..) + , HasEntityName(..) + , HasEquippedItem(..) , HasFriendly(..) , HasGenerateParams(..) , HasHitpointsHealed(..) , HasLanguage(..) + , HasLevelRange(..) , HasLongDescription(..) , HasMaxHitpoints(..) - , HasMaxLevel(..) - , HasMinLevel(..) , HasName(..) , HasSayVerb(..) , HasSpeed(..) @@ -53,19 +55,20 @@ module Xanthous.Entities.RawTypes , 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 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(..)) +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. @@ -104,13 +107,33 @@ data Attack = Attack 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 - { -- | Minimum dungeon level at which to generate this creature - _minLevel :: !(Maybe Word) - -- | Maximum dungeon level at which to generate this creature - , _maxLevel :: !(Maybe Word) + { -- | 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, Ord, Generic) + deriving stock (Eq, Show, Generic) deriving anyclass (NFData, CoArbitrary, Function) deriving Arbitrary via GenericArbitrary CreatureGenerateParams deriving EqProp via EqEqProp CreatureGenerateParams @@ -119,29 +142,18 @@ data CreatureGenerateParams = CreatureGenerateParams 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 = 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 - +canGenerate levelNumber gps = Interval.member levelNumber $ gps ^. levelRange data CreatureType = CreatureType { _name :: !Text diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Raws.hs b/users/grfn/xanthous/src/Xanthous/Entities/Raws.hs index 441e870160a5..10f0d831934e 100644 --- a/users/grfn/xanthous/src/Xanthous/Entities/Raws.hs +++ b/users/grfn/xanthous/src/Xanthous/Entities/Raws.hs @@ -5,19 +5,14 @@ module Xanthous.Entities.Raws , raw , RawType(..) , rawsWithType - , entityFromRaw ) where -------------------------------------------------------------------------------- import Data.FileEmbed import qualified Data.Yaml as Yaml import Xanthous.Prelude import System.FilePath.Posix -import Control.Monad.Random (MonadRandom) -------------------------------------------------------------------------------- import Xanthous.Entities.RawTypes -import Xanthous.Game.State -import qualified Xanthous.Entities.Creature as Creature -import qualified Xanthous.Entities.Item as Item import Xanthous.AI.Gormlak () -------------------------------------------------------------------------------- rawRaws :: [(FilePath, ByteString)] @@ -52,9 +47,3 @@ rawsWithType :: forall a. RawType a => HashMap Text a rawsWithType = mapFromList . itoListOf (ifolded . _RawType) $ raws -------------------------------------------------------------------------------- - -entityFromRaw :: MonadRandom m => EntityRaw -> m SomeEntity -entityFromRaw (Creature creatureType) - = SomeEntity <$> Creature.newWithType creatureType -entityFromRaw (Item itemType) - = SomeEntity <$> Item.newWithType itemType diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Raws/husk.yaml b/users/grfn/xanthous/src/Xanthous/Entities/Raws/husk.yaml index c6f2784fa5c6..cdfcde616d21 100644 --- a/users/grfn/xanthous/src/Xanthous/Entities/Raws/husk.yaml +++ b/users/grfn/xanthous/src/Xanthous/Entities/Raws/husk.yaml @@ -20,4 +20,7 @@ Creature: - description: kicks you damage: 2 generateParams: - minLevel: 1 + levelRange: [1, PosInf] + equippedItem: + entityName: broken-dagger + chance: 0.9 diff --git a/users/grfn/xanthous/src/Xanthous/Generators/Level/LevelContents.hs b/users/grfn/xanthous/src/Xanthous/Generators/Level/LevelContents.hs index fcca118743e9..4f8a2f42ee16 100644 --- a/users/grfn/xanthous/src/Xanthous/Generators/Level/LevelContents.hs +++ b/users/grfn/xanthous/src/Xanthous/Generators/Level/LevelContents.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE RecordWildCards #-} -------------------------------------------------------------------------------- module Xanthous.Generators.Level.LevelContents ( chooseCharacterPosition @@ -6,6 +7,7 @@ module Xanthous.Generators.Level.LevelContents , randomDoors , placeDownStaircase , tutorialMessage + , entityFromRaw ) where -------------------------------------------------------------------------------- import Xanthous.Prelude hiding (any, toList) @@ -17,14 +19,15 @@ import Data.Foldable (any, toList) import Linear.V2 -------------------------------------------------------------------------------- import Xanthous.Generators.Level.Util -import Xanthous.Random +import Xanthous.Random hiding (chance) +import qualified Xanthous.Random as Random import Xanthous.Data ( positionFromV2, Position, _Position , rotations, arrayNeighbors, Neighbors(..) , neighborPositions ) import Xanthous.Data.EntityMap (EntityMap, _EntityMap) -import Xanthous.Entities.Raws (rawsWithType, RawType) +import Xanthous.Entities.Raws (rawsWithType, RawType, raw) import qualified Xanthous.Entities.Item as Item import Xanthous.Entities.Item (Item) import qualified Xanthous.Entities.Creature as Creature @@ -33,6 +36,10 @@ import Xanthous.Entities.Environment (GroundMessage(..), Door(..), unlockedDoor, Staircase(..)) import Xanthous.Messages (message_) import Xanthous.Util.Graphics (circle) +import Xanthous.Entities.RawTypes +import Xanthous.Entities.Creature.Hippocampus (initialHippocampus) +import Xanthous.Entities.Common (inRightHand, asWieldedItem, wielded) +import Xanthous.Game.State (SomeEntity(SomeEntity)) -------------------------------------------------------------------------------- chooseCharacterPosition :: MonadRandom m => Cells -> m Position @@ -82,7 +89,40 @@ randomCreatures -> Cells -> m (EntityMap Creature) randomCreatures levelNumber - = randomEntities (Creature.newOnLevelWithType levelNumber) (0.0007, 0.002) + = randomEntities maybeNewCreature (0.0007, 0.002) + where + maybeNewCreature cType + | maybe True (canGenerate levelNumber) $ cType ^. generateParams + = Just <$> newCreatureWithType cType + | otherwise + = pure Nothing + +newCreatureWithType :: MonadRandom m => CreatureType -> m Creature +newCreatureWithType _creatureType = do + let _hitpoints = _creatureType ^. maxHitpoints + _hippocampus = initialHippocampus + + equipped <- fmap join + . traverse genEquipped + $ _creatureType + ^.. generateParams . _Just . equippedItem . _Just + let _inventory = maybe id (\ei -> wielded .~ inRightHand ei) (headMay equipped) mempty + pure Creature.Creature {..} + where + genEquipped cei = do + doGen <- Random.chance $ cei ^. chance + let entName = cei ^. entityName + itemType = + fromMaybe (error $ "raw \"" <> unpack entName <> "\" not of type Item") + . preview _Item + . fromMaybe (error $ "Could not find raw: " <> unpack entName) + $ raw entName + item <- Item.newWithType itemType + if doGen + then pure [fromMaybe (error $ "raw \"" <> unpack entName <> "\" not wieldable") + $ preview asWieldedItem item] + else pure [] + tutorialMessage :: MonadRandom m => Cells @@ -118,8 +158,8 @@ randomEntities newWithType sizeRange cells = floor . (* fromIntegral len) <$> getRandomR sizeRange entities <- for [0..numEntities] $ const $ do pos <- randomPosition cells - raw <- choose raws - entities <- newWithType raw + r <- choose raws + entities <- newWithType r pure $ (pos, ) <$> entities pure $ _EntityMap # (entities >>= toList) @@ -136,3 +176,7 @@ cellCandidates . regions -- cells ends up with true = wall, we want true = can put an item here . amap not + +entityFromRaw :: MonadRandom m => EntityRaw -> m SomeEntity +entityFromRaw (Creature ct) = SomeEntity <$> newCreatureWithType ct +entityFromRaw (Item it) = SomeEntity <$> Item.newWithType it diff --git a/users/grfn/xanthous/test/Xanthous/Entities/RawTypesSpec.hs b/users/grfn/xanthous/test/Xanthous/Entities/RawTypesSpec.hs index f5feb8a506db..e23f7faba3a6 100644 --- a/users/grfn/xanthous/test/Xanthous/Entities/RawTypesSpec.hs +++ b/users/grfn/xanthous/test/Xanthous/Entities/RawTypesSpec.hs @@ -1,8 +1,11 @@ +{-# LANGUAGE RecordWildCards #-} -------------------------------------------------------------------------------- module Xanthous.Entities.RawTypesSpec (main, test) where -------------------------------------------------------------------------------- import Test.Prelude -------------------------------------------------------------------------------- +import Data.Interval (Extended(..), (<=..<=)) +-------------------------------------------------------------------------------- import Xanthous.Entities.RawTypes -------------------------------------------------------------------------------- @@ -12,17 +15,31 @@ 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) + [ testGroup "Ord laws" + [ testProperty "comparability" $ \(a :: CreatureGenerateParams) b -> + a <= b || b <= a + , testProperty "transitivity" $ \(a :: CreatureGenerateParams) b c -> + a <= b && b <= c ==> a <= c + , testProperty "reflexivity" $ \(a :: CreatureGenerateParams) -> + a <= a + , testProperty "antisymmetry" $ \(a :: CreatureGenerateParams) b -> + (a <= b && b <= a) == (a == b) ] + , testGroup "canGenerate" $ + let makeParams minB maxB = + let _levelRange = maybe NegInf Finite minB <=..<= maybe PosInf Finite maxB + _equippedItem = Nothing + in CreatureGenerateParams {..} + in + [ testProperty "no bounds" $ \level -> + let gps = makeParams Nothing Nothing + in canGenerate level gps + , testProperty "min bound" $ \level minB -> + let gps = makeParams (Just minB) Nothing + in canGenerate level gps === (level >= minB) + , testProperty "max bound" $ \level maxB -> + let gps = makeParams Nothing (Just maxB) + in canGenerate level gps === (level <= maxB) + ] ] ] diff --git a/users/grfn/xanthous/test/Xanthous/Entities/RawsSpec.hs b/users/grfn/xanthous/test/Xanthous/Entities/RawsSpec.hs index 2e6f35457fc7..b6c80be51be7 100644 --- a/users/grfn/xanthous/test/Xanthous/Entities/RawsSpec.hs +++ b/users/grfn/xanthous/test/Xanthous/Entities/RawsSpec.hs @@ -4,6 +4,8 @@ module Xanthous.Entities.RawsSpec (main, test) where import Test.Prelude import Xanthous.Entities.Raws +import Xanthous.Entities.RawTypes + (_Creature, entityName, generateParams, HasEquippedItem (equippedItem)) main :: IO () main = defaultMain test @@ -12,5 +14,17 @@ test :: TestTree test = testGroup "Xanthous.Entities.Raws" [ testGroup "raws" [ testCase "are all valid" $ raws `deepseq` pure () + , testCase "all CreatureEquippedItems reference existent entity names" $ + let notFound + = raws + ^.. folded + . _Creature + . generateParams + . _Just + . equippedItem + . _Just + . entityName + . filtered (isNothing . raw) + in null notFound @? ("Some entities weren't found: " <> show notFound) ] ] diff --git a/users/grfn/xanthous/test/Xanthous/Game/StateSpec.hs b/users/grfn/xanthous/test/Xanthous/Game/StateSpec.hs index b02abb04b49c..34584f73b2ad 100644 --- a/users/grfn/xanthous/test/Xanthous/Game/StateSpec.hs +++ b/users/grfn/xanthous/test/Xanthous/Game/StateSpec.hs @@ -4,9 +4,10 @@ module Xanthous.Game.StateSpec (main, test) where import Test.Prelude -------------------------------------------------------------------------------- import Xanthous.Game.State -import Xanthous.Entities.Raws (raws, entityFromRaw) -import Control.Monad.Random (evalRandT) -import System.Random (getStdGen) +import Xanthous.Entities.Raws (raws) +import Xanthous.Generators.Level.LevelContents (entityFromRaw) +import Control.Monad.Random (evalRandT) +import System.Random (getStdGen) -------------------------------------------------------------------------------- main :: IO () |