about summary refs log tree commit diff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--users/grfn/xanthous/src/Xanthous/Data.hs31
-rw-r--r--users/grfn/xanthous/src/Xanthous/Entities/Creature.hs5
-rw-r--r--users/grfn/xanthous/src/Xanthous/Entities/Item.hs32
-rw-r--r--users/grfn/xanthous/src/Xanthous/Entities/RawTypes.hs2
-rw-r--r--users/grfn/xanthous/src/Xanthous/Entities/Raws.hs7
-rw-r--r--users/grfn/xanthous/src/Xanthous/Generators/Level/LevelContents.hs4
-rw-r--r--users/grfn/xanthous/src/Xanthous/Random.hs34
-rw-r--r--users/grfn/xanthous/src/Xanthous/Util.hs2
-rw-r--r--users/grfn/xanthous/test/Xanthous/Game/StateSpec.hs16
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 89d0993b4e..ba6f98558a 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 e95e9f0b98..f23cf25b43 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 b50a5eab80..6647c42731 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 88070ed7b8..b0fb5e086e 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 d4cae7ccc2..441e870160 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 7582ae2758..3cad569336 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 72bdb63d2c..329b321b8b 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 189e781e6c..fea9c07c12 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 3267d8ef9e..b02abb04b4 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
generated by cgit-pink 1.4.1 (git 2.44.0) at 2024-06-03T21·40+0000