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:
parent
8b97683f6e
commit
d8bd8e7eea
9 changed files with 108 additions and 25 deletions
|
@ -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
|
||||
|
|
|
@ -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 ->
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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"
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue