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

1 files changed, 106 insertions, 9 deletions

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"