From 2cfe4069bb9b46778d737f5ca535edcb9993f356 Mon Sep 17 00:00:00 2001
From: Griffin Smith <grfn@gws.fyi>
Date: Sat, 12 Jun 2021 21:11:58 -0400
Subject: feat(xanthous): Add a generator for random english syllables

Add a new "speech" generator module, with the beginnings of the vague
definition of the phonotactics of the language (there's one in here for
English based on the wikipedia article for English phonology, but it's
less than ideal as it has generated words like "sprurlkt") and the
ability to generate random syllables of a language by picking an onset,
nucleus, and coda from the list for that language (within a range of the
number of allowed of each syllable part). This will be used down the
road to automatically generate utterances from various
non-english-speaking creatures (so the accuracy is less important, just
that it "feels real").

Change-Id: I7b81375ec595239c05c5c800cbde1a2a900e38ac
Reviewed-on: https://cl.tvl.fyi/c/depot/+/3202
Reviewed-by: grfn <grfn@gws.fyi>
Tested-by: BuildkiteCI
---
 users/grfn/xanthous/src/Xanthous/Random.hs | 39 +++++++++++++++++++++++++++---
 1 file changed, 36 insertions(+), 3 deletions(-)

(limited to 'users/grfn/xanthous/src/Xanthous/Random.hs')

diff --git a/users/grfn/xanthous/src/Xanthous/Random.hs b/users/grfn/xanthous/src/Xanthous/Random.hs
index 6d34109df7f8..d97dcb9e1175 100644
--- a/users/grfn/xanthous/src/Xanthous/Random.hs
+++ b/users/grfn/xanthous/src/Xanthous/Random.hs
@@ -11,9 +11,10 @@ module Xanthous.Random
   , subRand
   , chance
   , chooseSubset
+  , chooseRange
   ) where
 --------------------------------------------------------------------------------
-import Xanthous.Prelude
+import           Xanthous.Prelude
 --------------------------------------------------------------------------------
 import           Data.List.NonEmpty (NonEmpty(..))
 import           Control.Monad.Random.Class (MonadRandom(getRandomR, getRandom))
@@ -25,6 +26,9 @@ import           Data.Random.Distribution.Uniform
 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)
+                               )
 --------------------------------------------------------------------------------
 
 instance {-# INCOHERENT #-} (Monad m, MonadRandom m) => DRS.MonadRandom m where
@@ -81,11 +85,13 @@ evenlyWeighted = Weighted . itoList
 weightedBy :: Functor t => (a -> w) -> t a -> Weighted w t a
 weightedBy weighting xs = Weighted $ (weighting &&& id) <$> xs
 
-instance (Num w, Ord w, Distribution Uniform w, Excludable w) => Choose (Weighted w [] a) where
+instance (Num w, Ord w, Distribution Uniform w, Excludable w)
+       => Choose (Weighted w [] a) where
   type RandomResult (Weighted w [] a) = Maybe a
   choose (Weighted ws) = sample $ headMay <$> weightedSample 1 ws
 
-instance (Num w, Ord w, Distribution Uniform w, Excludable w) => Choose (Weighted w NonEmpty a) where
+instance (Num w, Ord w, Distribution Uniform w, Excludable w)
+       => Choose (Weighted w NonEmpty a) where
   type RandomResult (Weighted w NonEmpty a) = a
   choose (Weighted ws) =
     sample
@@ -112,6 +118,33 @@ chooseSubset :: ( Num w, Ord w, Distribution Uniform w, Excludable w
                ) => w -> t a -> m (t a)
 chooseSubset = filterA . const . chance
 
+-- | Choose a random @n@ in the given interval
+chooseRange
+  :: ( MonadRandom m
+    , Distribution Uniform n
+    , Enum n
+    , Bounded n, Show n, Ord n)
+  => Interval n
+  -> m (Maybe n)
+chooseRange int = traverse sample distribution
+  where
+    (lower, lowerBoundary) = lowerBound' int
+    lowerR = case lower of
+      Finite x -> if lowerBoundary == Closed
+                 then x
+                 else succ x
+      _ -> minBound
+    (upper, upperBoundary) = upperBound' int
+    upperR = case upper of
+      Finite x -> if upperBoundary == Closed
+                 then x
+                 else pred x
+      _ -> maxBound
+    distribution
+      | lowerR <= upperR = Just $ Uniform lowerR upperR
+      | otherwise = Nothing
+
+
 --------------------------------------------------------------------------------
 
 bools :: NonEmpty Bool
-- 
cgit 1.4.1