diff options
Diffstat (limited to 'users/grfn/xanthous/src/Xanthous')
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Generators/Speech.hs | 108 | ||||
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Orphans.hs | 24 | ||||
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Random.hs | 39 |
3 files changed, 167 insertions, 4 deletions
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 0000000000..76830c4d91 --- /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 + +-------------------------------------------------------------------------------- + +-- <https://en.wikipedia.org/wiki/English_phonology#Phonotactics> +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 1fe9708edb..2a9a7a7ebc 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 6d34109df7..d97dcb9e11 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 |