From d8bd8e7eea5dcef4901bee14b8fe3027fd8605ac Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Sat, 19 Jun 2021 11:49:20 -0400 Subject: 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 Tested-by: BuildkiteCI --- users/grfn/xanthous/src/Xanthous/Data.hs | 31 ++++++++++++++++++++ .../xanthous/src/Xanthous/Entities/Creature.hs | 5 ++-- users/grfn/xanthous/src/Xanthous/Entities/Item.hs | 32 ++++++++++++++------ .../xanthous/src/Xanthous/Entities/RawTypes.hs | 2 ++ users/grfn/xanthous/src/Xanthous/Entities/Raws.hs | 7 +++-- .../src/Xanthous/Generators/Level/LevelContents.hs | 4 +-- users/grfn/xanthous/src/Xanthous/Random.hs | 34 ++++++++++++++++++++-- users/grfn/xanthous/src/Xanthous/Util.hs | 2 +- .../grfn/xanthous/test/Xanthous/Game/StateSpec.hs | 16 ++++++---- 9 files changed, 108 insertions(+), 25 deletions(-) diff --git a/users/grfn/xanthous/src/Xanthous/Data.hs b/users/grfn/xanthous/src/Xanthous/Data.hs index 89d0993b4e59..ba6f98558ad8 100644 --- a/users/grfn/xanthous/src/Xanthous/Data.hs +++ b/users/grfn/xanthous/src/Xanthous/Data.hs @@ -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 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 diff --git a/users/grfn/xanthous/src/Xanthous/Generators/Level/LevelContents.hs b/users/grfn/xanthous/src/Xanthous/Generators/Level/LevelContents.hs index 7582ae275892..3cad569336e1 100644 --- a/users/grfn/xanthous/src/Xanthous/Generators/Level/LevelContents.hs +++ b/users/grfn/xanthous/src/Xanthous/Generators/Level/LevelContents.hs @@ -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 diff --git a/users/grfn/xanthous/src/Xanthous/Random.hs b/users/grfn/xanthous/src/Xanthous/Random.hs index 72bdb63d2c61..329b321b8bda 100644 --- a/users/grfn/xanthous/src/Xanthous/Random.hs +++ b/users/grfn/xanthous/src/Xanthous/Random.hs @@ -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" -------------------------------------------------------------------------------- diff --git a/users/grfn/xanthous/src/Xanthous/Util.hs b/users/grfn/xanthous/src/Xanthous/Util.hs index 189e781e6cec..fea9c07c124d 100644 --- a/users/grfn/xanthous/src/Xanthous/Util.hs +++ b/users/grfn/xanthous/src/Xanthous/Util.hs @@ -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 diff --git a/users/grfn/xanthous/test/Xanthous/Game/StateSpec.hs b/users/grfn/xanthous/test/Xanthous/Game/StateSpec.hs index 3267d8ef9e9c..b02abb04b49c 100644 --- a/users/grfn/xanthous/test/Xanthous/Game/StateSpec.hs +++ b/users/grfn/xanthous/test/Xanthous/Game/StateSpec.hs @@ -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 -- cgit 1.4.1