feat(xanthous) Generate random volume+density for items

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
This commit is contained in:
Griffin Smith 2021-06-19 11:49:20 -04:00 committed by grfn
parent 8b97683f6e
commit d8bd8e7eea
9 changed files with 108 additions and 25 deletions

View file

@ -6,6 +6,8 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE NoTypeSynonymInstances #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE UndecidableInstances #-}
--------------------------------------------------------------------------------
-- | Common data types for Xanthous
--------------------------------------------------------------------------------
@ -117,6 +119,8 @@ import Xanthous.Util (EqEqProp(..), EqProp, between)
import Xanthous.Util.QuickCheck (GenericArbitrary(..))
import Xanthous.Orphans ()
import Xanthous.Util.Graphics
import Data.Random (Distribution)
import Data.Coerce
--------------------------------------------------------------------------------
-- | opposite ∘ opposite ≡ id
@ -495,6 +499,11 @@ newtype Per a b = Rate Double
deriving (Arbitrary, Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON)
via Double
deriving (Semigroup, Monoid) via Product Double
deriving via Double
instance ( Distribution d Double
, forall xx yy. Coercible xx yy => Coercible (d xx) (d yy)
)
=> Distribution d (Per a b)
invertRate :: a `Per` b -> b `Per` a
invertRate (Rate p) = Rate $ 1 / p
@ -529,6 +538,12 @@ newtype Square a = Square a
)
via a
deriving via (a :: Type)
instance ( Distribution d a
, forall xx yy. Coercible xx yy => Coercible (d xx) (d yy)
)
=> Distribution d (Square a)
newtype Cubic a = Cubic a
deriving stock (Show, Eq, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
@ -537,6 +552,12 @@ newtype Cubic a = Cubic a
)
via a
deriving via (a :: Type)
instance ( Distribution d a
, forall xx yy. Coercible xx yy => Coercible (d xx) (d yy)
)
=> Distribution d (Cubic a)
--------------------------------------------------------------------------------
newtype Ticks = Ticks Word
@ -546,6 +567,11 @@ newtype Ticks = Ticks Word
deriving (Semigroup, Monoid) via (Sum Word)
deriving Scalar via ScalarIntegral Ticks
deriving Arbitrary via GenericArbitrary Ticks
deriving via Word
instance ( Distribution d Word
, forall xx yy. Coercible xx yy => Coercible (d xx) (d yy)
)
=> Distribution d Ticks
newtype Tiles = Tiles Double
deriving stock (Show, Eq, Generic)
@ -553,6 +579,11 @@ newtype Tiles = Tiles Double
deriving (Num, Ord, Enum, Real, ToJSON, FromJSON, Scalar) via Double
deriving (Semigroup, Monoid) via (Sum Double)
deriving Arbitrary via GenericArbitrary Tiles
deriving via Double
instance ( Distribution d Double
, forall xx yy. Coercible xx yy => Coercible (d xx) (d yy)
)
=> Distribution d Tiles
type TicksPerTile = Ticks `Per` Tiles
type TilesPerTick = Tiles `Per` Ticks

View file

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

View file

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

View file

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

View file

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

View file

@ -100,7 +100,7 @@ tutorialMessage cells characterPosition = do
randomEntities
:: forall entity raw m. (MonadRandom m, RawType raw)
=> (raw -> entity)
=> (raw -> m entity)
-> (Float, Float)
-> Cells
-> m (EntityMap entity)
@ -114,7 +114,7 @@ randomEntities newWithType sizeRange cells =
entities <- for [0..numEntities] $ const $ do
pos <- randomPosition cells
raw <- choose raws
let entity = newWithType raw
entity <- newWithType raw
pure (pos, entity)
pure $ _EntityMap # entities

View file

@ -13,6 +13,7 @@ module Xanthous.Random
, chance
, chooseSubset
, chooseRange
, FiniteInterval(..)
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
@ -28,7 +29,7 @@ import Data.Random.Distribution.Uniform.Exclusive
import Data.Random.Sample
import qualified Data.Random.Source as DRS
import Data.Interval ( Interval, lowerBound', Extended (Finite)
, upperBound', Boundary (Closed)
, upperBound', Boundary (Closed), lowerBound, upperBound
)
--------------------------------------------------------------------------------
@ -128,7 +129,9 @@ chooseRange
:: ( MonadRandom m
, Distribution Uniform n
, Enum n
, Bounded n, Show n, Ord n)
, Bounded n
, Ord n
)
=> Interval n
-> m (Maybe n)
chooseRange int = traverse sample distribution
@ -149,6 +152,33 @@ chooseRange int = traverse sample distribution
| lowerR <= upperR = Just $ Uniform lowerR upperR
| otherwise = Nothing
instance ( Distribution Uniform n
, Enum n
, Bounded n
, Ord n
)
=> Choose (Interval n) where
type RandomResult (Interval n) = n
choose = fmap (fromMaybe $ error "Invalid interval") . chooseRange
newtype FiniteInterval a
= FiniteInterval { unwrapFiniteInterval :: (Interval a) }
instance ( Distribution Uniform n
, Ord n
)
=> Choose (FiniteInterval n) where
type RandomResult (FiniteInterval n) = n
-- TODO broken with open/closed right now
choose
= sample
. uncurry Uniform
. over both getFinite
. (lowerBound &&& upperBound)
. unwrapFiniteInterval
where
getFinite (Finite x) = x
getFinite _ = error "Infinite value"
--------------------------------------------------------------------------------

View file

@ -48,7 +48,7 @@ import Data.Proxy
import qualified Data.Vector as V
import Data.Semigroup (Max(..), Min(..))
import Data.Semigroup.Foldable
import Control.Monad.State.Class
import Control.Monad.State.Class
--------------------------------------------------------------------------------
newtype EqEqProp a = EqEqProp a

View file

@ -5,6 +5,8 @@ import Test.Prelude
--------------------------------------------------------------------------------
import Xanthous.Game.State
import Xanthous.Entities.Raws (raws, entityFromRaw)
import Control.Monad.Random (evalRandT)
import System.Random (getStdGen)
--------------------------------------------------------------------------------
main :: IO ()
@ -13,13 +15,15 @@ main = defaultMain test
test :: TestTree
test = testGroup "Xanthous.Game.StateSpec"
[ testGroup "entityTypeName"
[ testCase "for a creature" $
[ testCase "for a creature" $ do
let gormlakRaw = raws ^?! ix "gormlak"
creature = entityFromRaw gormlakRaw
in entityTypeName creature @?= "Creature"
, testCase "for an item" $
creature <- runRand $ entityFromRaw gormlakRaw
entityTypeName creature @?= "Creature"
, testCase "for an item" $ do
let stickRaw = raws ^?! ix "stick"
item = entityFromRaw stickRaw
in entityTypeName item @?= "Item"
item <- runRand $ entityFromRaw stickRaw
entityTypeName item @?= "Item"
]
]
where
runRand x = evalRandT x =<< getStdGen