module Synthesizer.State.Interpolation where
import qualified Synthesizer.State.Signal as Sig
import qualified Synthesizer.Plain.Control as Ctrl
import qualified Synthesizer.Generic.Interpolation as InterpolationG
import qualified Synthesizer.Generic.Signal as SigG
import qualified Synthesizer.Generic.SampledValue as Sample
import qualified Algebra.Module as Module
import qualified Algebra.RealField as RealField
import qualified Algebra.Field as Field
import qualified Algebra.Ring as Ring
import qualified Algebra.Additive as Additive
import Algebra.Module((*>))
import Data.Maybe (fromMaybe)
import Control.Monad.State (StateT(StateT), evalStateT, ap, )
import Control.Applicative (Applicative(pure, (<*>)), (<$>), liftA2, )
import Synthesizer.ApplicativeUtility (liftA4, )
import Synthesizer.Utility (affineComb, )
import PreludeBase
import NumericPrelude
data T t y =
Cons {
number :: Int,
offset :: Int,
func :: t -> Sig.T y -> y
}
toGeneric ::
(Sample.C y, SigG.C sig) =>
T t y -> InterpolationG.T sig t y
toGeneric ip =
InterpolationG.Cons {
InterpolationG.number = number ip,
InterpolationG.offset = offset ip,
InterpolationG.func = \ t x -> func ip t (Sig.fromGenericSignal x)
}
zeroPad :: (RealField.C t) =>
(T t y -> t -> Sig.T y -> a) ->
y -> T t y -> t -> Sig.T y -> a
zeroPad interpolate z ip phase x =
let (phInt, phFrac) = splitFraction phase
in interpolate ip phFrac
(delayPad z (offset ip phInt) (Sig.append x (Sig.repeat z)))
constantPad :: (RealField.C t) =>
(T t y -> t -> Sig.T y -> a) ->
T t y -> t -> Sig.T y -> a
constantPad interpolate ip phase x =
let (phInt, phFrac) = splitFraction phase
xPad =
do (xFirst,_) <- Sig.viewL x
return (delayPad xFirst (offset ip phInt) (Sig.extendConstant x))
in interpolate ip phFrac
(fromMaybe Sig.empty xPad)
cyclicPad :: (RealField.C t) =>
(T t y -> t -> Sig.T y -> a) ->
T t y -> t -> Sig.T y -> a
cyclicPad interpolate ip phase x =
let (phInt, phFrac) = splitFraction phase
in interpolate ip phFrac
(Sig.drop (mod (phInt offset ip) (Sig.length x)) (Sig.cycle x))
extrapolationPad :: (RealField.C t) =>
(T t y -> t -> Sig.T y -> a) ->
T t y -> t -> Sig.T y -> a
extrapolationPad interpolate ip phase =
interpolate ip (phase fromIntegral (offset ip))
skip :: (RealField.C t) =>
T t y -> (t, Sig.T y) -> (t, Sig.T y)
skip ip (phase0, x0) =
let (n, frac) = splitFraction phase0
(m, x1) = Sig.dropMarginRem (number ip) n x0
in (fromIntegral m + frac, x1)
single :: (RealField.C t) =>
T t y -> t -> Sig.T y -> y
single ip phase0 x0 =
uncurry (func ip) $ skip ip (phase0, x0)
data PrefixReader y a =
PrefixReader Int (StateT (Sig.T y) Maybe a)
instance Functor (PrefixReader y) where
fmap f (PrefixReader count parser) =
PrefixReader count (fmap f parser)
instance Applicative (PrefixReader y) where
pure = PrefixReader 0 . return
(PrefixReader count0 parser0) <*> (PrefixReader count1 parser1) =
PrefixReader (count0+count1) (parser0 `ap` parser1)
getNode :: PrefixReader y y
getNode = PrefixReader 1 (StateT Sig.viewL)
fromPrefixReader :: String -> Int -> PrefixReader y (t -> y) -> T t y
fromPrefixReader name off (PrefixReader count parser) =
Cons count off
(\t xs ->
maybe
(error (name ++ " interpolation: not enough nodes"))
($t)
(evalStateT parser xs))
constant :: T t y
constant =
fromPrefixReader "constant" 0 (const <$> getNode)
linear :: (Module.C t y) => T t y
linear =
fromPrefixReader "linear" 0
(liftA2
(\x0 x1 phase -> affineComb phase (x0,x1))
getNode getNode)
cubic :: (Field.C t, Module.C t y) => T t y
cubic =
fromPrefixReader "cubic" 1
(liftA4
(\xm1 x0 x1 x2 t ->
let lipm12 = affineComb t (xm1,x2)
lip01 = affineComb t (x0, x1)
three = 3 `asTypeOf` t
in lip01 + (t*(t1)/2) *>
(lipm12 + (x0+x1) three *> lip01))
getNode getNode getNode getNode)
cubicAlt :: (Field.C t, Module.C t y) => T t y
cubicAlt =
fromPrefixReader "cubicAlt" 1
(liftA4
(\xm1 x0 x1 x2 t ->
let half = 1/2 `asTypeOf` t
in cubicHalf t x0 (half *> (x1xm1)) +
cubicHalf (1t) x1 (half *> (x0x2)))
getNode getNode getNode getNode)
cubicHalf :: (Module.C t y) => t -> y -> y -> y
cubicHalf t x x' =
(t1)^2 *> ((1+2*t)*>x + t*>x')
piecewise :: (Module.C t y) =>
Int -> [t -> t] -> T t y
piecewise center ps =
Cons (length ps) (center1)
(\t -> Sig.linearComb (Sig.fromList (map ($t) (reverse ps))))
piecewiseConstant :: (Module.C t y) => T t y
piecewiseConstant =
piecewise 1 [const 1]
piecewiseLinear :: (Module.C t y) => T t y
piecewiseLinear =
piecewise 1 [id, (1)]
piecewiseCubic :: (Field.C t, Module.C t y) => T t y
piecewiseCubic =
piecewise 2 $
Ctrl.cubicFunc (0,(0,0)) (1,(0,1/2)) :
Ctrl.cubicFunc (0,(0,1/2)) (1,(1,0)) :
Ctrl.cubicFunc (0,(1,0)) (1,(0,1/2)) :
Ctrl.cubicFunc (0,(0,1/2)) (1,(0,0)) :
[]
function :: (Module.C t y) =>
(Int,Int)
-> (t -> t)
-> T t y
function (left,right) f =
let len = left+right
ps = Sig.take len $ Sig.iterate pred (pred right)
in Cons len left
(\t -> Sig.linearComb $
Sig.map (\x -> f (t + fromIntegral x)) ps)
delayPad :: y -> Int -> Sig.T y -> Sig.T y
delayPad z n =
if n<0
then Sig.drop (negate n)
else Sig.append (Sig.replicate n z)