From 2cfe4069bb9b46778d737f5ca535edcb9993f356 Mon Sep 17 00:00:00 2001 From: Griffin Smith 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 Tested-by: BuildkiteCI --- .../xanthous/src/Xanthous/Generators/Speech.hs | 108 +++++++++++++++++++++ users/grfn/xanthous/src/Xanthous/Orphans.hs | 24 ++++- users/grfn/xanthous/src/Xanthous/Random.hs | 39 +++++++- 3 files changed, 167 insertions(+), 4 deletions(-) create mode 100644 users/grfn/xanthous/src/Xanthous/Generators/Speech.hs (limited to 'users/grfn/xanthous/src') diff --git a/users/grfn/xanthous/src/Xanthous/Generators/Speech.hs b/users/grfn/xanthous/src/Xanthous/Generators/Speech.hs new file mode 100644 index 000000000000..76830c4d9116 --- /dev/null +++ b/users/grfn/xanthous/src/Xanthous/Generators/Speech.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +module Xanthous.Generators.Speech + ( -- * Abstract phonotactics + Phonotactics(..) + -- ** Lenses + , onsets + , nuclei + , codas + , numOnsets + , numNuclei + , numCodas + + -- ** Definitions for languages + , english + + -- * Language generation + , syllable + + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude hiding (replicateM) +import Data.Interval (Interval) +import qualified Data.Interval as Interval +import Control.Monad.Random.Class (MonadRandom) +import Xanthous.Random (chooseRange, choose, ChooseElement (ChooseElement)) +import Control.Monad (replicateM) +-------------------------------------------------------------------------------- + +newtype Phoneme = Phoneme Text + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData) + deriving newtype (IsString, Semigroup, Monoid) + +data Phonotactics = Phonotactics + { _onsets :: [Phoneme] + , _nuclei :: [Phoneme] + , _codas :: [Phoneme] + , _numOnsets :: Interval Word + , _numNuclei :: Interval Word + , _numCodas :: Interval Word + } + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData) +makeLenses ''Phonotactics + +syllable :: MonadRandom m => Phonotactics -> m Text +syllable phonotactics = do + let genPart num choices = do + n <- fromIntegral . fromMaybe 0 <$> chooseRange (phonotactics ^. num) + fmap (fromMaybe mempty . mconcat) + . replicateM n + . choose . ChooseElement + $ phonotactics ^. choices + + (Phoneme onset) <- genPart numOnsets onsets + (Phoneme nucleus) <- genPart numNuclei nuclei + (Phoneme coda) <- genPart numCodas codas + + pure $ onset <> nucleus <> coda + +-------------------------------------------------------------------------------- + +-- +english :: Phonotactics +english = Phonotactics + { _onsets = [ "pl" , "bl" , "kl" , "gl" , "pr" , "br" , "tr" , "dr" , "kr" + , "gr" , "tw" , "dw" , "gw" , "kw" , "pw" + + , "fl" , "sl" , {- "thl", -} "shl" {- , "vl" -} + , "p", "b", "t", "d", "k", "ɡ", "m", "n", "f", "v", "th", "s" + , "z", "h", "l", "w" + + , "sp", "st", "sk" + + , "sm", "sn" + + , "sf", "sθ" + + , "spl", "skl", "spr", "str", "skr", "skw", "sm", "sp", "st", "sk" + ] + , _nuclei = [ "a", "e", "i", "o", "u", "ur", "ar", "or", "ear", "are", "ure" + , "oa", "ee", "oo", "ei", "ie", "oi", "ou" + ] + , _codas = [ "m", "n", "ng", "p", "t", "tsh", "k", "f", "sh", "s", "th", "x" + , "v", "z", "zh", "l", "r", "w" + + , "lk", "lb", "lt", "ld", "ltsh", "ldsh", "lk" + , "rp", "rb", "rt", "rd", "rtsh", "rdsh", "rk", "rɡ" + , "lf", "lv", "lth", "ls", "lz", "lsh", "lth" + , "rf", "rv", "rth", "rs", "rz", "rth" + , "lm", "ln" + , "rm", "rn", "rl" + , "mp", "nt", "nd", "nth", "nsh", "ŋk" + , "mf", "ms", "mth", "nf", "nth", "ns", "nz", "ŋθ" + , "ft", "sp", "st", "sk" + , "fth" + , "pt", "kt" + , "pth", "ps", "th", "ts", "dth", "dz", "ks" + , "lpt", "lps", "lfth", "lts", "lst", "lkt", "lks" + , "rmth", "rpt", "rps", "rts", "rst", "rkt" + , "mpt", "mps", "ndth", "ŋkt", "ŋks", "ŋkth" + , "ksth", "kst" + ] + , _numOnsets = Interval.singleton 1 + , _numNuclei = Interval.singleton 1 + , _numCodas = Interval.singleton 1 + } diff --git a/users/grfn/xanthous/src/Xanthous/Orphans.hs b/users/grfn/xanthous/src/Xanthous/Orphans.hs index 1fe9708edbe0..2a9a7a7ebc29 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 PatternSynonyms #-} {-# LANGUAGE PackageImports #-} {-# OPTIONS_GHC -Wno-orphans #-} -------------------------------------------------------------------------------- +{-# OPTIONS_GHC -Wno-deferred-type-errors #-} module Xanthous.Orphans ( ppTemplate ) where @@ -31,6 +31,8 @@ import Linear -------------------------------------------------------------------------------- import Xanthous.Util.JSON import Xanthous.Util.QuickCheck +import qualified Data.Interval as Interval +import Data.Interval (Interval, Extended (..)) -------------------------------------------------------------------------------- instance forall s a. @@ -350,3 +352,23 @@ deriving newtype instance (Arbitrary s, CoArbitrary (m (a, s))) deriving via (GenericArbitrary (V2 a)) instance Arbitrary a => Arbitrary (V2 a) instance CoArbitrary a => CoArbitrary (V2 a) instance Function a => Function (V2 a) + +-------------------------------------------------------------------------------- + +instance Arbitrary r => Arbitrary (Extended r) where + arbitrary = oneof [ pure NegInf + , pure PosInf + , Finite <$> arbitrary + ] + +instance Arbitrary Interval.Boundary where + arbitrary = elements [ Interval.Open , Interval.Closed ] + +instance (Ord r, Arbitrary r) => Arbitrary (Interval r) where + arbitrary = do + lower <- arbitrary + upper <- arbitrary + pure $ (if upper < lower then flip else id) + Interval.interval + lower + upper 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