module Synthesizer.Plain.Interpolation where
import qualified Synthesizer.Plain.Control as Ctrl
import qualified Synthesizer.Plain.Signal as Sig
import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR
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 Synthesizer.Utility (viewListL, viewListR, affineComb, )
import Synthesizer.ApplicativeUtility (liftA4, )
import Control.Monad.State (StateT(StateT), evalStateT, replicateM_, ap, guard, )
import Control.Applicative (Applicative(pure, (<*>)), (<$>), liftA2, )
import PreludeBase
import NumericPrelude
data T t y =
Cons {
number :: Int,
offset :: Int,
func :: t -> Sig.T y -> y
}
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
(FiltNR.delayPad z (offset ip phInt) (x ++ 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,_) <- viewListL x
(xBody,xLast) <- viewListR x
return (FiltNR.delayPad xFirst (offset ip phInt) (xBody ++ repeat xLast))
in interpolate ip phFrac
(fromMaybe [] 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
(drop (mod (phInt offset ip) (length x)) (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)
singleRec :: (Ord t, Ring.C t) =>
T t y -> t -> Sig.T y -> y
singleRec ip phase x =
maybe
(func ip phase x)
(singleRec ip (phase 1))
(do (_,xs) <- viewListL x
guard (phase >= 1 && minLength (number ip) xs)
return xs)
multiRelative :: (RealField.C t) =>
T t y -> t -> Sig.T y -> Sig.T t -> Sig.T y
multiRelative ip phase0 x0 =
map (uncurry (func ip)) .
scanl
(\(phase,x) freq -> skip ip (phase + freq, x))
(skip ip (phase0,x0))
multiRelativeZeroPad :: (RealField.C t) =>
y -> T t y -> t -> Sig.T t -> Sig.T y -> Sig.T y
multiRelativeZeroPad z ip phase fs x =
zeroPad multiRelative z ip phase x fs
multiRelativeConstantPad :: (RealField.C t) =>
T t y -> t -> Sig.T t -> Sig.T y -> Sig.T y
multiRelativeConstantPad ip phase fs x =
constantPad multiRelative ip phase x fs
multiRelativeCyclicPad :: (RealField.C t) =>
T t y -> t -> Sig.T t -> Sig.T y -> Sig.T y
multiRelativeCyclicPad ip phase fs x =
cyclicPad multiRelative ip phase x fs
multiRelativeExtrapolationPad :: (RealField.C t) =>
T t y -> t -> Sig.T t -> Sig.T y -> Sig.T y
multiRelativeExtrapolationPad ip phase fs x =
extrapolationPad multiRelative ip phase x fs
multiRelativeZeroPadConstant ::
(RealField.C t, Additive.C y) => t -> Sig.T t -> Sig.T y -> Sig.T y
multiRelativeZeroPadConstant = multiRelativeZeroPad zero constant
multiRelativeZeroPadLinear ::
(RealField.C t, Module.C t y) => t -> Sig.T t -> Sig.T y -> Sig.T y
multiRelativeZeroPadLinear = multiRelativeZeroPad zero linear
multiRelativeZeroPadCubic ::
(RealField.C t, Module.C t y) => t -> Sig.T t -> Sig.T y -> Sig.T y
multiRelativeZeroPadCubic = multiRelativeZeroPad zero cubic
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 viewListL)
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 -> Module.linearComb (reverse (map ($t) 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
in Cons len left
(\t -> Module.linearComb (reverse
(map (\x -> f (t + fromIntegral x)) (take len [(left)..]))))
minLength :: Int -> Sig.T y -> Bool
minLength n xs =
maybe False (const True) (evalStateT (replicateM_ n (StateT viewListL)) xs)