module Synthesizer.Generic.Interpolation where
import qualified Synthesizer.Generic.Control as Ctrl
import qualified Synthesizer.Generic.SampledValue as Sample
import qualified Synthesizer.Generic.Signal as SigG
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.Additive(zero)
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 sig t y =
Cons {
number :: Int,
offset :: Int,
func :: t -> sig y -> y
}
zeroPad :: (RealField.C t, Sample.C y, SigG.C sig) =>
(T sig t y -> t -> sig y -> a) ->
y -> T sig t y -> t -> sig y -> a
zeroPad interpolate z ip phase x =
let (phInt, phFrac) = splitFraction phase
in interpolate ip phFrac
(delayPad z (offset ip phInt) (SigG.append x (SigG.repeat z)))
constantPad :: (RealField.C t, Sample.C y, SigG.C sig) =>
(T sig t y -> t -> sig y -> a) ->
T sig t y -> t -> sig y -> a
constantPad interpolate ip phase x =
let (phInt, phFrac) = splitFraction phase
xPad =
do (xFirst,_) <- SigG.viewL x
return (delayPad xFirst (offset ip phInt) (SigG.extendConstant x))
in interpolate ip phFrac
(fromMaybe SigG.empty xPad)
cyclicPad :: (RealField.C t, Sample.C y, SigG.C sig) =>
(T sig t y -> t -> sig y -> a) ->
T sig t y -> t -> sig y -> a
cyclicPad interpolate ip phase x =
let (phInt, phFrac) = splitFraction phase
in interpolate ip phFrac
(SigG.drop (mod (phInt offset ip) (SigG.length x)) (SigG.cycle x))
extrapolationPad :: (RealField.C t, Sample.C y, SigG.C sig) =>
(T sig t y -> t -> sig y -> a) ->
T sig t y -> t -> sig y -> a
extrapolationPad interpolate ip phase =
interpolate ip (phase fromIntegral (offset ip))
skip :: (RealField.C t, Sample.C y, SigG.C sig) =>
T sig t y -> (t, sig y) -> (t, sig y)
skip ip (phase0, x0) =
let (n, frac) = splitFraction phase0
(m, x1) = SigG.dropMarginRem (number ip) n x0
in (fromIntegral m + frac, x1)
single :: (RealField.C t, Sample.C y, SigG.C sig) =>
T sig t y -> t -> sig y -> y
single ip phase0 x0 =
uncurry (func ip) $ skip ip (phase0, x0)
multiRelative ::
(RealField.C t, Sample.C t, Sample.C y, SigG.C sig) =>
T sig t y -> t -> sig y -> sig t -> sig y
multiRelative ip phase0 x0 =
SigG.crochetL
(\freq pos ->
let (phase,x) = skip ip pos
in Just (func ip phase x, (phase+freq,x)))
(phase0,x0)
multiRelativeZeroPad ::
(RealField.C t, Sample.C t, Sample.C y, SigG.C sig) =>
y -> T sig t y -> t -> sig t -> sig y -> sig y
multiRelativeZeroPad z ip phase fs x =
zeroPad multiRelative z ip phase x fs
multiRelativeConstantPad ::
(RealField.C t, Sample.C t, Sample.C y, SigG.C sig) =>
T sig t y -> t -> sig t -> sig y -> sig y
multiRelativeConstantPad ip phase fs x =
constantPad multiRelative ip phase x fs
multiRelativeCyclicPad ::
(RealField.C t, Sample.C t, Sample.C y, SigG.C sig) =>
T sig t y -> t -> sig t -> sig y -> sig y
multiRelativeCyclicPad ip phase fs x =
cyclicPad multiRelative ip phase x fs
multiRelativeExtrapolationPad ::
(RealField.C t, Sample.C t, Sample.C y, SigG.C sig) =>
T sig t y -> t -> sig t -> sig y -> sig y
multiRelativeExtrapolationPad ip phase fs x =
extrapolationPad multiRelative ip phase x fs
multiRelativeZeroPadConstant ::
(RealField.C t, Additive.C y, Sample.C t, Sample.C y, SigG.C sig) =>
t -> sig t -> sig y -> sig y
multiRelativeZeroPadConstant = multiRelativeZeroPad zero constant
multiRelativeZeroPadLinear ::
(RealField.C t, Module.C t y, Sample.C t, Sample.C y, SigG.C sig) =>
t -> sig t -> sig y -> sig y
multiRelativeZeroPadLinear = multiRelativeZeroPad zero linear
multiRelativeZeroPadCubic ::
(RealField.C t, Module.C t y, Sample.C t, Sample.C y, SigG.C sig) =>
t -> sig t -> sig y -> sig y
multiRelativeZeroPadCubic = multiRelativeZeroPad zero cubic
data PrefixReader sig a =
PrefixReader Int (StateT sig Maybe a)
instance Functor (PrefixReader sig) where
fmap f (PrefixReader count parser) =
PrefixReader count (fmap f parser)
instance Applicative (PrefixReader sig) where
pure = PrefixReader 0 . return
(PrefixReader count0 parser0) <*> (PrefixReader count1 parser1) =
PrefixReader (count0+count1) (parser0 `ap` parser1)
getNode :: (Sample.C y, SigG.C sig) =>
PrefixReader (sig y) y
getNode = PrefixReader 1 (StateT SigG.viewL)
fromPrefixReader :: (Sample.C y, SigG.C sig) =>
String -> Int -> PrefixReader (sig y) (t -> y) -> T sig 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 :: (Sample.C y, SigG.C sig) => T sig t y
constant =
fromPrefixReader "constant" 0 (const <$> getNode)
linear :: (Module.C t y, Sample.C y, SigG.C sig) => T sig t y
linear =
fromPrefixReader "linear" 0
(liftA2
(\x0 x1 phase -> affineComb phase (x0,x1))
getNode getNode)
cubic :: (Field.C t, Module.C t y, Sample.C y, SigG.C sig) => T sig 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, Sample.C y, SigG.C sig) => T sig 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, Sample.C t, Sample.C y, SigG.C sig) =>
Int -> [t -> t] -> T sig t y
piecewise center ps =
Cons (length ps) (center1)
(\t -> linearComb (SigG.reverse (SigG.fromList (map ($t) ps))))
piecewiseConstant ::
(Module.C t y, Sample.C t, Sample.C y, SigG.C sig) => T sig t y
piecewiseConstant =
piecewise 1 [const 1]
piecewiseLinear ::
(Module.C t y, Sample.C t, Sample.C y, SigG.C sig) => T sig t y
piecewiseLinear =
piecewise 1 [id, (1)]
piecewiseCubic ::
(Field.C t, Module.C t y, Sample.C t, Sample.C y, SigG.C sig) => T sig 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, Sample.C t, Sample.C y, SigG.C sig) =>
(Int,Int)
-> (t -> t)
-> T sig t y
function (left,right) f =
let len = left+right
in Cons len left
(\t -> linearComb $ SigG.reverse $
SigG.map
(\x -> f (t + fromIntegral x))
(SigG.take len (SigG.iterate succ (left))))
linearComb ::
(SigG.C sig, Sample.C t, Sample.C y, Module.C t y) =>
sig t -> sig y -> y
linearComb ts ys =
SigG.sum $ SigG.zipWith (*>) ts ys
delayPad :: (Sample.C y, SigG.C sig) => y -> Int -> sig y -> sig y
delayPad z n =
if n<0 then SigG.drop (negate n) else SigG.append (SigG.replicate n z)