diff --git a/src/Synthesizer/Dimensional/Amplitude/Analysis.hs b/src/Synthesizer/Dimensional/Amplitude/Analysis.hs --- a/src/Synthesizer/Dimensional/Amplitude/Analysis.hs +++ b/src/Synthesizer/Dimensional/Amplitude/Analysis.hs @@ -47,13 +47,14 @@ import qualified Algebra.Algebraic as Algebraic import qualified Algebra.Module as Module import qualified Algebra.Field as Field -import qualified Algebra.Real as Real +import qualified Algebra.Absolute as Absolute +import qualified Algebra.RealRing as RealRing import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive -import PreludeBase (Ord, Bool, (<=), ($), (.), uncurry, error, ) --- import NumericPrelude +import NumericPrelude.Base (Ord, Bool, (<=), ($), (.), uncurry, error, ) +-- import NumericPrelude.Numeric import qualified Prelude as P @@ -111,7 +112,7 @@ Volume based on Manhattan norm. -} {-# INLINE volumeMaximum #-} -volumeMaximum :: (Real.C y, Dim.C u) => +volumeMaximum :: (RealRing.C y, Dim.C u) => SignalRateInd rate u y y -> DN.T u y volumeMaximum = volumeAux Ana.volumeMaximum @@ -127,7 +128,7 @@ Volume based on Sum norm. -} {-# INLINE volumeSum #-} -volumeSum :: (Field.C y, Real.C y, Dim.C u) => +volumeSum :: (Field.C y, Absolute.C y, Dim.C u) => SignalRateInd rate u y y -> DN.T u y volumeSum = volumeAux Ana.volumeSum @@ -178,7 +179,7 @@ volumeAux Ana.directCurrentOffset {-# INLINE rectify #-} -rectify :: (Real.C y) => +rectify :: (Absolute.C y) => SigA.T rate amp (Sig.T y) -> SigA.T rate amp (Sig.T y) rectify = SigA.processBody Ana.rectify diff --git a/src/Synthesizer/Dimensional/Amplitude/Control.hs b/src/Synthesizer/Dimensional/Amplitude/Control.hs --- a/src/Synthesizer/Dimensional/Amplitude/Control.hs +++ b/src/Synthesizer/Dimensional/Amplitude/Control.hs @@ -24,17 +24,17 @@ import qualified Algebra.DimensionTerm as Dim -- import qualified Algebra.Module as Module -import qualified Algebra.Real as Real +import qualified Algebra.Absolute as Absolute -- import qualified Algebra.Ring as Ring -- import qualified Algebra.Additive as Additive --- import NumericPrelude -import PreludeBase as P +-- import NumericPrelude.Numeric +import NumericPrelude.Base as P import Prelude () {-# INLINE constant #-} -constant :: (Real.C y, Dim.C u) => +constant :: (Absolute.C y, Dim.C u) => DN.T u y {-^ value -} -> SigA.R s u y y constant = @@ -46,7 +46,7 @@ This is not checked. -} {-# INLINE constantVector #-} -constantVector :: -- (Field.C y', Real.C y', OccScalar.C y y') => +constantVector :: -- (Field.C y', Absolute.C y', OccScalar.C y y') => DN.T u y {-^ amplitude -} -> yv {-^ value -} -> SigA.R s u y yv diff --git a/src/Synthesizer/Dimensional/Amplitude/Cut.hs b/src/Synthesizer/Dimensional/Amplitude/Cut.hs --- a/src/Synthesizer/Dimensional/Amplitude/Cut.hs +++ b/src/Synthesizer/Dimensional/Amplitude/Cut.hs @@ -53,8 +53,8 @@ import qualified Data.List as List -import PreludeBase (Ord, max, Bool, ($), (.), flip, ) -import NumericPrelude ((*>), ) +import NumericPrelude.Base (Ord, max, Bool, ($), (.), flip, ) +import NumericPrelude.Numeric ((*>), ) import Prelude () diff --git a/src/Synthesizer/Dimensional/Amplitude/Displacement.hs b/src/Synthesizer/Dimensional/Amplitude/Displacement.hs --- a/src/Synthesizer/Dimensional/Amplitude/Displacement.hs +++ b/src/Synthesizer/Dimensional/Amplitude/Displacement.hs @@ -34,7 +34,7 @@ import qualified Algebra.Transcendental as Trans import qualified Algebra.Module as Module import qualified Algebra.Field as Field -import qualified Algebra.Real as Real +import qualified Algebra.Absolute as Absolute import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive @@ -42,8 +42,8 @@ import qualified Data.List as List -import PreludeBase hiding (map, ) -import NumericPrelude +import NumericPrelude.Base hiding (map, ) +import NumericPrelude.Numeric import Prelude () @@ -55,7 +55,7 @@ -} {-# INLINE mix #-} mix :: - (Real.C y, Field.C y, Module.C y yv, Dim.C u) => + (Absolute.C y, Field.C y, Module.C y yv, Dim.C u) => SigA.R s u y yv -> SigA.R s u y yv -> SigA.R s u y yv @@ -66,7 +66,7 @@ {-# INLINE mixVolume #-} mixVolume :: - (Real.C y, Field.C y, Module.C y yv, Dim.C u) => + (Absolute.C y, Field.C y, Module.C y yv, Dim.C u) => DN.T u y -> SigA.R s u y yv -> SigA.R s u y yv @@ -82,7 +82,7 @@ -} {-# INLINE mixMulti #-} mixMulti :: - (Real.C y, Field.C y, Module.C y yv, Dim.C u) => + (Absolute.C y, Field.C y, Module.C y yv, Dim.C u) => [SigA.R s u y yv] -> SigA.R s u y yv mixMulti x = @@ -90,7 +90,7 @@ {-# INLINE mixMultiVolume #-} mixMultiVolume :: - (Real.C y, Field.C y, Module.C y yv, Dim.C u) => + (Absolute.C y, Field.C y, Module.C y yv, Dim.C u) => DN.T u y -> [SigA.R s u y yv] -> SigA.R s u y yv @@ -198,7 +198,7 @@ {-# INLINE mapLinearDimension #-} mapLinearDimension :: - (Field.C y, Real.C y, Dim.C u, Dim.C v) => + (Field.C y, Absolute.C y, Dim.C u, Dim.C v) => DN.T v y {- ^ range: one is mapped to @center + range * ampX@ -} -> DN.T (Dim.Mul v u) y {- ^ center: zero is mapped to @center@ -} -> SigA.T rate (Amp.Dimensional u y) (Sig.T y) diff --git a/src/Synthesizer/Dimensional/Amplitude/Filter.hs b/src/Synthesizer/Dimensional/Amplitude/Filter.hs --- a/src/Synthesizer/Dimensional/Amplitude/Filter.hs +++ b/src/Synthesizer/Dimensional/Amplitude/Filter.hs @@ -44,8 +44,8 @@ import qualified Algebra.Additive as Additive import qualified Algebra.Module as Module --- import NumericPrelude hiding (negate) --- import PreludeBase as P +-- import NumericPrelude.Numeric hiding (negate) +-- import NumericPrelude.Base as P import Prelude ((.), flip, fmap, ) diff --git a/src/Synthesizer/Dimensional/Amplitude/Flat.hs b/src/Synthesizer/Dimensional/Amplitude/Flat.hs --- a/src/Synthesizer/Dimensional/Amplitude/Flat.hs +++ b/src/Synthesizer/Dimensional/Amplitude/Flat.hs @@ -46,8 +46,8 @@ -- import Number.DimensionTerm ((&/&)) -import NumericPrelude -import PreludeBase +import NumericPrelude.Numeric +import NumericPrelude.Base import Prelude () diff --git a/src/Synthesizer/Dimensional/Arrow.hs b/src/Synthesizer/Dimensional/Arrow.hs --- a/src/Synthesizer/Dimensional/Arrow.hs +++ b/src/Synthesizer/Dimensional/Arrow.hs @@ -1,5 +1,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} {- | A wrapper around @(->)@ or @Causal.Process@ that adds amplitude handling to the Arrow paradigm. @@ -8,6 +10,9 @@ -} module Synthesizer.Dimensional.Arrow where +import qualified Synthesizer.Dimensional.Sample as Sample +import Synthesizer.Dimensional.Sample (Amplitude, Displacement, ) + import qualified Synthesizer.Dimensional.Signal.Private as SigA import qualified Synthesizer.Dimensional.Amplitude.Flat as Flat import qualified Synthesizer.Dimensional.Amplitude as Amp @@ -17,7 +22,7 @@ import qualified Control.Arrow as Arrow import qualified Control.Category as Category -import Control.Arrow (Arrow, ArrowLoop, ) +import Control.Arrow (Arrow, ArrowLoop, (>>>), (***), ) import Control.Category (Category, ) import Control.Applicative (Applicative, liftA2, ) @@ -33,19 +38,27 @@ import qualified Number.DimensionTerm as DN import qualified Algebra.DimensionTerm as Dim -import NumericPrelude (one) +import NumericPrelude.Numeric (one) import Prelude hiding (map, id, fst, snd, ) {- | -Note that @amp@ can also be a pair of amplitudes -or a more complicated ensemble of amplitudes. +The sample type parameters +can be arbitrarily nested tuples of 'Samples'. +Type functions are used for untangling amplitudes and displacements. +We use this approach in order to be able to match +(as good as possible) the Arrow type class. -} -newtype T amp0 amp1 arrow = - Cons (amp0 -> (arrow, amp1)) +newtype T arrow sample0 sample1 = + Cons (Amplitude sample0 -> + (arrow (Displacement sample0) (Displacement sample1), + Amplitude sample1)) +type Single arrow amp0 amp1 yv0 yv1 = + T arrow (Sample.T amp0 yv0) (Sample.T amp1 yv1) + {- It is tempting to declare a rate parameter for the process type, instead of putting the rate phantom into the arrow. @@ -74,12 +87,20 @@ infixl 9 `apply` +-- we need this generality in ControlledProcess.applyConverter {-# INLINE apply #-} apply :: + (SigG2.Transform sig (Displacement sample0) (Displacement sample1), + Applicable arrow rate) => + T arrow sample0 sample1 -> + SigA.T rate (Amplitude sample0) (sig (Displacement sample0)) -> + SigA.T rate (Amplitude sample1) (sig (Displacement sample1)) +{- (SigG2.Transform sig yv0 yv1, Applicable arrow rate) => - T amp0 amp1 (arrow yv0 yv1) -> + Single arrow amp0 amp1 yv0 yv1 -> SigA.T rate amp0 (sig yv0) -> SigA.T rate amp1 (sig yv1) +-} apply (Cons f) (SigA.Cons rate xAmp samples) = let (arrow, yAmp) = f xAmp in SigA.Cons rate yAmp (CausalArrow.apply arrow samples) @@ -88,7 +109,7 @@ applyFlat :: (Flat.C yv0 amp0, SigG2.Transform sig yv0 yv1, Applicable arrow rate) => - T (Amp.Flat yv0) amp1 (arrow yv0 yv1) -> + Single arrow (Amp.Flat yv0) amp1 yv0 yv1 -> SigA.T rate amp0 (sig yv0) -> SigA.T rate amp1 (sig yv1) applyFlat f = @@ -97,7 +118,7 @@ {-# INLINE canonicalizeFlat #-} canonicalizeFlat :: (Flat.C y flat, Arrow arrow) => - T flat (Amp.Flat y) (arrow y y) + Single arrow flat (Amp.Flat y) y y canonicalizeFlat = Cons $ \ amp -> (Arrow.arr (Flat.amplifySample amp), Amp.Flat) @@ -105,7 +126,7 @@ {-# INLINE applyConst #-} applyConst :: (Amp.C amp1, Ring.C y0, CausalArrow.C arrow) => - T (Amp.Numeric amp0) amp1 (arrow y0 yv1) -> + Single arrow (Amp.Numeric amp0) amp1 y0 yv1 -> amp0 -> SigA.T (Rate.Phantom s) amp1 (Sig.T yv1) applyConst (Cons f) x = @@ -120,7 +141,7 @@ ($/:) :: (Applicative f, SigG2.Transform sig yv0 yv1, Applicable arrow rate) => - f (T amp0 amp1 (arrow yv0 yv1)) -> + f (Single arrow amp0 amp1 yv0 yv1) -> f (SigA.T rate amp0 (sig yv0)) -> f (SigA.T rate amp1 (sig yv1)) ($/:) = liftA2 apply @@ -128,57 +149,89 @@ {-# INLINE ($/-) #-} ($/-) :: (Amp.C amp1, Functor f, Ring.C y0, CausalArrow.C arrow) => - f (T (Amp.Numeric amp0) amp1 (arrow y0 yv1)) -> + f (Single arrow (Amp.Numeric amp0) amp1 y0 yv1) -> amp0 -> f (SigA.T (Rate.Phantom s) amp1 (Sig.T yv1)) ($/-) p x = fmap (flip applyConst x) p -infixr 3 *** -infixr 3 &&& -infixr 1 >>>, <<< - - - {-# INLINE id #-} id :: (Category arrow) => - T amp amp (arrow yv yv) + T arrow sample sample id = Cons (\amp -> (Category.id, amp)) {-# INLINE compose #-} -{-# INLINE (>>>) #-} -compose, (>>>) :: +compose :: (Category arrow) => - T amp0 amp1 (arrow yv0 yv1) -> - T amp1 amp2 (arrow yv1 yv2) -> - T amp0 amp2 (arrow yv0 yv2) + T arrow sample0 sample1 -> + T arrow sample1 sample2 -> + T arrow sample0 sample2 compose (Cons f) (Cons g) = Cons $ \ xAmp -> let (causalXY, yAmp) = f xAmp (causalYZ, zAmp) = g yAmp in (causalXY Arrow.>>> causalYZ, zAmp) -(>>>) = compose -{-# INLINE (<<<) #-} -(<<<) :: - -- (Category arrow) => - (Arrow arrow) => - T amp1 amp2 (arrow yv1 yv2) -> - T amp0 amp1 (arrow yv0 yv1) -> - T amp0 amp2 (arrow yv0 yv2) -(<<<) = flip (>>>) +instance (Category arrow) => Category (T arrow) where + {-# INLINE id #-} + id = id + {-# INLINE (.) #-} + (.) = flip compose +{- | +This instance lacks an implementation for 'arr'. +However the syntactic sugar for arrows +uses 'arr' for shuffling the operands. +Actually shuffling is possible for our arrow, +but lifting general functions is a problem. +If you want to use arrow syntax, +you should hide the 'arr' from Control.Arrow +and use the one provided as plain function, here. +-} +instance (Arrow arrow) => Arrow (T arrow) where + {-# INLINE first #-} + {-# INLINE second #-} + {-# INLINE (***) #-} + {-# INLINE (&&&) #-} + + arr = error "Dimensional.Arrow.arr: sorry, there is no reasonable implementation" + first = first + second = second + (***) = split + (&&&) = fanout + + +{- | +This implementation would work for all 'f's +where the output amplitude does not depend on the input displacement. +This is true for all shuffling operations +that are needed in the translation of the arrow syntax. +However, for the implementation we would need type constraints +of the function passed to 'arr' +and this is not allowed. +-} +{-# INLINE arr #-} +arr :: + (Arrow arrow, Sample.Build sample0, Sample.Inspect sample1) => + (sample0 -> sample1) -> T arrow sample0 sample1 +arr f = Cons $ \amp0 -> + (Arrow.arr $ \yv0 -> + Sample.displacement $ f $ Sample.build amp0 yv0, + Sample.amplitude $ f $ Sample.build amp0 $ + error $ "Dimensional.Arrow.arr: " ++ + "output amplitude must not depend on input displacement") + {-# INLINE first #-} first :: (Arrow arrow) => - T amp0 amp1 (arrow yv0 yv1) -> - T (amp0, amp) (amp1, amp) (arrow (yv0, yv) (yv1, yv)) + T arrow sample0 sample1 -> + T arrow (sample0, sample) (sample1, sample) first (Cons f) = Cons $ \ (xAmp, amp) -> let (arrow, yAmp) = f xAmp @@ -187,56 +240,52 @@ {-# INLINE second #-} second :: (Arrow arrow) => - T amp0 amp1 (arrow yv0 yv1) -> - T (amp, amp0) (amp, amp1) (arrow (yv, yv0) (yv, yv1)) + T arrow sample0 sample1 -> + T arrow (sample, sample0) (sample, sample1) second (Cons f) = Cons $ \ (amp, xAmp) -> let (arrow, yAmp) = f xAmp in (Arrow.second arrow, (amp, yAmp)) {-# INLINE split #-} -{-# INLINE (***) #-} -split, (***) :: +split :: (Arrow arrow) => - T amp0 amp1 (arrow yv0 yv1) -> - T amp2 amp3 (arrow yv2 yv3) -> - T (amp0, amp2) (amp1, amp3) (arrow (yv0, yv2) (yv1, yv3)) + T arrow sample0 sample1 -> + T arrow sample2 sample3 -> + T arrow (sample0, sample2) (sample1, sample3) split f g = compose (first f) (second g) -(***) = split - {-# INLINE fanout #-} -{-# INLINE (&&&) #-} -fanout, (&&&) :: +fanout :: (Arrow arrow) => - T amp amp0 (arrow yv yv0) -> - T amp amp1 (arrow yv yv1) -> - T amp (amp0, amp1) (arrow yv (yv0, yv1)) + T arrow sample sample0 -> + T arrow sample sample1 -> + T arrow sample (sample0, sample1) fanout f g = compose double (split f g) -(&&&) = fanout - -- * map functions -{- | -This function can be abused to bring the amplitudes out of order. -So be careful! +{- +This has become a bit safer by the use of type families, +since now we can assert that amplitude and displacement tuples match. +Unless someone adds inappropriate type instances. -} independentMap :: (Arrow arrow) => - (amp0 -> amp1) -> (yv0 -> yv1) -> - T amp0 amp1 (arrow yv0 yv1) + (Amplitude sample0 -> Amplitude sample1) -> + (Displacement sample0 -> Displacement sample1) -> + T arrow sample0 sample1 independentMap f g = Cons (\amp -> (Arrow.arr g, f amp)) double :: (Arrow arrow) => - T amp (amp, amp) (arrow y (y, y)) + T arrow sample (sample, sample) double = let aux = \x -> (x, x) in independentMap aux aux @@ -245,7 +294,7 @@ forceDimensionalAmplitude :: (Dim.C v, Field.C y, Module.C y yv, Arrow arrow) => DN.T v y -> - T (Amp.Dimensional v y) (Amp.Dimensional v y) (arrow yv yv) + Single arrow (Amp.Dimensional v y) (Amp.Dimensional v y) yv yv forceDimensionalAmplitude ampOut = Cons $ \(Amp.Numeric ampIn) -> (Arrow.arr (DN.divToScalar ampIn ampOut *>), @@ -254,7 +303,7 @@ {- | -I will call the connection from input to output amplitudes of type @amp@, +I will call the connection from input to output amplitudes of type @amp@ the looping channel. It is essential, that the looping channel decouples output from input amplitude. You can achieve this by inserting one of the @forceAmplitude@ functions @@ -263,9 +312,8 @@ {-# INLINE loop #-} loop :: (ArrowLoop arrow) => - T (restAmpIn, amp) (restAmpOut, amp) - (arrow (restSampIn, yv) (restSampOut, yv)) -> - T restAmpIn restAmpOut (arrow restSampIn restSampOut) + T arrow (restSampleIn, sample) (restSampleOut, sample) -> + T arrow restSampleIn restSampleOut loop (Cons f) = Cons $ \restAmpIn -> let (arrow, (restAmpOut, amp)) = f (restAmpIn, amp) @@ -277,11 +325,10 @@ (Field.C y, Module.C y yv, Dim.C v, ArrowLoop arrow) => DN.T v y -> - T (restAmpIn, Amp.Dimensional v y) - (restAmpOut, Amp.Dimensional v y) - (arrow (restSampIn, yv) (restSampOut, yv)) -> - T restAmpIn restAmpOut - (arrow restSampIn restSampOut) + T arrow + (restSampleIn, Sample.T (Amp.Dimensional v y) yv) + (restSampleOut, Sample.T (Amp.Dimensional v y) yv) -> + T arrow restSampleIn restSampleOut loopVolume ampIn f = loop (f >>> second (forceDimensionalAmplitude ampIn)) @@ -292,12 +339,12 @@ Field.C y1, Module.C y1 yv1, Dim.C v1, ArrowLoop arrow) => (DN.T v0 y0, DN.T v1 y1) -> - T (restAmpIn, (Amp.Numeric (DN.T v0 y0), Amp.Numeric (DN.T v1 y1))) - (restAmpOut, (Amp.Numeric (DN.T v0 y0), Amp.Numeric (DN.T v1 y1))) - (arrow (restSampIn, (yv0,yv1)) - (restSampOut, (yv0,yv1))) -> - T restAmpIn restAmpOut - (arrow restSampIn restSampOut) + T arrow + (restSampleIn, (Sample.T (Amp.Dimensional v0 y0) yv0, + Sample.T (Amp.Dimensional v1 y1) yv1)) + (restSampleOut, (Sample.T (Amp.Dimensional v0 y0) yv0, + Sample.T (Amp.Dimensional v1 y1) yv1)) -> + T arrow restSampleIn restSampleOut loop2Volume (ampIn0,ampIn1) f = loop (f >>> second (forceDimensionalAmplitude ampIn0 *** diff --git a/src/Synthesizer/Dimensional/Causal/ControlledProcess.hs b/src/Synthesizer/Dimensional/Causal/ControlledProcess.hs --- a/src/Synthesizer/Dimensional/Causal/ControlledProcess.hs +++ b/src/Synthesizer/Dimensional/Causal/ControlledProcess.hs @@ -52,6 +52,10 @@ -} module Synthesizer.Dimensional.Causal.ControlledProcess where +import qualified Synthesizer.Dimensional.Sample as Sample +import Synthesizer.Dimensional.Sample (Amplitude, Displacement, ) +import Synthesizer.Dimensional.Causal.Process ((<<<), ) + import qualified Synthesizer.Dimensional.Process as Proc import qualified Synthesizer.Dimensional.Rate as Rate import qualified Synthesizer.Dimensional.Signal.Private as SigA @@ -82,8 +86,8 @@ import Foreign.Storable.Newtype as Store import Foreign.Storable (Storable(..)) -import NumericPrelude -import PreludeBase as P +import NumericPrelude.Numeric +import NumericPrelude.Base as P {- | @@ -114,11 +118,14 @@ @ec@ is the type for the external control parameters, @ic@ for internal control parameters. -} -type Converter s ecAmp ec ic = - MapD.T ecAmp Amp.Abstract ec (RateDep s ic) +type Converter s ec ic = + MapD.T ec (SampleRateDep s ic) +type SampleRateDep s ic = Sample.Abstract (RateDep s ic) + newtype RateDep s ic = RateDep {unRateDep :: ic} + instance Interpol.C a ic => Interpol.C a (RateDep s ic) where scaleAndAccumulate = Interpol.makeMac RateDep unRateDep @@ -139,43 +146,44 @@ -} {-# INLINE makeConverter #-} makeConverter :: - (ecAmp -> ec -> ic) -> Converter s ecAmp ec ic + (Sample.Amplitude ec -> Sample.Displacement ec -> ic) -> + Converter s ec ic makeConverter f = ArrowD.Cons $ swap . (,) Amp.Abstract . (RateDep.) . f {-# INLINE causalFromConverter #-} causalFromConverter :: - Converter s ecAmp ec ic -> - CausalD.T s ecAmp Amp.Abstract ec (RateDep s ic) + Converter s ec ic -> + CausalD.T s ec (SampleRateDep s ic) causalFromConverter = CausalD.map {-# INLINE joinSynchronousPlain #-} joinSynchronousPlain :: - T (Converter s ecAmp ec ic) - (CausalD.T s (ampIn, Amp.Abstract) ampOut (sampIn, RateDep s ic) sampOut) -> - CausalD.T s (ecAmp, ampIn) ampOut (ec, sampIn) sampOut + T (Converter s ec ic) + (CausalD.T s (sampleIn, SampleRateDep s ic) sampleOut) -> + CausalD.T s (ec, sampleIn) sampleOut joinSynchronousPlain p = - processor p CausalD.<<< - MapD.swap CausalD.^<< + processor p <<< + MapD.swap <<< CausalD.first (causalFromConverter (converter p)) {-# INLINE joinSynchronous #-} joinSynchronous :: Proc.T s u t - (T (Converter s ecAmp ec ic) - (CausalD.T s (ampIn, Amp.Abstract) ampOut (sampIn, RateDep s ic) sampOut)) -> - Proc.T s u t (CausalD.T s (ecAmp, ampIn) ampOut (ec, sampIn) sampOut) + (T (Converter s ec ic) + (CausalD.T s (sampleIn, SampleRateDep s ic) sampleOut)) -> + Proc.T s u t (CausalD.T s (ec, sampleIn) sampleOut) joinSynchronous cp = fmap joinSynchronousPlain cp {-# INLINE joinFirstSynchronousPlain #-} joinFirstSynchronousPlain :: - T (Converter s ecAmp ec ic, a) - (CausalD.T s (ampIn, Amp.Abstract) ampOut (sampIn, RateDep s ic) sampOut) -> + T (Converter s ec ic, a) + (CausalD.T s (sampleIn, SampleRateDep s ic) sampleOut) -> T a - (CausalD.T s (ecAmp, ampIn) ampOut (ec, sampIn) sampOut) + (CausalD.T s (ec, sampleIn) sampleOut) joinFirstSynchronousPlain p = Cons { converter = snd (converter p), @@ -191,11 +199,11 @@ {-# INLINE joinFirstSynchronous #-} joinFirstSynchronous :: Proc.T s u t - (T (Converter s ecAmp ec ic, a) - (CausalD.T s (ampIn, Amp.Abstract) ampOut (sampIn, RateDep s ic) sampOut)) -> + (T (Converter s ec ic, a) + (CausalD.T s (sampleIn, SampleRateDep s ic) sampleOut)) -> Proc.T s u t (T a - (CausalD.T s (ecAmp, ampIn) ampOut (ec, sampIn) sampOut)) + (CausalD.T s (ec, sampleIn) sampleOut)) joinFirstSynchronous cp = fmap joinFirstSynchronousPlain cp @@ -212,47 +220,39 @@ {-# INLINE runSynchronous1 #-} runSynchronous1 :: (Amp.C ecAmp) => Proc.T s u t - (T (Converter s ecAmp ec ic) - (CausalD.T s (ampIn, Amp.Abstract) ampOut (sampIn, RateDep s ic) sampOut)) -> + (T (Converter s (Sample.T ecAmp ec) ic) + (CausalD.T s (sampleIn, SampleRateDep s ic) sampleOut)) -> Proc.T s u t - (Signal s ecAmp ec -> CausalD.T s ampIn ampOut sampIn sampOut) + (Signal s ecAmp ec -> CausalD.T s sampleIn sampleOut) runSynchronous1 = fmap CausalD.applyFst . joinSynchronous {-# INLINE runSynchronousPlain2 #-} runSynchronousPlain2 :: (Amp.C ecAmp0, Amp.C ecAmp1) => - (T (Converter s (ecAmp0, ecAmp1) (ec0, ec1) ic) - (CausalD.T s (ampIn, Amp.Abstract) ampOut (sampIn, RateDep s ic) sampOut)) -> + (T (Converter s (Sample.T ecAmp0 ec0, Sample.T ecAmp1 ec1) ic) + (CausalD.T s (sampleIn, SampleRateDep s ic) sampleOut)) -> (Signal s ecAmp0 ec0 -> Signal s ecAmp1 ec1 -> - CausalD.T s ampIn ampOut sampIn sampOut) + CausalD.T s sampleIn sampleOut) runSynchronousPlain2 causal = let causalPairs = - joinSynchronousPlain causal CausalD.<<^ MapD.balanceLeft + joinSynchronousPlain causal <<< MapD.balanceLeft in \x y -> (causalPairs `CausalD.applyFst` x) `CausalD.applyFst` y {-# INLINE runSynchronous2 #-} runSynchronous2 :: (Amp.C ecAmp0, Amp.C ecAmp1) => Proc.T s u t - (T (Converter s (ecAmp0, ecAmp1) (ec0, ec1) ic) - (CausalD.T s (ampIn, Amp.Abstract) ampOut (sampIn, RateDep s ic) sampOut)) -> + (T (Converter s (Sample.T ecAmp0 ec0, Sample.T ecAmp1 ec1) ic) + (CausalD.T s (sampleIn, SampleRateDep s ic) sampleOut)) -> Proc.T s u t (Signal s ecAmp0 ec0 -> Signal s ecAmp1 ec1 -> - CausalD.T s ampIn ampOut sampIn sampOut) + CausalD.T s sampleIn sampleOut) runSynchronous2 cp = fmap runSynchronousPlain2 cp -{- -{-# INLINE runSynchronous3 #-} -runSynchronous3 :: - Proc.T s u t (T s (RP.T s sig0 ec0, RP.T s sig1 ec1, RP.T s sig2 ec2) ic a) -> - Proc.T s u t (RP.T s sig0 ec0 -> RP.T s sig1 ec1 -> RP.T s sig2 ec2 -> a) -runSynchronous3 = - fmap (\f x y z -> f (x,y,z)) . runSynchronous --} {-# INLINE runAsynchronous #-} @@ -260,14 +260,14 @@ (Dim.C u, RealField.C t) => Interpolation.T t (RateDep s ic) -> Proc.T s u t - (T (Converter s ecAmp ec ic) - (CausalD.T s (ampIn, Amp.Abstract) ampOut (sampIn, RateDep s ic) sampOut)) -> + (T (Converter s ec ic) + (CausalD.T s (sampleIn, SampleRateDep s ic) sampleOut)) -> SigA.T (Rate.Dimensional u t) Amp.Abstract (Sig.T (RateDep s ic)) -> Proc.T s u t - (CausalD.T s ampIn ampOut sampIn sampOut) + (CausalD.T s sampleIn sampleOut) runAsynchronous ip cp sig = liftA2 (\p k -> - CausalD.applyFst (processor p CausalD.<<^ MapD.swap) $ + CausalD.applyFst (processor p <<< MapD.swap) $ SigA.abstractFromBody $ Causal.applyConst (Interpolation.relativeConstantPad ip zero (SigA.body sig)) @@ -279,11 +279,11 @@ (Dim.C u, RealField.C t) => Interpolation.T t (RateDep s ic) -> Proc.T s u t - (T (Converter s ecAmp ec ic) - (CausalD.T s (ampIn, Amp.Abstract) ampOut (sampIn, RateDep s ic) sampOut)) -> + (T (Converter s ec ic) + (CausalD.T s (sampleIn, SampleRateDep s ic) sampleOut)) -> SigA.T (Rate.Dimensional u t) Amp.Abstract (Sig.T (RateDep s ic)) -> Proc.T s u t - (CausalD.T s ampIn ampOut sampIn sampOut) + (CausalD.T s sampleIn sampleOut) runAsynchronousBuffered ip cp = runAsynchronous ip cp . SigA.processBody (Sig.fromList . Sig.toList) @@ -291,7 +291,7 @@ {-# INLINE applyConverter1 #-} applyConverter1 :: (Amp.C ecAmp) => - Converter s ecAmp ec ic -> + Converter s (Sample.T ecAmp ec) ic -> SigA.T (Rate.Dimensional u t) ecAmp (Sig.T ec) -> SigA.T (Rate.Dimensional u t) Amp.Abstract (Sig.T (RateDep s ic)) applyConverter1 = MapD.apply @@ -301,11 +301,11 @@ (Dim.C u, Amp.C ecAmp, RealField.C t) => Interpolation.T t (RateDep s ic) -> Proc.T s u t - (T (Converter s ecAmp ec ic) - (CausalD.T s (ampIn, Amp.Abstract) ampOut (sampIn, RateDep s ic) sampOut)) -> + (T (Converter s (Sample.T ecAmp ec) ic) + (CausalD.T s (sampleIn, SampleRateDep s ic) sampleOut)) -> SigA.T (Rate.Dimensional u t) ecAmp (Sig.T ec) -> Proc.T s u t - (CausalD.T s ampIn ampOut sampIn sampOut) + (CausalD.T s sampleIn sampleOut) runAsynchronous1 ip cp x = cp >>= \p -> runAsynchronous ip cp @@ -316,12 +316,12 @@ (Dim.C u, Amp.C ecAmp, RealField.C t) => Interpolation.T t (RateDep s ic) -> Proc.T s u t - (T (Converter s ecAmp ec ic) - (CausalD.T s (ampIn, Amp.Abstract) ampOut (sampIn, RateDep s ic) sampOut)) -> + (T (Converter s (Sample.T ecAmp ec) ic) + (CausalD.T s (sampleIn, SampleRateDep s ic) sampleOut)) -> DN.T (Dim.Recip u) t -> (forall r. Proc.T r u t (Signal r ecAmp ec)) -> Proc.T s u t - (CausalD.T s ampIn ampOut sampIn sampOut) + (CausalD.T s sampleIn sampleOut) processAsynchronous1 ip cp rate x = runAsynchronous1 ip cp (SigA.render rate x) @@ -331,12 +331,12 @@ (DN.T (Dim.Recip u) t -> DN.T (Dim.Recip u) t -> DN.T (Dim.Recip u) t) -> - Converter s (ecAmp0, ecAmp1) (ec0, ec1) ic -> + Converter s (Sample.T ecAmp0 ec0, Sample.T ecAmp1 ec1) ic -> SigA.T (Rate.Dimensional u t) ecAmp0 (Sig.T ec0) -> SigA.T (Rate.Dimensional u t) ecAmp1 (Sig.T ec1) -> SigA.T (Rate.Dimensional u t) Amp.Abstract (Sig.T (RateDep s ic)) applyConverter2 mergeRate f x y = - MapD.apply f $ + ArrowD.apply f $ SigA.Cons (Rate.Actual $ mergeRate (SigA.actualSampleRate x) (SigA.actualSampleRate y)) (SigA.amplitude x, SigA.amplitude y) @@ -356,12 +356,12 @@ (Dim.C u, Amp.C ecAmp0, Amp.C ecAmp1, RealField.C t) => Interpolation.T t (RateDep s ic) -> Proc.T s u t - (T (Converter s (ecAmp0, ecAmp1) (ec0, ec1) ic) - (CausalD.T s (ampIn, Amp.Abstract) ampOut (sampIn, RateDep s ic) sampOut)) -> + (T (Converter s (Sample.T ecAmp0 ec0, Sample.T ecAmp1 ec1) ic) + (CausalD.T s (sampleIn, SampleRateDep s ic) sampleOut)) -> SigA.T (Rate.Dimensional u t) (ecAmp0) (Sig.T ec0) -> SigA.T (Rate.Dimensional u t) (ecAmp1) (Sig.T ec1) -> Proc.T s u t - (CausalD.T s ampIn ampOut sampIn sampOut) + (CausalD.T s sampleIn sampleOut) runAsynchronous2 ip cp x y = cp >>= \p -> runAsynchronous ip cp @@ -382,13 +382,13 @@ (Dim.C u, Amp.C ecAmp0, Amp.C ecAmp1, RealField.C t) => Interpolation.T t (RateDep s ic) -> Proc.T s u t - (T (Converter s (ecAmp0, ecAmp1) (ec0, ec1) ic) - (CausalD.T s (ampIn, Amp.Abstract) ampOut (sampIn, RateDep s ic) sampOut)) -> + (T (Converter s (Sample.T ecAmp0 ec0, Sample.T ecAmp1 ec1) ic) + (CausalD.T s (sampleIn, SampleRateDep s ic) sampleOut)) -> DN.T (Dim.Recip u) t -> (forall r. Proc.T r u t (Signal r ecAmp0 ec0)) -> (forall r. Proc.T r u t (Signal r ecAmp1 ec1)) -> Proc.T s u t - (CausalD.T s ampIn ampOut sampIn sampOut) + (CausalD.T s sampleIn sampleOut) processAsynchronous2 ip cp rate x y = let sigX = SigA.render rate x sigY = SigA.render rate y @@ -402,13 +402,13 @@ (Dim.C u, Amp.C ecAmp0, Amp.C ecAmp1, RealField.C t) => Interpolation.T t (RateDep s ic) -> Proc.T s u t - (T (Converter s (ecAmp0, ecAmp1) (ec0, ec1) ic) - (CausalD.T s (ampIn, Amp.Abstract) ampOut (sampIn, RateDep s ic) sampOut)) -> + (T (Converter s (Sample.T ecAmp0 ec0, Sample.T ecAmp1 ec1) ic) + (CausalD.T s (sampleIn, SampleRateDep s ic) sampleOut)) -> DN.T (Dim.Recip u) t -> (forall r. Proc.T r u t (Signal r ecAmp0 ec0)) -> (forall r. Proc.T r u t (Signal r ecAmp1 ec1)) -> Proc.T s u t - (CausalD.T s ampIn ampOut sampIn sampOut) + (CausalD.T s sampleIn sampleOut) processAsynchronousNaive2 ip cp rate x y = runAsynchronous2 ip cp (SigA.render rate x) (SigA.render rate y) @@ -429,13 +429,13 @@ (Dim.C u, Amp.C ecAmp0, Amp.C ecAmp1, Storable ic, RealField.C t) => Interpolation.T t (RateDep s ic) -> Proc.T s u t - (T (Converter s (ecAmp0, ecAmp1) (ec0, ec1) ic) - (CausalD.T s (ampIn, Amp.Abstract) ampOut (sampIn, RateDep s ic) sampOut)) -> + (T (Converter s (Sample.T ecAmp0 ec0, Sample.T ecAmp1 ec1) ic) + (CausalD.T s (sampleIn, SampleRateDep s ic) sampleOut)) -> DN.T (Dim.Recip u) t -> (forall r. Proc.T r u t (Signal r ecAmp0 ec0)) -> (forall r. Proc.T r u t (Signal r ecAmp1 ec1)) -> Proc.T s u t - (CausalD.T s ampIn ampOut sampIn sampOut) + (CausalD.T s sampleIn sampleOut) processAsynchronousStorable2 ip cp rate x y = let sigX = SigA.render rate x sigY = SigA.render rate y @@ -458,36 +458,16 @@ (Dim.C u, Amp.C ecAmp0, Amp.C ecAmp1, RealField.C t) => Interpolation.T t (RateDep s ic) -> Proc.T s u t - (T (Converter s (ecAmp0, ecAmp1) (ec0, ec1) ic) - (CausalD.T s (ampIn, Amp.Abstract) ampOut (sampIn, RateDep s ic) sampOut)) -> + (T (Converter s (Sample.T ecAmp0 ec0, Sample.T ecAmp1 ec1) ic) + (CausalD.T s (sampleIn, SampleRateDep s ic) sampleOut)) -> DN.T (Dim.Recip u) t -> (forall r. Proc.T r u t (Signal r ecAmp0 ec0)) -> (forall r. Proc.T r u t (Signal r ecAmp1 ec1)) -> Proc.T s u t - (CausalD.T s ampIn ampOut sampIn sampOut) + (CausalD.T s sampleIn sampleOut) processAsynchronousBuffered2 ip cp rate x y = let sigX = SigA.render rate x sigY = SigA.render rate y in cp >>= \p -> runAsynchronousBuffered ip cp (applyConverter2 const (converter p) sigX sigY) - - -{- -{-# INLINE runAsynchronous3 #-} -runAsynchronous3 :: - (Dim.C u, RealField.C t) => - Interpolation.T t (RateDep s ic) -> - Proc.T s u t (T s (RP.T r sig0 ec0, RP.T r sig1 ec1, RP.T r sig2 ec2) ic a) -> - SigP.T u t sig0 ec0 -> - SigP.T u t sig1 ec1 -> - SigP.T u t sig2 ec2 -> - Proc.T s u t a -runAsynchronous3 ip cp x y z = - let (srcRateX,sigX) = SigP.toSignal x - (srcRateY,sigY) = SigP.toSignal y - (srcRateZ,sigZ) = SigP.toSignal z - common = Rate.common "ControlledProcess.runAsynchronous3" - srcRate = srcRateX `common` srcRateY `common` srcRateZ - in runAsynchronous ip cp srcRate (sigX,sigY,sigZ) --} diff --git a/src/Synthesizer/Dimensional/Causal/Displacement.hs b/src/Synthesizer/Dimensional/Causal/Displacement.hs --- a/src/Synthesizer/Dimensional/Causal/Displacement.hs +++ b/src/Synthesizer/Dimensional/Causal/Displacement.hs @@ -1,5 +1,5 @@ {- | -Copyright : (c) Henning Thielemann 2008-2009 +Copyright : (c) Henning Thielemann 2008-2010 License : GPL Maintainer : synthesizer@henning-thielemann.de @@ -12,193 +12,78 @@ raise, distort, ) where +import qualified Synthesizer.Dimensional.Map.Displacement as Disp + import qualified Synthesizer.Dimensional.Process as Proc -import qualified Synthesizer.Dimensional.Amplitude as Amp +import qualified Synthesizer.Dimensional.Sample as Sample -import qualified Synthesizer.Dimensional.Arrow as ArrowD import qualified Synthesizer.Dimensional.Causal.Process as CausalD -import qualified Control.Arrow as Arrow -import Control.Arrow ((^<<), (&&&), ) - import qualified Number.DimensionTerm as DN import qualified Algebra.DimensionTerm as Dim import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField import qualified Algebra.Field as Field -import qualified Algebra.Real as Real +import qualified Algebra.Absolute as Absolute -- import qualified Algebra.Ring as Ring -- import qualified Algebra.Additive as Additive -- import Algebra.Module ((*>)) -import Control.Monad.Trans.Reader (Reader, runReader, asks, ) -import Control.Applicative (liftA2, ) - -import PreludeBase -import NumericPrelude +import NumericPrelude.Base +-- import NumericPrelude.Numeric import Prelude () -type DN v y = Amp.Numeric (DN.T v y) -type Context v y = Reader (DN.T v y) - -causalMap :: (yv0 -> yv1) -> CausalD.Core s yv0 yv1 -causalMap = Arrow.arr +type DNS v y yv = Sample.Dimensional v y yv -{- * Mixing -} +-- * Mixing -{- | -Mix two signals. -In contrast to 'zipWith' the result has the length of the longer signal. --} {-# INLINE mix #-} -mix :: (Real.C y, Field.C y, Module.C y yv, Dim.C v) => - Proc.T s u t (CausalD.T s (DN v y, DN v y) (DN v y) (yv,yv) yv) -mix = - Proc.pure $ - fromAmplitudeReader $ \(Amp.Numeric amp0, Amp.Numeric amp1) -> - (DN.abs amp0 + DN.abs amp1, mixCore amp0 amp1) +mix :: (Absolute.C y, Field.C y, Module.C y yv, Dim.C v) => + Proc.T s u t (CausalD.T s (DNS v y yv, DNS v y yv) (DNS v y yv)) +mix = Proc.pure $ Disp.mix {-# INLINE mixVolume #-} mixVolume :: (Field.C y, Module.C y yv, Dim.C v) => DN.T v y -> - Proc.T s u t (CausalD.T s (DN v y, DN v y) (DN v y) (yv,yv) yv) -mixVolume amp = - Proc.pure $ - fromAmplitudeReader $ \(Amp.Numeric amp0, Amp.Numeric amp1) -> - (amp, mixCore amp0 amp1) - -{-# INLINE mixCore #-} -mixCore :: - (Field.C y, Module.C y yv, Dim.C v) => - DN.T v y -> DN.T v y -> - Context v y (CausalD.Core s (yv,yv) yv) -mixCore amp0 amp1 = - liftA2 - (\toSamp0 toSamp1 -> - causalMap (\(y0,y1) -> toSamp0 y0 + toSamp1 y1)) - (toAmplitudeVector amp0) - (toAmplitudeVector amp1) + Proc.T s u t (CausalD.T s (DNS v y yv, DNS v y yv) (DNS v y yv)) +mixVolume = Proc.pure . Disp.mixVolume -{- | -Mix one or more signals. --} {-# INLINE fanoutAndMixMulti #-} fanoutAndMixMulti :: - (Real.C y, Field.C y, Module.C y yv, Dim.C v) => - [Proc.T s u t (CausalD.T s ampIn (DN v y) yvIn yv)] -> - Proc.T s u t (CausalD.T s ampIn (DN v y) yvIn yv) + (RealField.C y, Module.C y yv, Dim.C v) => + [Proc.T s u t (CausalD.T s sample (DNS v y yv))] -> + Proc.T s u t (CausalD.T s sample (DNS v y yv)) fanoutAndMixMulti = - fmap fanoutAndMixMultiPlain . sequence - -{-# INLINE fanoutAndMixMultiPlain #-} -fanoutAndMixMultiPlain :: - (Real.C y, Field.C y, Module.C y yv, Dim.C v) => - [CausalD.T s ampIn (DN v y) yvIn yv] -> - CausalD.T s ampIn (DN v y) yvIn yv -fanoutAndMixMultiPlain cs = - fromAmplitudeReader $ \ampIn -> - let ampCs = map (\(ArrowD.Cons f) -> f ampIn) cs - in (maximum (map (\(_, Amp.Numeric amp) -> amp) ampCs), - fanoutAndMixMultiVolumeCore ampCs) + fmap Disp.fanoutAndMixMulti . sequence {-# INLINE fanoutAndMixMultiVolume #-} fanoutAndMixMultiVolume :: (Field.C y, Module.C y yv, Dim.C v) => DN.T v y -> - [Proc.T s u t (CausalD.T s ampIn (DN v y) yvIn yv)] -> - Proc.T s u t (CausalD.T s ampIn (DN v y) yvIn yv) + [Proc.T s u t (CausalD.T s sample (DNS v y yv))] -> + Proc.T s u t (CausalD.T s sample (DNS v y yv)) fanoutAndMixMultiVolume amp = - fmap (fanoutAndMixMultiVolumePlain amp) . sequence + fmap (Disp.fanoutAndMixMultiVolume amp) . sequence -{-# INLINE fanoutAndMixMultiVolumePlain #-} -fanoutAndMixMultiVolumePlain :: - (Field.C y, Module.C y yv, Dim.C v) => - DN.T v y -> - [CausalD.T s ampIn (DN v y) yvIn yv] -> - CausalD.T s ampIn (DN v y) yvIn yv -fanoutAndMixMultiVolumePlain amp cs = - fromAmplitudeReader $ \ampIn -> - (amp, fanoutAndMixMultiVolumeCore $ - map (\(ArrowD.Cons f) -> f ampIn) cs) -{-# INLINE fanoutAndMixMultiVolumeCore #-} -fanoutAndMixMultiVolumeCore :: - (Field.C y, Module.C y yv, Dim.C v) => - [(CausalD.Core s yvIn yv, DN v y)] -> - Context v y (CausalD.Core s yvIn yv) -fanoutAndMixMultiVolumeCore cs = - foldr - (\(c, Amp.Numeric ampX) -> - liftA2 - (\toSamp rest -> - uncurry (+) ^<< (toSamp ^<< c) &&& rest) - (toAmplitudeVector ampX)) - (return $ causalMap (const zero)) cs - +-- * Miscellaneous -{- | -Add a number to all of the signal values. -This is useful for adjusting the center of a modulation. --} {-# INLINE raise #-} raise :: (Field.C y, Module.C y yv, Dim.C v) => DN.T v y -> yv -> - Proc.T s u t (CausalD.T s (DN v y) (DN v y) yv yv) -raise y' yv = - Proc.pure $ - fromAmplitudeReader $ \(Amp.Numeric amp) -> - (amp, fmap (\toSamp -> causalMap (toSamp yv +)) (toAmplitudeVector y')) + Proc.T s u t (CausalD.T s (DNS v y yv) (DNS v y yv)) +raise y yv = Proc.pure (Disp.raise y yv) -{- | -Distort the signal using a flat function. -The first signal gives the scaling of the function. -If the scaling is c and the input sample is y, -then @c * f(y/c)@ is output. -This way we can use an (efficient) flat function -and have a simple, yet dimension conform, way of controlling the distortion. -E.g. if the distortion function is @tanh@ -then the value @c@ controls the saturation level. --} {-# INLINE distort #-} distort :: (Field.C y, Module.C y yv, Dim.C v) => (yv -> yv) -> - Proc.T s u t (CausalD.T s (DN v y, DN v y) (DN v y) (y,yv) yv) -distort f = - Proc.pure $ - fromAmplitudeReader $ \(Amp.Numeric ampCtrl, Amp.Numeric ampIn) -> - (ampIn, - fmap (\toSamp -> - causalMap (\(c,y) -> - let c' = toSamp c - in c' *> f (recip c' *> y))) - (toAmplitudeScalar ampCtrl)) - - -{-# INLINE toAmplitudeScalar #-} -toAmplitudeScalar :: - (Field.C y, Dim.C u) => - DN.T u y -> Reader (DN.T u y) (y -> y) -toAmplitudeScalar ampIn = - asks (\ampOut -> (DN.divToScalar ampIn ampOut *)) - -{-# INLINE toAmplitudeVector #-} -toAmplitudeVector :: - (Module.C y yv, Field.C y, Dim.C u) => - DN.T u y -> Reader (DN.T u y) (yv -> yv) -toAmplitudeVector ampIn = - asks (\ampOut -> (DN.divToScalar ampIn ampOut *> )) - -{-# INLINE fromAmplitudeReader #-} -fromAmplitudeReader :: - (ampIn -> (ampOut, Reader ampOut (CausalD.Core s yv0 yv1))) -> - CausalD.T s ampIn (Amp.Numeric ampOut) yv0 yv1 -fromAmplitudeReader f = - ArrowD.Cons $ \ampIn -> - let (ampOut, rd) = f ampIn - in (runReader rd ampOut, Amp.Numeric ampOut) + Proc.T s u t (CausalD.T s (DNS v y y, DNS v y yv) (DNS v y yv)) +distort = + Proc.pure . Disp.distort diff --git a/src/Synthesizer/Dimensional/Causal/Filter.hs b/src/Synthesizer/Dimensional/Causal/Filter.hs --- a/src/Synthesizer/Dimensional/Causal/Filter.hs +++ b/src/Synthesizer/Dimensional/Causal/Filter.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleContexts #-} {- | Copyright : (c) Henning Thielemann 2008-2009 License : GPL @@ -85,6 +86,7 @@ import qualified Synthesizer.Dimensional.Map.Filter as FiltM import qualified Synthesizer.Dimensional.Process as Proc +import qualified Synthesizer.Dimensional.Sample as Sample import qualified Synthesizer.Dimensional.Amplitude as Amp -- import qualified Synthesizer.Dimensional.Rate as Rate import qualified Synthesizer.Dimensional.Causal.ControlledProcess as CCProc @@ -131,9 +133,9 @@ import qualified Number.NonNegative as NonNeg import qualified Algebra.Transcendental as Trans --- import qualified Algebra.RealField as RealField +-- import qualified Algebra.RealRing as RealRing import qualified Algebra.Field as Field --- import qualified Algebra.Real as Real +-- import qualified Algebra.Absolute as Absolute import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive -- import qualified Algebra.VectorSpace as VectorSpace @@ -145,8 +147,8 @@ import Data.Tuple.HT (swap, mapFst, ) -import NumericPrelude hiding (negate) -import PreludeBase as P +import NumericPrelude.Numeric hiding (negate) +import NumericPrelude.Base as P import Prelude () @@ -154,77 +156,75 @@ {-# INLINE amplify #-} amplify :: (Module.C y amp) => y -> - Proc.T s u t (CausalD.T s (Amp.Numeric amp) (Amp.Numeric amp) yv yv) + Proc.T s u t (CausalD.Single s (Amp.Numeric amp) (Amp.Numeric amp) yv yv) amplify volume = - Proc.pure $ CausalD.map $ FiltM.amplify volume + Proc.pure $ FiltM.amplify volume {-# INLINE amplifyDimension #-} amplifyDimension :: (Ring.C y, Dim.C u, Dim.C v0, Dim.C v1) => DN.T v0 y -> Proc.T s u t - (CausalD.T s + (CausalD.Single s (Amp.Dimensional v1 y) (Amp.Dimensional (Dim.Mul v0 v1) y) yv yv) amplifyDimension volume = - Proc.pure $ CausalD.map $ FiltM.amplifyDimension volume + Proc.pure $ FiltM.amplifyDimension volume {-# INLINE amplifyScalarDimension #-} amplifyScalarDimension :: (Ring.C y, Dim.C u, Dim.C v) => DN.T v y -> Proc.T s u t - (CausalD.T s + (CausalD.Single s (Amp.Dimensional Dim.Scalar y) (Amp.Dimensional v y) yv yv) amplifyScalarDimension volume = - Proc.pure $ CausalD.map $ FiltM.amplifyScalarDimension volume + Proc.pure $ FiltM.amplifyScalarDimension volume {-# INLINE negate #-} -negate :: (Additive.C yv) => - Proc.T s u t (CausalD.T s amp amp yv yv) +negate :: (Additive.C (Sample.Displacement sample)) => + Proc.T s u t (CausalD.T s sample sample) negate = - Proc.pure $ CausalD.map $ FiltM.negate + Proc.pure $ FiltM.negate {-# INLINE envelope #-} envelope :: (Ring.C y) => - Proc.T s u t (CausalD.T s (Amp.Flat y, amp) amp (y,y) y) + Proc.T s u t (CausalD.T s (Sample.Flat y, Sample.Numeric amp y) (Sample.Numeric amp y)) envelope = - Proc.pure $ CausalD.map $ FiltM.envelope + Proc.pure $ FiltM.envelope {-# INLINE envelopeScalarDimension #-} envelopeScalarDimension :: (Ring.C y, Dim.C u, Dim.C v) => Proc.T s u t (CausalD.T s - (Amp.Dimensional Dim.Scalar y, Amp.Dimensional v y) - (Amp.Dimensional v y) - (y,y) y) + (Sample.Dimensional Dim.Scalar y y, Sample.Dimensional v y y) + (Sample.Dimensional v y y)) envelopeScalarDimension = - Proc.pure $ CausalD.map $ FiltM.envelopeScalarDimension + Proc.pure $ FiltM.envelopeScalarDimension {-# INLINE envelopeVector #-} -envelopeVector :: (Module.C y yv) => - Proc.T s u t (CausalD.T s (Amp.Flat y, amp) amp (y,yv) yv) +envelopeVector :: (Module.C y (Sample.Displacement sample)) => + Proc.T s u t (CausalD.T s (Sample.Flat y, sample) sample) envelopeVector = - Proc.pure $ CausalD.map $ FiltM.envelopeVector + Proc.pure $ FiltM.envelopeVector {-# INLINE envelopeVectorDimension #-} envelopeVectorDimension :: (Module.C y0 yv, Ring.C y, Dim.C u, Dim.C v0, Dim.C v1) => Proc.T s u t (CausalD.T s - (Amp.Dimensional v0 y, Amp.Dimensional v1 y) - (Amp.Dimensional (Dim.Mul v0 v1) y) - (y0,yv) yv) + (Sample.Dimensional v0 y y0, Sample.Dimensional v1 y yv) + (Sample.Dimensional (Dim.Mul v0 v1) y yv)) envelopeVectorDimension = - Proc.pure $ CausalD.map $ FiltM.envelopeVectorDimension + Proc.pure $ FiltM.envelopeVectorDimension {-# INLINE differentiate #-} differentiate :: (Additive.C yv, Ring.C q, Dim.C u, Dim.C v) => Proc.T s u q - (CausalD.T s + (CausalD.Single s (Amp.Dimensional v q) (Amp.Dimensional (DimensionGradient u v) q) yv yv) differentiate = flip fmap Proc.getSampleRate $ \rate -> @@ -238,7 +238,7 @@ {- | needs a good handling of boundaries, yet -} {-# INLINE meanStatic #-} meanStatic :: - (RealField.C q, Module.C q yv, Dim.C u, Dim.C v) => + (RealRing.C q, Module.C q yv, Dim.C u, Dim.C v) => DN.T (Dim.Recip u) q {- ^ cut-off frequency -} -> Proc.T s u q ( SigA.R s v q yv @@ -246,7 +246,7 @@ meanStatic time = FiltR.meanStatic time -meanStaticSeparateTY :: (Additive.C yv, Field.C y, RealField.C t, +meanStaticSeparateTY :: (Additive.C yv, Field.C y, RealRing.C t, Module.C y yv, Dim.C u, Dim.C v) => DN.T (Dim.Recip u) t {- ^ cut-off frequency -} -> Proc.T s u t ( @@ -266,7 +266,7 @@ {- | needs a better handling of boundaries, yet -} {-# INLINE mean #-} -mean :: (Additive.C yv, RealField.C q, +mean :: (Additive.C yv, RealRing.C q, Module.C q yv, Dim.C u, Dim.C v) => DN.T (Dim.Recip u) q {- ^ minimum cut-off frequency -} -> Proc.T s u q ( @@ -279,7 +279,7 @@ {-# INLINE delay #-} -delay :: (Additive.C yv, Field.C y, RealField.C t, Dim.C u, Dim.C v) => +delay :: (Additive.C yv, Field.C y, RealRing.C t, Dim.C u, Dim.C v) => DN.T u t -> Proc.T s u t ( SigA.R s v y yv @@ -291,7 +291,7 @@ {-# INLINE phaseModulation #-} phaseModulation :: - (Additive.C yv, RealField.C q, Dim.C u, Dim.C v, + (Additive.C yv, RealRing.C q, Dim.C u, Dim.C v, Sample.C q, Sample.C yv) => Interpolation.T q yv -> DN.T u q @@ -311,7 +311,7 @@ {-# INLINE frequencyModulation #-} frequencyModulation :: - (Flat.C flat q, Additive.C yv, RealField.C q, Dim.C u, Dim.C v) => + (Flat.C flat q, Additive.C yv, RealRing.C q, Dim.C u, Dim.C v) => Interpolation.T q yv -> Proc.T s u q ( RP.T s flat q {- v frequency factors -} @@ -335,7 +335,7 @@ -} {-# INLINE frequencyModulationDecoupled #-} frequencyModulationDecoupled :: - (Flat.C flat q, Additive.C yv, RealField.C q, Dim.C u, Dim.C v) => + (Flat.C flat q, Additive.C yv, RealRing.C q, Dim.C u, Dim.C v) => Interpolation.T q yv -> Proc.T s u q ( RP.T s flat q {- v frequency factors -} @@ -354,7 +354,7 @@ {- | symmetric phaser -} {-# INLINE phaser #-} phaser :: - (Additive.C yv, RealField.C q, + (Additive.C yv, RealRing.C q, Module.C q yv, Dim.C u, Dim.C v, Sample.C q, Sample.C yv) => Interpolation.T q yv @@ -368,7 +368,7 @@ {-# INLINE phaserStereo #-} phaserStereo :: - (Additive.C yv, RealField.C q, + (Additive.C yv, RealRing.C q, Module.C q yv, Dim.C u, Dim.C v, Sample.C q, Sample.C yv) => Interpolation.T q yv @@ -386,12 +386,12 @@ Proc.T s u q (CCProc.T (CCProc.Converter s - (Amp.Dimensional (Dim.Recip u) q) - q {- v signal for cut off and band center frequency -} + (Sample.Dimensional (Dim.Recip u) q q) + {- v signal for cut off and band center frequency -} ic) (CausalD.T s - (amp, Amp.Abstract) amp - (yv0, CCProc.RateDep s ic) yv1)) + (Sample.T amp yv0, CCProc.SampleRateDep s ic) + (Sample.T amp yv1))) {-# INLINE firstOrderLowpass #-} {-# INLINE firstOrderHighpass #-} @@ -506,16 +506,16 @@ Proc.T s u q (CCProc.T (CCProc.Converter s - (Amp.Dimensional Dim.Scalar q, Amp.Dimensional (Dim.Recip u) q) - (q,q) + (Sample.Dimensional Dim.Scalar q q, + Sample.Dimensional (Dim.Recip u) q q) {- v signal for resonance, i.e. factor of amplification at the resonance frequency relatively to the transition band. -} {- v signal for cut off and band center frequency -} ic) (CausalD.T s - (amp, Amp.Abstract) amp - (yv0, CCProc.RateDep s ic) yv1)) + (Sample.T amp yv0, CCProc.SampleRateDep s ic) + (Sample.T amp yv1))) -- ToDo: use this one instead of ResonantFilter @@ -523,16 +523,15 @@ Proc.T s u q (CCProc.T (CCProc.Converter s - (Amp.Flat q, Amp.Dimensional (Dim.Recip u) q) - (q,q) + (Sample.Flat q, Sample.Dimensional (Dim.Recip u) q q) {- v signal for resonance, i.e. factor of amplification at the resonance frequency relatively to the transition band. -} {- v signal for cut off and band center frequency -} ic) (CausalD.T s - (amp, Amp.Abstract) amp - (yv0, CCProc.RateDep s ic) yv1)) + (Sample.T amp yv0, CCProc.SampleRateDep s ic) + (Sample.T amp yv1))) @@ -542,7 +541,7 @@ {-# INLINE bandlimitFromUniversal #-} highpassFromUniversal, lowpassFromUniversal, bandpassFromUniversal, bandlimitFromUniversal :: - CausalD.T s amp amp (UniFilter.Result yv) yv + CausalD.Single s amp amp (UniFilter.Result yv) yv -- Proc.T s u q (CausalD.T s amp amp (UniFilter.Result yv) yv) highpassFromUniversal = homogeneousMap UniFilter.highpass bandpassFromUniversal = homogeneousMap UniFilter.bandpass @@ -551,7 +550,7 @@ homogeneousMap :: (yv0 -> yv1) -> - CausalD.T s amp amp yv0 yv1 + CausalD.Single s amp amp yv0 yv1 -- Proc.T s u t (CausalD.T s amp amp yv0 yv1) homogeneousMap f = CausalD.homogeneous (Causal.map f) @@ -605,7 +604,7 @@ in frequencyResonanceControl (\x -> (FiltRec.poleResonance x, - Allpass.cascadeParameter orderInt Allpass.flangerPhase $ + Allpass.flangerParameter orderInt $ FiltRec.poleFrequency x)) (uncurry affineComb ^<< Causal.second (Causal.fanout @@ -673,14 +672,14 @@ -- CausalD.homogeneous almost fits, but it cannot handle the control input -{-# INLINE frequencyResonanceControlFlat #-} -frequencyResonanceControlFlat :: +{-# INLINE _frequencyResonanceControlFlat #-} +_frequencyResonanceControlFlat :: (Field.C q, Dim.C u) => (FiltRec.Pole q -> ic) -> Modifier.Simple state ic yv0 yv1 -> ResonantFilterFlat s u q ic amp yv0 yv1 -frequencyResonanceControlFlat mkParam filt = +_frequencyResonanceControlFlat mkParam filt = flip fmap (Proc.withParam toFrequencyScalar) $ \toFreq -> CCProc.Cons (CCProc.makeConverter $ \ (Amp.Flat, Amp.Numeric freqAmp) -> @@ -696,7 +695,7 @@ {- {- | Infinitely many equi-delayed exponentially decaying echos. -} {-# INLINE comb #-} -comb :: (RealField.C t, Module.C y yv, Dim.C u, Dim.C v, Sample.C yv) => +comb :: (RealRing.C t, Module.C y yv, Dim.C u, Dim.C v, Sample.C yv) => DN.T u t -> y -> Proc.T s u t (SigA.R s v y yv -> SigA.R s v y yv) comb = FiltR.comb @@ -704,7 +703,7 @@ {- | Infinitely many equi-delayed echos processed by an arbitrary time-preserving signal processor. -} {-# INLINE combProc #-} combProc :: - (RealField.C t, Real.C y, Field.C y, Module.C y yv, Sample.C yv, + (RealRing.C t, Absolute.C y, Field.C y, Module.C y yv, Sample.C yv, Dim.C u, Dim.C v) => DN.T u t -> Proc.T s u t (SigA.R s v y yv -> SigA.R s v y yv) -> @@ -729,7 +728,7 @@ {-# INLINE integrate #-} integrate :: (Additive.C yv, Field.C q, Dim.C u, Dim.C v) => Proc.T s u q - (CausalD.T s (Amp.Dimensional v q) (Amp.Dimensional (Dim.Mul u v) q) yv yv) + (CausalD.T s (Sample.Dimensional v q yv) (Sample.Dimensional (Dim.Mul u v) q yv)) integrate = flip fmap Proc.getSampleRate $ \rate -> CausalD.consFlip $ \ (Amp.Numeric amp) -> diff --git a/src/Synthesizer/Dimensional/Causal/Oscillator.hs b/src/Synthesizer/Dimensional/Causal/Oscillator.hs --- a/src/Synthesizer/Dimensional/Causal/Oscillator.hs +++ b/src/Synthesizer/Dimensional/Causal/Oscillator.hs @@ -1,7 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleContexts #-} {- | -Copyright : (c) Henning Thielemann 2009 +Copyright : (c) Henning Thielemann 2009-2010 License : GPL Maintainer : synthesizer@henning-thielemann.de @@ -31,21 +31,23 @@ shapePhaseFreqModFromSampledTone, ) where +import qualified Synthesizer.Dimensional.Causal.Oscillator.Core as OsciCore import qualified Synthesizer.Dimensional.Causal.Process as CausalD -import qualified Synthesizer.Causal.Process as Causal import Control.Arrow ((<<^), (<<<), second, ) +import qualified Synthesizer.Dimensional.Sample as Sample + import qualified Synthesizer.Dimensional.Amplitude as Amp import qualified Synthesizer.Dimensional.Rate as Rate import qualified Synthesizer.Causal.Oscillator as Osci +import Synthesizer.Causal.Filter.NonRecursive (amplify, ) import qualified Synthesizer.Generic.Signal as SigG -- import qualified Synthesizer.Dimensional.Wave.Smoothed as WaveSmooth import qualified Synthesizer.Dimensional.Wave.Controlled as WaveCtrl import qualified Synthesizer.Dimensional.Wave as WaveD -import qualified Synthesizer.Basic.Wave as Wave import qualified Synthesizer.Basic.Phase as Phase import qualified Synthesizer.Dimensional.Signal.Private as SigA @@ -59,15 +61,16 @@ -- import Number.DimensionTerm ((&*&)) import qualified Algebra.RealField as RealField -import qualified Algebra.Field as Field import qualified Algebra.Ring as Ring -import NumericPrelude -import PreludeBase as P +import NumericPrelude.Numeric +import NumericPrelude.Base as P type Frequency u t = Amp.Numeric (DN.T (Dim.Recip u) t) +type SampleFrequency u t = Sample.T (Frequency u t) t + {- {- | oscillator with a functional waveform with constant frequency -} {-# INLINE static #-} @@ -96,13 +99,12 @@ {- | oscillator with a functional waveform with modulated frequency -} {-# INLINE freqMod #-} freqMod :: (RealField.C t, Dim.C u) => - WaveD.T amp t y {- ^ waveform -} + WaveD.T t y {- ^ waveform -} -> Phase.T t {- ^ start phase -} -> Proc.T s u t - (CausalD.T s (Frequency u t) amp t y) + (CausalD.T s (SampleFrequency u t) y) freqMod wave phase = - staticAuxHom wave $ \toFreq (Amp.Numeric freqAmp) w -> - Osci.freqMod w phase <<< amplify (toFreq freqAmp) + fmap (wave CausalD.^<<) $ OsciCore.freqMod phase {- {- | oscillator with a functional waveform with modulated frequency -} @@ -121,51 +123,55 @@ {- | oscillator with modulated phase -} {-# INLINE phaseMod #-} phaseMod :: (RealField.C t, Dim.C u) => - WaveD.T amp t y {- ^ waveform -} + WaveD.T t y {- ^ waveform -} -> DN.T (Dim.Recip u) t {- ^ frequency -} -> Proc.T s u t - (CausalD.T s (Amp.Flat t) amp t y) + (CausalD.T s (Sample.Flat t) y) phaseMod wave freq = - staticAuxHom wave $ \toFreq Amp.Flat w -> - Osci.phaseMod w $ toFreq freq + fmap (wave CausalD.^<<) $ + OsciCore.phaseMod freq + {- | oscillator with modulated shape -} {-# INLINE shapeMod #-} shapeMod :: (RealField.C t, Dim.C u) => - WaveCtrl.T amp c t y + WaveCtrl.T c t y {- ^ waveform -} -> Phase.T t {- ^ phase -} -> DN.T (Dim.Recip u) t {- ^ frequency -} -> Proc.T s u t - (CausalD.T s (Amp.Flat c) amp c y) + (CausalD.T s c y) shapeMod wave phase freq = - staticAuxCtrl wave $ \toFreq Amp.Flat w -> - Osci.shapeMod w phase $ toFreq freq + fmap (wave CausalD.^<<) $ + fmap CausalD.feedSnd $ + OsciCore.static phase freq {- | oscillator with a functional waveform with modulated phase and frequency -} {-# INLINE phaseFreqMod #-} phaseFreqMod :: (RealField.C t, Dim.C u) => - WaveD.T amp t y {- ^ waveform -} + WaveD.T t y {- ^ waveform -} -> Proc.T s u t - (CausalD.T s (Amp.Flat t, Frequency u t) amp (t,t) y) + (CausalD.T s (Sample.Flat t, SampleFrequency u t) y) phaseFreqMod wave = - freqModAuxHom wave $ \scaleFreq (Amp.Flat, Amp.Numeric freqAmp) w -> - Osci.phaseFreqMod w <<< second (scaleFreq freqAmp) + fmap (wave CausalD.^<<) $ + OsciCore.phaseFreqMod + {- | oscillator with both shape and frequency modulation -} {-# INLINE shapeFreqMod #-} shapeFreqMod :: (RealField.C t, Dim.C u) => - WaveCtrl.T amp c t y + WaveCtrl.T c t y {- ^ waveform -} -> Phase.T t {- ^ phase -} -> Proc.T s u t - (CausalD.T s (Amp.Flat c, Frequency u t) amp (c,t) y) + (CausalD.T s (c, SampleFrequency u t) y) shapeFreqMod wave phase = - freqModAuxCtrl wave $ \scaleFreq (Amp.Flat, Amp.Numeric freqAmp) w -> - Osci.shapeFreqMod w phase <<< second (scaleFreq freqAmp) + fmap (wave CausalD.^<<) $ + fmap second $ + OsciCore.freqMod phase {- @@ -204,8 +210,8 @@ -> t -> Phase.T t -> Proc.T s u t (CausalD.T s - (Amp.Flat t, Frequency u t) amp - (t,t) yv) + (Sample.Flat t, SampleFrequency u t) + (Sample.T amp yv)) shapeFreqModFromSampledTone ipLeap ipStep srcFreq sampledTone shape0 phase = let SigA.Cons (Rate.Actual srcRate) amp samples = sampledTone @@ -231,8 +237,8 @@ -> t -> Phase.T t -> Proc.T s u t (CausalD.T s - (Amp.Flat t, Amp.Flat t, Frequency u t) amp - (t,t,t) yv) + (Sample.Flat t, Sample.Flat t, SampleFrequency u t) + (Sample.T amp yv)) shapePhaseFreqModFromSampledTone ipLeap ipStep srcFreq sampledTone shape0 phase = let SigA.Cons (Rate.Actual srcRate) amp samples = sampledTone @@ -253,51 +259,3 @@ <<^ Causal.unpackTriple -} - --- helper functions - -{-# INLINE freqModAuxCtrl #-} -freqModAuxCtrl :: (Dim.C u, Field.C t) => - WaveCtrl.T amp1 c t y -> - ((DN.T (Dim.Recip u) t -> Causal.T t t) -> - amp0 -> (c -> Wave.T t y) -> Causal.T yv0 yv1) -> - Proc.T s u t (CausalD.T s amp0 amp1 yv0 yv1) -freqModAuxCtrl wave f = - staticAuxCtrl wave $ \toFreq -> f (amplify . toFreq) - -{-# INLINE staticAuxCtrl #-} -staticAuxCtrl :: (Dim.C u, Field.C t) => - WaveCtrl.T amp1 c t y -> - ((DN.T (Dim.Recip u) t -> t) -> - amp0 -> (c -> Wave.T t y) -> Causal.T yv0 yv1) -> - Proc.T s u t (CausalD.T s amp0 amp1 yv0 yv1) -staticAuxCtrl (WaveCtrl.Cons amp1 wave) f = - flip fmap (Proc.withParam toFrequencyScalar) $ \toFreq -> - CausalD.consFlip $ \amp0 -> - (amp1, f toFreq amp0 wave) - - -{-# INLINE freqModAuxHom #-} -freqModAuxHom :: (Dim.C u, Field.C t) => - WaveD.T amp1 t y -> - ((DN.T (Dim.Recip u) t -> Causal.T t t) -> - amp0 -> Wave.T t y -> Causal.T yv0 yv1) -> - Proc.T s u t (CausalD.T s amp0 amp1 yv0 yv1) -freqModAuxHom wave f = - staticAuxHom wave $ \toFreq amp0 w -> f (amplify . toFreq) amp0 w - -{-# INLINE staticAuxHom #-} -staticAuxHom :: (Dim.C u, Field.C t) => - WaveD.T amp1 t y -> - ((DN.T (Dim.Recip u) t -> t) -> - amp0 -> Wave.T t y -> Causal.T yv0 yv1) -> - Proc.T s u t (CausalD.T s amp0 amp1 yv0 yv1) -staticAuxHom (WaveD.Cons amp1 wave) f = - flip fmap (Proc.withParam toFrequencyScalar) $ \toFreq -> - CausalD.consFlip $ \amp0 -> - (amp1, f toFreq amp0 wave) - - --- ToDo: move to Causal.Filter -amplify :: (Ring.C a) => a -> Causal.T a a -amplify x = Causal.map (x Ring.*) diff --git a/src/Synthesizer/Dimensional/Causal/Oscillator/Core.hs b/src/Synthesizer/Dimensional/Causal/Oscillator/Core.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Dimensional/Causal/Oscillator/Core.hs @@ -0,0 +1,84 @@ +{- | +Turn frequency information into signals of phases. +This is mainly the fundament for implementation of oscillators +but you may also use it for generating coherent waves of different form. +-} +module Synthesizer.Dimensional.Causal.Oscillator.Core where + +import qualified Synthesizer.Causal.Oscillator.Core as Osci +import qualified Synthesizer.Dimensional.Causal.Process as CausalD +import Synthesizer.Causal.Filter.NonRecursive (amplify, ) +import Control.Arrow ((<<<), second, ) + +import qualified Synthesizer.Dimensional.Sample as Sample +import qualified Synthesizer.Dimensional.Amplitude as Amp +import qualified Synthesizer.Dimensional.Rate as Rate +import qualified Synthesizer.Basic.Phase as Phase +import Synthesizer.Dimensional.Wave (SamplePhase, ) + +import qualified Synthesizer.State.Signal as Sig + +import qualified Synthesizer.Dimensional.Signal.Private as SigA +import qualified Synthesizer.Dimensional.Process as Proc +import Synthesizer.Dimensional.Process (toFrequencyScalar, ) + +import qualified Number.DimensionTerm as DN +import qualified Algebra.DimensionTerm as Dim +-- import Number.DimensionTerm ((&*&)) + +import qualified Algebra.RealField as RealField +-- import qualified Algebra.Field as Field +-- import qualified Algebra.Ring as Ring + +-- import NumericPrelude.Numeric +import NumericPrelude.Base as P + + +type Frequency u t = Amp.Numeric (DN.T (Dim.Recip u) t) +type SampleFrequency u t = Sample.T (Frequency u t) t + + +{-# INLINE static #-} +static :: + (RealField.C t, Dim.C u) => + Phase.T t {- ^ start phase -} + -> DN.T (Dim.Recip u) t + {- ^ frequency -} + -> Proc.T s u t + (SigA.T (Rate.Phantom s) Amp.Abstract (Sig.T (Phase.T t))) +-- (Signal s Amp.Abstract (Phase.T t)) +static phase freq = + flip fmap (toFrequencyScalar freq) $ \f -> + SigA.Cons Rate.Phantom Amp.Abstract $ + Osci.static phase f + +{-# INLINE phaseMod #-} +phaseMod :: (RealField.C t, Dim.C u) => + DN.T (Dim.Recip u) t {- ^ frequency -} + -> Proc.T s u t + (CausalD.T s (Sample.Flat t) (SamplePhase t)) +phaseMod freq = + flip fmap (toFrequencyScalar freq) $ \f -> + CausalD.consFlip $ \Amp.Flat -> + (Amp.Abstract, Osci.phaseMod f) + +{-# INLINE freqMod #-} +freqMod :: (RealField.C t, Dim.C u) => + Phase.T t {- ^ phase -} + -> Proc.T s u t + (CausalD.T s (SampleFrequency u t) (SamplePhase t)) +freqMod phase = + flip fmap (Proc.withParam toFrequencyScalar) $ \toFreq -> + CausalD.consFlip $ \(Amp.Numeric freqAmp) -> + (Amp.Abstract, + Osci.freqMod phase <<< amplify (toFreq freqAmp)) + +{-# INLINE phaseFreqMod #-} +phaseFreqMod :: (RealField.C t, Dim.C u) => + Proc.T s u t + (CausalD.T s (Sample.Flat t, SampleFrequency u t) (SamplePhase t)) +phaseFreqMod = + flip fmap (Proc.withParam toFrequencyScalar) $ \toFreq -> + CausalD.consFlip $ \(Amp.Flat, Amp.Numeric freqAmp) -> + (Amp.Abstract, + Osci.phaseFreqMod <<< second (amplify (toFreq freqAmp))) diff --git a/src/Synthesizer/Dimensional/Causal/Process.hs b/src/Synthesizer/Dimensional/Causal/Process.hs --- a/src/Synthesizer/Dimensional/Causal/Process.hs +++ b/src/Synthesizer/Dimensional/Causal/Process.hs @@ -1,12 +1,27 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Synthesizer.Dimensional.Causal.Process where +module Synthesizer.Dimensional.Causal.Process ( + module Synthesizer.Dimensional.Causal.Process, + -- * re-export Arrow, it would be better to restrict that to Causal processes + (Arrow.***), (Arrow.&&&), + (Arrow.>>>), (Arrow.<<<), + + ArrowD.compose, + ArrowD.first, + ArrowD.second, + ArrowD.split, + ArrowD.fanout, + ArrowD.loop, + ArrowD.loopVolume, + ) where + import qualified Synthesizer.Dimensional.Arrow as ArrowD import qualified Synthesizer.Dimensional.Map as Map import qualified Synthesizer.Dimensional.Signal.Private as SigA +import qualified Synthesizer.Dimensional.Sample as Sample import qualified Synthesizer.Dimensional.Amplitude.Flat as Flat import qualified Synthesizer.Dimensional.Amplitude as Amp import qualified Synthesizer.Dimensional.Rate as Rate @@ -14,7 +29,7 @@ import qualified Synthesizer.Causal.Arrow as CausalArrow import qualified Synthesizer.Causal.Process as Causal import qualified Control.Arrow as Arrow -import Control.Arrow (Arrow, ArrowLoop, ) +import Control.Arrow (Arrow, ArrowLoop, first, (>>>), (<<<), ) import Control.Category (Category, ) import Control.Applicative (Applicative, ) @@ -32,7 +47,7 @@ import Data.Tuple.HT as TupleHT (mapFst, ) -import NumericPrelude (one) +-- import NumericPrelude.Numeric (one) import Prelude hiding (map, id, fst, snd, ) @@ -41,9 +56,12 @@ Note that @amp@ can also be a pair of amplitudes or a more complicated ensemble of amplitudes. -} -type T s amp0 amp1 yv0 yv1 = - ArrowD.T amp0 amp1 (Core s yv0 yv1) +type T s sample0 sample1 = + ArrowD.T (Core s) sample0 sample1 +type Single s amp0 amp1 yv0 yv1 = + ArrowD.Single (Core s) amp0 amp1 yv0 yv1 + newtype Core s yv0 yv1 = Core (Causal.T yv0 yv1) deriving (Category, Arrow, ArrowLoop, CausalArrow.C) @@ -52,8 +70,11 @@ consFlip :: - (amp0 -> (amp1, Causal.T yv0 yv1)) -> - T s amp0 amp1 yv0 yv1 + (Sample.Amplitude sample0 -> + (Sample.Amplitude sample1, + Causal.T (Sample.Displacement sample0) + (Sample.Displacement sample1))) -> + T s sample0 sample1 consFlip f = ArrowD.Cons $ \ampIn -> let (ampOut, causal) = f ampIn @@ -65,7 +86,7 @@ {-# INLINE apply #-} apply :: (SigG2.Transform sig yv0 yv1) => - T s amp0 amp1 yv0 yv1 -> + Single s amp0 amp1 yv0 yv1 -> SigA.T (Rate.Phantom s) amp0 (sig yv0) -> SigA.T (Rate.Phantom s) amp1 (sig yv1) apply = ArrowD.apply @@ -73,7 +94,7 @@ {-# INLINE applyFlat #-} applyFlat :: (Flat.C yv0 amp0, SigG2.Transform sig yv0 yv1) => - T s (Amp.Flat yv0) amp1 yv0 yv1 -> + Single s (Amp.Flat yv0) amp1 yv0 yv1 -> SigA.T (Rate.Phantom s) amp0 (sig yv0) -> SigA.T (Rate.Phantom s) amp1 (sig yv1) applyFlat = ArrowD.applyFlat @@ -81,7 +102,7 @@ {-# INLINE canonicalizeFlat #-} canonicalizeFlat :: (Flat.C y flat) => - T s flat (Amp.Flat y) y y + Single s flat (Amp.Flat y) y y canonicalizeFlat = ArrowD.canonicalizeFlat @@ -89,7 +110,7 @@ {-# INLINE applyConst #-} applyConst :: (Amp.C amp1, Ring.C y0) => - T s (Amp.Numeric amp0) amp1 y0 yv1 -> + Single s (Amp.Numeric amp0) amp1 y0 yv1 -> amp0 -> SigA.T (Rate.Phantom s) amp1 (Sig.T yv1) applyConst = ArrowD.applyConst @@ -101,7 +122,7 @@ {-# INLINE ($/:) #-} ($/:) :: (Applicative f, SigG2.Transform sig yv0 yv1) => - f (T s amp0 amp1 yv0 yv1) -> + f (Single s amp0 amp1 yv0 yv1) -> f (SigA.T (Rate.Phantom s) amp0 (sig yv0)) -> f (SigA.T (Rate.Phantom s) amp1 (sig yv1)) ($/:) = (ArrowD.$/:) @@ -109,7 +130,7 @@ {-# INLINE ($/-) #-} ($/-) :: (Amp.C amp1, Functor f, Ring.C y0) => - f (T s (Amp.Numeric amp0) amp1 y0 yv1) -> + f (Single s (Amp.Numeric amp0) amp1 y0 yv1) -> amp0 -> f (SigA.T (Rate.Phantom s) amp1 (Sig.T yv1)) ($/-) = (ArrowD.$/-) @@ -120,27 +141,27 @@ {-# INLINE applyFst #-} applyFst :: - (Amp.C amp, SigG.Read sig yv) => - T s (amp, restAmpIn) restAmpOut (yv, restSampIn) restSampOut -> + (SigG.Read sig yv) => + T s (Sample.T amp yv, restSampleIn) restSampleOut -> SigA.T (Rate.Phantom s) amp (sig yv) -> - T s restAmpIn restAmpOut restSampIn restSampOut + T s restSampleIn restSampleOut applyFst c x = c <<< feedFst x {-# INLINE applyFlatFst #-} applyFlatFst :: (Flat.C yv amp, SigG.Read sig yv) => - T s (Amp.Flat yv, restAmpIn) restAmpOut (yv, restSampIn) restSampOut -> + T s (Sample.T (Amp.Flat yv) yv, restSampleIn) restSampleOut -> SigA.T (Rate.Phantom s) amp (sig yv) -> - T s restAmpIn restAmpOut restSampIn restSampOut + T s restSampleIn restSampleOut applyFlatFst c = applyFst (c <<< first canonicalizeFlat) {-# INLINE feedFst #-} feedFst :: - (Amp.C amp, SigG.Read sig yv) => + (SigG.Read sig yv) => SigA.T (Rate.Phantom s) amp (sig yv) -> - T s restAmp (amp, restAmp) restSamp (yv, restSamp) + T s restSample (Sample.T amp yv, restSample) feedFst x = ArrowD.Cons $ \yAmp -> (Core $ Causal.feedFst (SigA.body x), (SigA.amplitude x, yAmp)) @@ -148,17 +169,17 @@ {-# INLINE applySnd #-} applySnd :: - (Amp.C amp, SigG.Read sig yv) => - T s (restAmpIn, amp) restAmpOut (restSampIn, yv) restSampOut -> + (SigG.Read sig yv) => + T s (restSampleIn, Sample.T amp yv) restSampleOut -> SigA.T (Rate.Phantom s) amp (sig yv) -> - T s restAmpIn restAmpOut restSampIn restSampOut + T s restSampleIn restSampleOut applySnd c x = c <<< feedSnd x {-# INLINE feedSnd #-} feedSnd :: - (Amp.C amp, SigG.Read sig yv) => + (SigG.Read sig yv) => SigA.T (Rate.Phantom s) amp (sig yv) -> - T s restAmp (restAmp, amp) restSamp (restSamp, yv) + T s restSample (restSample, Sample.T amp yv) feedSnd x = ArrowD.Cons $ \yAmp -> (Core $ Causal.feedSnd (SigA.body x), (yAmp, SigA.amplitude x)) @@ -166,153 +187,83 @@ {-# INLINE map #-} map :: - Map.T amp0 amp1 yv0 yv1 -> - T s amp0 amp1 yv0 yv1 + Map.T sample0 sample1 -> + T s sample0 sample1 map (ArrowD.Cons f) = ArrowD.Cons $ mapFst Arrow.arr . f -{- | -Lift a low-level homogeneous process to a dimensional one. - -Note that the @amp@ type variable is unrestricted. -This way we show, that the amplitude is not touched, -which also means that the underlying low-level process must be homogeneous. --} -{-# INLINE homogeneous #-} -homogeneous :: - Causal.T yv0 yv1 -> - T s amp amp yv0 yv1 -homogeneous c = - ArrowD.Cons $ \ xAmp -> (Core c, xAmp) - - -{-# INLINE id #-} -id :: - T s amp amp yv yv -id = - ArrowD.id - - -infixr 3 *** -infixr 3 &&& -infixr 1 >>>, ^>>, >>^ -infixr 1 <<<, ^<<, <<^ - - -{-# INLINE compose #-} -{-# INLINE (>>>) #-} -compose, (>>>) :: - T s amp0 amp1 yv0 yv1 -> - T s amp1 amp2 yv1 yv2 -> - T s amp0 amp2 yv0 yv2 -compose = ArrowD.compose - -(>>>) = compose - -{-# INLINE (<<<) #-} -(<<<) :: - T s amp1 amp2 yv1 yv2 -> - T s amp0 amp1 yv0 yv1 -> - T s amp0 amp2 yv0 yv2 -(<<<) = flip (>>>) - - -{-# INLINE first #-} -first :: - T s amp0 amp1 yv0 yv1 -> - T s (amp0, amp) (amp1, amp) (yv0, yv) (yv1, yv) -first = ArrowD.first - -{-# INLINE second #-} -second :: - T s amp0 amp1 yv0 yv1 -> - T s (amp, amp0) (amp, amp1) (yv, yv0) (yv, yv1) -second = ArrowD.second - -{-# INLINE split #-} -{-# INLINE (***) #-} -split, (***) :: - T s amp0 amp1 yv0 yv1 -> - T s amp2 amp3 yv2 yv3 -> - T s (amp0, amp2) (amp1, amp3) (yv0, yv2) (yv1, yv3) -split = ArrowD.split - -(***) = split - -{-# INLINE fanout #-} -{-# INLINE (&&&) #-} -fanout, (&&&) :: - T s amp amp0 yv yv0 -> - T s amp amp1 yv yv1 -> - T s amp (amp0, amp1) yv (yv0, yv1) -fanout = ArrowD.fanout - -(&&&) = fanout - - --- * map functions +infixr 1 ^>>, >>^ +infixr 1 ^<<, <<^ {-# INLINE (^>>) #-} -- | Precomposition with a pure function. (^>>) :: - Map.T amp0 amp1 yv0 yv1 -> - T s amp1 amp2 yv1 yv2 -> - T s amp0 amp2 yv0 yv2 + Map.T sample0 sample1 -> + T s sample1 sample2 -> + T s sample0 sample2 f ^>> a = map f >>> a {-# INLINE (>>^) #-} -- | Postcomposition with a pure function. (>>^) :: - T s amp0 amp1 yv0 yv1 -> - Map.T amp1 amp2 yv1 yv2 -> - T s amp0 amp2 yv0 yv2 + T s sample0 sample1 -> + Map.T sample1 sample2 -> + T s sample0 sample2 a >>^ f = a >>> map f {-# INLINE (<<^) #-} -- | Precomposition with a pure function (right-to-left variant). (<<^) :: - T s amp1 amp2 yv1 yv2 -> - Map.T amp0 amp1 yv0 yv1 -> - T s amp0 amp2 yv0 yv2 + T s sample1 sample2 -> + Map.T sample0 sample1 -> + T s sample0 sample2 a <<^ f = a <<< map f {-# INLINE (^<<) #-} -- | Postcomposition with a pure function (right-to-left variant). (^<<) :: - Map.T amp1 amp2 yv1 yv2 -> - T s amp0 amp1 yv0 yv1 -> - T s amp0 amp2 yv0 yv2 + Map.T sample1 sample2 -> + T s sample0 sample1 -> + T s sample0 sample2 f ^<< a = map f <<< a --- loop :: a (b, d) (c, d) -> a b c -{-# INLINE loopVolume #-} -loopVolume :: - (Field.C y, Module.C y yv, Dim.C v) => - DN.T v y -> - T s (restAmpIn, Amp.Dimensional v y) - (restAmpOut, Amp.Dimensional v y) - (restSampIn, yv) (restSampOut, yv) -> - T s restAmpIn restAmpOut restSampIn restSampOut -loopVolume ampIn f = - ArrowD.loop (f >>> ArrowD.second (Map.forceDimensionalAmplitude ampIn)) +{- | +Lift a low-level homogeneous process to a dimensional one. --- loop2 :: a (b, (d,e)) (c, (d,e)) -> a b c +Note that the @amp@ type variable is unrestricted. +This way we show, that the amplitude is not touched, +which also means that the underlying low-level process must be homogeneous. +-} +{-# INLINE homogeneous #-} +homogeneous :: + Causal.T yv0 yv1 -> + Single s amp amp yv0 yv1 +homogeneous c = + ArrowD.Cons $ \ xAmp -> (Core c, xAmp) + +{-# INLINE id #-} +id :: + T s sample sample +id = + ArrowD.id + + {-# INLINE loop2Volume #-} loop2Volume :: (Field.C y0, Module.C y0 yv0, Dim.C v0, Field.C y1, Module.C y1 yv1, Dim.C v1) => (DN.T v0 y0, DN.T v1 y1) -> T s - (restAmpIn, (Amp.Numeric (DN.T v0 y0), Amp.Numeric (DN.T v1 y1))) - (restAmpOut, (Amp.Numeric (DN.T v0 y0), Amp.Numeric (DN.T v1 y1))) - (restSampIn, (yv0,yv1)) - (restSampOut, (yv0,yv1)) -> - T s restAmpIn restAmpOut restSampIn restSampOut + (restSampleIn, (Sample.T (Amp.Dimensional v0 y0) yv0, + Sample.T (Amp.Dimensional v1 y1) yv1)) + (restSampleOut, (Sample.T (Amp.Dimensional v0 y0) yv0, + Sample.T (Amp.Dimensional v1 y1) yv1)) -> + T s restSampleIn restSampleOut loop2Volume (amp0,amp1) p = - loopVolume amp0 $ - loopVolume amp1 $ + ArrowD.loopVolume amp0 $ + ArrowD.loopVolume amp1 $ (Map.balanceRight >>> p >>> Map.balanceLeft) -- alternative implementation to ArrowD.loop2Volume diff --git a/src/Synthesizer/Dimensional/ChunkySize/Cut.hs b/src/Synthesizer/Dimensional/ChunkySize/Cut.hs --- a/src/Synthesizer/Dimensional/ChunkySize/Cut.hs +++ b/src/Synthesizer/Dimensional/ChunkySize/Cut.hs @@ -24,12 +24,12 @@ -- import qualified Number.NonNegative as NonNeg --- import qualified Algebra.RealField as RealField +-- import qualified Algebra.RealRing as RealRing -- import qualified Algebra.Field as Field --- import NumericPrelude hiding (negate) --- import PreludeBase as P +-- import NumericPrelude.Numeric hiding (negate) +-- import NumericPrelude.Base as P import Prelude hiding (splitAt, take, drop, length, ) diff --git a/src/Synthesizer/Dimensional/ChunkySize/Signal.hs b/src/Synthesizer/Dimensional/ChunkySize/Signal.hs --- a/src/Synthesizer/Dimensional/ChunkySize/Signal.hs +++ b/src/Synthesizer/Dimensional/ChunkySize/Signal.hs @@ -27,12 +27,12 @@ -- import qualified Number.NonNegative as NonNeg --- import qualified Algebra.RealField as RealField +-- import qualified Algebra.RealRing as RealRing -- import qualified Algebra.Field as Field --- import NumericPrelude hiding (negate) --- import PreludeBase as P +-- import NumericPrelude.Numeric hiding (negate) +-- import NumericPrelude.Base as P import Prelude hiding (splitAt, take, drop, length, ) diff --git a/src/Synthesizer/Dimensional/Cyclic/Analysis.hs b/src/Synthesizer/Dimensional/Cyclic/Analysis.hs --- a/src/Synthesizer/Dimensional/Cyclic/Analysis.hs +++ b/src/Synthesizer/Dimensional/Cyclic/Analysis.hs @@ -31,8 +31,8 @@ import qualified Algebra.Field as Field -import PreludeBase ((.), ) -import NumericPrelude ((+), negate, (/), fromIntegral, pi, ) +import NumericPrelude.Base ((.), ) +import NumericPrelude.Numeric ((+), negate, (/), fromIntegral, pi, ) import Prelude (Int, ) diff --git a/src/Synthesizer/Dimensional/Cyclic/Signal.hs b/src/Synthesizer/Dimensional/Cyclic/Signal.hs --- a/src/Synthesizer/Dimensional/Cyclic/Signal.hs +++ b/src/Synthesizer/Dimensional/Cyclic/Signal.hs @@ -35,8 +35,8 @@ import Data.Monoid (Monoid, ) -import NumericPrelude -import PreludeBase +import NumericPrelude.Numeric +import NumericPrelude.Base import Prelude () diff --git a/src/Synthesizer/Dimensional/Map.hs b/src/Synthesizer/Dimensional/Map.hs --- a/src/Synthesizer/Dimensional/Map.hs +++ b/src/Synthesizer/Dimensional/Map.hs @@ -4,6 +4,9 @@ -} module Synthesizer.Dimensional.Map where +import qualified Synthesizer.Dimensional.Sample as Sample +import Synthesizer.Dimensional.Sample (Amplitude, Displacement, ) + import qualified Synthesizer.Dimensional.Arrow as ArrowD import qualified Synthesizer.Dimensional.Signal.Private as SigA @@ -39,14 +42,26 @@ but maps are not bound to a sampling rate, and thus do not need the @s@ type parameter. -} -type T amp0 amp1 yv0 yv1 = - ArrowD.T amp0 amp1 (yv0 -> yv1) +type T = ArrowD.T (->) +type Single amp0 amp1 yv0 yv1 = + ArrowD.Single (->) amp0 amp1 yv0 yv1 + +consFlip :: + (Sample.Amplitude sample0 -> + (Sample.Amplitude sample1, + Sample.Displacement sample0 -> + Sample.Displacement sample1)) -> + T sample0 sample1 +consFlip f = + ArrowD.Cons $ TupleHT.swap . f + + {-# INLINE apply #-} apply :: (SigG2.Transform sig yv0 yv1) => - T amp0 amp1 yv0 yv1 -> + Single amp0 amp1 yv0 yv1 -> SigA.T rate amp0 (sig yv0) -> SigA.T rate amp1 (sig yv1) apply = ArrowD.apply @@ -54,7 +69,7 @@ {-# INLINE applyFlat #-} applyFlat :: (Flat.C yv0 amp0, SigG2.Transform sig yv0 yv1) => - T (Amp.Flat yv0) amp1 yv0 yv1 -> + Single (Amp.Flat yv0) amp1 yv0 yv1 -> SigA.T rate amp0 (sig yv0) -> SigA.T rate amp1 (sig yv1) applyFlat = ArrowD.applyFlat @@ -64,14 +79,14 @@ forceDimensionalAmplitude :: (Dim.C v, Field.C y, Module.C y yv, Arrow arrow) => DN.T v y -> - ArrowD.T (Amp.Dimensional v y) (Amp.Dimensional v y) (arrow yv yv) + ArrowD.Single arrow (Amp.Dimensional v y) (Amp.Dimensional v y) yv yv forceDimensionalAmplitude = ArrowD.forceDimensionalAmplitude {-# INLINE forcePrimitiveAmplitude #-} forcePrimitiveAmplitude :: (Amp.Primitive amp, Arrow arrow) => - ArrowD.T amp amp (arrow yv yv) + ArrowD.Single arrow amp amp yv yv forcePrimitiveAmplitude = independent (const Amp.primitive) Func.id @@ -96,7 +111,7 @@ mapAmplitude :: (Amp.C amp0, Amp.C amp1, Arrow arrow) => (amp0 -> amp1) -> - ArrowD.T amp0 amp1 (arrow yv yv) + ArrowD.Single arrow amp0 amp1 yv yv mapAmplitude f = independent f Func.id @@ -108,8 +123,8 @@ {-# INLINE mapAmplitudeSameType #-} mapAmplitudeSameType :: (Arrow arrow) => - (amp -> amp) -> - ArrowD.T amp amp (arrow yv yv) + (Sample.Amplitude sample -> Sample.Amplitude sample) -> + ArrowD.T arrow sample sample mapAmplitudeSameType f = independent f Func.id @@ -121,32 +136,29 @@ {-# INLINE independent #-} independent :: (Arrow arrow) => - (amp0 -> amp1) -> (yv0 -> yv1) -> - ArrowD.T amp0 amp1 (arrow yv0 yv1) + (Sample.Amplitude sample0 -> Sample.Amplitude sample1) -> + (Sample.Displacement sample0 -> Sample.Displacement sample1) -> + ArrowD.T arrow sample0 sample1 independent = ArrowD.independentMap {-# INLINE id #-} id :: (Category arrow) => - ArrowD.T amp amp - (arrow y y) + ArrowD.T arrow sample sample id = ArrowD.id {-# INLINE double #-} double :: (Arrow arrow) => - ArrowD.T amp (amp, amp) - (arrow y (y, y)) + ArrowD.T arrow sample (sample, sample) double = - let aux = \x -> (x, x) - in independent aux aux + ArrowD.double {-# INLINE fst #-} fst :: (Arrow arrow) => - ArrowD.T (amp0,amp1) amp0 - (arrow (y0,y1) y0) + ArrowD.T arrow (sample0,sample1) sample0 fst = let aux = Tuple.fst in independent aux aux @@ -154,8 +166,7 @@ {-# INLINE snd #-} snd :: (Arrow arrow) => - ArrowD.T (amp0,amp1) amp1 - (arrow (y0,y1) y1) + ArrowD.T arrow (sample0,sample1) sample1 snd = let aux = Tuple.snd in independent aux aux @@ -163,8 +174,7 @@ {-# INLINE swap #-} swap :: (Arrow arrow) => - ArrowD.T (amp0,amp1) (amp1,amp0) - (arrow (y0,y1) (y1,y0)) + ArrowD.T arrow (sample0,sample1) (sample1,sample0) swap = let aux = TupleHT.swap in independent aux aux @@ -172,8 +182,8 @@ {-# INLINE balanceRight #-} balanceRight :: (Arrow arrow) => - ArrowD.T ((amp0,amp1), amp2) (amp0, (amp1,amp2)) - (arrow ((y0,y1), y2) (y0, (y1,y2))) + ArrowD.T arrow + ((sample0,sample1), sample2) (sample0, (sample1,sample2)) balanceRight = let aux = \((a,b), c) -> (a, (b,c)) in independent aux aux @@ -181,8 +191,8 @@ {-# INLINE balanceLeft #-} balanceLeft :: (Arrow arrow) => - ArrowD.T (amp0, (amp1,amp2)) ((amp0,amp1), amp2) - (arrow (y0, (y1,y2)) ((y0,y1), y2)) + ArrowD.T arrow + (sample0, (sample1,sample2)) ((sample0,sample1), sample2) balanceLeft = let aux = \(a, (b,c)) -> ((a,b), c) in independent aux aux @@ -190,8 +200,8 @@ {-# INLINE packTriple #-} packTriple :: (Arrow arrow) => - ArrowD.T (amp0,(amp1,amp2)) (amp0,amp1,amp2) - (arrow (y0,(y1,y2)) (y0,y1,y2)) + ArrowD.T arrow + (sample0,(sample1,sample2)) (sample0,sample1,sample2) packTriple = let aux = \(a,(b,c)) -> (a,b,c) in independent aux aux @@ -199,8 +209,8 @@ {-# INLINE unpackTriple #-} unpackTriple :: (Arrow arrow) => - ArrowD.T (amp0,amp1,amp2) (amp0,(amp1,amp2)) - (arrow (y0,y1,y2) (y0,(y1,y2))) + ArrowD.T arrow + (sample0,sample1,sample2) (sample0,(sample1,sample2)) unpackTriple = let aux = \(a,b,c) -> (a,(b,c)) in independent aux aux diff --git a/src/Synthesizer/Dimensional/Map/Displacement.hs b/src/Synthesizer/Dimensional/Map/Displacement.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Dimensional/Map/Displacement.hs @@ -0,0 +1,183 @@ +module Synthesizer.Dimensional.Map.Displacement ( + mix, mixVolume, + fanoutAndMixMulti, fanoutAndMixMultiVolume, + raise, distort, + ) where + +import qualified Synthesizer.Dimensional.Amplitude as Amp +import qualified Synthesizer.Dimensional.Sample as Sample + +import qualified Synthesizer.Dimensional.Arrow as ArrowD + +import qualified Control.Arrow as Arrow +import Control.Arrow (Arrow, arr, (^<<), (&&&), ) + +import qualified Number.DimensionTerm as DN +import qualified Algebra.DimensionTerm as Dim + +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Absolute as Absolute +-- import qualified Algebra.Ring as Ring +-- import qualified Algebra.Additive as Additive + +-- import Algebra.Module ((*>)) + +import Control.Monad.Trans.Reader (Reader, runReader, asks, ) +import Control.Applicative (liftA2, ) + +import NumericPrelude.Base +import NumericPrelude.Numeric +import Prelude () + + +type DNS v y yv = Sample.Dimensional v y yv +type Context v y = Reader (DN.T v y) + + +-- * Mixing + +{- | +Mix two signals. +In contrast to 'zipWith' the result has the length of the longer signal. +-} +{-# INLINE mix #-} +mix :: + (Absolute.C y, Field.C y, Module.C y yv, Dim.C v, Arrow arrow) => + ArrowD.T arrow (DNS v y yv, DNS v y yv) (DNS v y yv) +mix = + fromAmplitudeReader $ \(Amp.Numeric amp0, Amp.Numeric amp1) -> + (DN.abs amp0 + DN.abs amp1, mixCore amp0 amp1) + +{-# INLINE mixVolume #-} +mixVolume :: + (Field.C y, Module.C y yv, Dim.C v, Arrow arrow) => + DN.T v y -> + ArrowD.T arrow (DNS v y yv, DNS v y yv) (DNS v y yv) +mixVolume amp = + fromAmplitudeReader $ \(Amp.Numeric amp0, Amp.Numeric amp1) -> + (amp, mixCore amp0 amp1) + +{-# INLINE mixCore #-} +mixCore :: + (Field.C y, Module.C y yv, Dim.C v, Arrow arrow) => + DN.T v y -> DN.T v y -> + Context v y (arrow (yv,yv) yv) +mixCore amp0 amp1 = + liftA2 + (\toSamp0 toSamp1 -> + arr (\(y0,y1) -> toSamp0 y0 + toSamp1 y1)) + (toAmplitudeVector amp0) + (toAmplitudeVector amp1) + + +{- | +Mix one or more signals. +-} +{-# INLINE fanoutAndMixMulti #-} +fanoutAndMixMulti :: + (RealField.C y, Module.C y yv, Dim.C v, Arrow arrow) => + [ArrowD.T arrow sample (DNS v y yv)] -> + ArrowD.T arrow sample (DNS v y yv) +fanoutAndMixMulti cs = + fromAmplitudeReader $ \ampIn -> + let ampCs = map (\(ArrowD.Cons f) -> f ampIn) cs + in (maximum (map (\(_, Amp.Numeric amp) -> amp) ampCs), + fanoutAndMixMultiCore ampCs) + +{- | +Mix zero or more signals. +-} +{-# INLINE fanoutAndMixMultiVolume #-} +fanoutAndMixMultiVolume :: + (Field.C y, Module.C y yv, Dim.C v, Arrow arrow) => + DN.T v y -> + [ArrowD.T arrow sample (DNS v y yv)] -> + ArrowD.T arrow sample (DNS v y yv) +fanoutAndMixMultiVolume amp cs = + fromAmplitudeReader $ \ampIn -> + (amp, fanoutAndMixMultiCore $ + map (\(ArrowD.Cons f) -> f ampIn) cs) + +{-# INLINE fanoutAndMixMultiCore #-} +fanoutAndMixMultiCore :: + (Field.C y, Module.C y yv, Dim.C v, Arrow arrow) => + [(arrow yvIn yv, Amp.Dimensional v y)] -> + Context v y (arrow yvIn yv) +fanoutAndMixMultiCore cs = + foldr + (\(c, Amp.Numeric ampX) -> + liftA2 + (\toSamp rest -> + uncurry (+) ^<< (toSamp ^<< c) &&& rest) + (toAmplitudeVector ampX)) + (return $ arr (const zero)) cs + + +-- * Miscellaneous + +{- | +Add a number to all of the signal values. +This is useful for adjusting the center of a modulation. +-} +{-# INLINE raise #-} +raise :: + (Field.C y, Module.C y yv, Dim.C v, Arrow arrow) => + DN.T v y -> + yv -> + ArrowD.T arrow (DNS v y yv) (DNS v y yv) +raise y' yv = + fromAmplitudeReader $ \(Amp.Numeric amp) -> + (amp, fmap (\toSamp -> arr (toSamp yv +)) (toAmplitudeVector y')) + +{- | +Distort the signal using a flat function. +The first signal gives the scaling of the function. +If the scaling is @c@ and the input sample is @y@, +then @c * f(y/c)@ is emitted. +This way we can use an (efficient) flat function +and have a simple, yet dimension conform, way of controlling the distortion. +E.g. if the distortion function is @tanh@ +then the value @c@ controls the saturation level. +-} +{-# INLINE distort #-} +distort :: + (Field.C y, Module.C y yv, Dim.C v, Arrow arrow) => + (yv -> yv) -> + ArrowD.T arrow (DNS v y y, DNS v y yv) (DNS v y yv) +distort f = + fromAmplitudeReader $ \(Amp.Numeric ampCtrl, Amp.Numeric ampIn) -> + (ampIn, + fmap (\toSamp -> + arr (\(c,y) -> + let c' = toSamp c + in c' *> f (recip c' *> y))) + (toAmplitudeScalar ampCtrl)) + + + +{-# INLINE toAmplitudeScalar #-} +toAmplitudeScalar :: + (Field.C y, Dim.C u) => + DN.T u y -> Context u y (y -> y) +toAmplitudeScalar ampIn = + asks (\ampOut -> (DN.divToScalar ampIn ampOut *)) + +{-# INLINE toAmplitudeVector #-} +toAmplitudeVector :: + (Module.C y yv, Field.C y, Dim.C u) => + DN.T u y -> Context u y (yv -> yv) +toAmplitudeVector ampIn = + asks (\ampOut -> (DN.divToScalar ampIn ampOut *> )) + +{-# INLINE fromAmplitudeReader #-} +fromAmplitudeReader :: + (Sample.Amplitude sampleIn -> + (ampOut, + Reader ampOut (arrow (Sample.Displacement sampleIn) yvOut))) -> + ArrowD.T arrow sampleIn (Sample.Numeric ampOut yvOut) +fromAmplitudeReader f = + ArrowD.Cons $ \ampIn -> + let (ampOut, rd) = f ampIn + in (runReader rd ampOut, Amp.Numeric ampOut) diff --git a/src/Synthesizer/Dimensional/Map/Filter.hs b/src/Synthesizer/Dimensional/Map/Filter.hs --- a/src/Synthesizer/Dimensional/Map/Filter.hs +++ b/src/Synthesizer/Dimensional/Map/Filter.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleContexts #-} {- | Copyright : (c) Henning Thielemann 2009 License : GPL @@ -20,8 +21,12 @@ ) where import qualified Synthesizer.Dimensional.Map as MapD +import qualified Synthesizer.Dimensional.Arrow as ArrowD import qualified Synthesizer.Dimensional.Amplitude as Amp +import qualified Synthesizer.Dimensional.Sample as Sample +import Control.Arrow (Arrow, ) + import qualified Number.DimensionTerm as DN import qualified Algebra.DimensionTerm as Dim @@ -30,9 +35,9 @@ -- import qualified Number.NonNegative as NonNeg -- import qualified Algebra.Transcendental as Trans --- import qualified Algebra.RealField as RealField +-- import qualified Algebra.RealRing as RealRing -- import qualified Algebra.Field as Field --- import qualified Algebra.Real as Real +-- import qualified Algebra.Absolute as Absolute import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive -- import qualified Algebra.VectorSpace as VectorSpace @@ -40,32 +45,35 @@ -- import Control.Monad(liftM2) -import NumericPrelude hiding (negate) -import PreludeBase as P +import NumericPrelude.Numeric hiding (negate) +import NumericPrelude.Base as P import Prelude () {- | The amplification factor must be positive. -} {-# INLINE amplify #-} -amplify :: (Module.C y amp) => +amplify :: + (Module.C y amp, Arrow arrow) => y -> - MapD.T (Amp.Numeric amp) (Amp.Numeric amp) yv yv + ArrowD.Single arrow (Amp.Numeric amp) (Amp.Numeric amp) yv yv amplify volume = MapD.independent (fmap (volume *>)) id {-# INLINE amplifyDimension #-} -amplifyDimension :: (Ring.C y, Dim.C v0, Dim.C v1) => +amplifyDimension :: + (Ring.C y, Dim.C v0, Dim.C v1, Arrow arrow) => DN.T v0 y -> - MapD.T - (Amp.Dimensional v1 y) (Amp.Dimensional (Dim.Mul v0 v1) y) - yv yv + ArrowD.Single arrow + (Amp.Dimensional v1 y) (Amp.Dimensional (Dim.Mul v0 v1) y) + yv yv amplifyDimension volume = MapD.independent (fmap (volume &*&)) id {-# INLINE amplifyScalarDimension #-} -amplifyScalarDimension :: (Ring.C y, Dim.C v) => +amplifyScalarDimension :: + (Ring.C y, Dim.C v, Arrow arrow) => DN.T v y -> - MapD.T + ArrowD.Single arrow (Amp.Dimensional Dim.Scalar y) (Amp.Dimensional v y) yv yv amplifyScalarDimension volume = @@ -75,25 +83,26 @@ {-# INLINE negate #-} -negate :: (Additive.C yv) => - MapD.T amp amp yv yv +negate :: + (Additive.C (Sample.Displacement sample), Arrow arrow) => + ArrowD.T arrow sample sample negate = MapD.independent id Additive.negate {-# INLINE envelope #-} -envelope :: (Ring.C y) => - MapD.T (Amp.Flat y, amp) amp (y,y) y +envelope :: + (Ring.C y, Arrow arrow) => + ArrowD.T arrow (Sample.Flat y, Sample.Numeric amp y) (Sample.Numeric amp y) envelope = MapD.independent snd (uncurry (*)) {-# INLINE envelopeScalarDimension #-} envelopeScalarDimension :: - (Ring.C y, Dim.C v) => - MapD.T - (Amp.Dimensional Dim.Scalar y, Amp.Dimensional v y) - (Amp.Dimensional v y) - (y,y) y + (Ring.C y, Dim.C v, Arrow arrow) => + ArrowD.T arrow + (Sample.Dimensional Dim.Scalar y y, Sample.Dimensional v y y) + (Sample.Dimensional v y y) envelopeScalarDimension = MapD.independent (\(Amp.Numeric ampEnv, Amp.Numeric ampSig) -> @@ -101,18 +110,18 @@ (uncurry (*)) {-# INLINE envelopeVector #-} -envelopeVector :: (Module.C y yv) => - MapD.T (Amp.Flat y, amp) amp (y,yv) yv +envelopeVector :: + (Module.C y (Sample.Displacement sample), Arrow arrow) => + ArrowD.T arrow (Sample.Flat y, sample) sample envelopeVector = MapD.independent snd (uncurry (*>)) {-# INLINE envelopeVectorDimension #-} envelopeVectorDimension :: - (Module.C y0 yv, Ring.C y, Dim.C v0, Dim.C v1) => - MapD.T - (Amp.Dimensional v0 y, Amp.Dimensional v1 y) - (Amp.Dimensional (Dim.Mul v0 v1) y) - (y0,yv) yv + (Module.C y0 yv, Ring.C y, Dim.C v0, Dim.C v1, Arrow arrow) => + ArrowD.T arrow + (Sample.Dimensional v0 y y0, Sample.Dimensional v1 y yv) + (Sample.Dimensional (Dim.Mul v0 v1) y yv) envelopeVectorDimension = MapD.independent (\(Amp.Numeric ampEnv, Amp.Numeric ampSig) -> diff --git a/src/Synthesizer/Dimensional/Process.hs b/src/Synthesizer/Dimensional/Process.hs --- a/src/Synthesizer/Dimensional/Process.hs +++ b/src/Synthesizer/Dimensional/Process.hs @@ -40,7 +40,7 @@ import Number.DimensionTerm ((*&), (&/&), ) -- ((&*&), ) -import qualified Algebra.RealField as RealField +import qualified Algebra.RealRing as RealRing import qualified Algebra.Field as Field import qualified Algebra.Ring as Ring @@ -52,8 +52,8 @@ {- -import NumericPrelude -import PreludeBase as P +import NumericPrelude.Numeric +import NumericPrelude.Base as P -} @@ -182,12 +182,12 @@ else error $ funcName ++ ": negative chunkSize" intFromTime :: - (RealField.C t, Dim.C u) => + (RealRing.C t, Dim.C u) => String -> DN.T u t -> T s u t Int intFromTime funcName t = - fmap (checkedChunkSize funcName . RealField.ceiling) $ toTimeScalar t + fmap (checkedChunkSize funcName . RealRing.ceiling) $ toTimeScalar t intFromTime98 :: (Ring.C t, RealFrac t, Dim.C u) => diff --git a/src/Synthesizer/Dimensional/Rate.hs b/src/Synthesizer/Dimensional/Rate.hs --- a/src/Synthesizer/Dimensional/Rate.hs +++ b/src/Synthesizer/Dimensional/Rate.hs @@ -10,8 +10,8 @@ import qualified Synthesizer.Utility as Util {- -import NumericPrelude -import PreludeBase as P +import NumericPrelude.Numeric +import NumericPrelude.Base as P -} diff --git a/src/Synthesizer/Dimensional/Rate/Analysis.hs b/src/Synthesizer/Dimensional/Rate/Analysis.hs --- a/src/Synthesizer/Dimensional/Rate/Analysis.hs +++ b/src/Synthesizer/Dimensional/Rate/Analysis.hs @@ -23,12 +23,12 @@ import Number.DimensionTerm ((*&)) import qualified Algebra.Field as Field --- import qualified Algebra.Real as Real +-- import qualified Algebra.Absolute as Absolute -- import qualified Algebra.Ring as Ring -import PreludeBase ((.), ) -import NumericPrelude +import NumericPrelude.Base ((.), ) +import NumericPrelude.Numeric import Prelude () diff --git a/src/Synthesizer/Dimensional/Rate/Control.hs b/src/Synthesizer/Dimensional/Rate/Control.hs --- a/src/Synthesizer/Dimensional/Rate/Control.hs +++ b/src/Synthesizer/Dimensional/Rate/Control.hs @@ -34,12 +34,12 @@ import qualified Algebra.Transcendental as Trans import qualified Algebra.Field as Field --- import qualified Algebra.Real as Real +-- import qualified Algebra.Absolute as Absolute import qualified Algebra.Ring as Ring -- import qualified Algebra.Additive as Additive -import NumericPrelude -import PreludeBase +import NumericPrelude.Numeric +import NumericPrelude.Base import Prelude () diff --git a/src/Synthesizer/Dimensional/Rate/Cut.hs b/src/Synthesizer/Dimensional/Rate/Cut.hs --- a/src/Synthesizer/Dimensional/Rate/Cut.hs +++ b/src/Synthesizer/Dimensional/Rate/Cut.hs @@ -23,14 +23,14 @@ -- import qualified Number.NonNegative as NonNeg -import qualified Algebra.RealField as RealField +import qualified Algebra.RealRing as RealRing -- import qualified Algebra.Field as Field import Data.Monoid (Monoid, mappend, mconcat, ) -import NumericPrelude hiding (negate) --- import PreludeBase as P +import NumericPrelude.Numeric hiding (negate) +-- import NumericPrelude.Base as P import Prelude hiding (splitAt, take, drop, concat, ) @@ -43,7 +43,7 @@ but only after buffering. -} {-# INLINE splitAt #-} -splitAt :: (CutG.Transform sig, RealField.C t, Dim.C u) => +splitAt :: (CutG.Transform sig, RealRing.C t, Dim.C u) => DN.T u t -> Proc.T s u t (Signal s amp sig -> @@ -51,29 +51,29 @@ splitAt t' = flip fmap (Proc.toTimeScalar t') $ \t x -> - let (y,z) = CutG.splitAt (RealField.round t) $ SigA.body x + let (y,z) = CutG.splitAt (RealRing.round t) $ SigA.body x in (SigA.replaceBody y x, SigA.replaceBody z x) {-# INLINE take #-} -take :: (CutG.Transform sig, RealField.C t, Dim.C u) => +take :: (CutG.Transform sig, RealRing.C t, Dim.C u) => DN.T u t -> Proc.T s u t (Signal s amp sig -> Signal s amp sig) take t' = flip fmap (Proc.toTimeScalar t') $ - \t -> SigA.processBody (CutG.take (RealField.round t)) + \t -> SigA.processBody (CutG.take (RealRing.round t)) {-# INLINE drop #-} -drop :: (CutG.Transform sig, RealField.C t, Dim.C u) => +drop :: (CutG.Transform sig, RealRing.C t, Dim.C u) => DN.T u t -> Proc.T s u t (Signal s amp sig -> Signal s amp sig) drop t' = flip fmap (Proc.toTimeScalar t') $ - \t -> SigA.processBody (CutG.drop (RealField.round t)) + \t -> SigA.processBody (CutG.drop (RealRing.round t)) {-# INLINE concat #-} diff --git a/src/Synthesizer/Dimensional/Rate/Dirac.hs b/src/Synthesizer/Dimensional/Rate/Dirac.hs --- a/src/Synthesizer/Dimensional/Rate/Dirac.hs +++ b/src/Synthesizer/Dimensional/Rate/Dirac.hs @@ -19,7 +19,7 @@ import Data.Tuple.HT (mapPair, mapSnd, ) -import NumericPrelude (zero, one, ) +import NumericPrelude.Numeric (zero, one, ) {- | diff --git a/src/Synthesizer/Dimensional/Rate/Filter.hs b/src/Synthesizer/Dimensional/Rate/Filter.hs --- a/src/Synthesizer/Dimensional/Rate/Filter.hs +++ b/src/Synthesizer/Dimensional/Rate/Filter.hs @@ -110,7 +110,7 @@ import qualified Algebra.Transcendental as Trans import qualified Algebra.RealField as RealField import qualified Algebra.Field as Field --- import qualified Algebra.Real as Real +import qualified Algebra.RealRing as RealRing import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive -- import qualified Algebra.VectorSpace as VectorSpace @@ -122,8 +122,8 @@ -- import Control.Monad(liftM2) -import NumericPrelude hiding (negate) -import PreludeBase as P +import NumericPrelude.Numeric hiding (negate) +import NumericPrelude.Base as P import Prelude () @@ -211,7 +211,7 @@ toStorable) {-# INLINE delay #-} -delay :: (Additive.C yv, RealField.C t, Dim.C u, SigG.Write sig yv) => +delay :: (Additive.C yv, RealRing.C t, Dim.C u, SigG.Write sig yv) => DN.T u t -> Proc.T s u t ( SigA.T (Rate.Phantom s) amp (sig yv) @@ -290,7 +290,7 @@ {-# INLINE frequencyModulation #-} frequencyModulation :: (Flat.C t flat, - Additive.C yv, RealField.C t, Dim.C u) => + Additive.C yv, RealRing.C t, Dim.C u) => Interpolation.T t yv -> Proc.T s u t ( Signal s flat t {- v frequency factors -} @@ -337,7 +337,7 @@ {-# INLINE interpolateMultiRelativeZeroPad #-} interpolateMultiRelativeZeroPad :: - (RealField.C q, Additive.C yv) => + (RealRing.C q, Additive.C yv) => Interpolation.T q yv -> Sig.T q -> Sig.T yv @@ -590,7 +590,7 @@ {- | Infinitely many equi-delayed exponentially decaying echos. -} {-# INLINE comb #-} -comb :: (RealField.C t, Module.C y yv, Dim.C u, Storable yv) => +comb :: (RealRing.C t, Module.C y yv, Dim.C u, Storable yv) => DN.T u t -> y -> Proc.T s u t (Signal s amp yv -> Signal s amp yv) comb time gain = do t <- toTimeScalar time diff --git a/src/Synthesizer/Dimensional/Rate/Oscillator.hs b/src/Synthesizer/Dimensional/Rate/Oscillator.hs --- a/src/Synthesizer/Dimensional/Rate/Oscillator.hs +++ b/src/Synthesizer/Dimensional/Rate/Oscillator.hs @@ -4,7 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {- | -Copyright : (c) Henning Thielemann 2008, 2009 +Copyright : (c) Henning Thielemann 2008-2010 License : GPL Maintainer : synthesizer@henning-thielemann.de @@ -36,13 +36,16 @@ shapePhaseFreqModFromSampledTone, ) where +import qualified Synthesizer.Dimensional.Causal.Oscillator as OsciC import qualified Synthesizer.State.Oscillator as Osci import qualified Synthesizer.State.Signal as Sig import qualified Synthesizer.Dimensional.Causal.Process as CausalD +import qualified Synthesizer.Dimensional.Causal.Oscillator.Core as OsciCore import qualified Synthesizer.Dimensional.Causal.Oscillator as OsciC import qualified Synthesizer.Dimensional.Map as MapD +import qualified Synthesizer.Dimensional.Sample as Sample import qualified Synthesizer.Dimensional.Amplitude.Flat as Flat -- import qualified Synthesizer.Dimensional.Amplitude as Amp import qualified Synthesizer.Dimensional.Rate as Rate @@ -52,7 +55,6 @@ -- import qualified Synthesizer.Dimensional.Wave.Smoothed as WaveSmooth import qualified Synthesizer.Dimensional.Wave.Controlled as WaveCtrl import qualified Synthesizer.Dimensional.Wave as WaveD -import qualified Synthesizer.Basic.Wave as Wave import qualified Synthesizer.Basic.Phase as Phase import qualified Synthesizer.Dimensional.Cyclic.Signal as SigC @@ -68,10 +70,9 @@ -- import Number.DimensionTerm ((&*&)) import qualified Algebra.RealField as RealField -import qualified Algebra.Field as Field --- import NumericPrelude -import PreludeBase as P +-- import NumericPrelude.Numeric +import NumericPrelude.Base as P @@ -79,33 +80,29 @@ SigA.T (Rate.Phantom s) amp (Sig.T y) -withWave :: - WaveD.T amp t y -> (Wave.T t y -> Sig.T y) -> Signal s amp y -withWave (WaveD.Cons amp w) f = - SigA.Cons Rate.Phantom amp $ f w - - {- * Oscillators with constant waveforms -} {- | oscillator with a functional waveform with constant frequency -} {-# INLINE static #-} static :: (RealField.C t, Dim.C u) => - WaveD.T amp t y {- ^ waveform -} + WaveD.T t (Sample.T amp y) {- ^ waveform -} -> Phase.T t {- ^ start phase -} -> DN.T (Dim.Recip u) t {- ^ frequency -} -> Proc.T s u t (Signal s amp y) -static wave phase = - staticAux (\freq -> withWave wave $ \w -> Osci.static w phase freq) +static wave phase freq = + fmap (MapD.apply wave) $ + OsciCore.static phase freq + {- {- | oscillator with a functional waveform with constant frequency -} {-# INLINE staticAntiAlias #-} staticAntiAlias :: (RealField.C t, Dim.C u, Smooth amp t wave sig) => - WaveD.T amp t y + WaveD.T t (Sample.T amp y) {- ^ waveform -} -> Phase.T t {- ^ start phase -} -> DN.T (Dim.Recip u) t @@ -119,14 +116,15 @@ {-# INLINE freqMod #-} freqMod :: (RealField.C t, Dim.C u) => - WaveD.T amp t y {- ^ waveform -} + WaveD.T t (Sample.T amp y) {- ^ waveform -} -> Phase.T t {- ^ start phase -} -> Proc.T s u t ( SigA.R s (Dim.Recip u) t t {- v frequency control -} -> Signal s amp y) freqMod wave phase = - freqModAux (\t -> withWave wave $ \w -> Osci.freqMod w phase t) + fmap CausalD.apply $ + OsciC.freqMod wave phase {- {- | oscillator with a functional waveform with modulated frequency -} @@ -134,7 +132,7 @@ freqModAntiAlias :: (RealField.C t, Dim.C u, Smooth amp t wave sig) => - WaveD.T amp t y + WaveD.T t (Sample.T amp y) {- ^ waveform -} -> Phase.T t {- ^ start phase -} -> Proc.T s u t ( @@ -149,40 +147,38 @@ {-# INLINE phaseMod #-} phaseMod :: (Flat.C t flat, RealField.C t, Dim.C u) => - WaveD.T amp t y {- ^ waveform -} + WaveD.T t (Sample.T amp y) {- ^ waveform -} -> DN.T (Dim.Recip u) t {- ^ frequency -} -> Proc.T s u t ( Signal s flat t {- v phase modulation, phases must have no unit -} -> Signal s amp y) -phaseMod wave = - staticAux (\freq sig -> - withWave wave $ \w -> Osci.phaseMod w freq . Flat.toSamples $ sig) +phaseMod wave freq = + fmap CausalD.applyFlat $ + OsciC.phaseMod wave freq {- | oscillator with modulated shape -} {-# INLINE shapeMod #-} shapeMod :: - (Flat.C c flat, RealField.C t, Dim.C u) => - WaveCtrl.T amp c t y + (RealField.C t, Dim.C u) => + WaveCtrl.T (Sample.T cAmp c) t (Sample.T amp y) {- ^ waveform -} -> Phase.T t {- ^ phase -} -> DN.T (Dim.Recip u) t {- ^ frequency -} -> Proc.T s u t ( - Signal s flat c {- v shape control -} + Signal s cAmp c {- v shape control -} -> Signal s amp y) -shapeMod wave phase = - staticAux (\freq -> - SigA.Cons Rate.Phantom (WaveCtrl.amplitude wave) . - Osci.shapeMod (WaveCtrl.body wave) phase freq . Flat.toSamples) - +shapeMod wave phase freq = + fmap CausalD.apply $ + OsciC.shapeMod wave phase freq {- | oscillator with a functional waveform with modulated phase and frequency -} {-# INLINE phaseFreqMod #-} phaseFreqMod :: (Flat.C t flat, RealField.C t, Dim.C u) => - WaveD.T amp t y {- ^ waveform -} + WaveD.T t (Sample.T amp y) {- ^ waveform -} -> Proc.T s u t ( Signal s flat t {- v phase control -} @@ -190,29 +186,28 @@ {- v frequency control -} -> Signal s amp y) phaseFreqMod wave = - fmap flip $ - freqModAux (\ freqs phases -> - withWave wave $ \w -> - Osci.phaseFreqMod w (Flat.toSamples phases) freqs) + flip fmap (OsciC.phaseFreqMod wave) $ \osci phases freqs -> + CausalD.applyFlatFst osci phases + `CausalD.apply` + freqs {- | oscillator with both shape and frequency modulation -} {-# INLINE shapeFreqMod #-} -shapeFreqMod :: (Flat.C c flat, RealField.C t, Dim.C u) => - WaveCtrl.T amp c t y +shapeFreqMod :: (RealField.C t, Dim.C u) => + WaveCtrl.T (Sample.T cAmp c) t (Sample.T amp y) {- ^ waveform -} -> Phase.T t {- ^ phase -} -> Proc.T s u t ( - Signal s flat c + Signal s cAmp c {- v shape control -} -> SigA.R s (Dim.Recip u) t t {- v frequency control -} -> Signal s amp y) shapeFreqMod wave phase = - fmap flip $ - freqModAux - (\ freqs parameters -> - SigA.Cons Rate.Phantom (WaveCtrl.amplitude wave) $ - Osci.shapeFreqMod (WaveCtrl.body wave) phase (Flat.toSamples parameters) freqs) + flip fmap (OsciC.shapeFreqMod wave phase) $ \osci shapes freqs -> + CausalD.applyFst osci shapes + `CausalD.apply` + freqs {- | @@ -228,8 +223,8 @@ -> DN.T (Dim.Recip u) t {- ^ frequency -} -> Proc.T s u t (Signal s amp y) -staticSample ip wave phase = - staticAux $ +staticSample ip wave phase freq = + flip fmap (toFrequencyScalar freq) $ SigA.Cons Rate.Phantom (SigA.amplitude wave) . Osci.staticSample ip (SigC.toPeriod $ SigA.body wave) phase @@ -247,9 +242,10 @@ {- v frequency control -} -> Signal s amp y) freqModSample ip wave phase = - freqModAux $ + flip fmap (Proc.withParam toFrequencyScalar) $ \toFreq -> SigA.Cons Rate.Phantom (SigA.amplitude wave) . - Osci.freqModSample ip (SigC.toPeriod $ SigA.body wave) phase + Osci.freqModSample ip (SigC.toPeriod $ SigA.body wave) phase . + SigA.scalarSamples toFreq {- @@ -332,23 +328,3 @@ phaseDistort `CausalD.apply` freqs) - - -{-# INLINE freqModAux #-} -freqModAux :: (Field.C t, Dim.C u) => - (Sig.T t -> c) - -> Proc.T s u t ( - SigA.R s (Dim.Recip u) t t - -> c) -freqModAux f = - fmap - (\toFreq -> f . SigA.scalarSamples toFreq) - (Proc.withParam toFrequencyScalar) - -{-# INLINE staticAux #-} -staticAux :: (Dim.C u, Field.C t) => - (t -> c) - -> DN.T (Dim.Recip u) t - -> Proc.T s u t c -staticAux f freq = - fmap f (toFrequencyScalar freq) diff --git a/src/Synthesizer/Dimensional/RateAmplitude/Analysis.hs b/src/Synthesizer/Dimensional/RateAmplitude/Analysis.hs --- a/src/Synthesizer/Dimensional/RateAmplitude/Analysis.hs +++ b/src/Synthesizer/Dimensional/RateAmplitude/Analysis.hs @@ -50,14 +50,15 @@ -- import qualified Algebra.Transcendental as Trans import qualified Algebra.Algebraic as Algebraic -import qualified Algebra.Field as Field import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.RealRing as RealRing import qualified Algebra.Ring as Ring -import qualified Algebra.Real as Real +import qualified Algebra.Absolute as Absolute -import PreludeBase (Ord, ($), (.), return, fmap, id, ) -import NumericPrelude (sqr, abs, ) +import NumericPrelude.Base (Ord, ($), (.), return, fmap, id, ) +import NumericPrelude.Numeric (sqr, abs, ) import Prelude (Int, ) @@ -71,7 +72,7 @@ Manhattan norm. -} {-# INLINE normMaximum #-} -normMaximum :: (Real.C y, Dim.C u, Dim.C v) => +normMaximum :: (RealRing.C y, Dim.C u, Dim.C v) => Signal u t v y y -> DN.T v y normMaximum = AnaA.volumeMaximum @@ -92,7 +93,7 @@ Sum norm. -} {-# INLINE normSum #-} -normSum :: (Field.C q, Real.C q, Dim.C u, Dim.C v) => +normSum :: (Field.C q, Absolute.C q, Dim.C u, Dim.C v) => Signal u q v q q -> DN.T (Dim.Mul u v) q normSum = @@ -153,7 +154,7 @@ Manhattan norm. -} {-# INLINE normMaximumProc #-} -normMaximumProc :: (Real.C y, Dim.C u, Dim.C v) => +normMaximumProc :: (RealRing.C y, Dim.C u, Dim.C v) => Proc.T s u y (SigA.R s v y y -> DN.T v y) normMaximumProc = Proc.pure AnaA.volumeMaximum @@ -177,7 +178,7 @@ Sum norm. -} {-# INLINE normSumProc #-} -normSumProc :: (Field.C q, Real.C q, Dim.C u, Dim.C v) => +normSumProc :: (Field.C q, Absolute.C q, Dim.C u, Dim.C v) => Proc.T s u q ( SigA.R s v q q -> DN.T (Dim.Mul u v) q) diff --git a/src/Synthesizer/Dimensional/RateAmplitude/Control.hs b/src/Synthesizer/Dimensional/RateAmplitude/Control.hs --- a/src/Synthesizer/Dimensional/RateAmplitude/Control.hs +++ b/src/Synthesizer/Dimensional/RateAmplitude/Control.hs @@ -43,18 +43,19 @@ import qualified Algebra.Transcendental as Trans import qualified Algebra.RealField as RealField import qualified Algebra.Field as Field -import qualified Algebra.Real as Real +import qualified Algebra.RealRing as RealRing -- import qualified Algebra.Ring as Ring +import qualified Algebra.Absolute as Absolute import qualified Algebra.Additive as Additive -import NumericPrelude -import PreludeBase +import NumericPrelude.Numeric +import NumericPrelude.Base import Prelude () {-# INLINE constant #-} -constant :: (Real.C y, Dim.C u, Dim.C v) => +constant :: (Absolute.C y, Dim.C u, Dim.C v) => DN.T v y {-^ value -} -> Proc.T s u t (SigA.R s v y y) constant y = Proc.pure $ CtrlA.constant y @@ -64,7 +65,7 @@ This is not checked. -} {-# INLINE constantVector #-} -constantVector :: -- (Field.C y', Real.C y', Dim.C v) => +constantVector :: -- (Field.C y', Absolute.C y', Dim.C v) => DN.T v y {-^ amplitude -} -> yv {-^ value -} -> Proc.T s u t (SigA.R s v y yv) @@ -72,7 +73,7 @@ {- Using the 'Ctrl.linear' instead of 'Ctrl.linearStable' the type class constraints would be weaker. -linear :: (Additive.C y, Field.C y', Real.C y', Dim.C v) => +linear :: (Additive.C y, Field.C y', Absolute.C y', Dim.C v) => -} {- | @@ -84,7 +85,7 @@ -} {-# INLINE linear #-} linear :: - (Field.C q, Real.C q, Dim.C u, Dim.C v) => + (Field.C q, Absolute.C q, Dim.C u, Dim.C v) => DN.T (DimensionGradient u v) q {-^ slope of the curve -} -> DN.T v q {-^ initial value -} @@ -115,7 +116,7 @@ in z {-# INLINE exponential #-} -exponential :: (Trans.C q, Real.C q, Dim.C u, Dim.C v) => +exponential :: (Trans.C q, Absolute.C q, Dim.C u, Dim.C v) => DN.T u q {-^ time where the function reaches 1\/e of the initial value -} -> DN.T v q {-^ initial value -} -> Proc.T s u q (SigA.R s v q q) @@ -129,7 +130,7 @@ -} {-# INLINE exponential2 #-} -exponential2 :: (Trans.C q, Real.C q, Dim.C u, Dim.C v) => +exponential2 :: (Trans.C q, Absolute.C q, Dim.C u, Dim.C v) => DN.T u q {-^ half life, time where the function reaches 1\/2 of the initial value -} -> DN.T v q {-^ initial value -} -> Proc.T s u q (SigA.R s v q q) @@ -143,7 +144,7 @@ -} {-# INLINE exponentialFromTo #-} exponentialFromTo :: - (Trans.C q, RealField.C q, Dim.C u, Dim.C v) => + (Trans.C q, RealRing.C q, Dim.C u, Dim.C v) => DN.T u q {-^ duration of the ramp -} -> (DN.T v q, DN.T v q) {-^ initial and final value -} @@ -162,7 +163,7 @@ {-# INLINE cubicHermite #-} cubicHermite :: - (Field.C q, Real.C q, Dim.C u, Dim.C v) => + (RealField.C q, Dim.C u, Dim.C v) => (DN.T u q, (DN.T v q, DN.T (DimensionGradient u v) q)) -> (DN.T u q, (DN.T v q, DN.T (DimensionGradient u v) q)) -> Proc.T s u q (SigA.R s v q q) diff --git a/src/Synthesizer/Dimensional/RateAmplitude/Cut.hs b/src/Synthesizer/Dimensional/RateAmplitude/Cut.hs --- a/src/Synthesizer/Dimensional/RateAmplitude/Cut.hs +++ b/src/Synthesizer/Dimensional/RateAmplitude/Cut.hs @@ -55,38 +55,38 @@ import qualified Algebra.NormedSpace.Maximum as NormedMax import qualified Algebra.Module as Module -import qualified Algebra.RealField as RealField +import qualified Algebra.RealRing as RealRing import qualified Algebra.Field as Field import qualified Algebra.Ring as Ring import qualified Data.List as List -import PreludeBase ((.), ($), Ord, (<=), map, return, error, ) --- import NumericPrelude +import NumericPrelude.Base ((.), ($), Ord, (<=), map, return, error, ) +-- import NumericPrelude.Numeric import Prelude (RealFrac, ) {- * dissection -} {-# INLINE splitAt #-} -splitAt :: (RealField.C t, Dim.C u, Dim.C v, Storable yv) => +splitAt :: (RealRing.C t, Dim.C u, Dim.C v, Storable yv) => DN.T u t -> Proc.T s u t (SigA.R s v y yv -> (SigA.R s v y yv, SigA.R s v y yv)) splitAt t' = do t <- toTimeScalar t' return $ \x -> - let (ss0,ss1) = Sig.splitAt (RealField.round t) (SigA.body x) + let (ss0,ss1) = Sig.splitAt (RealRing.round t) (SigA.body x) in (SigA.replaceBody ss0 x, SigA.replaceBody ss1 x) {-# INLINE take #-} -take :: (RealField.C t, Dim.C u, Dim.C v) => +take :: (RealRing.C t, Dim.C u, Dim.C v) => DN.T u t -> Proc.T s u t (SigA.R s v y yv -> SigA.R s v y yv) take t' = CutR.take t' -- fmap (fst.) $ splitAt t {-# INLINE drop #-} -drop :: (RealField.C t, Dim.C u, Dim.C v) => +drop :: (RealRing.C t, Dim.C u, Dim.C v) => DN.T u t -> Proc.T s u t (SigA.R s v y yv -> SigA.R s v y yv) drop t' = CutR.drop t' @@ -94,7 +94,7 @@ {-# INLINE takeUntilPause #-} takeUntilPause :: - (RealField.C t, Dim.C u, + (RealRing.C t, Dim.C u, Field.C y, NormedMax.C y yv, Dim.C v) => DN.T v y -> DN.T u t -> Proc.T s u t (SigA.R s v y yv -> SigA.R s v y yv) takeUntilPause y' t' = @@ -103,7 +103,7 @@ let y = toAmplitudeScalar x y' in SigA.processBody (CutS.takeUntilInterval ((<=y) . NormedMax.norm) - (RealField.ceiling t)) x + (RealRing.ceiling t)) x {-# INLINE unzip #-} diff --git a/src/Synthesizer/Dimensional/RateAmplitude/Demonstration.hs b/src/Synthesizer/Dimensional/RateAmplitude/Demonstration.hs --- a/src/Synthesizer/Dimensional/RateAmplitude/Demonstration.hs +++ b/src/Synthesizer/Dimensional/RateAmplitude/Demonstration.hs @@ -70,8 +70,8 @@ import Data.Tuple.HT (snd3, ) -import PreludeBase -import NumericPrelude +import NumericPrelude.Base +import NumericPrelude.Numeric diff --git a/src/Synthesizer/Dimensional/RateAmplitude/Displacement.hs b/src/Synthesizer/Dimensional/RateAmplitude/Displacement.hs --- a/src/Synthesizer/Dimensional/RateAmplitude/Displacement.hs +++ b/src/Synthesizer/Dimensional/RateAmplitude/Displacement.hs @@ -22,14 +22,14 @@ import qualified Algebra.Module as Module import qualified Algebra.Field as Field -import qualified Algebra.Real as Real +import qualified Algebra.Absolute as Absolute -- import qualified Algebra.Ring as Ring -- import qualified Algebra.Additive as Additive -- import Algebra.Module ((*>)) -import PreludeBase --- import NumericPrelude +import NumericPrelude.Base +-- import NumericPrelude.Numeric import Prelude () @@ -38,7 +38,7 @@ {-| Mix two signals. In opposition to 'zipWith' the result has the length of the longer signal. -} {-# INLINE mix #-} -mix :: (Real.C y, Field.C y, Module.C y yv, Dim.C v) => +mix :: (Absolute.C y, Field.C y, Module.C y yv, Dim.C v) => Proc.T s u t ( SigA.R s v y yv -> SigA.R s v y yv @@ -47,7 +47,7 @@ {-# INLINE mixVolume #-} mixVolume :: - (Real.C y, Field.C y, Module.C y yv, Dim.C v) => + (Absolute.C y, Field.C y, Module.C y yv, Dim.C v) => DN.T v y -> Proc.T s u t ( SigA.R s v y yv @@ -60,7 +60,7 @@ -} {-# INLINE mixMulti #-} mixMulti :: - (Real.C y, Field.C y, Module.C y yv, Dim.C v) => + (Absolute.C y, Field.C y, Module.C y yv, Dim.C v) => Proc.T s u t ( [SigA.R s v y yv] -> SigA.R s v y yv) @@ -68,7 +68,7 @@ {-# INLINE mixMultiVolume #-} mixMultiVolume :: - (Real.C y, Field.C y, Module.C y yv, Dim.C v) => + (Absolute.C y, Field.C y, Module.C y yv, Dim.C v) => DN.T v y -> Proc.T s u t ( [SigA.R s v y yv] @@ -124,7 +124,7 @@ by a linear (affine) function with a unit. -} {-# INLINE mapLinearDimension #-} -mapLinearDimension :: (Field.C y, Real.C y, Dim.C u, Dim.C v) => +mapLinearDimension :: (Field.C y, Absolute.C y, Dim.C u, Dim.C v) => DN.T v y {- ^ range: one is mapped to @center + range * ampX@ -} -> DN.T (Dim.Mul v u) y {- ^ center: zero is mapped to @center@ -} -> Proc.T s u t ( diff --git a/src/Synthesizer/Dimensional/RateAmplitude/File.hs b/src/Synthesizer/Dimensional/RateAmplitude/File.hs --- a/src/Synthesizer/Dimensional/RateAmplitude/File.hs +++ b/src/Synthesizer/Dimensional/RateAmplitude/File.hs @@ -34,6 +34,7 @@ import qualified Algebra.Module as Module import qualified Algebra.RealField as RealField import qualified Algebra.Field as Field +import qualified Algebra.RealRing as RealRing -- import qualified Algebra.Ring as Ring import qualified Algebra.DimensionTerm as Dim @@ -42,8 +43,8 @@ import System.Exit(ExitCode) -import NumericPrelude -import PreludeBase +import NumericPrelude.Numeric +import NumericPrelude.Base diff --git a/src/Synthesizer/Dimensional/RateAmplitude/Filter.hs b/src/Synthesizer/Dimensional/RateAmplitude/Filter.hs --- a/src/Synthesizer/Dimensional/RateAmplitude/Filter.hs +++ b/src/Synthesizer/Dimensional/RateAmplitude/Filter.hs @@ -75,18 +75,21 @@ -- import Synthesizer.Dimensional.Process ((.:), (.^), ) import qualified Synthesizer.Dimensional.Amplitude.Flat as Flat -import qualified Synthesizer.Dimensional.Amplitude as Amp +-- import qualified Synthesizer.Dimensional.Amplitude as Amp import qualified Synthesizer.Dimensional.Signal.Private as SigA import qualified Synthesizer.State.Signal as Sig -import Synthesizer.Plain.Signal (Modifier) +-- import Synthesizer.Plain.Signal (Modifier) import Synthesizer.Dimensional.Process - (toTimeScalar, toFrequencyScalar, DimensionGradient, ) + (DimensionGradient, toTimeScalar, {- toFrequencyScalar, -} ) +{- import qualified Synthesizer.Frame.Stereo as Stereo +-} import Foreign.Storable (Storable, ) +{- -- import qualified Synthesizer.State.Displacement as Disp import qualified Synthesizer.Interpolation as Interpolation import qualified Synthesizer.State.Filter.Delay as Delay @@ -99,6 +102,7 @@ import qualified Synthesizer.State.Filter.Recursive.Integration as Integrate import qualified Synthesizer.State.Filter.Recursive.MovingAverage as MA import qualified Synthesizer.Plain.Filter.Recursive as FiltRec +-} import qualified Synthesizer.State.Filter.NonRecursive as FiltNR import qualified Synthesizer.Storable.Signal as SigSt @@ -107,14 +111,14 @@ import qualified Number.DimensionTerm as DN import qualified Algebra.DimensionTerm as Dim -import Number.DimensionTerm ((&*&), (&/&)) +import Number.DimensionTerm ((&*&), {- (&/&), -} ) -import qualified Number.NonNegative as NonNeg +-- import qualified Number.NonNegative as NonNeg -import qualified Algebra.Transcendental as Trans -import qualified Algebra.RealField as RealField +-- import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealRing as RealRing import qualified Algebra.Field as Field -import qualified Algebra.Real as Real +import qualified Algebra.Absolute as Absolute import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive -- import qualified Algebra.VectorSpace as VectorSpace @@ -122,8 +126,8 @@ -- import Control.Monad(liftM2) -import NumericPrelude hiding (negate) -import PreludeBase as P +import NumericPrelude.Numeric hiding (negate) +import NumericPrelude.Base as P import Prelude () @@ -200,7 +204,7 @@ {- | needs a good handling of boundaries, yet -} {-# INLINE meanStatic #-} meanStatic :: - (RealField.C q, Module.C q yv, Dim.C u, Dim.C v) => + (RealRing.C q, Module.C q yv, Dim.C u, Dim.C v) => DN.T (Dim.Recip u) q {- ^ cut-off frequency -} -> Proc.T s u q ( SigA.R s v q yv @@ -208,7 +212,7 @@ meanStatic time = FiltR.meanStatic time -meanStaticSeparateTY :: (Additive.C yv, Field.C y, RealField.C t, +meanStaticSeparateTY :: (Additive.C yv, Field.C y, RealRing.C t, Module.C y yv, Dim.C u, Dim.C v) => DN.T (Dim.Recip u) t {- ^ cut-off frequency -} -> Proc.T s u t ( @@ -229,7 +233,7 @@ {- | needs a better handling of boundaries, yet -} {-# INLINE mean #-} mean :: - (Additive.C yv, RealField.C q, + (Additive.C yv, RealRing.C q, Module.C q yv, Dim.C u, Dim.C v, Storable q, Storable yv) => DN.T (Dim.Recip u) q {- ^ minimum cut-off frequency -} @@ -243,7 +247,7 @@ {-# INLINE delay #-} -delay :: (Additive.C yv, Field.C y, RealField.C t, Dim.C u, Dim.C v) => +delay :: (Additive.C yv, Field.C y, RealRing.C t, Dim.C u, Dim.C v) => DN.T u t -> Proc.T s u t ( SigA.R s v y yv @@ -255,7 +259,7 @@ {-# INLINE phaseModulation #-} phaseModulation :: - (Additive.C yv, RealField.C q, Dim.C u, Dim.C v, + (Additive.C yv, RealRing.C q, Dim.C u, Dim.C v, Storable q, Storable yv) => Interpolation.T q yv -> DN.T u q @@ -275,7 +279,7 @@ {-# INLINE frequencyModulation #-} frequencyModulation :: - (Flat.C q flat, Additive.C yv, RealField.C q, Dim.C u, Dim.C v) => + (Flat.C q flat, Additive.C yv, RealRing.C q, Dim.C u, Dim.C v) => Interpolation.T q yv -> Proc.T s u q ( FlatSignal s flat q {- v frequency factors -} @@ -299,7 +303,7 @@ -} {-# INLINE frequencyModulationDecoupled #-} frequencyModulationDecoupled :: - (Flat.C q flat, Additive.C yv, RealField.C q, Dim.C u, Dim.C v) => + (Flat.C q flat, Additive.C yv, RealRing.C q, Dim.C u, Dim.C v) => Interpolation.T q yv -> Proc.T s u q ( FlatSignal s flat q {- v frequency factors -} @@ -318,7 +322,7 @@ {- | symmetric phaser -} {-# INLINE phaser #-} phaser :: - (Additive.C yv, RealField.C q, + (Additive.C yv, RealRing.C q, Module.C q yv, Dim.C u, Dim.C v, Storable q, Storable yv) => Interpolation.T q yv @@ -339,7 +343,7 @@ {-# INLINE phaserStereo #-} phaserStereo :: - (Additive.C yv, RealField.C q, + (Additive.C yv, RealRing.C q, Module.C q yv, Dim.C u, Dim.C v, Storable q, Storable yv) => Interpolation.T q yv @@ -359,7 +363,7 @@ {- {-# INLINE phaserCore #-} phaserCore :: - (Additive.C yv, RealField.C q, + (Additive.C yv, RealRing.C q, Module.C q yv, Dim.C u, Dim.C v, Storable q, Storable yv) => Interpolation.T q yv @@ -538,7 +542,7 @@ {- | Infinitely many equi-delayed exponentially decaying echos. -} {-# INLINE comb #-} -comb :: (RealField.C t, Module.C y yv, Dim.C u, Dim.C v, Storable yv) => +comb :: (RealRing.C t, Module.C y yv, Dim.C u, Dim.C v, Storable yv) => DN.T u t -> y -> Proc.T s u t (SigA.R s v y yv -> SigA.R s v y yv) comb = FiltR.comb @@ -546,7 +550,7 @@ {- | Infinitely many equi-delayed echos processed by an arbitrary time-preserving signal processor. -} {-# INLINE combProc #-} combProc :: - (RealField.C t, Real.C y, Field.C y, Module.C y yv, + (RealRing.C t, Absolute.C y, Field.C y, Module.C y yv, Dim.C u, Dim.C v, Storable yv) => DN.T u t -> Proc.T s u t (SigA.R s v y yv -> SigA.R s v y yv) -> diff --git a/src/Synthesizer/Dimensional/RateAmplitude/Instrument.hs b/src/Synthesizer/Dimensional/RateAmplitude/Instrument.hs --- a/src/Synthesizer/Dimensional/RateAmplitude/Instrument.hs +++ b/src/Synthesizer/Dimensional/RateAmplitude/Instrument.hs @@ -30,7 +30,8 @@ import Synthesizer.Dimensional.Process (($:), ($::), ($^), (.^), ($#), ) import qualified Synthesizer.Dimensional.Amplitude.Displacement as DispA -import qualified Synthesizer.Dimensional.Amplitude as Amp +import qualified Synthesizer.Dimensional.Amplitude.Flat as Flat +import qualified Synthesizer.Dimensional.Sample as Sample -- import qualified Synthesizer.Dimensional.Rate as Rate -- import qualified Synthesizer.Storable.Signal as SigSt @@ -62,8 +63,8 @@ import Data.List(zip4) -import PreludeBase -import NumericPrelude +import NumericPrelude.Base +import NumericPrelude.Numeric @@ -434,7 +435,7 @@ {- sampledWave :: (RealField.C t, Storable y) => Interpolation.T t y -> amp -> [y] -> - WaveD.T (Amp.Actual amp) t y + WaveD.T t (Sample.Numeric amp y) sampledWave ip amp = WaveD.amplified amp . WaveG.sample ip . SigSt.fromList SigSt.defaultChunkSize @@ -442,7 +443,7 @@ sampledWave :: (RealField.C t) => Interpolation.T t y -> amp -> [y] -> - WaveD.T (Amp.Numeric amp) t y + WaveD.T t (Sample.Numeric amp y) sampledWave ip amp = WaveD.amplified amp . WaveG.sample ip @@ -455,8 +456,9 @@ DN.T Dim.Frequency a -> Proc.T s Dim.Time a (SigA.R s Dim.Voltage a a) osciSharp freq = - let control = DN.fromNumber 10 &*^ CtrlR.exponential2 (DN.time 0.01) - in Osci.shapeMod (DN.voltage 1 `WaveCtrl.amplified` Wave.powerNormed) zero freq $& control + Osci.shapeMod (DN.voltage 1 `WaveCtrl.amplified` Wave.powerNormed) zero freq $: + (Flat.canonicalize $^ + DN.fromNumber 10 &*^ CtrlR.exponential2 (DN.time 0.01)) {-| Build a saw sound from its harmonics and modulate it. @@ -482,7 +484,7 @@ DN.T Dim.Frequency a {-^ frequency of the pulses, interesting ones are around 100 Hz and below -} -> Proc.T s Dim.Time a (SigA.R s Dim.Voltage a a) pulsedNoise freq = - let raisedSine :: Trans.C a => a -> WaveD.T (Amp.Dimensional Dim.Voltage a) a a + let raisedSine :: Trans.C a => a -> WaveD.T a (Sample.Dimensional Dim.Voltage a a) raisedSine v = DN.voltage v &*~ Wave.raise one Wave.sine c = Proc.pure Ana.lessOrEqual $: Osci.static (raisedSine 1.0) zero freq diff --git a/src/Synthesizer/Dimensional/RateAmplitude/Noise.hs b/src/Synthesizer/Dimensional/RateAmplitude/Noise.hs --- a/src/Synthesizer/Dimensional/RateAmplitude/Noise.hs +++ b/src/Synthesizer/Dimensional/RateAmplitude/Noise.hs @@ -35,8 +35,8 @@ import System.Random (Random, RandomGen, mkStdGen) -import NumericPrelude -import PreludeBase as P +import NumericPrelude.Numeric +import NumericPrelude.Base as P diff --git a/src/Synthesizer/Dimensional/RateAmplitude/Piece.hs b/src/Synthesizer/Dimensional/RateAmplitude/Piece.hs --- a/src/Synthesizer/Dimensional/RateAmplitude/Piece.hs +++ b/src/Synthesizer/Dimensional/RateAmplitude/Piece.hs @@ -32,17 +32,17 @@ -- import qualified Algebra.Module as Module import qualified Algebra.Transcendental as Trans -import qualified Algebra.RealField as RealField +import qualified Algebra.RealRing as RealRing import qualified Algebra.Field as Field --- import qualified Algebra.Real as Real +-- import qualified Algebra.Absolute as Absolute -- import qualified Algebra.Ring as Ring -- import qualified Algebra.Additive as Additive -- import Control.Monad.Fix (mfix, ) import Control.Monad (liftM3, ) -import NumericPrelude (zero, ) -import PreludeBase +import NumericPrelude.Numeric (zero, ) +import NumericPrelude.Base import Prelude () @@ -66,7 +66,7 @@ infinite descriptions cannot be used here. -} {-# INLINE run #-} -run :: (Trans.C q, RealField.C q, Dim.C u, Dim.C v, SigG.Write sig q) => +run :: (Trans.C q, RealRing.C q, Dim.C u, Dim.C v, SigG.Write sig q) => DN.T u q -> Sequence s u v sig q -> Proc.T s u q (SigA.T (Rate.Phantom s) (Amp.Dimensional v q) (sig q)) @@ -79,7 +79,7 @@ {-# INLINE runVolume #-} runVolume :: - (Trans.C q, RealField.C q, Dim.C u, Dim.C v, SigG.Write sig q) => + (Trans.C q, RealRing.C q, Dim.C u, Dim.C v, SigG.Write sig q) => DN.T u q -> Sequence s u v sig q -> DN.T v q -> @@ -99,7 +99,7 @@ {-# INLINE runState #-} -runState :: (Trans.C q, RealField.C q, Dim.C u, Dim.C v) => +runState :: (Trans.C q, RealRing.C q, Dim.C u, Dim.C v) => Sequence s u v Sig.T q -> Proc.T s u q (SigA.R s v q q) runState = run zero @@ -107,7 +107,7 @@ {-# INLINE runStateVolume #-} runStateVolume :: - (Trans.C q, RealField.C q, Dim.C u, Dim.C v) => + (Trans.C q, RealRing.C q, Dim.C u, Dim.C v) => Sequence s u v Sig.T q -> DN.T v q -> Proc.T s u q (SigA.R s v q q) diff --git a/src/Synthesizer/Dimensional/RateAmplitude/Play.hs b/src/Synthesizer/Dimensional/RateAmplitude/Play.hs --- a/src/Synthesizer/Dimensional/RateAmplitude/Play.hs +++ b/src/Synthesizer/Dimensional/RateAmplitude/Play.hs @@ -36,17 +36,19 @@ import qualified Algebra.Module as Module import qualified Algebra.RealField as RealField import qualified Algebra.Field as Field +import qualified Algebra.RealRing as RealRing -- import qualified Algebra.Ring as Ring import System.Exit(ExitCode) -import NumericPrelude -import PreludeBase +import NumericPrelude.Numeric +import NumericPrelude.Base type Signal u t v y yv = SigA.T (Rate.Dimensional u t) (Amp.Dimensional v y) (Sig.T yv) + {-# INLINE auto #-} auto :: (Bounded int, ToInteger.C int, Storable int, Frame.C int, @@ -66,7 +68,7 @@ DN.divToScalar (SigA.actualSampleRate sig) freqUnit in Play.extended SigSt.hPut opts SoxOpt.none (round sampleRate) - (Builder.toLazyStorableVector SigSt.defaultChunkSize $ + (Builder.toLazyStorableVector SigA.defaultChunkSize $ Sig.monoidConcatMap (BinSmp.outputFromCanonical put) $ SigA.vectorSamples (flip DN.divToScalar amp) sig) diff --git a/src/Synthesizer/Dimensional/RateAmplitude/Rain.hs b/src/Synthesizer/Dimensional/RateAmplitude/Rain.hs --- a/src/Synthesizer/Dimensional/RateAmplitude/Rain.hs +++ b/src/Synthesizer/Dimensional/RateAmplitude/Rain.hs @@ -20,8 +20,10 @@ import qualified Synthesizer.Dimensional.Wave.Controlled as WaveCtrl import qualified Synthesizer.Dimensional.Wave as WaveD +import qualified Synthesizer.Dimensional.Arrow as ArrowD import Synthesizer.Dimensional.Wave ((&*~), ) +import Control.Arrow ((<<<), first, ) import qualified Synthesizer.Dimensional.Process as Proc import qualified Synthesizer.Dimensional.Signal as SigA @@ -35,8 +37,10 @@ import Synthesizer.Dimensional.RateAmplitude.Piece ((|#), (#|), (-|#), (#|-), ) -import qualified Synthesizer.Dimensional.Rate as Rate +import qualified Synthesizer.Dimensional.Amplitude.Flat as Flat import qualified Synthesizer.Dimensional.Amplitude as Amp +import qualified Synthesizer.Dimensional.Sample as Sample +import qualified Synthesizer.Dimensional.Rate as Rate import qualified Synthesizer.Frame.Stereo as Stereo @@ -80,8 +84,8 @@ import System.Random (randoms, randomRs, mkStdGen, ) -import PreludeBase -import NumericPrelude +import NumericPrelude.Base +import NumericPrelude.Numeric type PitchClass = Int @@ -97,10 +101,10 @@ a = 9 h = 11 -chords, chords0, chords1, chords2 :: [([PitchClass],Int)] +chords, _chords0, chords1, _chords2 :: [([PitchClass],Int)] chords = chords1 -chords0 = +_chords0 = ([c,e,g], 4) : ([c,e,a], 1) : ([d,g,h], 1) : @@ -116,7 +120,7 @@ ([c,e,g], 1) : [] -chords2 = +_chords2 = ([c,e,g], 1) : ([c,e,a], 1) : ([c,e,g], 1) : @@ -202,22 +206,22 @@ Piece.halfSine Piece.FlatLeft) #| DN.scalar 0.01 -stringDistortion :: +_stringDistortion :: DN.Time Double -> DN.Voltage Double -> DN.Frequency Double -> Phase.T Double -> Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double Double) -stringDistortion duration volume freq phase = +_stringDistortion duration volume freq phase = Disp.distort sin $: (volume &*^ stringEnvelope duration) $: Osci.static (volume &*~ Wave.saw) phase freq {-# INLINE stringMorph #-} -{-# INLINE stringMorph2 #-} -{-# INLINE stringMorph3 #-} -{-# INLINE stringMorph4 #-} -stringMorph, stringMorph2, stringMorph3, stringMorph4 :: +{-# INLINE _stringMorph2 #-} +{-# INLINE _stringMorph3 #-} +{-# INLINE _stringMorph4 #-} +stringMorph, _stringMorph2, _stringMorph3, _stringMorph4 :: DN.Time Double -> DN.Voltage Double -> DN.Frequency Double -> @@ -225,32 +229,42 @@ Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double Double) stringMorph duration volume freq phase = Osci.shapeMod - (WaveCtrl.amplified volume + (makeWave volume (\r -> Wave.distort (sin . ((pi/2*r)*)) Wave.saw)) phase freq $: Ctrl.line (stringAttack + duration) (DN.scalar 1, DN.scalar 7) -stringMorph2 duration volume freq phase = +_stringMorph2 duration volume freq phase = Osci.shapeMod - (WaveCtrl.amplified volume Wave.truncCosine) + (makeWave volume Wave.truncCosine) phase freq $: Ctrl.line (stringAttack + duration) (DN.scalar 1, DN.scalar 7) -stringMorph3 duration volume freq phase = +_stringMorph3 duration volume freq phase = Osci.shapeMod - (WaveCtrl.amplified volume (Wave.powerNormed . (^2))) + (makeWave volume (Wave.powerNormed . (^2))) phase freq $: Ctrl.line (stringAttack + duration) (DN.scalar 0.1, DN.scalar 2) -stringMorph4 duration volume freq phase = +_stringMorph4 duration volume freq phase = Osci.shapeMod - (WaveCtrl.amplified volume (Wave.trapezoidSkew . (^2))) + (makeWave volume (Wave.trapezoidSkew . (^2))) phase freq $: Ctrl.line (stringAttack + duration) (DN.scalar 0, DN.scalar 1) + +makeWave :: (Ring.C y, Dim.C u, Flat.C c flat) => + DN.T u y -> + (c -> Wave.T t y) -> + WaveCtrl.T + (Sample.T flat c) t + (Sample.Dimensional u y y) +makeWave volume wave = + WaveCtrl.amplified volume wave <<< + first ArrowD.canonicalizeFlat {-# INLINE strings #-} strings :: diff --git a/src/Synthesizer/Dimensional/RateAmplitude/Traumzauberbaum.hs b/src/Synthesizer/Dimensional/RateAmplitude/Traumzauberbaum.hs --- a/src/Synthesizer/Dimensional/RateAmplitude/Traumzauberbaum.hs +++ b/src/Synthesizer/Dimensional/RateAmplitude/Traumzauberbaum.hs @@ -25,11 +25,14 @@ import qualified Synthesizer.Dimensional.RateAmplitude.File as File import qualified Synthesizer.Dimensional.RateAmplitude.Play as Play +import qualified Data.StorableVector.Lazy.Builder as Bld +import Data.Int (Int16, ) + import Synthesizer.Dimensional.Signal (($-), ) import Synthesizer.Dimensional.Process (($:), ($::), ($^), ) import Synthesizer.Dimensional.Amplitude.Displacement (mapExponential, ) -import qualified Synthesizer.Dimensional.Amplitude as Amp +import qualified Synthesizer.Dimensional.Sample as Sample import qualified Synthesizer.Frame.Stereo as Stereo @@ -51,8 +54,8 @@ -- import System.Random (Random, randomRs, mkStdGen) -import PreludeBase -import NumericPrelude +import NumericPrelude.Base +import NumericPrelude.Numeric type PitchClass = Int @@ -173,16 +176,16 @@ {-# INLINE smoothSaw #-} smoothSaw :: Double -> - WaveD.T (Amp.Dimensional Dim.Voltage Double) Double Double -smoothSaw a = - DN.voltage 1 &*~ Wave.triangleAsymmetric a + WaveD.T Double (Sample.Dimensional Dim.Voltage Double Double) +smoothSaw p = + DN.voltage 1 &*~ Wave.triangleAsymmetric p {-# INLINE smoothSquare #-} smoothSquare :: Double -> - WaveD.T (Amp.Dimensional Dim.Voltage Double) Double Double -smoothSquare a = - DN.voltage 1 &*~ Wave.trapezoid a + WaveD.T Double (Sample.Dimensional Dim.Voltage Double Double) +smoothSquare p = + DN.voltage 1 &*~ Wave.trapezoid p {-# INLINE timeUnit #-} @@ -200,10 +203,10 @@ $: Ctrl.constant (DN.scalar (assemblePitch p))) melody) -{-# INLINE simpleMusic #-} -simpleMusic :: +{-# INLINE _simpleMusic #-} +_simpleMusic :: Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double Double) -simpleMusic = +_simpleMusic = Osci.freqMod (smoothSquare 0.9) zero $: (mapExponential 2 (DN.frequency 440) $^ pitchControl) @@ -239,10 +242,10 @@ $: (mapExponential 2 (DN.frequency 440) $^ filteredPitchControl)) -{-# INLINE filteredMusic #-} -filteredMusic :: +{-# INLINE _filteredMusic #-} +_filteredMusic :: Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double Double) -filteredMusic = +_filteredMusic = Filt.lowpassFromUniversal $^ (Filt.universal $- DN.scalar 10 @@ -251,11 +254,11 @@ $: (mapExponential 2 (DN.frequency 440) $^ pitchControl))) -{-# INLINE makeChordPhaser #-} -makeChordPhaser :: +{-# INLINE _makeChordPhaser #-} +_makeChordPhaser :: Chord -> Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double (Stereo.T Double)) -makeChordPhaser chord = +_makeChordPhaser chord = Disp.mixMulti $:: (map (\p -> Cut.mergeStereo @@ -334,10 +337,10 @@ $: Ctrl.constant (DN.scalar (assemblePitch p))) bass) -} -{-# INLINE bassPhaserSignal #-} -bassPhaserSignal :: +{-# INLINE _bassPhaserSignal #-} +_bassPhaserSignal :: Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double (Stereo.T Double)) -bassPhaserSignal = +_bassPhaserSignal = Cut.mergeStereo $: (Osci.freqMod (smoothSaw 0.8) zero $: (mapExponential 2 (DN.frequency 54.7) $^ bassControl)) @@ -436,7 +439,22 @@ [] +_playBuilder :: IO () +_playBuilder = + Play.renderTimeVoltage + (Bld.put :: Int16 -> Bld.Builder Int16) + (DN.frequency (44100::Double)) + songSignal + >> return () +_render :: IO () +_render = + File.renderTimeVoltageStereoDoubleToInt16 + (DN.frequency (44100::Double)) + "traumzauberbaum.aiff" + songSignal + >> return () + main :: IO () main = Play.renderTimeVoltageStereoDoubleToInt16 @@ -446,13 +464,6 @@ -- accompaniment -- bassSignal >> return () -{- - File.renderTimeVoltageStereoDoubleToInt16 - (DN.frequency (44100::Double)) - "traumzauberbaum.aiff" - songSignal - >> return () --} {- import installed synthesizer package diff --git a/src/Synthesizer/Dimensional/Sample.hs b/src/Synthesizer/Dimensional/Sample.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Dimensional/Sample.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE TypeFamilies #-} +module Synthesizer.Dimensional.Sample where + +import qualified Synthesizer.Dimensional.Amplitude as Amp + +{- | +The constructor is only needed for 'arr', +which is a kind of a hack. +-} +data T amp yv = Cons amp yv + +cons :: Amp.C amp => amp -> yv -> T amp yv +cons = Cons + +type Dimensional v y yv = T (Amp.Dimensional v y) yv +type Numeric amp yv = T (Amp.Numeric amp) yv +type Flat y = T (Amp.Flat y) y +type Abstract y = T Amp.Abstract y + + +{- | +When you define additional instances, +take care that displacements and amplitudes cannot be brought out of order! +-} +type family Amplitude sample +type instance Amplitude (T amp yv) = amp +type instance Amplitude (sample0, sample1) = + (Amplitude sample0, Amplitude sample1) +type instance Amplitude (sample0, sample1, sample2) = + (Amplitude sample0, Amplitude sample1, Amplitude sample2) + +type family Displacement sample +type instance Displacement (T amp yv) = yv +type instance Displacement (sample0, sample1) = + (Displacement sample0, Displacement sample1) +type instance Displacement (sample0, sample1, sample2) = + (Displacement sample0, Displacement sample1, Displacement sample2) + + +class Build sample where + build :: Amplitude sample -> Displacement sample -> sample + +instance Build (T amp yv) where + {-# INLINE build #-} + build = Cons + +instance + (Build sample0, Build sample1) => + Build (sample0, sample1) where + {-# INLINE build #-} + build (amp0,amp1) (yv0,yv1) = + (build amp0 yv0, build amp1 yv1) + +instance + (Build sample0, Build sample1, Build sample2) => + Build (sample0, sample1, sample2) where + {-# INLINE build #-} + build (amp0,amp1,amp2) (yv0,yv1,yv2) = + (build amp0 yv0, build amp1 yv1, build amp2 yv2) + + +class Inspect sample where + {- method names are chosen analogously to the type functions -} + amplitude :: sample -> Amplitude sample + displacement :: sample -> Displacement sample + +instance Inspect (T amp yv) where + {-# INLINE amplitude #-} + {-# INLINE displacement #-} + amplitude (Cons amp _) = amp + displacement (Cons _ yv) = yv + +instance + (Inspect sample0, Inspect sample1) => + Inspect (sample0, sample1) where + {-# INLINE amplitude #-} + {-# INLINE displacement #-} + amplitude (sample0, sample1) = + (amplitude sample0, amplitude sample1) + displacement (sample0, sample1) = + (displacement sample0, displacement sample1) + +instance + (Inspect sample0, Inspect sample1, Inspect sample2) => + Inspect (sample0, sample1, sample2) where + {-# INLINE amplitude #-} + {-# INLINE displacement #-} + amplitude (sample0, sample1, sample2) = + (amplitude sample0, amplitude sample1, amplitude sample2) + displacement (sample0, sample1, sample2) = + (displacement sample0, displacement sample1, displacement sample2) diff --git a/src/Synthesizer/Dimensional/Signal.hs b/src/Synthesizer/Dimensional/Signal.hs --- a/src/Synthesizer/Dimensional/Signal.hs +++ b/src/Synthesizer/Dimensional/Signal.hs @@ -31,9 +31,9 @@ -- import Number.DimensionTerm ((&/&)) -- import qualified Algebra.Module as Module --- import qualified Algebra.RealField as RealField +-- import qualified Algebra.RealRing as RealRing import qualified Algebra.Field as Field -import qualified Algebra.Real as Real +import qualified Algebra.Absolute as Absolute -- import qualified Algebra.Ring as Ring import Control.Applicative (Applicative, ) @@ -48,7 +48,7 @@ Only possible for non-negative values so far. -} {-# INLINE ($-) #-} -($-) :: (Field.C y, Real.C y, Dim.C u, Dim.C v) => +($-) :: (Field.C y, Absolute.C y, Dim.C u, Dim.C v) => Proc.T s u t (R s v y y -> a) -> DN.T v y -> Proc.T s u t a ($-) f x = f $: Proc.pure (CtrlV.constant x) diff --git a/src/Synthesizer/Dimensional/Signal/Private.hs b/src/Synthesizer/Dimensional/Signal/Private.hs --- a/src/Synthesizer/Dimensional/Signal/Private.hs +++ b/src/Synthesizer/Dimensional/Signal/Private.hs @@ -23,7 +23,7 @@ import qualified Synthesizer.State.Signal as Sig import qualified Algebra.Module as Module -import qualified Algebra.RealField as RealField +import qualified Algebra.RealRing as RealRing import qualified Algebra.Field as Field import qualified Algebra.Ring as Ring @@ -31,8 +31,8 @@ import qualified Algebra.DimensionTerm as Dim --- import NumericPrelude -import PreludeBase as P +-- import NumericPrelude.Numeric +import NumericPrelude.Base as P import Prelude () @@ -188,7 +188,7 @@ T rate amp (Sig.T yv) cache = processBody - (Sig.fromStorableSignal . Sig.toStorableSignal SigSt.defaultChunkSize) + (Sig.fromStorableSignal . Sig.toStorableSignal defaultChunkSize) {-# INLINE bindCached #-} bindCached :: @@ -211,7 +211,7 @@ {-# INLINE store #-} store :: - (RealField.C t, Dim.C u, Storable yv) => + (RealRing.C t, Dim.C u, Storable yv) => DN.T u t -> Proc.T s u t ( {- @@ -230,7 +230,7 @@ we do not need Proc context {-# INLINE storeTake #-} storeTake :: - (RealField.C t, Dim.C u, Storable yv) => + (RealRing.C t, Dim.C u, Storable yv) => Proc.T s u t ( T (Rate.Phantom s) Amp.Abstract SVP.LazySize -> T (Rate.Phantom s) amp (Sig.T yv) -> @@ -262,20 +262,26 @@ {-# INLINE toStorableInt16Mono #-} toStorableInt16Mono :: - (RealField.C a) => + (RealRing.C a) => T rate (Amp.Dimensional Dim.Voltage a) (Sig.T a) -> SigSt.T Int16 toStorableInt16Mono = - Sig.toStorableSignal SigSt.defaultChunkSize . + Sig.toStorableSignal defaultChunkSize . Sig.map BinSmp.int16FromCanonical . scalarSamples (DN.toNumberWithDimension Dim.voltage) {-# INLINE toStorableInt16Stereo #-} toStorableInt16Stereo :: - (Module.C a a, RealField.C a) => + (Module.C a a, RealRing.C a) => T rate (Amp.Dimensional Dim.Voltage a) (Sig.T (Stereo.T a)) -> SigSt.T (Stereo.T Int16) toStorableInt16Stereo = - Sig.toStorableSignal SigSt.defaultChunkSize . + Sig.toStorableSignal defaultChunkSize . Sig.map (Stereo.map BinSmp.int16FromCanonical) . vectorSamples (DN.toNumberWithDimension Dim.voltage) + + +defaultChunkSize :: SigSt.ChunkSize +defaultChunkSize = +-- SigSt.chunkSize 131072 + SigSt.defaultChunkSize diff --git a/src/Synthesizer/Dimensional/Wave.hs b/src/Synthesizer/Dimensional/Wave.hs --- a/src/Synthesizer/Dimensional/Wave.hs +++ b/src/Synthesizer/Dimensional/Wave.hs @@ -1,5 +1,9 @@ module Synthesizer.Dimensional.Wave where +import qualified Synthesizer.Dimensional.Sample as Sample +import qualified Synthesizer.Dimensional.Map as MapD + +import qualified Synthesizer.Basic.Phase as Phase import qualified Synthesizer.Basic.Wave as Wave import qualified Synthesizer.Generic.Wave as WaveG import qualified Synthesizer.Generic.Signal as SigG @@ -10,82 +14,89 @@ import qualified Synthesizer.Dimensional.Amplitude as Amp import qualified Algebra.Transcendental as Trans -import qualified Algebra.RealField as RealField +import qualified Algebra.RealRing as RealRing import qualified Algebra.Ring as Ring import qualified Number.DimensionTerm as DN import qualified Algebra.DimensionTerm as Dim -import NumericPrelude -import PreludeBase +import NumericPrelude.Numeric +import NumericPrelude.Base import Prelude () -data T amp t y = - Cons { - amplitude :: amp, - body :: Wave.T t y - } +type SamplePhase t = Sample.Abstract (Phase.T t) -{- -data T amp body = - Cons { - amplitude :: amp, - body :: body - } +{- | +We define a dimensional waveform in terms of a Map. +This allows any kind and number of result samples +and distortion of waveforms using @(distortion <<<)@ -} +type T t y = MapD.T (SamplePhase t) y +{-# INLINE simple #-} +simple :: + amp -> + Wave.T t y -> + T t (Sample.T amp y) +simple amp wave = + MapD.independent + (const $ amp) + (Wave.apply wave) + + infix 7 &*~ {-# INLINE (&*~) #-} (&*~) :: amp -> Wave.T t y -> - T (Amp.Numeric amp) t y + T t (Sample.Numeric amp y) (&*~) = amplified {-# INLINE sample #-} sample :: - (RealField.C t, SigG.Transform sig y) => + (RealRing.C t, SigG.Transform sig y) => Interpolation.T t y -> - SigA.T rate amp (sig y) -> T amp t y + SigA.T rate amp (sig y) -> + T t (Sample.T amp y) sample ip wave = - Cons (SigA.amplitude wave) $ + simple (SigA.amplitude wave) $ WaveG.sample ip (SigA.body wave) {-# INLINE flat #-} flat :: (Ring.C y) => Wave.T t y -> - T (Amp.Flat y) t y -flat = Cons Amp.Flat + T t (Sample.Flat y) +flat = simple Amp.Flat {-# INLINE abstract #-} abstract :: Wave.T t y -> - T Amp.Abstract t y -abstract = Cons Amp.Abstract + T t (Sample.Abstract y) +abstract = simple Amp.Abstract {-# INLINE amplified #-} amplified :: amp -> Wave.T t y -> - T (Amp.Numeric amp) t y + T t (Sample.Numeric amp y) {- (Ring.C y, Dim.C u) => DN.T u y -> Wave.T t y -> - T (Amp.Dimensional u y) t y + T t (Sample.Dimensional u y y) -} {- amp -> Wave.T t y -> T amp t y -} -amplified = Cons . Amp.Numeric +amplified = simple . Amp.Numeric {-# INLINE mapLinear #-} @@ -93,7 +104,7 @@ y -> DN.T u y -> Wave.T t y -> - T (Amp.Dimensional u y) t y + T t (Sample.Dimensional u y y) mapLinear depth center = amplified center . Wave.distort (\x -> one+x*depth) @@ -102,7 +113,7 @@ y -> DN.T u y -> Wave.T t y -> - T (Amp.Dimensional u y) t y + T t (Sample.Dimensional u y y) mapExponential depth center = -- amplified center . Wave.distort (depth**) -- should be faster diff --git a/src/Synthesizer/Dimensional/Wave/Controlled.hs b/src/Synthesizer/Dimensional/Wave/Controlled.hs --- a/src/Synthesizer/Dimensional/Wave/Controlled.hs +++ b/src/Synthesizer/Dimensional/Wave/Controlled.hs @@ -1,13 +1,6 @@ -{- | +{- ToDo: -How to handle dimensional values as control parameters? -How to combine control parameters with antialiasing waveforms? - -Actually, a waveform is like a Map where one parameter is of type Phase.T. -A waveform with dimensional control parameter -should be treated like a dimensional Map. -If we do not use the Map type for waveforms -we must at least provide a function for applying a Map to a Wave. +Antialiasing waveforms and oscillators I think the oscillators should always provide the frequency to the apply method of a wave. @@ -19,6 +12,11 @@ -} module Synthesizer.Dimensional.Wave.Controlled where +import Synthesizer.Dimensional.Wave (SamplePhase, ) + +import qualified Synthesizer.Dimensional.Sample as Sample +import qualified Synthesizer.Dimensional.Map as MapD + import qualified Synthesizer.Basic.Wave as Wave import qualified Synthesizer.Generic.Wave as WaveG import qualified Synthesizer.Generic.Signal as SigG @@ -36,83 +34,96 @@ import qualified Number.DimensionTerm as DN import qualified Algebra.DimensionTerm as Dim -import NumericPrelude -import PreludeBase +import NumericPrelude.Numeric +import NumericPrelude.Base import Prelude () -data T amp c t y = - Cons { - amplitude :: amp, - body :: c -> Wave.T t y - } - -{- -data T amp body = - Cons { - amplitude :: amp, - body :: body - } --} - {- | -Interpolate first within waves and then across waves, -which is simpler but maybe less efficient for lists. -However for types with fast indexing/drop like StorableVector this is optimal. +We define a dimensional parametrized waveform in terms of a Map. +This allows any kind and number of control parameters +and distortion of waveforms using @(distortion <<<)@ -} -sampledTone :: - (RealField.C t, SigG.Transform sig y, Dim.C u) => - Interpolation.T t y -> - Interpolation.T t y -> - DN.T u t -> SigA.T (Rate.Dimensional u t) amp (sig y) -> T amp t t y -sampledTone ipLeap ipStep period tone = - Cons (SigA.amplitude tone) $ - WaveG.sampledTone ipLeap ipStep - (DN.mulToScalar period (SigA.actualSampleRate tone)) - (SigA.body tone) +type T c t y = MapD.T (c, SamplePhase t) y +{-# INLINE simple #-} +simple :: + (Amp.Primitive cAmp) => + amp -> + (c -> Wave.T t y) -> + T (Sample.T cAmp c) t (Sample.T amp y) +simple amp wave = + MapD.independent + (const $ amp) + (\(c,p) -> Wave.apply (wave c) p) {-# INLINE flat #-} -flat :: (Ring.C y) => +flat :: + (Ring.C y, Amp.Primitive cAmp) => (c -> Wave.T t y) -> - T (Amp.Flat y) c t y -flat = Cons Amp.Flat + T (Sample.T cAmp c) t (Sample.Flat y) +flat = simple Amp.Flat {-# INLINE abstract #-} abstract :: + (Amp.Primitive cAmp) => (c -> Wave.T t y) -> - T Amp.Abstract c t y -abstract = Cons Amp.Abstract + T (Sample.T cAmp c) t (Sample.Abstract y) +abstract = simple Amp.Abstract {-# INLINE amplified #-} -amplified :: (Ring.C y, Dim.C u) => +amplified :: + (Ring.C y, Dim.C u, Amp.Primitive cAmp) => DN.T u y -> (c -> Wave.T t y) -> - T (Amp.Dimensional u y) c t y -amplified = Cons . Amp.Numeric + T (Sample.T cAmp c) t (Sample.Dimensional u y y) +amplified = simple . Amp.Numeric {-# INLINE mapLinear #-} -mapLinear :: (Ring.C y, Dim.C u) => +mapLinear :: + (Ring.C y, Dim.C u, Amp.Primitive cAmp) => y -> DN.T u y -> (c -> Wave.T t y) -> - T (Amp.Dimensional u y) c t y + T (Sample.T cAmp c) t (Sample.Dimensional u y y) mapLinear depth center = amplified center . (Wave.distort (\x -> one+x*depth) .) {-# INLINE mapExponential #-} -mapExponential :: (Trans.C y, Dim.C u) => +mapExponential :: + (Trans.C y, Dim.C u, Amp.Primitive cAmp) => y -> DN.T u y -> (c -> Wave.T t y) -> - T (Amp.Dimensional u y) c t y + T (Sample.T cAmp c) t (Sample.Dimensional u y y) mapExponential depth center = -- amplified center . Wave.distort (depth**) -- should be faster amplified center . let logDepth = log depth in (Wave.distort (exp . (logDepth*)) .) + + + +{- | +Interpolate first within waves and then across waves, +which is simpler but maybe less efficient for lists. +However for types with fast indexing/drop like StorableVector this is optimal. +-} +sampledTone :: + (RealField.C t, SigG.Transform sig y, Dim.C u) => + Interpolation.T t y -> + Interpolation.T t y -> + DN.T u t -> + SigA.T (Rate.Dimensional u t) amp (sig y) -> + T (Sample.Flat t) t (Sample.T amp y) +sampledTone ipLeap ipStep period tone = + simple + (SigA.amplitude tone) + (WaveG.sampledTone ipLeap ipStep + (DN.mulToScalar period (SigA.actualSampleRate tone)) + (SigA.body tone)) diff --git a/synthesizer-dimensional.cabal b/synthesizer-dimensional.cabal --- a/synthesizer-dimensional.cabal +++ b/synthesizer-dimensional.cabal @@ -1,5 +1,5 @@ Name: synthesizer-dimensional -Version: 0.4 +Version: 0.5 License: GPL License-File: LICENSE Author: Henning Thielemann @@ -11,7 +11,7 @@ High-level functions that use physical units and abstract from the sample rate in statically type safe way. Stability: Experimental -Tested-With: GHC==6.10.4 +Tested-With: GHC==6.10.4, GHC==6.12.1 Cabal-Version: >=1.6 Build-Type: Simple @@ -28,7 +28,7 @@ Source-Repository this - Tag: 0.4 + Tag: 0.5 Type: darcs Location: http://code.haskell.org/synthesizer/dimensional/ @@ -38,14 +38,14 @@ Library Build-Depends: - synthesizer-core >=0.3 && <0.4, - transformers >=0.0.1 && <0.2, - event-list >=0.0.10 && <0.1, - non-negative >=0.0.5 && <0.1, - numeric-prelude >=0.1.1 && <0.2, + synthesizer-core >=0.4 && <0.5, + transformers >=0.2 && <0.3, + event-list >=0.1 && <0.2, + non-negative >=0.1 && <0.2, + numeric-prelude >=0.2 && <0.3, utility-ht >=0.0.5 && <0.1, storable-record >=0.0.1 && <0.1, - sox >=0.1 && <0.2, + sox >=0.2 && <0.3, storablevector >=0.2.3 && <0.3, binary >=0.1 && <1, bytestring >= 0.9 && <0.10 @@ -61,9 +61,11 @@ Exposed-modules: Synthesizer.Dimensional.Signal Synthesizer.Dimensional.Amplitude + Synthesizer.Dimensional.Sample Synthesizer.Dimensional.Rate Synthesizer.Dimensional.Arrow Synthesizer.Dimensional.Map + Synthesizer.Dimensional.Map.Displacement Synthesizer.Dimensional.Map.Filter Synthesizer.Dimensional.Process Synthesizer.Dimensional.Causal.Process @@ -78,6 +80,7 @@ Synthesizer.Dimensional.Causal.Displacement Synthesizer.Dimensional.Causal.Filter Synthesizer.Dimensional.Causal.Oscillator + Synthesizer.Dimensional.Causal.Oscillator.Core -- Synthesizer.Dimensional.ControlledProcess Synthesizer.Dimensional.Rate.Analysis Synthesizer.Dimensional.Rate.Control