feat(gs/xanthous): Allow generating creatures with items

Add an `equippedItems` field to the CreatureType raw, which provides a
chance for generating that creature with an item equipped, which goes
into a new `inventory` field on the creature entity itself. Currently
the creature doesn't actually *use* this equipped item, but it's a step.

This commit also adds a broken-dagger equipped 90% of the time to the
"husk" creature.

Change-Id: I6416c0678ba7bc1b002c5ce6119f7dc97dd86437

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))

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

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 ,))

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

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
 
-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)
+-- | 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 (Eq, Show, Ord, Generic)
+  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
+  { -- | 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, 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

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

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

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

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)
+        ]
     ]
   ]

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)
     ]
   ]

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 ()