module Synthesizer.Plain.Control where
import Synthesizer.Plain.Displacement (raise)
import qualified Synthesizer.Plain.Signal as Sig
import qualified Algebra.Module as Module
import qualified Algebra.Transcendental as Trans
import qualified Algebra.RealRing as RealRing
import qualified Algebra.Field as Field
import qualified Algebra.Ring as Ring
import qualified Algebra.Additive as Additive
import Algebra.Module((*>))
import Number.Complex (cis,real)
import Data.List (zipWith4, tails, )
import Data.List.HT (iterateAssociative, )
import qualified Prelude as P
import NumericPrelude.Base
import NumericPrelude.Numeric
constant :: y -> Sig.T y
constant = repeat
linear :: Additive.C y =>
y
-> y
-> Sig.T y
linear d y0 = iterate (d+) y0
linearMultiscale :: Additive.C y =>
y
-> y
-> Sig.T y
linearMultiscale = curveMultiscale (+)
linearMultiscaleNeutral :: Additive.C y =>
y
-> Sig.T y
linearMultiscaleNeutral slope =
curveMultiscaleNeutral (+) slope zero
linearStable :: Ring.C y =>
y
-> y
-> Sig.T y
linearStable d y0 =
curveStable (d*) (+) 1 y0
linearMean :: Field.C y =>
y
-> y
-> Sig.T y
linearMean d y0 = y0 :
foldr (\pow xs -> y0+pow : linearSubdivision xs)
unreachable (iterate (2*) d)
linearSubdivision :: Field.C y =>
Sig.T y
-> Sig.T y
linearSubdivision = subdivide (\x0 x1 -> (x0+x1)/2)
line :: Field.C y =>
Int
-> (y,y)
-> Sig.T y
line n (y0,y1) =
take n $ linear ((y1y0) / fromIntegral n) y0
exponential, exponentialMultiscale, exponentialStable :: Trans.C y =>
y
-> y
-> Sig.T y
exponential time = iterate (* exp ( recip time))
exponentialMultiscale time = curveMultiscale (*) (exp ( recip time))
exponentialStable time = exponentialStableGen exp ( recip time)
exponentialMultiscaleNeutral :: Trans.C y =>
y
-> Sig.T y
exponentialMultiscaleNeutral time =
curveMultiscaleNeutral (*) (exp ( recip time)) one
exponential2, exponential2Multiscale, exponential2Stable :: Trans.C y =>
y
-> y
-> Sig.T y
exponential2 halfLife = iterate (* 0.5 ** recip halfLife)
exponential2Multiscale halfLife = curveMultiscale (*) (0.5 ** recip halfLife)
exponential2Stable halfLife = exponentialStableGen (0.5 **) (recip halfLife)
exponential2MultiscaleNeutral :: Trans.C y =>
y
-> Sig.T y
exponential2MultiscaleNeutral halfLife =
curveMultiscaleNeutral (*) (0.5 ** recip halfLife) one
exponentialFromTo, exponentialFromToMultiscale :: Trans.C y =>
y
-> y
-> y
-> Sig.T y
exponentialFromTo time y0 y1 =
iterate (* (y1/y0) ** recip time) y0
exponentialFromToMultiscale time y0 y1 =
curveMultiscale (*) ((y1/y0) ** recip time) y0
exponentialStableGen :: (Ring.C y, Ring.C t) =>
(t -> y)
-> t
-> y
-> Sig.T y
exponentialStableGen expFunc = curveStable expFunc (*)
vectorExponential :: (Trans.C y, Module.C y v) =>
y
-> v
-> Sig.T v
vectorExponential time y0 = iterate (exp (1/time) *>) y0
vectorExponential2 :: (Trans.C y, Module.C y v) =>
y
-> v
-> Sig.T v
vectorExponential2 halfLife y0 = iterate (0.5**(1/halfLife) *>) y0
cosine, cosineMultiscale, cosineSubdiv, cosineStable :: Trans.C y =>
y
-> y
-> Sig.T y
cosine = cosineWithSlope $
\d x -> map cos (linear d x)
cosineMultiscale = cosineWithSlope $
\d x -> map real (curveMultiscale (*) (cis d) (cis x))
cosineSubdiv =
let aux d y0 =
cos y0 :
foldr (\pow xs -> cos(y0+pow) : cosineSubdivision pow xs)
unreachable (iterate (2*) d)
in cosineWithSlope aux
cosineSubdivision :: Trans.C y =>
y
-> Sig.T y
-> Sig.T y
cosineSubdivision angle =
let k = recip (2 * cos angle)
in subdivide (\x0 x1 -> (x0+x1)*k)
cosineStable = cosineWithSlope $
\d x -> map real (exponentialStableGen cis d (cis x))
cosineWithSlope :: Trans.C y =>
(y -> y -> signal)
-> y
-> y
-> signal
cosineWithSlope c t0 t1 =
let inc = pi/(t1t0)
in c inc (t0*inc)
cubicHermite :: Field.C y => (y, (y,y)) -> (y, (y,y)) -> Sig.T y
cubicHermite node0 node1 =
map (cubicFunc node0 node1) (linear 1 0)
cubicFunc :: Field.C y => (y, (y,y)) -> (y, (y,y)) -> y -> y
cubicFunc (t0, (y0,dy0)) (t1, (y1,dy1)) t =
let dt = t0t1
dt0 = tt0
dt1 = tt1
x0 = dt1^2
x1 = dt0^2
in ((dy0*dt0 + y0 * (12/dt*dt0)) * x0 +
(dy1*dt1 + y1 * (1+2/dt*dt1)) * x1) / dt^2
cubicHermiteStable :: Field.C y => (y, (y,y)) -> (y, (y,y)) -> Sig.T y
cubicHermiteStable node0 node1 =
cubicFunc node0 node1 0 :
foldr (\pow xs ->
cubicFunc node0 node1 pow : head xs :
cubicFunc node0 node1 (3*pow) : cubicSubdivision xs)
unreachable (iterate (2*) 1)
cubicSubdivision :: Field.C y => Sig.T y -> Sig.T y
cubicSubdivision xs =
let xs0:xs1:xs2:xs3:_ = tails xs
inter = zipWith4 (\x0 x1 x2 x3 -> (9*(x1+x2) (x0+x3))/16)
xs0 xs1 xs2 xs3
in head xs1 : flattenPairs (zip inter xs2)
data Control y =
CtrlStep
| CtrlLin
| CtrlExp {ctrlExpSaturation :: y}
| CtrlCos
| CtrlCubic {ctrlCubicGradient0 :: y,
ctrlCubicGradient1 :: y}
deriving (Eq, Show)
data ControlPiece y =
ControlPiece {pieceType :: Control y,
pieceY0 :: y,
pieceY1 :: y,
pieceDur :: y}
deriving (Eq, Show)
newtype PieceRightSingle y = PRS y
newtype PieceRightDouble y = PRD y
type ControlDist y = (y, Control y, y)
infixr 5 -|#, #|-, =|#, #|=, |#, #|
( #|-) :: (y, Control y) -> (PieceRightSingle y, [ControlPiece y]) ->
(ControlDist y, [ControlPiece y])
(d,c) #|- (PRS y1, xs) = ((d,c,y1), xs)
(-|#) :: y -> (ControlDist y, [ControlPiece y]) ->
(PieceRightSingle y, [ControlPiece y])
y0 -|# ((d,c,y1), xs) = (PRS y0, ControlPiece c y0 y1 d : xs)
( #|=) :: (y, Control y) -> (PieceRightDouble y, [ControlPiece y]) ->
(ControlDist y, [ControlPiece y])
(d,c) #|= (PRD y1, xs) = ((d,c,y1), xs)
(=|#) :: (y,y) -> (ControlDist y, [ControlPiece y]) ->
(PieceRightDouble y, [ControlPiece y])
(y01,y10) =|# ((d,c,y11), xs) = (PRD y01, ControlPiece c y10 y11 d : xs)
( #|) :: (y, Control y) -> y ->
(ControlDist y, [ControlPiece y])
(d,c) #| y1 = ((d,c,y1), [])
(|#) :: y -> (ControlDist y, [ControlPiece y]) ->
[ControlPiece y]
y0 |# ((d,c,y1), xs) = ControlPiece c y0 y1 d : xs
piecewise :: (Trans.C y, RealRing.C y) =>
[ControlPiece y] -> Sig.T y
piecewise xs =
let ts = scanl (\(_,fr) d -> splitFraction (fr+d))
(0,1) (map pieceDur xs)
in concat (zipWith3
(\n t (ControlPiece c yi0 yi1 d) ->
piecewisePart yi0 yi1 t d n c)
(map fst (tail ts)) (map (subtract 1 . snd) ts)
xs)
piecewisePart :: (Trans.C y) =>
y -> y -> y -> y -> Int -> Control y -> Sig.T y
piecewisePart y0 y1 t0 d n ctrl =
take n
(case ctrl of
CtrlStep -> constant y0
CtrlLin -> let s = (y1y0)/d in linearStable s (y0t0*s)
CtrlExp s -> let y0' = y0s; y1' = y1s; yd = y0'/y1'
in raise s (exponentialStable (d / log yd)
(y0' * yd**(t0/d)))
CtrlCos -> map (\y -> (1+y)*(y0/2)+(1y)*(y1/2))
(cosineStable t0 (t0+d))
CtrlCubic yd0 yd1 ->
cubicHermiteStable (t0,(y0,yd0)) (t0+d,(y1,yd1)))
curveStable :: (Additive.C t) =>
(t -> y)
-> (y -> y -> y)
-> t
-> y
-> Sig.T y
curveStable expFunc op time y0 =
y0 : map (op y0)
(foldr
(\e xs ->
let k = expFunc e
in k : concatMapPair (\x -> (x, op x k)) xs)
unreachable (iterate double time))
unreachable :: a
unreachable = error "only reachable in infinity"
double :: Additive.C t => t -> t
double t = t+t
concatMapPair :: (a -> (b,b)) -> Sig.T a -> Sig.T b
concatMapPair f = flattenPairs . map f
flattenPairs :: Sig.T (a,a) -> Sig.T a
flattenPairs = foldr (\(a,b) xs -> a:b:xs) []
subdivide :: (y -> y -> y) -> Sig.T y -> Sig.T y
subdivide f xs0@(x:xs1) =
x : flattenPairs (zipWith (\x0 x1 -> (f x0 x1, x1)) xs0 xs1)
subdivide _ [] = []
concatMapPair' :: (a -> (b,b)) -> Sig.T a -> Sig.T b
concatMapPair' f = concatMap ((\(x,y) -> [x,y]) . f)
curveMultiscale :: (y -> y -> y) -> y -> y -> Sig.T y
curveMultiscale op d y0 =
y0 : map (op y0) (iterateAssociative op d)
curveMultiscaleNeutral :: (y -> y -> y) -> y -> y -> Sig.T y
curveMultiscaleNeutral op d neutral =
neutral : iterateAssociative op d