module Synthesizer.Causal.ToneModulation (
ToneModS.interpolateCell,
seekCell,
oscillatorCells,
oscillatorSuffixes,
integrateFractional,
integrateFractionalClip,
limitRelativeShapes,
limitMinRelativeValues,
) where
import qualified Synthesizer.Basic.ToneModulation as ToneMod
import qualified Synthesizer.Basic.Phase as Phase
import qualified Synthesizer.State.ToneModulation as ToneModS
import qualified Synthesizer.Interpolation as Interpolation
import qualified Synthesizer.Causal.Oscillator.Core as Osci
import qualified Synthesizer.Causal.Process as Causal
import qualified Synthesizer.Generic.Signal as SigG
import Control.Arrow (first, (<<<), (<<^), (^<<), (&&&), (***), )
import Control.Monad.Trans.State (state, )
import Data.Tuple.HT (mapFst, )
import qualified Algebra.RealField as RealField
import qualified Algebra.Ring as Ring
import qualified Algebra.Additive as Additive
import NumericPrelude.Numeric
import NumericPrelude.Base
import Prelude ()
oscillatorCells :: (RealField.C t, SigG.Transform sig y) =>
Interpolation.Margin ->
Interpolation.Margin ->
Int -> t -> sig y -> (t, Phase.T t) ->
Causal.T (t,t) ((t,t), ToneModS.Cell sig y)
oscillatorCells :: forall t (sig :: * -> *) y.
(C t, Transform sig y) =>
Margin
-> Margin
-> Int
-> t
-> sig y
-> (t, T t)
-> T (t, t) ((t, t), Cell sig y)
oscillatorCells
Margin
marginLeap Margin
marginStep Int
periodInt t
period sig y
sampledTone (t
shape0, T t
phase) =
Int -> t -> ((t, T t), sig y) -> ((t, t), Cell sig y)
forall t (sig :: * -> *) y.
(C t, Transform sig y) =>
Int -> t -> ((t, T t), sig y) -> ((t, t), Cell sig y)
seekCell Int
periodInt t
period
(((t, T t), sig y) -> ((t, t), Cell sig y))
-> T (t, t) ((t, T t), sig y) -> T (t, t) ((t, t), Cell sig y)
forall (a :: * -> * -> *) c d b.
Arrow a =>
(c -> d) -> a b c -> a b d
^<< Margin
-> Margin
-> Int
-> t
-> sig y
-> (t, T t)
-> T (t, t) ((t, T t), sig y)
forall t (sig :: * -> *) y.
(C t, Transform sig y) =>
Margin
-> Margin
-> Int
-> t
-> sig y
-> (t, T t)
-> T (t, t) ((t, T t), sig y)
oscillatorSuffixes Margin
marginLeap Margin
marginStep
Int
periodInt t
period sig y
sampledTone (t
shape0, T t
phase)
seekCell :: (RealField.C t, SigG.Transform sig y) =>
Int -> t ->
((t, Phase.T t), sig y) ->
((t,t), ToneModS.Cell sig y)
seekCell :: forall t (sig :: * -> *) y.
(C t, Transform sig y) =>
Int -> t -> ((t, T t), sig y) -> ((t, t), Cell sig y)
seekCell Int
periodInt t
period =
(\((t, T t)
sp,sig y
ptr) ->
let (Int
k,(t, t)
q) = Int -> t -> (t, T t) -> (Int, (t, t))
forall a. C a => Int -> a -> (a, T a) -> (Int, (a, a))
ToneMod.flattenShapePhase Int
periodInt t
period (t, T t)
sp
in ((t, t)
q, Int -> sig y -> Cell sig y
forall (sig :: * -> *) y.
Transform sig y =>
Int -> sig y -> Cell sig y
ToneModS.makeCell Int
periodInt (sig y -> Cell sig y) -> sig y -> Cell sig y
forall a b. (a -> b) -> a -> b
$
Int -> sig y -> sig y
forall sig. Transform sig => Int -> sig -> sig
SigG.drop (Int -> Int
forall a. (Ord a, C a, Show a) => a -> a
ToneModS.checkNonNeg (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
periodIntInt -> Int -> Int
forall a. C a => a -> a -> a
+Int
k) sig y
ptr))
oscillatorSuffixes :: (RealField.C t, SigG.Transform sig y) =>
Interpolation.Margin ->
Interpolation.Margin ->
Int -> t ->
sig y -> (t, Phase.T t) ->
Causal.T (t,t) ((t, Phase.T t), sig y)
oscillatorSuffixes :: forall t (sig :: * -> *) y.
(C t, Transform sig y) =>
Margin
-> Margin
-> Int
-> t
-> sig y
-> (t, T t)
-> T (t, t) ((t, T t), sig y)
oscillatorSuffixes
Margin
marginLeap Margin
marginStep Int
periodInt t
period sig y
sampledTone (t
shape0, T t
phase) =
let margin :: Int
margin =
Margin -> Margin -> Int -> Int
ToneMod.interpolationNumber Margin
marginLeap Margin
marginStep Int
periodInt
ipOffset :: Int
ipOffset =
Int
periodInt Int -> Int -> Int
forall a. C a => a -> a -> a
+
Margin -> Margin -> Int -> Int
ToneMod.interpolationOffset Margin
marginLeap Margin
marginStep Int
periodInt
(t
shape0min, T t t
shapeLimiter) =
t -> t -> (t, T t t)
forall t. (C t, Ord t) => t -> t -> (t, T t t)
limitMinRelativeValues (Int -> t
forall a b. (C a, C b) => a -> b
fromIntegral Int
ipOffset) t
shape0
((Int
skip0,(t, T t)
coord0), T (t, t) (Skip t)
coordinator) =
t -> (t, T t) -> (Skip t, T (t, t) (Skip t))
forall t. C t => t -> (t, T t) -> (Skip t, T (t, t) (Skip t))
integrateFractional t
period (t
shape0min, T t
phase)
in (\(((Bool
b,Int
n),sig y
ptr), sp :: (t, T t)
sp@(t
_,T t
p)) ->
(if Bool
b
then (t
forall a. C a => a
zero, t -> T t -> T t
forall a. C a => a -> T a -> T a
Phase.increment (Int -> t
forall a b. (C a, C b) => a -> b
fromIntegral Int
n t -> t -> t
forall a. C a => a -> a -> a
/ t
period) T t
p)
else (t, T t)
sp,
sig y
ptr))
((((Bool, Int), sig y), (t, T t)) -> ((t, T t), sig y))
-> T (t, t) (((Bool, Int), sig y), (t, T t))
-> T (t, t) ((t, T t), sig y)
forall (a :: * -> * -> *) c d b.
Arrow a =>
(c -> d) -> a b c -> a b d
^<<
((((Bool, Int), sig y) -> Int -> ((Bool, Int), sig y))
-> ((Bool, Int), sig y) -> T Int ((Bool, Int), sig y)
forall acc x. (acc -> x -> acc) -> acc -> T x acc
Causal.scanL
(\ ((Bool
_,Int
n),sig y
ptr) Int
d -> Int -> Int -> sig y -> ((Bool, Int), sig y)
forall (sig :: * -> *) y.
Transform sig y =>
Int -> Int -> sig y -> ((Bool, Int), sig y)
dropMargin Int
margin (Int
nInt -> Int -> Int
forall a. C a => a -> a -> a
+Int
d) sig y
ptr)
(Int -> Int -> sig y -> ((Bool, Int), sig y)
forall (sig :: * -> *) y.
Transform sig y =>
Int -> Int -> sig y -> ((Bool, Int), sig y)
dropMargin Int
margin (Int
skip0 Int -> Int -> Int
forall a. C a => a -> a -> a
- Int
ipOffset) sig y
sampledTone)
T Int ((Bool, Int), sig y)
-> T (t, T t) (t, T t)
-> T (Skip t) (((Bool, Int), sig y), (t, T t))
forall b c b' c'. T b c -> T b' c' -> T (b, b') (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
***
(t, T t) -> T (t, T t) (t, T t)
forall x. x -> T x x
Causal.consInit (t, T t)
coord0)
T (Skip t) (((Bool, Int), sig y), (t, T t))
-> T (t, t) (Skip t) -> T (t, t) (((Bool, Int), sig y), (t, T t))
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<<
T (t, t) (Skip t)
coordinator
T (t, t) (Skip t) -> T (t, t) (t, t) -> T (t, t) (Skip t)
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<<
T t t -> T (t, t) (t, t)
forall b c d. T b c -> T (b, d) (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
Causal.first T t t
shapeLimiter
dropMargin :: (SigG.Transform sig y) =>
Int -> Int -> sig y -> ((Bool, Int), sig y)
dropMargin :: forall (sig :: * -> *) y.
Transform sig y =>
Int -> Int -> sig y -> ((Bool, Int), sig y)
dropMargin Int
margin Int
n sig y
xs =
(Int -> (Bool, Int)) -> (Int, sig y) -> ((Bool, Int), sig y)
forall a c b. (a -> c) -> (a, b) -> (c, b)
mapFst ((,) (Int -> sig y -> Bool
forall sig. Transform sig => Int -> sig -> Bool
SigG.lengthAtMost (Int
marginInt -> Int -> Int
forall a. C a => a -> a -> a
+Int
n) sig y
xs)) ((Int, sig y) -> ((Bool, Int), sig y))
-> (Int, sig y) -> ((Bool, Int), sig y)
forall a b. (a -> b) -> a -> b
$
Int -> Int -> sig y -> (Int, sig y)
forall sig. Transform sig => Int -> Int -> sig -> (Int, sig)
SigG.dropMarginRem Int
margin (Int -> Int
forall a. (Ord a, C a, Show a) => a -> a
ToneModS.checkNonNeg Int
n) sig y
xs
regroup :: (Int,t) -> Phase.T t -> ToneMod.Skip t
regroup :: forall t. (Int, t) -> T t -> Skip t
regroup (Int
d,t
s) T t
p = (Int
d, (t
s,T t
p))
integrateFractional :: (RealField.C t) =>
t ->
(t, Phase.T t) ->
(ToneMod.Skip t, Causal.T (t,t) (ToneMod.Skip t))
integrateFractional :: forall t. C t => t -> (t, T t) -> (Skip t, T (t, t) (Skip t))
integrateFractional t
period (t
shape0, T t
phase) =
let sf0 :: (Int, t)
sf0 = t -> (Int, t)
forall b. C b => t -> (b, t)
forall a b. (C a, C b) => a -> (b, a)
splitFraction t
shape0
shapeOffsets :: T t (Int, t)
shapeOffsets =
(t -> State t (Int, t)) -> t -> T t (Int, t)
forall a s b. (a -> State s b) -> s -> T a b
Causal.fromState
(\t
c -> (t -> ((Int, t), t)) -> State t (Int, t)
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state ((t -> ((Int, t), t)) -> State t (Int, t))
-> (t -> ((Int, t), t)) -> State t (Int, t)
forall a b. (a -> b) -> a -> b
$ \t
s0 ->
let s1 :: (Int, t)
s1 = t -> (Int, t)
forall b. C b => t -> (b, t)
forall a b. (C a, C b) => a -> (b, a)
splitFraction (t
s0t -> t -> t
forall a. C a => a -> a -> a
+t
c)
in ((Int, t)
s1, (Int, t) -> t
forall a b. (a, b) -> b
snd (Int, t)
s1))
((Int, t) -> t
forall a b. (a, b) -> b
snd (Int, t)
sf0)
scale :: (a, b) -> t
scale (a
n,b
_) = a -> t
forall a b. (C a, C b) => a -> b
fromIntegral a
n t -> t -> t
forall a. C a => a -> a -> a
/ t
period
phase0 :: T t
phase0 = t -> T t -> T t
forall a. C a => a -> T a -> T a
Phase.decrement ((Int, t) -> t
forall {a} {b}. C a => (a, b) -> t
scale (Int, t)
sf0) T t
phase
phases :: T ((Int, b), t) (T t)
phases =
T t -> T t (T t)
forall a. C a => T a -> T a (T a)
Osci.freqModSync T t
phase0
T t (T t) -> (((Int, b), t) -> t) -> T ((Int, b), t) (T t)
forall (a :: * -> * -> *) c d b.
Arrow a =>
a c d -> (b -> c) -> a b d
<<^ (\((Int, b)
s,t
f) -> t
f t -> t -> t
forall a. C a => a -> a -> a
- (Int, b) -> t
forall {a} {b}. C a => (a, b) -> t
scale (Int, b)
s)
in ((Int, t) -> T t -> Skip t
forall t. (Int, t) -> T t -> Skip t
regroup (Int, t)
sf0 T t
phase0,
((Int, t) -> T t -> Skip t) -> ((Int, t), T t) -> Skip t
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Int, t) -> T t -> Skip t
forall t. (Int, t) -> T t -> Skip t
regroup
(((Int, t), T t) -> Skip t)
-> T (t, t) ((Int, t), T t) -> T (t, t) (Skip t)
forall (a :: * -> * -> *) c d b.
Arrow a =>
(c -> d) -> a b c -> a b d
^<<
((((Int, t), t) -> (Int, t)) -> T ((Int, t), t) (Int, t)
forall a b. (a -> b) -> T a b
Causal.map ((Int, t), t) -> (Int, t)
forall a b. (a, b) -> a
fst T ((Int, t), t) (Int, t)
-> T ((Int, t), t) (T t) -> T ((Int, t), t) ((Int, t), T t)
forall b c c'. T b c -> T b c' -> T b (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& T ((Int, t), t) (T t)
forall {b}. T ((Int, b), t) (T t)
phases)
T ((Int, t), t) ((Int, t), T t)
-> T (t, t) ((Int, t), t) -> T (t, t) ((Int, t), T t)
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<<
T t (Int, t) -> T (t, t) ((Int, t), t)
forall b c d. T b c -> T (b, d) (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first T t (Int, t)
shapeOffsets)
integrateFractionalClip :: (RealField.C t) =>
t ->
(t, Phase.T t) ->
Causal.T (t,t) (ToneMod.Skip t)
integrateFractionalClip :: forall t. C t => t -> (t, T t) -> T (t, t) (Skip t)
integrateFractionalClip t
period (t
shape0, T t
phase) =
let sf0 :: (Int, t)
sf0 = t -> (Int, t)
forall b. C b => t -> (b, t)
forall a b. (C a, C b) => a -> (b, a)
splitFraction t
shape0
shapeOffsets :: T t (Int, t)
shapeOffsets =
(t -> State t (Int, t)) -> t -> T t (Int, t)
forall a s b. (a -> State s b) -> s -> T a b
Causal.fromState
(\t
c -> (t -> ((Int, t), t)) -> State t (Int, t)
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state ((t -> ((Int, t), t)) -> State t (Int, t))
-> (t -> ((Int, t), t)) -> State t (Int, t)
forall a b. (a -> b) -> a -> b
$ \t
s0 ->
let s1 :: (Int, t)
s1 = t -> (Int, t)
forall b. C b => t -> (b, t)
forall a b. (C a, C b) => a -> (b, a)
splitFraction (t
s0t -> t -> t
forall a. C a => a -> a -> a
+t
c)
in ((Int, t)
s1, (Int, t) -> t
forall a b. (a, b) -> b
snd (Int, t)
s1))
((Int, t) -> t
forall a b. (a, b) -> b
snd (Int, t)
sf0)
scale :: (a, b) -> t
scale (a
n,b
_) = a -> t
forall a b. (C a, C b) => a -> b
fromIntegral a
n t -> t -> t
forall a. C a => a -> a -> a
/ t
period
phases :: T ((Int, b), t) (T t)
phases =
T t -> T t (T t)
forall a. C a => T a -> T a (T a)
Osci.freqMod
(t -> T t -> T t
forall a. C a => a -> T a -> T a
Phase.decrement ((Int, t) -> t
forall {a} {b}. C a => (a, b) -> t
scale (Int, t)
sf0) T t
phase)
T t (T t) -> (((Int, b), t) -> t) -> T ((Int, b), t) (T t)
forall (a :: * -> * -> *) c d b.
Arrow a =>
a c d -> (b -> c) -> a b d
<<^ (\((Int, b)
s,t
f) -> t
f t -> t -> t
forall a. C a => a -> a -> a
- (Int, b) -> t
forall {a} {b}. C a => (a, b) -> t
scale (Int, b)
s)
in ((Int, t) -> T t -> Skip t) -> ((Int, t), T t) -> Skip t
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Int, t) -> T t -> Skip t
forall t. (Int, t) -> T t -> Skip t
regroup
(((Int, t), T t) -> Skip t)
-> T (t, t) ((Int, t), T t) -> T (t, t) (Skip t)
forall (a :: * -> * -> *) c d b.
Arrow a =>
(c -> d) -> a b c -> a b d
^<<
(((Int, t) -> T (Int, t) (Int, t)
forall x. x -> T x x
Causal.consInit (Int, t)
sf0 T (Int, t) (Int, t)
-> (((Int, t), t) -> (Int, t)) -> T ((Int, t), t) (Int, t)
forall (a :: * -> * -> *) c d b.
Arrow a =>
a c d -> (b -> c) -> a b d
<<^ ((Int, t), t) -> (Int, t)
forall a b. (a, b) -> a
fst) T ((Int, t), t) (Int, t)
-> T ((Int, t), t) (T t) -> T ((Int, t), t) ((Int, t), T t)
forall b c c'. T b c -> T b c' -> T b (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& T ((Int, t), t) (T t)
forall {b}. T ((Int, b), t) (T t)
phases)
T ((Int, t), t) ((Int, t), T t)
-> T (t, t) ((Int, t), t) -> T (t, t) ((Int, t), T t)
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<<
T t (Int, t) -> T (t, t) ((Int, t), t)
forall b c d. T b c -> T (b, d) (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first T t (Int, t)
shapeOffsets
limitRelativeShapes :: (Ring.C t, Ord t) =>
Interpolation.Margin ->
Interpolation.Margin ->
Int -> t -> (t, Causal.T t t)
limitRelativeShapes :: forall t.
(C t, Ord t) =>
Margin -> Margin -> Int -> t -> (t, T t t)
limitRelativeShapes Margin
marginLeap Margin
marginStep Int
periodInt =
t -> t -> (t, T t t)
forall t. (C t, Ord t) => t -> t -> (t, T t t)
limitMinRelativeValues (t -> t -> (t, T t t)) -> t -> t -> (t, T t t)
forall a b. (a -> b) -> a -> b
$ Int -> t
forall a b. (C a, C b) => a -> b
fromIntegral (Int -> t) -> Int -> t
forall a b. (a -> b) -> a -> b
$
Margin -> Margin -> Int -> Int
ToneMod.interpolationOffset Margin
marginLeap Margin
marginStep Int
periodInt Int -> Int -> Int
forall a. C a => a -> a -> a
+ Int
periodInt
limitMinRelativeValues :: (Additive.C t, Ord t) =>
t -> t -> (t, Causal.T t t)
limitMinRelativeValues :: forall t. (C t, Ord t) => t -> t -> (t, T t t)
limitMinRelativeValues t
xMin t
x0 =
let x1 :: t
x1 = t
xMint -> t -> t
forall a. C a => a -> a -> a
-t
x0
in if t
x1t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<=t
forall a. C a => a
zero
then (t
x0, T t t
forall a. T a a
Causal.id)
else (t
xMin,
(t -> t -> Maybe (t, t)) -> t -> T t t
forall x acc y. (x -> acc -> Maybe (y, acc)) -> acc -> T x y
Causal.crochetL
(\t
x t
lim -> (t, t) -> Maybe (t, t)
forall a. a -> Maybe a
Just ((t, t) -> Maybe (t, t)) -> (t, t) -> Maybe (t, t)
forall a b. (a -> b) -> a -> b
$
let d :: t
d = t
xt -> t -> t
forall a. C a => a -> a -> a
-t
lim
in if t
dt -> t -> Bool
forall a. Ord a => a -> a -> Bool
>=t
forall a. C a => a
zero
then (t
d,t
forall a. C a => a
zero) else (t
forall a. C a => a
zero, t -> t
forall a. C a => a -> a
negate t
d)) t
x1)