feat(xanthous) Generate random volume+density for items r/2679

Generate random volumes and densities for items based on the ranges for
those two quantities in the raw when building instances of items.

Since this is the first time creating an item is impure, this also lifts
entity generation into a (random) monadic context

Change-Id: I2de4880e8144f7ff9e1304eb32806ed1d7affa18
Reviewed-on: https://cl.tvl.fyi/c/depot/+/3226
Reviewed-by: grfn <grfn@gws.fyi>
Tested-by: BuildkiteCI

4 files changed, 32 insertions, 14 deletions

diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Creature.hs b/users/grfn/xanthous/src/Xanthous/Entities/Creature.hs
index e95e9f0b985b..f23cf25b4392 100644
--- a/users/grfn/xanthous/src/Xanthous/Entities/Creature.hs
+++ b/users/grfn/xanthous/src/Xanthous/Entities/Creature.hs
@@ -33,6 +33,7 @@ import           Test.QuickCheck
 import           Test.QuickCheck.Arbitrary.Generic
 import           Data.Aeson.Generic.DerivingVia
 import           Data.Aeson (ToJSON, FromJSON)
+import           Control.Monad.Random (MonadRandom)
 --------------------------------------------------------------------------------
 import           Xanthous.AI.Gormlak
 import           Xanthous.Entities.RawTypes hiding
@@ -74,11 +75,11 @@ instance Entity Creature where
 
 --------------------------------------------------------------------------------
 
-newWithType :: CreatureType -> Creature
+newWithType :: MonadRandom m => CreatureType -> m Creature
 newWithType _creatureType =
   let _hitpoints = _creatureType ^. maxHitpoints
       _hippocampus = initialHippocampus
-  in Creature {..}
+  in pure Creature {..}
 
 damage :: Hitpoints -> Creature -> Creature
 damage amount = hitpoints %~ \hp ->
diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Item.hs b/users/grfn/xanthous/src/Xanthous/Entities/Item.hs
index b50a5eab809d..6647c42731fa 100644
--- a/users/grfn/xanthous/src/Xanthous/Entities/Item.hs
+++ b/users/grfn/xanthous/src/Xanthous/Entities/Item.hs
@@ -1,49 +1,63 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE RecordWildCards #-}
 --------------------------------------------------------------------------------
 module Xanthous.Entities.Item
   ( Item(..)
   , itemType
+  , density
+  , volume
   , newWithType
   , isEdible
+  , weight
   ) where
 --------------------------------------------------------------------------------
 import           Xanthous.Prelude
-import           Test.QuickCheck
+import           Test.QuickCheck (Arbitrary, CoArbitrary, Function)
 import           Data.Aeson (ToJSON, FromJSON)
 import           Data.Aeson.Generic.DerivingVia
+import           Control.Monad.Random (MonadRandom)
 --------------------------------------------------------------------------------
-import           Xanthous.Entities.RawTypes hiding (Item, description, isEdible)
+import           Xanthous.Entities.RawTypes (ItemType)
 import qualified Xanthous.Entities.RawTypes as Raw
 import           Xanthous.Game.State
+import           Xanthous.Data (Grams, Per, Cubic, Meters, (|*|))
+import           Xanthous.Util.QuickCheck (GenericArbitrary(GenericArbitrary))
+import           Xanthous.Random (choose, FiniteInterval(..))
 --------------------------------------------------------------------------------
 
 data Item = Item
   { _itemType :: ItemType
+  , _density  :: Grams `Per` Cubic Meters
+  , _volume   :: Cubic Meters
   }
   deriving stock (Eq, Show, Ord, Generic)
   deriving anyclass (NFData, CoArbitrary, Function)
   deriving Draw via DrawRawChar "_itemType" Item
+  deriving Arbitrary via GenericArbitrary Item
   deriving (ToJSON, FromJSON)
        via WithOptions '[ FieldLabelModifier '[Drop 1] ]
                        Item
 makeLenses ''Item
 
-{-# ANN Item ("HLint: ignore Use newtype instead of data" :: String )#-}
-
 -- deriving via (Brainless Item) instance Brain Item
 instance Brain Item where step = brainVia Brainless
 
-instance Arbitrary Item where
-  arbitrary = Item <$> arbitrary
-
 instance Entity Item where
   description = view $ itemType . Raw.description
   entityChar = view $ itemType . Raw.char
   entityCollision = const Nothing
 
-newWithType :: ItemType -> Item
-newWithType = Item
+newWithType :: MonadRandom m => ItemType -> m Item
+newWithType _itemType = do
+  _density <- choose . FiniteInterval $ _itemType ^. Raw.density
+  _volume  <- choose . FiniteInterval $ _itemType ^. Raw.volume
+  pure Item {..}
 
 isEdible :: Item -> Bool
 isEdible = Raw.isEdible . view itemType
+
+-- | The weight of this item, calculated by multiplying its volume by the
+-- density of its material
+weight :: Item -> Grams
+weight item = (item ^. density) |*| (item ^. volume)
diff --git a/users/grfn/xanthous/src/Xanthous/Entities/RawTypes.hs b/users/grfn/xanthous/src/Xanthous/Entities/RawTypes.hs
index 88070ed7b8bd..b0fb5e086e26 100644
--- a/users/grfn/xanthous/src/Xanthous/Entities/RawTypes.hs
+++ b/users/grfn/xanthous/src/Xanthous/Entities/RawTypes.hs
@@ -31,6 +31,7 @@ module Xanthous.Entities.RawTypes
   , HasAttackMessage(..)
   , HasChar(..)
   , HasDamage(..)
+  , HasDensity(..)
   , HasDescription(..)
   , HasEatMessage(..)
   , HasEdible(..)
@@ -42,6 +43,7 @@ module Xanthous.Entities.RawTypes
   , HasName(..)
   , HasSayVerb(..)
   , HasSpeed(..)
+  , HasVolume(..)
   , HasWieldable(..)
   ) where
 --------------------------------------------------------------------------------
diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Raws.hs b/users/grfn/xanthous/src/Xanthous/Entities/Raws.hs
index d4cae7ccc299..441e870160a5 100644
--- a/users/grfn/xanthous/src/Xanthous/Entities/Raws.hs
+++ b/users/grfn/xanthous/src/Xanthous/Entities/Raws.hs
@@ -12,6 +12,7 @@ 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
@@ -52,8 +53,8 @@ rawsWithType = mapFromList . itoListOf (ifolded . _RawType) $ raws
 
 --------------------------------------------------------------------------------
 
-entityFromRaw :: EntityRaw -> SomeEntity
+entityFromRaw :: MonadRandom m => EntityRaw -> m SomeEntity
 entityFromRaw (Creature creatureType)
-  = SomeEntity $ Creature.newWithType creatureType
+  = SomeEntity <$> Creature.newWithType creatureType
 entityFromRaw (Item itemType)
-  = SomeEntity $ Item.newWithType itemType
+  = SomeEntity <$> Item.newWithType itemType