{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
module Synthesizer.Plain.Control (
constant,
linear,
linearMultiscale,
linearMultiscaleNeutral,
linearStable,
linearMean,
line,
exponential, exponentialMultiscale, exponentialStable,
exponentialMultiscaleNeutral,
exponential2, exponential2Multiscale, exponential2Stable,
exponential2MultiscaleNeutral,
exponentialFromTo, exponentialFromToMultiscale,
vectorExponential,
vectorExponential2,
cosine, cosineMultiscale, cosineSubdiv, cosineStable,
cubicHermite,
cubicHermiteStable,
curveMultiscale,
curveMultiscaleNeutral,
cubicFunc,
cosineWithSlope,
) where
import qualified Synthesizer.Plain.Signal as Sig
import Data.List (zipWith4, tails, )
import Data.List.HT (iterateAssociative, )
import qualified Algebra.Module as Module
import qualified Algebra.Transcendental as Trans
import qualified Algebra.Field as Field
import qualified Algebra.Ring as Ring
import qualified Algebra.Additive as Additive
import Number.Complex (cis,real, )
import NumericPrelude.Numeric
import NumericPrelude.Base
constant :: y -> Sig.T y
constant :: forall y. y -> T y
constant = forall y. y -> T y
repeat
linear :: Additive.C y =>
y
-> y
-> Sig.T y
linear :: forall y. C y => y -> y -> T y
linear y
d y
y0 = forall a. (a -> a) -> a -> [a]
iterate (y
dforall a. C a => a -> a -> a
+) y
y0
linearMultiscale :: Additive.C y =>
y
-> y
-> Sig.T y
linearMultiscale :: forall y. C y => y -> y -> T y
linearMultiscale = forall y. (y -> y -> y) -> y -> y -> T y
curveMultiscale forall a. C a => a -> a -> a
(+)
linearMultiscaleNeutral :: Additive.C y =>
y
-> Sig.T y
linearMultiscaleNeutral :: forall y. C y => y -> T y
linearMultiscaleNeutral y
slope =
forall y. (y -> y -> y) -> y -> y -> T y
curveMultiscaleNeutral forall a. C a => a -> a -> a
(+) y
slope forall a. C a => a
zero
linearStable :: Ring.C y =>
y
-> y
-> Sig.T y
linearStable :: forall y. C y => y -> y -> T y
linearStable y
d y
y0 =
forall t y. C t => (t -> y) -> (y -> y -> y) -> t -> y -> T y
curveStable (y
dforall a. C a => a -> a -> a
*) forall a. C a => a -> a -> a
(+) y
1 y
y0
linearMean :: Field.C y =>
y
-> y
-> Sig.T y
linearMean :: forall y. C y => y -> y -> T y
linearMean y
d y
y0 = y
y0 forall a. a -> [a] -> [a]
:
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\y
pow [y]
xs -> y
y0forall a. C a => a -> a -> a
+y
pow forall a. a -> [a] -> [a]
: forall y. C y => T y -> T y
linearSubdivision [y]
xs)
forall a. a
unreachable (forall a. (a -> a) -> a -> [a]
iterate (y
2forall a. C a => a -> a -> a
*) y
d)
linearSubdivision :: Field.C y =>
Sig.T y
-> Sig.T y
linearSubdivision :: forall y. C y => T y -> T y
linearSubdivision = forall y. (y -> y -> y) -> T y -> T y
subdivide (\y
x0 y
x1 -> (y
x0forall a. C a => a -> a -> a
+y
x1)forall a. C a => a -> a -> a
/y
2)
line :: Field.C y =>
Int
-> (y,y)
-> Sig.T y
line :: forall y. C y => Int -> (y, y) -> T y
line Int
n (y
y0,y
y1) =
forall a. Int -> [a] -> [a]
take Int
n forall a b. (a -> b) -> a -> b
$ forall y. C y => y -> y -> T y
linear ((y
y1forall a. C a => a -> a -> a
-y
y0) forall a. C a => a -> a -> a
/ forall a b. (C a, C b) => a -> b
fromIntegral Int
n) y
y0
exponential, exponentialMultiscale, exponentialStable :: Trans.C y =>
y
-> y
-> Sig.T y
exponential :: forall y. C y => y -> y -> T y
exponential y
time = forall a. (a -> a) -> a -> [a]
iterate (forall a. C a => a -> a -> a
* forall a. C a => a -> a
exp (- forall a. C a => a -> a
recip y
time))
exponentialMultiscale :: forall y. C y => y -> y -> T y
exponentialMultiscale y
time = forall y. (y -> y -> y) -> y -> y -> T y
curveMultiscale forall a. C a => a -> a -> a
(*) (forall a. C a => a -> a
exp (- forall a. C a => a -> a
recip y
time))
exponentialStable :: forall y. C y => y -> y -> T y
exponentialStable y
time = forall y t. (C y, C t) => (t -> y) -> t -> y -> T y
exponentialStableGen forall a. C a => a -> a
exp (- forall a. C a => a -> a
recip y
time)
exponentialMultiscaleNeutral :: Trans.C y =>
y
-> Sig.T y
exponentialMultiscaleNeutral :: forall y. C y => y -> T y
exponentialMultiscaleNeutral y
time =
forall y. (y -> y -> y) -> y -> y -> T y
curveMultiscaleNeutral forall a. C a => a -> a -> a
(*) (forall a. C a => a -> a
exp (- forall a. C a => a -> a
recip y
time)) forall a. C a => a
one
exponential2, exponential2Multiscale, exponential2Stable :: Trans.C y =>
y
-> y
-> Sig.T y
exponential2 :: forall y. C y => y -> y -> T y
exponential2 y
halfLife = forall a. (a -> a) -> a -> [a]
iterate (forall a. C a => a -> a -> a
* y
0.5 forall a. C a => a -> a -> a
** forall a. C a => a -> a
recip y
halfLife)
exponential2Multiscale :: forall y. C y => y -> y -> T y
exponential2Multiscale y
halfLife = forall y. (y -> y -> y) -> y -> y -> T y
curveMultiscale forall a. C a => a -> a -> a
(*) (y
0.5 forall a. C a => a -> a -> a
** forall a. C a => a -> a
recip y
halfLife)
exponential2Stable :: forall y. C y => y -> y -> T y
exponential2Stable y
halfLife = forall y t. (C y, C t) => (t -> y) -> t -> y -> T y
exponentialStableGen (y
0.5 forall a. C a => a -> a -> a
**) (forall a. C a => a -> a
recip y
halfLife)
exponential2MultiscaleNeutral :: Trans.C y =>
y
-> Sig.T y
exponential2MultiscaleNeutral :: forall y. C y => y -> T y
exponential2MultiscaleNeutral y
halfLife =
forall y. (y -> y -> y) -> y -> y -> T y
curveMultiscaleNeutral forall a. C a => a -> a -> a
(*) (y
0.5 forall a. C a => a -> a -> a
** forall a. C a => a -> a
recip y
halfLife) forall a. C a => a
one
exponentialFromTo, exponentialFromToMultiscale :: Trans.C y =>
y
-> y
-> y
-> Sig.T y
exponentialFromTo :: forall y. C y => y -> y -> y -> T y
exponentialFromTo y
time y
y0 y
y1 =
forall a. (a -> a) -> a -> [a]
iterate (forall a. C a => a -> a -> a
* (y
y1forall a. C a => a -> a -> a
/y
y0) forall a. C a => a -> a -> a
** forall a. C a => a -> a
recip y
time) y
y0
exponentialFromToMultiscale :: forall y. C y => y -> y -> y -> T y
exponentialFromToMultiscale y
time y
y0 y
y1 =
forall y. (y -> y -> y) -> y -> y -> T y
curveMultiscale forall a. C a => a -> a -> a
(*) ((y
y1forall a. C a => a -> a -> a
/y
y0) forall a. C a => a -> a -> a
** forall a. C a => a -> a
recip y
time) y
y0
exponentialStableGen :: (Ring.C y, Ring.C t) =>
(t -> y)
-> t
-> y
-> Sig.T y
exponentialStableGen :: forall y t. (C y, C t) => (t -> y) -> t -> y -> T y
exponentialStableGen t -> y
expFunc = forall t y. C t => (t -> y) -> (y -> y -> y) -> t -> y -> T y
curveStable t -> y
expFunc forall a. C a => a -> a -> a
(*)
vectorExponential :: (Trans.C y, Module.C y v) =>
y
-> v
-> Sig.T v
vectorExponential :: forall y v. (C y, C y v) => y -> v -> T v
vectorExponential y
time v
y0 = forall a. (a -> a) -> a -> [a]
iterate (forall a. C a => a -> a
exp (-y
1forall a. C a => a -> a -> a
/y
time) forall a v. C a v => a -> v -> v
*>) v
y0
vectorExponential2 :: (Trans.C y, Module.C y v) =>
y
-> v
-> Sig.T v
vectorExponential2 :: forall y v. (C y, C y v) => y -> v -> T v
vectorExponential2 y
halfLife v
y0 = forall a. (a -> a) -> a -> [a]
iterate (y
0.5forall a. C a => a -> a -> a
**(y
1forall a. C a => a -> a -> a
/y
halfLife) forall a v. C a v => a -> v -> v
*>) v
y0
cosine, cosineMultiscale, cosineSubdiv, cosineStable :: Trans.C y =>
y
-> y
-> Sig.T y
cosine :: forall y. C y => y -> y -> T y
cosine = forall y signal. C y => (y -> y -> signal) -> y -> y -> signal
cosineWithSlope forall a b. (a -> b) -> a -> b
$
\y
d y
x -> forall a b. (a -> b) -> [a] -> [b]
map forall a. C a => a -> a
cos (forall y. C y => y -> y -> T y
linear y
d y
x)
cosineMultiscale :: forall y. C y => y -> y -> T y
cosineMultiscale = forall y signal. C y => (y -> y -> signal) -> y -> y -> signal
cosineWithSlope forall a b. (a -> b) -> a -> b
$
\y
d y
x -> forall a b. (a -> b) -> [a] -> [b]
map forall a. T a -> a
real (forall y. (y -> y -> y) -> y -> y -> T y
curveMultiscale forall a. C a => a -> a -> a
(*) (forall a. C a => a -> T a
cis y
d) (forall a. C a => a -> T a
cis y
x))
cosineSubdiv :: forall y. C y => y -> y -> T y
cosineSubdiv =
let aux :: a -> a -> [a]
aux a
d a
y0 =
forall a. C a => a -> a
cos a
y0 forall a. a -> [a] -> [a]
:
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a
pow [a]
xs -> forall a. C a => a -> a
cos(a
y0forall a. C a => a -> a -> a
+a
pow) forall a. a -> [a] -> [a]
: forall y. C y => y -> T y -> T y
cosineSubdivision a
pow [a]
xs)
forall a. a
unreachable (forall a. (a -> a) -> a -> [a]
iterate (a
2forall a. C a => a -> a -> a
*) a
d)
in forall y signal. C y => (y -> y -> signal) -> y -> y -> signal
cosineWithSlope forall y. C y => y -> y -> T y
aux
cosineSubdivision :: Trans.C y =>
y
-> Sig.T y
-> Sig.T y
cosineSubdivision :: forall y. C y => y -> T y -> T y
cosineSubdivision y
angle =
let k :: y
k = forall a. C a => a -> a
recip (y
2 forall a. C a => a -> a -> a
* forall a. C a => a -> a
cos y
angle)
in forall y. (y -> y -> y) -> T y -> T y
subdivide (\y
x0 y
x1 -> (y
x0forall a. C a => a -> a -> a
+y
x1)forall a. C a => a -> a -> a
*y
k)
cosineStable :: forall y. C y => y -> y -> T y
cosineStable = forall y signal. C y => (y -> y -> signal) -> y -> y -> signal
cosineWithSlope forall a b. (a -> b) -> a -> b
$
\y
d y
x -> forall a b. (a -> b) -> [a] -> [b]
map forall a. T a -> a
real (forall y t. (C y, C t) => (t -> y) -> t -> y -> T y
exponentialStableGen forall a. C a => a -> T a
cis y
d (forall a. C a => a -> T a
cis y
x))
cosineWithSlope :: Trans.C y =>
(y -> y -> signal)
-> y
-> y
-> signal
cosineWithSlope :: forall y signal. C y => (y -> y -> signal) -> y -> y -> signal
cosineWithSlope y -> y -> signal
c y
t0 y
t1 =
let inc :: y
inc = forall a. C a => a
piforall a. C a => a -> a -> a
/(y
t1forall a. C a => a -> a -> a
-y
t0)
in y -> y -> signal
c y
inc (-y
t0forall a. C a => a -> a -> a
*y
inc)
cubicHermite :: Field.C y => (y, (y,y)) -> (y, (y,y)) -> Sig.T y
cubicHermite :: forall y. C y => (y, (y, y)) -> (y, (y, y)) -> T y
cubicHermite (y, (y, y))
node0 (y, (y, y))
node1 =
forall a b. (a -> b) -> [a] -> [b]
map (forall y. C y => (y, (y, y)) -> (y, (y, y)) -> y -> y
cubicFunc (y, (y, y))
node0 (y, (y, y))
node1) (forall y. C y => y -> y -> T y
linear y
1 y
0)
cubicFunc :: Field.C y => (y, (y,y)) -> (y, (y,y)) -> y -> y
cubicFunc :: forall y. C y => (y, (y, y)) -> (y, (y, y)) -> y -> y
cubicFunc (y
t0, (y
y0,y
dy0)) (y
t1, (y
y1,y
dy1)) y
t =
let dt :: y
dt = y
t0forall a. C a => a -> a -> a
-y
t1
dt0 :: y
dt0 = y
tforall a. C a => a -> a -> a
-y
t0
dt1 :: y
dt1 = y
tforall a. C a => a -> a -> a
-y
t1
x0 :: y
x0 = y
dt1forall a. C a => a -> Integer -> a
^Integer
2
x1 :: y
x1 = y
dt0forall a. C a => a -> Integer -> a
^Integer
2
in ((y
dy0forall a. C a => a -> a -> a
*y
dt0 forall a. C a => a -> a -> a
+ y
y0 forall a. C a => a -> a -> a
* (y
1forall a. C a => a -> a -> a
-y
2forall a. C a => a -> a -> a
/y
dtforall a. C a => a -> a -> a
*y
dt0)) forall a. C a => a -> a -> a
* y
x0 forall a. C a => a -> a -> a
+
(y
dy1forall a. C a => a -> a -> a
*y
dt1 forall a. C a => a -> a -> a
+ y
y1 forall a. C a => a -> a -> a
* (y
1forall a. C a => a -> a -> a
+y
2forall a. C a => a -> a -> a
/y
dtforall a. C a => a -> a -> a
*y
dt1)) forall a. C a => a -> a -> a
* y
x1) forall a. C a => a -> a -> a
/ y
dtforall a. C a => a -> Integer -> a
^Integer
2
cubicHermiteStable :: Field.C y => (y, (y,y)) -> (y, (y,y)) -> Sig.T y
cubicHermiteStable :: forall y. C y => (y, (y, y)) -> (y, (y, y)) -> T y
cubicHermiteStable (y, (y, y))
node0 (y, (y, y))
node1 =
forall y. C y => (y, (y, y)) -> (y, (y, y)) -> y -> y
cubicFunc (y, (y, y))
node0 (y, (y, y))
node1 y
0 forall a. a -> [a] -> [a]
:
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\y
pow [y]
xs ->
forall y. C y => (y, (y, y)) -> (y, (y, y)) -> y -> y
cubicFunc (y, (y, y))
node0 (y, (y, y))
node1 y
pow forall a. a -> [a] -> [a]
: forall a. [a] -> a
head [y]
xs forall a. a -> [a] -> [a]
:
forall y. C y => (y, (y, y)) -> (y, (y, y)) -> y -> y
cubicFunc (y, (y, y))
node0 (y, (y, y))
node1 (y
3forall a. C a => a -> a -> a
*y
pow) forall a. a -> [a] -> [a]
: forall y. C y => T y -> T y
cubicSubdivision [y]
xs)
forall a. a
unreachable (forall a. (a -> a) -> a -> [a]
iterate (y
2forall a. C a => a -> a -> a
*) y
1)
cubicSubdivision :: Field.C y => Sig.T y -> Sig.T y
cubicSubdivision :: forall y. C y => T y -> T y
cubicSubdivision T y
xs =
let T y
xs0:T y
xs1:T y
xs2:T y
xs3:[T y]
_ = forall a. [a] -> [[a]]
tails T y
xs
inter :: T y
inter = forall a b c d e.
(a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e]
zipWith4 (\y
x0 y
x1 y
x2 y
x3 -> (y
9forall a. C a => a -> a -> a
*(y
x1forall a. C a => a -> a -> a
+y
x2) forall a. C a => a -> a -> a
- (y
x0forall a. C a => a -> a -> a
+y
x3))forall a. C a => a -> a -> a
/y
16)
T y
xs0 T y
xs1 T y
xs2 T y
xs3
in forall a. [a] -> a
head T y
xs1 forall a. a -> [a] -> [a]
: forall a. T (a, a) -> T a
flattenPairs (forall a b. [a] -> [b] -> [(a, b)]
zip T y
inter T y
xs2)
curveStable :: (Additive.C t) =>
(t -> y)
-> (y -> y -> y)
-> t
-> y
-> Sig.T y
curveStable :: forall t y. C t => (t -> y) -> (y -> y -> y) -> t -> y -> T y
curveStable t -> y
expFunc y -> y -> y
op t
time y
y0 =
y
y0 forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (y -> y -> y
op y
y0)
(forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
(\t
e [y]
xs ->
let k :: y
k = t -> y
expFunc t
e
in y
k forall a. a -> [a] -> [a]
: forall a b. (a -> (b, b)) -> T a -> T b
concatMapPair (\y
x -> (y
x, y -> y -> y
op y
x y
k)) [y]
xs)
forall a. a
unreachable (forall a. (a -> a) -> a -> [a]
iterate forall t. C t => t -> t
double t
time))
unreachable :: a
unreachable :: forall a. a
unreachable = forall a. HasCallStack => [Char] -> a
error [Char]
"only reachable in infinity"
double :: Additive.C t => t -> t
double :: forall t. C t => t -> t
double t
t = t
tforall a. C a => a -> a -> a
+t
t
concatMapPair :: (a -> (b,b)) -> Sig.T a -> Sig.T b
concatMapPair :: forall a b. (a -> (b, b)) -> T a -> T b
concatMapPair a -> (b, b)
f = forall a. T (a, a) -> T a
flattenPairs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map a -> (b, b)
f
flattenPairs :: Sig.T (a,a) -> Sig.T a
flattenPairs :: forall a. T (a, a) -> T a
flattenPairs = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(a
a,a
b) T a
xs -> a
aforall a. a -> [a] -> [a]
:a
bforall a. a -> [a] -> [a]
:T a
xs) []
subdivide :: (y -> y -> y) -> Sig.T y -> Sig.T y
subdivide :: forall y. (y -> y -> y) -> T y -> T y
subdivide y -> y -> y
f xs0 :: T y
xs0@(y
x:T y
xs1) =
y
x forall a. a -> [a] -> [a]
: forall a. T (a, a) -> T a
flattenPairs (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\y
x0 y
x1 -> (y -> y -> y
f y
x0 y
x1, y
x1)) T y
xs0 T y
xs1)
subdivide y -> y -> y
_ [] = []
_concatMapPair :: (a -> (b,b)) -> Sig.T a -> Sig.T b
_concatMapPair :: forall a b. (a -> (b, b)) -> T a -> T b
_concatMapPair a -> (b, b)
f = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((\(b
x,b
y) -> [b
x,b
y]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> (b, b)
f)
curveMultiscale :: (y -> y -> y) -> y -> y -> Sig.T y
curveMultiscale :: forall y. (y -> y -> y) -> y -> y -> T y
curveMultiscale y -> y -> y
op y
d y
y0 =
y
y0 forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (y -> y -> y
op y
y0) (forall a. (a -> a -> a) -> a -> [a]
iterateAssociative y -> y -> y
op y
d)
curveMultiscaleNeutral :: (y -> y -> y) -> y -> y -> Sig.T y
curveMultiscaleNeutral :: forall y. (y -> y -> y) -> y -> y -> T y
curveMultiscaleNeutral y -> y -> y
op y
d y
neutral =
y
neutral forall a. a -> [a] -> [a]
: forall a. (a -> a -> a) -> a -> [a]
iterateAssociative y -> y -> y
op y
d