about summary refs log tree commit diff
path: root/users/grfn/xanthous/src/Xanthous/Random.hs
diff options
context:
space:
mode:
authorGriffin Smith <grfn@gws.fyi>2021-06-19T15·49-0400
committergrfn <grfn@gws.fyi>2021-06-23T21·52+0000
commitd8bd8e7eea5dcef4901bee14b8fe3027fd8605ac (patch)
tree0b9e02b87175ff8d16baa5a7d8a1c60a267cea28 /users/grfn/xanthous/src/Xanthous/Random.hs
parent8b97683f6ef53605130542ea6de1e587b353aa5b (diff)
feat(xanthous) Generate random volume+density for items r/2679
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
Diffstat (limited to 'users/grfn/xanthous/src/Xanthous/Random.hs')
-rw-r--r--users/grfn/xanthous/src/Xanthous/Random.hs34
1 files changed, 32 insertions, 2 deletions
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"
 
 --------------------------------------------------------------------------------