module Synthesizer.Generic.Control where
import qualified Synthesizer.Generic.Signal as SigG
import qualified Synthesizer.Generic.Signal2 as SigG2
import Synthesizer.Generic.Displacement (raise)
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 qualified Number.Complex as Complex
import qualified Prelude as P
import NumericPrelude.Base
import NumericPrelude.Numeric
constant :: (SigG.Write sig y) =>
SigG.LazySize -> y -> sig y
constant = SigG.repeat
linear :: (Additive.C y, SigG.Write sig y) =>
SigG.LazySize
-> y
-> y
-> sig y
linear size d y0 = SigG.iterate size (d+) y0
linearMultiscale ::
(Additive.C y, SigG.Write sig y) =>
SigG.LazySize
-> y
-> y
-> sig y
linearMultiscale size =
curveMultiscale size (+)
linearMultiscaleNeutral :: (Additive.C y, SigG.Write sig y) =>
SigG.LazySize
-> y
-> sig y
linearMultiscaleNeutral size slope =
curveMultiscaleNeutral size (+) slope zero
line :: (Field.C y, SigG.Write sig y) =>
SigG.LazySize
-> Int
-> (y,y)
-> sig y
line size n (y0,y1) =
SigG.take n $ linear size ((y1y0) / fromIntegral n) y0
exponential, exponentialMultiscale ::
(Trans.C y, SigG.Write sig y) =>
SigG.LazySize
-> y
-> y
-> sig y
exponential size time =
SigG.iterate size (* exp ( recip time))
exponentialMultiscale size time =
curveMultiscale size (*) (exp ( recip time))
exponentialMultiscaleNeutral :: (Trans.C y, SigG.Write sig y) =>
SigG.LazySize
-> y
-> sig y
exponentialMultiscaleNeutral size time =
curveMultiscaleNeutral size (*) (exp ( recip time)) one
exponential2, exponential2Multiscale :: (Trans.C y, SigG.Write sig y) =>
SigG.LazySize
-> y
-> y
-> sig y
exponential2 size halfLife =
SigG.iterate size (* 0.5 ** recip halfLife)
exponential2Multiscale size halfLife =
curveMultiscale size (*) (0.5 ** recip halfLife)
exponential2MultiscaleNeutral :: (Trans.C y, SigG.Write sig y) =>
SigG.LazySize
-> y
-> sig y
exponential2MultiscaleNeutral size halfLife =
curveMultiscaleNeutral size (*) (0.5 ** recip halfLife) one
vectorExponential ::
(Trans.C y, Module.C y v, SigG.Write sig v) =>
SigG.LazySize
-> y
-> v
-> sig v
vectorExponential size time y0 =
SigG.iterate size (exp (1/time) *>) y0
vectorExponential2 ::
(Trans.C y, Module.C y v, SigG.Write sig v) =>
SigG.LazySize
-> y
-> v
-> sig v
vectorExponential2 size halfLife y0 =
SigG.iterate size (0.5**(1/halfLife) *>) y0
cosine, cosineMultiscaleLinear :: (Trans.C y, SigG.Write sig y) =>
SigG.LazySize
-> y
-> y
-> sig y
cosine size = cosineWithSlope $
\d x -> SigG.map cos (linear size d x)
cosineMultiscaleLinear size = cosineWithSlope $
\d x -> SigG.map cos (linearMultiscale size d x)
cosineMultiscale ::
(Trans.C y, SigG.Write sig (Complex.T y),
SigG2.Transform sig (Complex.T y) y) =>
SigG.LazySize
-> y
-> y
-> sig y
cosineMultiscale size = cosineWithSlope $
\d x -> SigG2.map real (curveMultiscale size (*) (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, SigG.Write sig y) =>
SigG.LazySize
-> (y, (y,y)) -> (y, (y,y)) -> sig y
cubicHermite size node0 node1 =
SigG.map (cubicFunc node0 node1) $ linear size 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
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, SigG.Write sig y) =>
SigG.LazySize -> [ControlPiece y] -> sig y
piecewise size xs =
let ts = scanl (\(_,fr) d -> splitFraction (fr+d))
(0,1) (map pieceDur xs)
in SigG.concat (zipWith3
(\n t (ControlPiece c yi0 yi1 d) ->
piecewisePart size yi0 yi1 t d n c)
(map fst (tail ts)) (map (subtract 1 . snd) ts)
xs)
piecewisePart :: (Trans.C y, SigG.Write sig y) =>
SigG.LazySize -> y -> y -> y -> y -> Int -> Control y -> sig y
piecewisePart size y0 y1 t0 d n ctrl =
SigG.take n
(case ctrl of
CtrlStep -> constant size y0
CtrlLin -> let s = (y1y0)/d in linearMultiscale size s (y0t0*s)
CtrlExp s -> let y0' = y0s; y1' = y1s; yd = y0'/y1'
in raise s (exponentialMultiscale size (d / log yd)
(y0' * yd**(t0/d)))
CtrlCos -> SigG.map
(\y -> (1+y)*(y0/2)+(1y)*(y1/2))
(cosineMultiscaleLinear size t0 (t0+d))
CtrlCubic yd0 yd1 ->
cubicHermite size (t0,(y0,yd0)) (t0+d,(y1,yd1)))
curveMultiscale :: (SigG.Write sig y) =>
SigG.LazySize -> (y -> y -> y) -> y -> y -> sig y
curveMultiscale size op d y0 =
SigG.cons y0 . SigG.map (op y0) $ SigG.iterateAssociative size op d
curveMultiscaleNeutral :: (SigG.Write sig y) =>
SigG.LazySize -> (y -> y -> y) -> y -> y -> sig y
curveMultiscaleNeutral size op d neutral =
SigG.cons neutral $ SigG.iterateAssociative size op d