feat(xanthous): Track the volume and density of item types r/2678

Allow the itemType raw to have density and volume fields, both of which
represent *intervals* of both density and volume (because both can
hypothetically vary a bit). The idea here is that when we're making
an *instance* of one of these items, we pick a random value in the
range.

Lots of stuff in this commit is datatype and typeclass instances to
support things like intervals being fields on datatypes that get
serialized to saved games - including a manual definition of Ord for
Item since Ord isn't well-defined for intervals

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

7 files changed, 194 insertions, 21 deletions

diff --git a/users/grfn/xanthous/src/Xanthous/App.hs b/users/grfn/xanthous/src/Xanthous/App.hs
index 1e915a03fe05..6ed545e3aa4f 100644
--- a/users/grfn/xanthous/src/Xanthous/App.hs
+++ b/users/grfn/xanthous/src/Xanthous/App.hs
@@ -32,6 +32,7 @@ import           Xanthous.Data
                  , position
                  , Position
                  , (|*|)
+                 , Tiles(..)
                  )
 import           Xanthous.Data.App (ResourceName, Panel(..), AppEvent(..))
 import qualified Xanthous.Data.EntityMap as EntityMap
@@ -127,7 +128,7 @@ handleCommand (Move dir) = do
   collisionAt newPos >>= \case
     Nothing -> do
       characterPosition .= newPos
-      stepGameBy =<< uses (character . speed) (|*| 1)
+      stepGameBy =<< uses (character . speed) (|*| Tiles 1)
       describeEntitiesAt newPos
     Just Combat -> attackAt newPos
     Just Stop -> pure ()
diff --git a/users/grfn/xanthous/src/Xanthous/App/Autocommands.hs b/users/grfn/xanthous/src/Xanthous/App/Autocommands.hs
index 5892536137b0..5d4db1a47465 100644
--- a/users/grfn/xanthous/src/Xanthous/App/Autocommands.hs
+++ b/users/grfn/xanthous/src/Xanthous/App/Autocommands.hs
@@ -30,7 +30,7 @@ autoStep (AutoMove dir) = do
   collisionAt newPos >>= \case
     Nothing -> do
       characterPosition .= newPos
-      stepGameBy =<< uses (character . speed) (|*| 1)
+      stepGameBy =<< uses (character . speed) (|*| (1 :: Tiles))
       describeEntitiesAt newPos
       cancelIfDanger
     Just _ -> cancelAutocommand
diff --git a/users/grfn/xanthous/src/Xanthous/Data.hs b/users/grfn/xanthous/src/Xanthous/Data.hs
index c9c11b553b67..89d0993b4e59 100644
--- a/users/grfn/xanthous/src/Xanthous/Data.hs
+++ b/users/grfn/xanthous/src/Xanthous/Data.hs
@@ -3,8 +3,6 @@
 {-# LANGUAGE RoleAnnotations        #-}
 {-# LANGUAGE RecordWildCards        #-}
 {-# LANGUAGE DeriveTraversable      #-}
-{-# LANGUAGE DeriveFoldable         #-}
-{-# LANGUAGE DeriveFunctor          #-}
 {-# LANGUAGE TemplateHaskell        #-}
 {-# LANGUAGE NoTypeSynonymInstances #-}
 {-# LANGUAGE DuplicateRecordFields  #-}
@@ -56,6 +54,10 @@ module Xanthous.Data
   , TicksPerTile
   , TilesPerTick
   , timesTiles
+  , Square(..)
+  , Cubic(..)
+  , Grams
+  , Meters
 
     -- *
   , Dimensions'(..)
@@ -490,9 +492,9 @@ rotations orig@(Neighbors tl t tr l r bl b br) = V4
 newtype Per a b = Rate Double
   deriving stock (Show, Eq, Generic)
   deriving anyclass (NFData, CoArbitrary, Function)
-  deriving (Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON) via Double
+  deriving (Arbitrary, Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON)
+       via Double
   deriving (Semigroup, Monoid) via Product Double
-instance Arbitrary (Per a b) where arbitrary = genericArbitrary
 
 invertRate :: a `Per` b -> b `Per` a
 invertRate (Rate p) = Rate $ 1 / p
@@ -500,9 +502,42 @@ invertRate (Rate p) = Rate $ 1 / p
 invertedRate :: Iso (a `Per` b) (b' `Per` a') (b `Per` a) (a' `Per` b')
 invertedRate = iso invertRate invertRate
 
+type (:*:) :: Type -> Type -> Type
+type family (:*:) a b where
+  (a `Per` b) :*: b = a
+  (Square a) :*: a = Cubic a
+  a :*: a = Square a
+
 infixl 7 |*|
-(|*|) :: (Scalar a, Scalar b) => a `Per` b -> b -> a
-(|*|) (Rate rate) b = fromScalar $ rate * scalar b
+class MulUnit a b where
+  (|*|) :: a -> b -> a :*: b
+
+instance (Scalar a, Scalar b) => MulUnit (a `Per` b) b where
+  (Rate rate) |*| b = fromScalar $ rate * scalar b
+
+instance forall a. (Scalar a, a :*: a ~ Square a) => MulUnit a a where
+  x' |*| y' = Square @a . fromScalar $ scalar x' * scalar y'
+
+instance forall a. (Scalar a) => MulUnit (Square a) a where
+  x' |*| y' = Cubic @a . fromScalar $ scalar x' * scalar y'
+
+newtype Square a = Square a
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving ( Arbitrary, Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON
+           , Scalar
+           )
+       via a
+
+newtype Cubic a = Cubic a
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving ( Arbitrary, Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON
+           , Scalar
+           )
+       via a
+
+--------------------------------------------------------------------------------
 
 newtype Ticks = Ticks Word
   deriving stock (Show, Eq, Generic)
@@ -510,14 +545,14 @@ newtype Ticks = Ticks Word
   deriving (Num, Ord, Bounded, Enum, Integral, Real, ToJSON, FromJSON) via Word
   deriving (Semigroup, Monoid) via (Sum Word)
   deriving Scalar via ScalarIntegral Ticks
-instance Arbitrary Ticks where arbitrary = genericArbitrary
+  deriving Arbitrary via GenericArbitrary Ticks
 
 newtype Tiles = Tiles Double
   deriving stock (Show, Eq, Generic)
   deriving anyclass (NFData, CoArbitrary, Function)
   deriving (Num, Ord, Enum, Real, ToJSON, FromJSON, Scalar) via Double
   deriving (Semigroup, Monoid) via (Sum Double)
-instance Arbitrary Tiles where arbitrary = genericArbitrary
+  deriving Arbitrary via GenericArbitrary Tiles
 
 type TicksPerTile = Ticks `Per` Tiles
 type TilesPerTick = Tiles `Per` Ticks
@@ -536,6 +571,23 @@ newtype Hitpoints = Hitpoints Word
 
 --------------------------------------------------------------------------------
 
+-- | Grams, the fundamental measure of weight in Xanthous.
+newtype Grams = Grams Double
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving ( Arbitrary, Num, Ord, Enum, Real, Floating, Fractional, RealFloat
+           , RealFrac, Scalar, ToJSON, FromJSON
+           )
+       via Double
+  deriving (Semigroup, Monoid) via Sum Double
+
+-- | Every tile is 1 meter
+type Meters = Tiles
+
+
+
+--------------------------------------------------------------------------------
+
 data Box a = Box
   { _topLeftCorner :: V2 a
   , _dimensions    :: V2 a
diff --git a/users/grfn/xanthous/src/Xanthous/Entities/RawTypes.hs b/users/grfn/xanthous/src/Xanthous/Entities/RawTypes.hs
index b7c5fe31c995..88070ed7b8bd 100644
--- a/users/grfn/xanthous/src/Xanthous/Entities/RawTypes.hs
+++ b/users/grfn/xanthous/src/Xanthous/Entities/RawTypes.hs
@@ -51,11 +51,12 @@ import Data.Aeson.Generic.DerivingVia
 import Data.Aeson (ToJSON, FromJSON)
 --------------------------------------------------------------------------------
 import Xanthous.Messages (Message(..))
-import Xanthous.Data (TicksPerTile, Hitpoints)
+import Xanthous.Data (TicksPerTile, Hitpoints, Per, Grams, Cubic, Meters)
 import Xanthous.Data.EntityChar
 import Xanthous.Util.QuickCheck
 import Xanthous.Generators.Speech (Language, gormlak, english)
 import Xanthous.Orphans ()
+import Data.Interval (Interval, lowerBound', upperBound')
 --------------------------------------------------------------------------------
 
 -- | Identifiers for languages that creatures can speak.
@@ -153,10 +154,12 @@ data ItemType = ItemType
   , _description     :: !Text
   , _longDescription :: !Text
   , _char            :: !EntityChar
+  , _density         :: !(Interval (Grams `Per` Cubic Meters))
+  , _volume          :: !(Interval (Cubic Meters))
   , _edible          :: !(Maybe EdibleItem)
   , _wieldable       :: !(Maybe WieldableItem)
   }
-  deriving stock (Show, Eq, Ord, Generic)
+  deriving stock (Show, Eq, Generic)
   deriving anyclass (NFData, CoArbitrary, Function)
   deriving Arbitrary via GenericArbitrary ItemType
   deriving (ToJSON, FromJSON)
@@ -164,6 +167,20 @@ data ItemType = ItemType
                        ItemType
 makeFieldsNoPrefix ''ItemType
 
+instance Ord ItemType where
+  compare x y
+    = compareOf name x y
+    <> compareOf description x y
+    <> compareOf longDescription x y
+    <> compareOf char x y
+    <> compareOf (density . to extractInterval) x y
+    <> compareOf (volume . to extractInterval) x y
+    <> compareOf edible x y
+    <> compareOf wieldable x y
+    where
+      compareOf l = comparing (view l)
+      extractInterval = lowerBound' &&& upperBound'
+
 -- | Can this item be eaten?
 isEdible :: ItemType -> Bool
 isEdible = has $ edible . _Just
diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Raws/noodles.yaml b/users/grfn/xanthous/src/Xanthous/Entities/Raws/noodles.yaml
index c3f19dce91d1..c0501a18a8e0 100644
--- a/users/grfn/xanthous/src/Xanthous/Entities/Raws/noodles.yaml
+++ b/users/grfn/xanthous/src/Xanthous/Entities/Raws/noodles.yaml
@@ -10,3 +10,5 @@ Item:
     hitpointsHealed: 2
     eatMessage:
       - You slurp up the noodles. Yumm!
+  density: 500000
+  volume: 0.001
diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Raws/stick.yaml b/users/grfn/xanthous/src/Xanthous/Entities/Raws/stick.yaml
index bc7fde4d8b02..4100808ca071 100644
--- a/users/grfn/xanthous/src/Xanthous/Entities/Raws/stick.yaml
+++ b/users/grfn/xanthous/src/Xanthous/Entities/Raws/stick.yaml
@@ -12,3 +12,7 @@ Item:
       - You bonk the {{creature.creatureType.name}} over the head with your stick.
       - You bash the {{creature.creatureType.name}} on the noggin with your stick.
       - You whack the {{creature.creatureType.name}} with your stick.
+  # https://www.sciencedirect.com/topics/agricultural-and-biological-sciences/wood-density
+  # it's a hard stick. so it's dense wood.
+  density: 890000 # g/m³
+  volume: [ 0.003, 0.006 ] # ≈3.5 cm radius × ≈1m length
diff --git a/users/grfn/xanthous/src/Xanthous/Orphans.hs b/users/grfn/xanthous/src/Xanthous/Orphans.hs
index e6ea1310319b..0b282af44ca0 100644
--- a/users/grfn/xanthous/src/Xanthous/Orphans.hs
+++ b/users/grfn/xanthous/src/Xanthous/Orphans.hs
@@ -1,10 +1,10 @@
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE PackageImports #-}
-{-# OPTIONS_GHC -Wno-orphans #-}
+{-# LANGUAGE RecordWildCards       #-}
+{-# LANGUAGE StandaloneDeriving    #-}
+{-# LANGUAGE UndecidableInstances  #-}
+{-# LANGUAGE PackageImports        #-}
+{-# OPTIONS_GHC -Wno-orphans       #-}
+{-# OPTIONS_GHC -Wno-type-defaults #-}
 --------------------------------------------------------------------------------
-{-# OPTIONS_GHC -Wno-deferred-type-errors #-}
 module Xanthous.Orphans
   ( ppTemplate
   ) where
@@ -28,11 +28,15 @@ import           Text.Mustache
 import           Text.Mustache.Type ( showKey )
 import           Control.Monad.State
 import           Linear
+import qualified Data.Interval as Interval
+import           Data.Interval ( Interval, Extended (..), Boundary (..)
+                               , lowerBound', upperBound', (<=..<), (<=..<=)
+                               , interval)
+import           Test.QuickCheck.Checkers (EqProp ((=-=)))
 --------------------------------------------------------------------------------
 import           Xanthous.Util.JSON
 import           Xanthous.Util.QuickCheck
-import qualified Data.Interval as Interval
-import Data.Interval (Interval, Extended (..))
+import           Xanthous.Util (EqEqProp(EqEqProp))
 --------------------------------------------------------------------------------
 
 instance forall s a.
@@ -241,6 +245,8 @@ instance CoArbitrary a => CoArbitrary (MaybeDefault a) where
 instance (Eq a, Show a, Read a, Function a) => Function (MaybeDefault a) where
   function = functionShow
 
+deriving via (EqEqProp Attr) instance EqProp Attr
+
 instance Arbitrary Attr where
   arbitrary = do
     attrStyle <- arbitrary
@@ -367,12 +373,46 @@ instance Function a => Function (V2 a)
 
 --------------------------------------------------------------------------------
 
-instance Arbitrary r => Arbitrary (Extended r) where
+instance CoArbitrary Boundary
+instance Function Boundary
+
+instance Arbitrary a => Arbitrary (Extended a) where
   arbitrary = oneof [ pure NegInf
                     , pure PosInf
                     , Finite <$> arbitrary
                     ]
 
+instance CoArbitrary a => CoArbitrary (Extended a) where
+  coarbitrary NegInf = variant 1
+  coarbitrary PosInf = variant 2
+  coarbitrary (Finite x) = variant 3 . coarbitrary x
+
+instance (Function a) => Function (Extended a) where
+  function = functionMap g h
+    where
+     g NegInf = Left True
+     g (Finite a) = Right a
+     g PosInf = Left False
+     h (Left False) = PosInf
+     h (Left True) = NegInf
+     h (Right a) = Finite a
+
+instance ToJSON a => ToJSON (Extended a) where
+  toJSON NegInf = String "NegInf"
+  toJSON PosInf = String "PosInf"
+  toJSON (Finite x) = toJSON x
+
+instance FromJSON a => FromJSON (Extended a) where
+  parseJSON (String "NegInf") = pure NegInf
+  parseJSON (String "PosInf") = pure PosInf
+  parseJSON val               = Finite <$> parseJSON val
+
+instance (EqProp a, Show a) => EqProp (Extended a) where
+  NegInf =-= NegInf = property True
+  PosInf =-= PosInf = property True
+  (Finite x) =-= (Finite y) = x =-= y
+  x =-= y = counterexample (show x <> " /= " <> show y) False
+
 instance Arbitrary Interval.Boundary where
   arbitrary = elements [ Interval.Open , Interval.Closed ]
 
@@ -384,3 +424,60 @@ instance (Ord r, Arbitrary r) => Arbitrary (Interval r) where
       Interval.interval
       lower
       upper
+
+instance CoArbitrary a => CoArbitrary (Interval a) where
+  coarbitrary int = coarbitrary (lowerBound' int) . coarbitrary (upperBound' int)
+
+instance (Function a, Ord a) => Function (Interval a) where
+  function = functionMap g h
+    where
+      g = lowerBound' &&& upperBound'
+      h = uncurry interval
+
+deriving via (EqEqProp (Interval a)) instance Eq a => (EqProp (Interval a))
+
+instance ToJSON a => ToJSON (Interval a) where
+  toJSON x = Array . fromList $
+    [ object [ lowerKey .= lowerVal ]
+    , object [ upperKey .= upperVal ]
+    ]
+    where
+      (lowerVal, lowerBoundary) = lowerBound' x
+      (upperVal, upperBoundary) = upperBound' x
+      upperKey = boundaryToKey upperBoundary
+      lowerKey = boundaryToKey lowerBoundary
+      boundaryToKey Open = "Excluded"
+      boundaryToKey Closed = "Included"
+
+instance forall a. (FromJSON a, Ord a) => FromJSON (Interval a) where
+  parseJSON x =
+    boundPairWithBoundary x
+      <|> boundPairWithoutBoundary x
+      <|> singleVal x
+    where
+      boundPairWithBoundary = withArray "Bound pair" $ \arr -> do
+        checkLength arr
+        lower <- parseBound $ arr ^?! ix 0
+        upper <- parseBound $ arr ^?! ix 1
+        pure $ interval lower upper
+      parseBound = withObject "Bound" $ \obj -> do
+        when (length obj /= 1) $ fail "Expected an object with a single key"
+        let [(k, v)] = obj ^@.. ifolded
+        boundary <- case k of
+          "Excluded" -> pure Open
+          "Open"     -> pure Open
+          "Included" -> pure Closed
+          "Closed"   -> pure Closed
+          _          -> fail "Invalid boundary specification"
+        val <- parseJSON v
+        pure (val, boundary)
+      boundPairWithoutBoundary = withArray "Bound pair" $ \arr -> do
+        checkLength arr
+        lower <- parseJSON $ arr ^?! ix 0
+        upper <- parseJSON $ arr ^?! ix 1
+        pure $ lower <=..< upper
+      singleVal v = do
+        val <- parseJSON v
+        pure $ val <=..<= val
+      checkLength arr =
+        when (length arr /= 2) $ fail "Expected array of length 2"