packages feed

synthesizer 0.0.3 → 0.2

raw patch · 216 files changed

+13458/−7073 lines, 216 filesdep +filepathdep +gnuplotdep +soxdep −mtldep −unixdep ~arraydep ~basedep ~containers

Dependencies added: filepath, gnuplot, sox, storable-record, transformers, utility-ht

Dependencies removed: mtl, unix

Dependency ranges changed: array, base, containers, event-list, non-negative, numeric-prelude, numeric-quest, random, special-functors, storablevector

Files

Makefile view
@@ -65,8 +65,7 @@  #MODULES = Synthesizer Instruments SignalIO Signal Test Filter/Test -MODULE_PATH = src  # the other modules are now present by (Cabal) packages-# MODULE_PATH = src:..:../numericprelude/src:../linearalgebra:../math:../shell-haskell:../haskore/src:../haskore/src/GHC+MODULE_PATH = src:src-3  # the other modules are now present by (Cabal) packages   HC      = ghc   # ghc-6.2.2@@ -116,6 +115,9 @@  ghci-custom: 	$(HCINT) $(GHC_OPTIONS) -i:$(MODULE_PATH)++tutorial:+	$(HCINT) -Wall -fobject-code -fexcess-precision -O2 -fvia-C -optc-O2 -odirdist/build -hidirdist/build -hide-package synthesizer -i:$(MODULE_PATH) src/Synthesizer/Generic/Tutorial.hs  %.o:	%.hs 	$(HC) -i:$(MODULE_PATH) -O --make $<
− doc/Prologue.txt 
@@ -1,272 +0,0 @@--This is a collection of modules for synthesizing and processing audio signals.-It allows generation of effects, instruments and-even music using the Haskore package.-It can write raw audio data to files,-convert them to common audio formats or-play them using external commands from the Sox package.--A signal is modeled by a list of values.-E.g. @[Double]@ represents a mono signal,-@[(Double, Double)]@ stores a stereo signal.-Since a list is lazy, it can be infinitely long,-and it also supports feedback.-(The drawback is, that its implementation is very slow.-I'm working on that issue.)-We are using the NumericPrelude type class hierarchy-which is cleaner than the one of Haskell 98-and provides us with type classes for vector spaces.-This allows us to formulate many algorithms for mono, stereo and multi-channel signals at once.-The drawback is that the vector space type class has multiple type parameters.-This type extension is availabe in GHC and Hugs and maybe other compilers.-It may hurt you, because type inference fails sometimes,-resulting in strange type errors.-(To be precise: GHC suggests type constraints intended for fixing the problem,-but if you copy them to your program, they won't fix the problem,-because the constraint refers to local variables-that you have no access to at the signature.-In this case you have to use 'asTypeOf' or similar self-written helpers.)--There must also be information about how fast sample values are emitted.-This is specified by the sample rate.-44100 Hz means that 44100 sample values are emitted per second.-This information must be stored along with the sample values.-This is where things become complicated.--In the very basic modules in the "Synthesizer.Plain" directory,-there is no notion of sample rate.-You have to base all computations on the number of samples.-This is unintuitive and disallows easy adaption to different audio devices-(CD, DAT, ...).-But it is very simple and can be re-used in the higher level modules.--Let's continue with the sample rate issue.-Sounds of different sources may differ in their sampling rate-(and also with respect to its amplitude and the unit of the values).-Sampled sounds have 44100 Hz on a compact disk,-48000 Hz or 32000 Hz on DAT recorders.-We want to respect different sampling rates and volumes,-we want to let signals in different formats coexist nicely,-and we want to let the user choose when to do which conversion-(called /resampling/)-in order to bring them together.--In fact this view generalises the concept of note, control, and audio rates,-which is found in some software synthesizers,-like CSound and SuperCollider.-If signals of different rate are fed to a signal processor-in such a software synthesizer,-all signals are converted to the highest rate among the inputs.-Then the processor runs at this rate.-The conversion is usually done by \"constant\" interpolation,-in order to minimize recomputation of internal parameters.-However the handling of different signal rates must be built into every processor,-and may even reduce the computation speed.-Consider an exponential envelope which is computed at control rate-and an amplifier which applies this envelope to an audio signal.-The amplifier has to upsample the exponential envelope before applying it to the signal.-But the generation of the exponential is very simple,-one multiplication per sample,-and the amplifier is very simple, too,-again only one multiplication per sample.-So, is there a need for trouble of the resampling?-Does it really accelerates computation?-Many other envelope generators like straight lines, sines, oscillators,-are comparably simple.-However there are some processors like filters,-which need some recomputation when a control parameter changes.--Our approach is this one:-We try to avoid resampling and compute all signals at the same rate,-if no speed loss must be expected.-If a speed loss is to be expected,-we can interpolate the internal parameters of the processor explicitly.-This way we can also specify an interpolation method.-Alternatively we can move the interpolation into the processor-but let the user specify an interpolation method.-(Currently it can be used only manually for the low-level routines in "Synthesizer.Plain"-and there is no support for that mechanism in the high level variants.)--Additional to the treatment of sampling rates,-we also want to separate amplitude information from the signal.-The separated amplitude serves two purposes:--(1) The amplitude can be equipped with a physical unit,-    whereas this information is omitted for the samples.-    Since I can hardly imagine that it is sensible to mix samples-    with different physical units,-    it would be only wasted time to always check-    if all physical values of a sequence have the same unit.--(2) The amplitude can be a floating point number,-    but the samples can be fixed point numbers.-    This is interesting for hardware digital signal processors-    or other low-level applications.-    With this method we can separate the overall dynamics from the samples.---Let's elaborate on the physical units now.-With them we can work with values from the real world immediately-and we have additional (dynamic) safety by unit checks.--Of course I prefer static safety.-E.g. I want to avoid-to accidentally call a function with conflicting parameters.-However, I see no way for both applying the unit checks statically-and let the user enter physical quantities.-Phantom types or unit vectors stored in a type do not seem to help here.-We have two solutions:--(1) Store units in a data structure and check them dynamically.-    This is imported from NumericPreludes's "Number.Physical".-    Units can be fetched from the user.-    The API of signal processing functions is generic enough-    to cover both values without units and values with units.-    Debugging of unit errors is cumbersome.--(2) Store physical dimensions in types-    either using Buckwalter's dimensional package-    or using NumericPreludes's "Number.DimensionTerm".-    Here we use the latter one.-    This is the most useful if user interaction is not needed.-    If data is fetched from an audio file-    the dimensions are statically fixed.--There are still several alternatives-of how to handle the sample rates-(that can be equipped with physical dimensions).--(1) Stick to simple lists as data and-    pass additional information directly to the functions.-    E.g. mixing several signals is easy-    since only one sampleRate is given-    which applies to all signals.-    But it leads to the problem-    that subsequent function calls must receive the same value.-    This cannot be guaranteed and is thus a source of error.-    E.g. the mistake-       @play (44100*hertz) (osciSine (22050*hertz) (440*hertz))@-    can't be detected.-    In this approach the signal data structure is very simple,-    the values may be passed to multiple functions,-    the combinations are simply done by function application,-    a supervisor is not necessary,-    consistency checks can hardly be performed.-    This approach is certainly the most basic one,-    on which others, more safer ones, can sit on top.-    It is implemented in "Synthesizer.Plain" with numbers without units.--(2) Equip signals with sample rate and amplitude.-    Processors without input need the sample rate as explicit parameter.-    If there is more than one signal as input,-    then there must be additional checks.-    The error in-    @-       mix (osciSine (22050*hertz) (440*hertz))-           (osciSine (44100*hertz) (330*hertz))-    @-    can be detected at runtime.-    However the sample rate has to be specified for both input signals,-    although it is obvious, that both signals have to share the sample rate.-    In this approach the data structure is more complex,-    the values may be passed to multiple functions-    but consistency checks can be performed-    and a supervisor is still not necessary.-    This strategy is implemented in the "Synthesizer.Physical" modules.--(3) We still like to hide the sample rate where possible.-    All processors should work as good as possible at each rate.-    Here we provide the sample rate to each processor.-    The result of a processor is not just a list of samples-    but it is a function, which computes the list of samples-    depending on the sample rate.-    Sample rate is fixed not until it comes to the rendering of a sound,-    e.g. for playing or writing of a file.-       @play (44100*hertz) (osciSine (440*hertz))@-    Returning a function instead of computed data-    has the disadvantage that multiply used data cannot be shared.-    For these situations we need a @share@ function.-    Combinator functions similar to @($)@ are used-    to plug sample rate dependent output from one processor-    into plain signal parameters.-    With this approach, the type signature tells-    which signals share the sample rate.-    Infinitely many signals can be handled.-    Types for time and volume can be chosen quite freely.-    Supervision is not necessary.-    This strategy is implemented in the "Synthesizer.Inference.Reader" modules,-    where we hide the sample rate in a 'Control.Monad.Reader.Reader'.-    There is also "Synthesizer.SampleRateContext"-    which exposes the sample rate.-    It is more convenient to implement and to call,-    but I think it is more unsafe,-    because you can mix sample rates from different sources accidentally.-    The same is available for numbers with dimension terms in types.-    See "Synthesizer.Dimensional".-    /In most cases this will be the method of choice!/-    Maybe I'm going to wrap this in a Reader monad\/applicative functor.-    It also requires that Haddock supports comments in parameters of type constructors.--(4) I have tried more sophisticated approaches-    in order to handle not only the sample rates but also the amplitudes.-    However I feel that I wanted more than I actually needed.-    I do no longer maintain these approaches but explain them for completeness.-    The most convenient solution for handling sample rates and amplitudes-    is certainly an inference system like Haskell's type system.-    If some input and output signals of a processor-    must have the same sampling rate,-    then the concrete rate must only be known for one of these signals.-    If no participating signal has a fixed rate, this is an error.-    The dependencies of sampling rates become very large by this system.-    The direction can be from inputs to outputs and vice versa,-    not to mention loops.-    This approach needs a lot of management,-    e.g. a supervisor which runs the network,-    but it is very convenient and safe.-    However, sometimes you have to fiddle with monads.-    Unfortunately it is restricted to finitely many monads-    and the types for time and volume are restricted.-    Thus this concept does not scale to physical units expressed in types.-    This strategy is implemented in the modules under "Synthesizer.Inference.Monad".--(5) We try to work-around the restrictions-    using a function based approach.-    Since the parameters are functions,-    sharing cannot take place.-    There is no way to spread sample rate from one consumer to another one.-    E.g. If there is-    @-       let y = f x;-           z = g x-    @-    and it is known that @f@ and @g@ maintain the sample rate,-    and the sample rate of @z@ is known - how to infer the sample rate of @y@?-    This approach was dropped quickly and-    exists for historical reasons in "Synthesizer.Inference.Func".--(6) There is a very cool approach,-    which implements the equation solver of the monadic approach-    by lazy evaluation and Peano numbers.-    This poses no restriction on types-    and works for infinitely many equations as well.-    The drawbacks are difficult application-    (you cannot simply apply a function to a signal,-    but you must compose functions in a special way),-    and slow solution of the equation system-    (quadratic time although in principle-    only run-time around linear time is necessary,-    it's similar to topological sort).-    However it's as slow as the explicit solver using monads in "Synthesizer.Inference.Monad".-    This strategy is tested in the modules under "InferenceFix".---An interface to the music composition library Haskore-can be found in "Haskore.Interface.Signal.Write".-Example songs based on this interface-are stored in the directory "Music".--The module "Presentation" in the @dafx@ package contains functions-for demonstrating synthesizer functions in GHCi-and "DAFx" contains some examples based on them.-Just hit @make dafx@ in a shell in order to compile the modules-and enter the interactive GHC with all modules loaded.
speedtest/FusionTest.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -O2 -fglasgow-exts #-}+{-# OPTIONS_GHC -O2 #-} module Main (main) where  import qualified Synthesizer.Storable.Signal as SigSt@@ -10,7 +10,6 @@ import qualified Synthesizer.State.Control as CtrlS import qualified Synthesizer.State.Filter.NonRecursive as FiltNRS import qualified Synthesizer.State.Cut as CutS-import qualified Synthesizer.State.Control as CtrlS import qualified Synthesizer.State.NoiseCustom as NoiseS import qualified Synthesizer.State.Interpolation as InterpolationS @@ -23,6 +22,7 @@ import qualified Synthesizer.Generic.Filter.Delay as DelayG import qualified Synthesizer.Generic.Interpolation as InterpolationG +import qualified Synthesizer.Interpolation.Module as InterpolationM import qualified Synthesizer.Basic.Wave       as Wave import qualified Synthesizer.Basic.Phase      as Phase import qualified Synthesizer.Basic.DistortionControlled as Dist@@ -33,9 +33,9 @@  import qualified Data.EventList.Relative.TimeBody as EventList -import BinarySample (numToInt16Packed, doubleToInt16Packed)-import Data.Int (Int8, Int16)-import Foreign.Storable (Storable)+import Synthesizer.Basic.Binary (int16FromCanonical, int16FromDouble, )+import Data.Int (Int8, Int16, )+import Foreign.Storable (Storable, ) import qualified Sound.Signal as Signal import qualified Data.List as List import qualified Data.Char as Char@@ -100,7 +100,7 @@ mapTest6 :: SigSt.T Int16 mapTest6 =    storableFromFusionList $ SigFL.take 200000 $-   SigFL.map numToInt16Packed $+   SigFL.map int16FromCanonical $ --   SigFL.map (^2) $    SigFL.repeat (3::Double) @@ -113,15 +113,15 @@ osciTest0 =    storableFromFusionList $    SigFL.take 200000 $-   -- numToInt16Packed is not only slow in execution but also blocks fusion - why?-   SigFL.map numToInt16Packed $+   -- int16FromCanonical is not only slow in execution but also blocks fusion - why?+   SigFL.map int16FromCanonical $    (OsciFL.staticSaw zeroPhase 0.01 :: SigFL.T Double)  osciTest0a :: SigSt.T Int16 osciTest0a =    storableFromFusionList $    SigFL.take 200000 $-   SigFL.map doubleToInt16Packed $+   SigFL.map int16FromDouble $    OsciFL.staticSaw zeroPhase 0.01  {-@@ -140,7 +140,7 @@ osciTest0b =    storableFromFusionList $    SigFL.take 200000 $-   SigFL.map doubleToInt16Packed $+   SigFL.map int16FromDouble $    FiltNRFL.envelope       (CtrlFL.exponential2 50000 1)       (OsciFL.staticSaw zeroPhase 0.01)@@ -149,14 +149,14 @@ osciTest0ba =    storableFromFusionList $    SigFL.take 200000 $-   SigFL.map doubleToInt16Packed $+   SigFL.map int16FromDouble $    CtrlFL.exponential2 50000 1  osciTest0c :: SigSt.T Int16 osciTest0c =    storableFromFusionList $    SigFL.take 200000 $-   SigFL.map doubleToInt16Packed $+   SigFL.map int16FromDouble $    FiltNRFL.envelope       (CtrlFL.exponential2 50000 0.5)       (OsciFL.shapeMod Wave.squareBalanced zeroPhase 0.01 $@@ -166,7 +166,7 @@ osciTest0d =    storableFromFusionList $    SigFL.take 200000 $-   SigFL.map doubleToInt16Packed $+   SigFL.map int16FromDouble $    FiltNRFL.envelope --      (exponential2 50000 0.5)       (CtrlFL.exponential2 50000 0.5)@@ -178,7 +178,7 @@ osciTest0e =    storableFromFusionList $    SigFL.take 200000 $-   SigFL.map doubleToInt16Packed $+   SigFL.map int16FromDouble $    FiltNRFL.envelope       (CtrlFL.exponential2 50000 0.5)       (OsciFL.shapeFreqMod Wave.squareBalanced zeroPhase@@ -189,7 +189,7 @@ osciTest0ea =    storableFromFusionList $    SigFL.take 200000 $-   SigFL.map doubleToInt16Packed $+   SigFL.map int16FromDouble $       (OsciFL.shapeFreqMod Wave.squareBalanced zeroPhase           (OsciFL.staticSine zeroPhase 0.00002)           (OsciFL.staticSine zeroPhase 0.0001))@@ -198,7 +198,7 @@ osciTest0f =    storableFromFusionList $    SigFL.take 200000 $-   SigFL.map doubleToInt16Packed $+   SigFL.map int16FromDouble $    FiltNRFL.envelope       (CtrlFL.exponential2 50000 1) --      (SigFL.zipWith (\x y -> (x+y)/2)@@ -214,7 +214,7 @@ osciTest0fa =    storableFromFusionList $    SigFL.take 200000 $-   SigFL.map doubleToInt16Packed $+   SigFL.map int16FromDouble $    FiltNRFL.envelope       (CtrlFL.exponential2 50000 1)       (SigFL.mix@@ -246,20 +246,20 @@ osciTest4 :: SigSt.T Int16 osciTest4 =    SigSt.take 200000 $-   SigSt.map numToInt16Packed $  -- this is now really fast thanks to specialisation+   SigSt.map int16FromCanonical $  -- this is now really fast thanks to specialisation    (SigSt.iterate defaultChunkSize (1+) 0 :: SigSt.T Double)  osciTest5 :: SigSt.T Int16 osciTest5 =    SigSt.take 200000 $-   SigSt.map doubleToInt16Packed $+   SigSt.map int16FromDouble $    (SigSt.iterate defaultChunkSize (1+) 0 :: SigSt.T Double)  osciTest6 :: SigSt.T Int16 osciTest6 =    -- takeCrochet is slow if not fused away    SigSt.takeCrochet 200000 $-   SigSt.map doubleToInt16Packed $+   SigSt.map int16FromDouble $    (SigSt.iterate defaultChunkSize (1+) 0 :: SigSt.T Double)  @@ -309,7 +309,7 @@ osciTest7 :: SigSt.T Int16 osciTest7 =    SigSt.take 200000 $-   SigSt.map doubleToInt16Packed $+   SigSt.map int16FromDouble $ --   SigSt.map (\x -> sin (2*pi*x)) $    SigSt.map (Wave.apply Wave.sine) $ --   SigSt.map (Wave.apply waveSine) $@@ -321,14 +321,14 @@ osciTest8 :: SigSt.T Int16 osciTest8 =    SigSt.take 200000 $-   SigSt.map doubleToInt16Packed $+   SigSt.map int16FromDouble $    (OsciSt.staticSaw defaultChunkSize zeroPhase 0.01 :: SigSt.T Double)   appendTest0 :: SigSt.T Int16 appendTest0 =    storableFromFusionList $-   SigFL.map doubleToInt16Packed $+   SigFL.map int16FromDouble $       let tone0 = SigFL.take 100000 $ OsciFL.static Wave.saw zeroPhase 0.010           tone1 = SigFL.take 100000 $ OsciFL.static Wave.saw zeroPhase 0.015       in  SigFL.append tone0 tone1@@ -338,12 +338,12 @@    let tone0 = SigFL.take 100000 $ OsciFL.static Wave.saw zeroPhase 0.010        tone1 = SigFL.take 100000 $ OsciFL.static Wave.saw zeroPhase 0.015    in  storableFromFusionList $-       SigFL.map doubleToInt16Packed $+       SigFL.map int16FromDouble $        SigFL.append tone0 tone1  appendTest2 :: SigSt.T Int16 appendTest2 =-   SigSt.map doubleToInt16Packed $+   SigSt.map int16FromDouble $    SigSt.appendFromFusionList defaultChunkSize       (SigFL.take 100000 $ OsciFL.static Wave.saw zeroPhase 0.010)       (SigFL.take 100000 $ OsciFL.static Wave.saw zeroPhase 0.015)@@ -351,21 +351,21 @@ appendTest3 :: SigSt.T Int16 appendTest3 =    storableFromFusionList $-   SigFL.map doubleToInt16Packed $+   SigFL.map int16FromDouble $    SigSt.appendFusionList defaultChunkSize       (SigFL.take 100001 $ OsciFL.static Wave.sine zeroPhase 0.010)       (SigFL.take 100000 $ OsciFL.static Wave.saw zeroPhase 0.015)  mixTest0 :: SigSt.T Int16 mixTest0 =-   SigSt.map doubleToInt16Packed $+   SigSt.map int16FromDouble $    SigSt.mixSize defaultChunkSize       (SigSt.replicate defaultChunkSize 100000 NP.zero)       (SigSt.replicate defaultChunkSize 100001 NP.one)  mixTest3 :: SigSt.T Int16 mixTest3 =-   SigSt.map doubleToInt16Packed $+   SigSt.map int16FromDouble $    SigSt.mixSize defaultChunkSize --      (storableFromFusionList $ SigFL.take 100000 $ OsciFL.static Wave.sine zeroPhase 0.010) --      (storableFromFusionList $ SigFL.take 100000 $ CtrlFL.exponential2 50000 1)@@ -374,7 +374,7 @@  mixTest4 :: SigSt.T Int16 mixTest4 =-   SigSt.map doubleToInt16Packed $+   SigSt.map int16FromDouble $    SigSt.mixSize defaultChunkSize       (SigSt.take 100002 $ OsciSt.staticSine defaultChunkSize zeroPhase 0.020) $    SigSt.mixSize defaultChunkSize@@ -384,7 +384,7 @@  mixTest5 :: SigSt.T Int16 mixTest5 =-   SigSt.map doubleToInt16Packed $+   SigSt.map int16FromDouble $    SigSt.take 441000 $ --   SigSt.append    SigSt.mix@@ -394,7 +394,7 @@  mixTest6 :: SigSt.T Int16 mixTest6 =-   SigSt.map doubleToInt16Packed $+   SigSt.map int16FromDouble $    SigSt.take 441000 $ --   SigSt.append    SigSt.mix@@ -406,7 +406,7 @@ stateTest0 :: SigSt.T Int16 stateTest0 =    SigS.toStorableSignal defaultChunkSize $-   SigS.map doubleToInt16Packed $+   SigS.map int16FromDouble $    SigS.take 441000 $    SigS.zipWith (*) (SigS.iterate ((1-1e-4)*) 1) $ --   SigS.map (\t -> if even (floor t :: Int) then 1 else -1) $@@ -416,7 +416,7 @@ stateTest1 :: SigSt.T Int16 stateTest1 =    SigS.toStorableSignal defaultChunkSize $-   SigS.map doubleToInt16Packed $+   SigS.map int16FromDouble $    SigS.take 100000 $    SigS.zipWith Dist.sine (SigS.iterate ((1-0.3e-4)*) 1) $    SigS.map (Wave.apply Wave.sine) $@@ -425,7 +425,7 @@ stateTest2 :: SigSt.T Int16 stateTest2 =    SigS.toStorableSignal defaultChunkSize $-   SigS.map doubleToInt16Packed $+   SigS.map int16FromDouble $    SigS.take 100000 $    SigS.map (Dist.logit 1) $    SigS.map (Dist.sine 5) $@@ -437,21 +437,21 @@ stateOsciTest0 =    SigS.toStorableSignal defaultChunkSize $    SigS.take 200000 $-   SigS.map numToInt16Packed $+   SigS.map int16FromCanonical $    (OsciS.static Wave.saw zeroPhase 0.01 :: SigS.T Double)  stateOsciTest0a :: SigSt.T Int16 stateOsciTest0a =    SigS.toStorableSignal defaultChunkSize $    SigS.take 200000 $-   SigS.map doubleToInt16Packed $+   SigS.map int16FromDouble $    OsciS.static Wave.saw zeroPhase 0.01  stateOsciTest0fa :: SigSt.T Int16 stateOsciTest0fa =    SigS.toStorableSignal defaultChunkSize $    SigS.take 200000 $-   SigS.map doubleToInt16Packed $+   SigS.map int16FromDouble $ --   FiltNRS.envelope --      (CtrlS.exponential2 50000 1)    SigS.map (0.5*) $@@ -484,7 +484,7 @@ stateOsciTestChord =    SigS.toStorableSignal defaultChunkSize $    SigS.take 200000 $-   SigS.map doubleToInt16Packed $+   SigS.map int16FromDouble $    SigS.map (0.2*) $    chord @@ -492,7 +492,7 @@ stateFilterTest =    SigS.toStorableSignal defaultChunkSize $    SigS.take 200000 $-   SigS.map doubleToInt16Packed $+   SigS.map int16FromDouble $    SigS.map (0.05*) $    SigS.map UniFilter.lowpass $    SigS.modifyModulated@@ -507,7 +507,7 @@ stateAppendTest0 :: SigSt.T Int16 stateAppendTest0 =    SigS.toStorableSignal defaultChunkSize $-   SigS.map doubleToInt16Packed $+   SigS.map int16FromDouble $       let tone f =              SigS.take 50000 $              SigS.map (Wave.apply Wave.saw) $@@ -519,7 +519,7 @@ stateAppendTest1 :: SigSt.T Int16 stateAppendTest1 =    SigS.toStorableSignal defaultChunkSize $-   SigS.map doubleToInt16Packed $+   SigS.map int16FromDouble $       let tone f =              SigS.take 50000 $              SigS.map (Wave.apply Wave.saw) $@@ -530,7 +530,7 @@  stateAppendTest2 :: SigSt.T Int16 stateAppendTest2 =-   SigSt.map doubleToInt16Packed $+   SigSt.map int16FromDouble $       let tone f =              SigS.toStorableSignal defaultChunkSize $              SigS.take 50000 $@@ -543,7 +543,7 @@ stateConcatTest0 :: SigSt.T Int16 stateConcatTest0 =    SigS.toStorableSignal defaultChunkSize $-   SigS.map doubleToInt16Packed $+   SigS.map int16FromDouble $       let tone f =              SigS.take 50000 $              SigS.map (Wave.apply Wave.saw) $@@ -557,7 +557,7 @@ stateConcatTest1 :: SigSt.T Int16 stateConcatTest1 =    SigS.toStorableSignal defaultChunkSize $-   SigS.map doubleToInt16Packed $+   SigS.map int16FromDouble $       let tone f =              SigS.take 50000 $              SigS.map (Wave.apply Wave.saw) $@@ -582,7 +582,7 @@  storableConcatTest :: SigSt.T Int16 storableConcatTest =-   SigSt.map doubleToInt16Packed $+   SigSt.map int16FromDouble $    SigSt.concat $    take 13 $    map storablePercTone $@@ -590,7 +590,7 @@  storableArrangeTest :: SigSt.T Int16 storableArrangeTest =-   SigSt.map doubleToInt16Packed $+   SigSt.map int16FromDouble $    SigSt.map (0.5*) $    CutSt.arrange defaultChunkSize $    foldr (EventList.cons 4000) (EventList.empty) $@@ -603,7 +603,7 @@ -- about 2 seconds storableConcatInfTest :: SigSt.T Int16 storableConcatInfTest =-   SigSt.map doubleToInt16Packed $+   SigSt.map int16FromDouble $    SigSt.map (0.5*) $    SigSt.concat $    take 110 $@@ -613,7 +613,7 @@ -- about 5-6 seconds storableArrangeInfTest :: SigSt.T Int16 storableArrangeInfTest =-   SigSt.map doubleToInt16Packed $+   SigSt.map int16FromDouble $    SigSt.map (0.5*) $    SigSt.take 440000 $    CutSt.arrange defaultChunkSize $@@ -636,7 +636,7 @@ stateArrangeInfTest :: SigSt.T Int16 stateArrangeInfTest =    SigS.toStorableSignal defaultChunkSize $-   SigS.map doubleToInt16Packed $+   SigS.map int16FromDouble $    SigS.map (0.5*) $    SigS.take 440000 $    CutS.arrange $@@ -655,7 +655,7 @@ fastSineTest :: SigSt.T Int16 fastSineTest =    SigS.toStorableSignal defaultChunkSize $-   SigS.map doubleToInt16Packed $+   SigS.map int16FromDouble $    SigS.take 440000 $ --   OsciS.static Wave.sine zeroPhase $ --   OsciS.static Wave.fastSine4 zeroPhase $@@ -676,13 +676,13 @@ stateBubblesTest :: SigSt.T Int16 stateBubblesTest =    SigS.toStorableSignal defaultChunkSize $-   SigS.map doubleToInt16Packed $+   SigS.map int16FromDouble $    SigS.take 440000 $    stateBubbles  storableCombTest :: SigSt.T Int16 storableCombTest =-   SigSt.map doubleToInt16Packed $+   SigSt.map int16FromDouble $    SigSt.delayLoopOverlap 11000 (SigSt.map (0.5*)) $    SigS.toStorableSignal defaultChunkSize $ --   SigS.append (statePercTone 0.01) (SigS.replicate 40000 0)@@ -695,7 +695,7 @@ storableTakeTest =    SigSt.take 440000 $    SigS.toStorableSignal defaultChunkSize $-   SigS.map doubleToInt16Packed $+   SigS.map int16FromDouble $    OsciS.static Wave.saw zeroPhase 0.01  @@ -703,7 +703,7 @@ stateNoiseTest =    SigS.toStorableSignal defaultChunkSize $    SigS.take 440000 $-   SigS.map doubleToInt16Packed $+   SigS.map int16FromDouble $    SigS.map (0.3*) $    SigS.map UniFilter.lowpass $    SigS.modifyModulated@@ -720,7 +720,7 @@ stateADSRTest :: SigSt.T Int16 stateADSRTest =    SigS.toStorableSignal defaultChunkSize $-   SigS.map doubleToInt16Packed $+   SigS.map int16FromDouble $    FiltNRS.envelope       (CtrlS.piecewise           (0    |#  (5000, CtrlS.cubicPiece 0.001 0) #|-@@ -733,13 +733,12 @@ phaserTest :: SigSt.T Int16 phaserTest =    SigSt.take 440000 $-   SigSt.map doubleToInt16Packed $+   SigSt.map int16FromDouble $    SigSt.map (0.5*) $    (\noise ->        SigSt.mix           noise---          (DelayG.modulated InterpolationG.linear (-500)-          (DelayG.modulated (InterpolationS.toGeneric InterpolationS.linear) (-500)+          (DelayG.modulated InterpolationM.linear (-500)              (SigS.toStorableSignal defaultChunkSize                 (SigS.map                    (\x -> 100*(2+x) :: Double)@@ -753,8 +752,8 @@ phaserTest0 :: SigSt.T Int16 phaserTest0 =    SigSt.take 440000 $-   SigSt.map doubleToInt16Packed $-   DelayG.modulated InterpolationG.constant (-500)+   SigSt.map int16FromDouble $+   DelayG.modulated InterpolationM.constant (-500)       (SigSt.repeat defaultChunkSize (142::Double)) $    SigSt.repeat defaultChunkSize (23::Double) @@ -762,7 +761,7 @@ phaserTest1 :: SigSt.T Int16 phaserTest1 =    SigSt.take 440000 $-   SigSt.map doubleToInt16Packed $+   SigSt.map int16FromDouble $ --   SigG.mapTails (maybe 0 fst . SigSt.viewL . SigSt.drop 100) $ {-    (\noise ->
speedtest/SpeedTest.hs view
@@ -21,10 +21,10 @@  import Data.Word (Word8) -import Control.Monad (when, foldM, zipWithM)+import Control.Monad (when, foldM, zipWithM_, ) import Data.List (unfoldr)-import NumericPrelude.Condition (toMaybe)-import NumericPrelude.List (sliceVert)+import Data.Maybe.HT (toMaybe, )+import Data.List.HT (sliceVertical, )  import PreludeBase import NumericPrelude@@ -191,7 +191,7 @@    FilePath -> [Int16] -> IO () writeSignalMonoBlock fileName signal =    bracket (openBinaryFile fileName WriteMode) hClose $-      \h -> let blocks = sliceVert maxBlockSize signal+      \h -> let blocks = sliceVertical maxBlockSize signal             in  allocaBytes (int16size * maxBlockSize) $                    \p -> mapM_ (putIntBlock h p) blocks @@ -202,7 +202,7 @@  putIntBlockSlow :: Handle -> Ptr Int16 -> [Int16] -> IO () putIntBlockSlow h p xs =-   do zipWithM (pokeElemOff p) [0..] xs+   do zipWithM_ (pokeElemOff p) [0..] xs       hPutBuf h p (int16size * length xs)
speedtest/SpeedTestExp.hs view
@@ -16,7 +16,7 @@ import System.IO (openBinaryFile, hClose, hPutBuf, IOMode(WriteMode)) import Foreign (Int16, pokeElemOff, allocaBytes) import Control.Exception (bracket)-import Control.Monad (zipWithM)+import Control.Monad (zipWithM_)  import GHC.Float (double2Int) @@ -61,7 +61,7 @@ writeSignal name num signal =    bracket (openBinaryFile name WriteMode) hClose $ \h ->    allocaBytes (2*num) $ \buf ->-      zipWithM+      zipWithM_          (pokeElemOff buf) [0..(num-1)]          (map doubleToInt16' signal) >>       hPutBuf h buf (2*num)@@ -70,7 +70,7 @@ writeExponentialList name num hl y0 =    bracket (openBinaryFile name WriteMode) hClose $ \h ->    allocaBytes (2*num) $ \buf ->-      zipWithM+      zipWithM_          (pokeElemOff buf) [0..(num-1)]          (map doubleToInt16' (let k = 0.5 ** recip hl                               in  iterate (k*) y0)) >>
+ src-3/Synthesizer/Causal/Process.hs view
@@ -0,0 +1,393 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ExistentialQuantification #-}+{- |+Processes that use only the current and past data.+Essentially this is a data type for the 'Synthesizer.State.Signal.crochetL' function.+-}+{-+ToDo:+Causal process usually depend on the sample rate,+so we need a phantom type parameter of T for the rate.++Include ST monad for mutable arrays,+this can be useful for delay lines.+On the other hand, couldn't we also use the StorableVector.Cursor data structure+and avoid the ST monad here?+-}+module Synthesizer.Causal.Process (+   T,+   fromStateMaybe,+   fromState,+   fromSimpleModifier,++   id,+   map,+   first,+   second,+   compose,+   split,+   fanout,+   loop,++{-+   We don't re-export these identifiers+   because people could abuse them for other Arrows.++   (>>>), (***), (&&&),+   (Arrow.^<<), (Arrow.^>>), (Arrow.<<^), (Arrow.>>^),+-}++   apply,+   applyFst,+   applySnd,+   applyGeneric,+   applyGenericSameType,+   applyConst,+   apply2,+   apply3,++   feed,+   feedFst,+   feedSnd,+   feedGenericFst,+   feedGenericSnd,+   feedConstFst,+   feedConstSnd,++   crochetL,+   scanL,+   scanL1,+   zipWith,+   consInit,+   chainControlled,+   replicateControlled,+   feedback,+   feedbackControlled,++   -- for testing+   applyFst',+   applySnd',+) where++import qualified Synthesizer.State.Signal as Sig+import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.Generic.Signal2 as SigG2++import qualified Synthesizer.Plain.Modifier as Modifier++-- import qualified Control.Arrow as Arrow++import Control.Arrow+          (Arrow(..), returnA, (<<<), (^>>), {- ArrowApply(..), -} ArrowLoop(..),+           Kleisli(Kleisli), runKleisli, )+import Control.Monad.Trans.State+          (State, state, runState,+           StateT(StateT), runStateT, )+import Control.Monad (liftM, )++import Data.Tuple.HT (mapSnd, )+import Data.Function.HT (nest, )+import Prelude hiding (id, map, zipWith, )++++-- | Cf. StreamFusion  'Synthesizer.State.Signal.T'+data T a b =+   forall s. -- Seq s =>+      Cons !(a -> StateT s Maybe b)  -- compute next value+           !s                        -- initial state++++{-# INLINE fromStateMaybe #-}+fromStateMaybe :: (a -> StateT s Maybe b) -> s -> T a b+fromStateMaybe = Cons++{-# INLINE fromState #-}+fromState :: (a -> State s b) -> s -> T a b+fromState f =+   fromStateMaybe (\x -> StateT (Just . runState (f x)))++{-# INLINE fromSimpleModifier #-}+fromSimpleModifier ::+   Modifier.Simple s ctrl a b -> T (ctrl,a) b+fromSimpleModifier (Modifier.Simple s f) =+   fromState (uncurry f) s+++{-+It's almost a Kleisli Arrow,+but the hidden type of the state disturbs.+-}+instance Arrow T where+   {-# INLINE pure #-}+   {-# INLINE (>>>) #-}+   {-# INLINE first #-}+   {-# INLINE second #-}+   {-# INLINE (***) #-}+   {-# INLINE (&&&) #-}++   pure   = map+   (>>>)  = compose+   first  = liftKleisli first+   second = liftKleisli second+   (***)  = split+   (&&&)  = fanout+++{-+I think we cannot define an ArrowApply instance,+because we must extract the initial state somehow+from the inner (T a b) which is not possible.++instance ArrowApply T where+--   app = Cons (runKleisli undefined) ()+   app = first (arr (flip Cons () . runKleisli)) >>> app+-}+++instance ArrowLoop T where+   {-# INLINE loop #-}+   loop = liftKleisli loop+++{-# INLINE extendStateFstT #-}+extendStateFstT :: Monad m => StateT s m a -> StateT (t,s) m a+extendStateFstT st =+   StateT (\(t0,s0) -> liftM (mapSnd (\s1 -> (t0,s1))) (runStateT st s0))++{-# INLINE extendStateSndT #-}+extendStateSndT :: Monad m => StateT s m a -> StateT (s,t) m a+extendStateSndT st =+   StateT (\(s0,t0) -> liftM (mapSnd (\s1 -> (s1,t0))) (runStateT st s0))+++{-# INLINE liftKleisli #-}+liftKleisli ::+   (forall s.+    Kleisli (StateT s Maybe) a0 a1 ->+    Kleisli (StateT s Maybe) b0 b1) ->+   T a0 a1 -> T b0 b1+liftKleisli op (Cons f s) =+   Cons (runKleisli $ op $ Kleisli f) s++{-# INLINE liftKleisli2 #-}+liftKleisli2 ::+   (forall s.+      Kleisli (StateT s Maybe) a0 a1 ->+      Kleisli (StateT s Maybe) b0 b1 ->+      Kleisli (StateT s Maybe) c0 c1) ->+   T a0 a1 -> T b0 b1 -> T c0 c1+liftKleisli2 op (Cons f s) (Cons g t) =+   Cons+      (runKleisli+         (Kleisli (extendStateSndT . f) `op`+          Kleisli (extendStateFstT . g)))+      (s,t)+++{-# INLINE id #-}+id :: T a a+id = returnA++{-# INLINE map #-}+map :: (a -> b) -> T a b+map f = fromState (return . f) ()++{-# INLINE compose #-}+compose :: T a b -> T b c -> T a c+compose = liftKleisli2 (>>>)++{-# INLINE split #-}+split :: T a b -> T c d -> T (a,c) (b,d)+split = liftKleisli2 (***)++{-# INLINE fanout #-}+fanout :: T a b -> T a c -> T a (b,c)+fanout = liftKleisli2 (&&&)+++{-# INLINE getNext #-}+getNext :: StateT (Sig.T a) Maybe a+getNext = StateT Sig.viewL++{-# INLINE apply #-}+apply :: T a b -> Sig.T a -> Sig.T b+apply (Cons f s) =+   Sig.crochetL (runStateT . f) s++{- |+I think this function does too much.+Better use 'feedFst' and (>>>).+-}+{-# INLINE applyFst #-}+applyFst, applyFst' :: T (a,b) c -> Sig.T a -> T b c+applyFst c as =+   c <<< feedFst as++applyFst' (Cons f s) as =+   Cons (\b ->+           do a <- extendStateFstT getNext+              extendStateSndT (f (a,b)))+        (s,as)++{- |+I think this function does too much.+Better use 'feedSnd' and (>>>).+-}+{-# INLINE applySnd #-}+applySnd, applySnd' :: T (a,b) c -> Sig.T b -> T a c+applySnd c as =+   c <<< feedSnd as++applySnd' (Cons f s) bs =+   Cons (\a ->+           do b <- extendStateFstT getNext+              extendStateSndT (f (a,b)))+        (s,bs)++{-# INLINE applyGeneric #-}+applyGeneric :: (SigG2.Transform sig a b) =>+   T a b -> sig a -> sig b+applyGeneric (Cons f s) =+   SigG2.crochetL (runStateT . f) s++{-# INLINE applyGenericSameType #-}+applyGenericSameType :: (SigG.Transform sig a) =>+   T a a -> sig a -> sig a+applyGenericSameType (Cons f s) =+   SigG.crochetL (runStateT . f) s+++{- |+applyConst c x == apply c (repeat x)+-}+{-# INLINE applyConst #-}+applyConst :: T a b -> a -> Sig.T b+applyConst (Cons f s) a =+   Sig.unfoldR (runStateT (f a)) s++{-+Can be easily done by converting the result of applyConst to generic signal+{-# INLINE applyConstGeneric #-}+applyConstGeneric :: SigG.LazySize -> T a b -> a -> sig b+applyConstGeneric size (Cons f s) a =+   SigG.unfoldR size (runStateT (f a)) s+-}+++{-# INLINE apply2 #-}+apply2 :: T (a,b) c -> Sig.T a -> Sig.T b -> Sig.T c+apply2 f x y =+   apply (applyFst f x) y++{-# INLINE apply3 #-}+apply3 :: T (a,b,c) d -> Sig.T a -> Sig.T b -> Sig.T c -> Sig.T d+apply3 f x y z =+   apply2 (applyFst ((\(a,(b,c)) -> (a,b,c)) ^>> f) x) y z+++{-# INLINE feed #-}+feed :: Sig.T a -> T () a+feed = fromStateMaybe (const getNext)++{-# INLINE feedFst #-}+feedFst :: Sig.T a -> T b (a,b)+feedFst = fromStateMaybe (\b -> fmap (flip (,) b) getNext)++{-# INLINE feedSnd #-}+feedSnd :: Sig.T a -> T b (b,a)+feedSnd = fromStateMaybe (\b -> fmap ((,) b) getNext)++{-# INLINE feedConstFst #-}+feedConstFst :: a -> T b (a,b)+feedConstFst a = map (\b -> (a,b))++{-# INLINE feedConstSnd #-}+feedConstSnd :: a -> T b (b,a)+feedConstSnd a = map (\b -> (b,a))++{-# INLINE feedGenericFst #-}+feedGenericFst :: (SigG.Read sig a) =>+   sig a -> T b (a,b)+feedGenericFst =+   feedFst . SigG.toState++{-# INLINE feedGenericSnd #-}+feedGenericSnd :: (SigG.Read sig a) =>+   sig a -> T b (b,a)+feedGenericSnd =+   feedSnd . SigG.toState++++-- * list like functions++{-# INLINE crochetL #-}+crochetL :: (x -> acc -> Maybe (y, acc)) -> acc -> T x y+crochetL f s = fromStateMaybe (StateT . f) s++{-# INLINE scanL #-}+scanL :: (acc -> x -> acc) -> acc -> T x acc+scanL f start =+   fromState (\x -> state $ \acc -> (acc, f acc x)) start++{-# INLINE scanL1 #-}+scanL1 :: (x -> x -> x) -> T x x+scanL1 f =+   crochetL (\x acc -> Just (x, Just $ maybe x (flip f x) acc)) Nothing++{-# INLINE zipWith #-}+zipWith :: (a -> b -> c) -> Sig.T a -> T b c+zipWith f = applyFst (map (uncurry f))++{- |+Prepend an element to a signal,+but keep the signal length,+i.e. drop the last element.+-}+{-# INLINE consInit #-}+consInit :: x -> T x x+consInit =+   crochetL (\x acc -> Just (acc, x))++++{-# INLINE chainControlled #-}+chainControlled :: [T (c,x) x] -> T (c,x) x+chainControlled =+   foldr+      (\p rest -> map fst &&& p  >>>  rest)+      (map snd)++{- |+If @T@ would be the function type @->@+then @replicateControlled 3 f@ computes+@\(c,x) -> f(c, f(c, f(c, x)))@.+-}+{-# INLINE replicateControlled #-}+replicateControlled :: Int -> T (c,x) x -> T (c,x) x+replicateControlled n p =+   nest n+      (map fst &&& p  >>> )+      (map snd)+++{-# INLINE feedback #-}+feedback :: T (a,c) b -> T b c -> T a b+feedback forth back =+   loop (forth >>>  id &&& back)++{-# INLINE feedbackControlled #-}+feedbackControlled :: T ((ctrl,a),c) b -> T (ctrl,b) c -> T (ctrl,a) b+feedbackControlled forth back =+   loop (map (fst.fst) &&& forth  >>>  map snd &&& back)++{-+{-# INLINE feedbackControlled #-}+feedbackControlled :: T (ctrl, (a,c)) b -> T (ctrl,b) c -> T (ctrl,a) b+feedbackControlled forth back =+   loop ((\((ctrl,a),c) -> (ctrl, (a,c)))  ^>>+         map fst &&& forth  >>>+         map snd &&& back)+-}
+ src-4/Synthesizer/Causal/Process.hs view
@@ -0,0 +1,398 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ExistentialQuantification #-}+{- |+Processes that use only the current and past data.+Essentially this is a data type for the 'Synthesizer.State.Signal.crochetL' function.+-}+{-+ToDo:+Causal process usually depend on the sample rate,+so we need a phantom type parameter of T for the rate.++Include ST monad for mutable arrays,+this can be useful for delay lines.+On the other hand, couldn't we also use the StorableVector.Cursor data structure+and avoid the ST monad here?+-}+module Synthesizer.Causal.Process (+   T,+   fromStateMaybe,+   fromState,+   fromSimpleModifier,++   id,+   map,+   first,+   second,+   compose,+   split,+   fanout,+   loop,++{-+   We don't re-export these identifiers+   because people could abuse them for other Arrows.++   (>>>), (***), (&&&),+   (Arrow.^<<), (Arrow.^>>), (Arrow.<<^), (Arrow.>>^),+-}++   apply,+   applyFst,+   applySnd,+   applyGeneric,+   applyGenericSameType,+   applyConst,+   apply2,+   apply3,++   feed,+   feedFst,+   feedSnd,+   feedGenericFst,+   feedGenericSnd,+   feedConstFst,+   feedConstSnd,++   crochetL,+   scanL,+   scanL1,+   zipWith,+   consInit,+   chainControlled,+   replicateControlled,+   feedback,+   feedbackControlled,++   -- for testing+   applyFst',+   applySnd',+) where++import qualified Synthesizer.State.Signal as Sig+import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.Generic.Signal2 as SigG2++import qualified Synthesizer.Plain.Modifier as Modifier++-- import qualified Control.Arrow as Arrow++import qualified Control.Category as Cat+import Control.Arrow+          (Arrow(..), returnA, (<<<), (>>>), (^>>), {- ArrowApply(..), -} ArrowLoop(..),+           Kleisli(Kleisli), runKleisli, )+import Control.Monad.Trans.State+          (State, state, runState,+           StateT(StateT), runStateT, )+import Control.Monad (liftM, )++import Data.Tuple.HT (mapSnd, )+import Data.Function.HT (nest, )+import Prelude hiding (id, map, zipWith, )++++-- | Cf. StreamFusion  'Synthesizer.State.Signal.T'+data T a b =+   forall s. -- Seq s =>+      Cons !(a -> StateT s Maybe b)  -- compute next value+           !s                        -- initial state++++{-# INLINE fromStateMaybe #-}+fromStateMaybe :: (a -> StateT s Maybe b) -> s -> T a b+fromStateMaybe = Cons++{-# INLINE fromState #-}+fromState :: (a -> State s b) -> s -> T a b+fromState f =+   fromStateMaybe (\x -> StateT (Just . runState (f x)))++{-# INLINE fromSimpleModifier #-}+fromSimpleModifier ::+   Modifier.Simple s ctrl a b -> T (ctrl,a) b+fromSimpleModifier (Modifier.Simple s f) =+   fromState (uncurry f) s+++{-+It's almost a Kleisli Arrow,+but the hidden type of the state disturbs.+-}+instance Cat.Category T where+   {-# INLINE id #-}+   {-# INLINE (.) #-}++   id  = fromState return ()+   (.) = flip compose++instance Arrow T where+   {-# INLINE arr #-}+   {-# INLINE first #-}+   {-# INLINE second #-}+   {-# INLINE (***) #-}+   {-# INLINE (&&&) #-}++   arr    = map+   first  = liftKleisli first+   second = liftKleisli second+   (***)  = split+   (&&&)  = fanout++{-+I think we cannot define an ArrowApply instance,+because we must extract the initial state somehow+from the inner (T a b) which is not possible.++instance ArrowApply T where+--   app = Cons (runKleisli undefined) ()+   app = first (arr (flip Cons () . runKleisli)) >>> app+-}+++instance ArrowLoop T where+   {-# INLINE loop #-}+   loop = liftKleisli loop+++{-# INLINE extendStateFstT #-}+extendStateFstT :: Monad m => StateT s m a -> StateT (t,s) m a+extendStateFstT st =+   StateT (\(t0,s0) -> liftM (mapSnd (\s1 -> (t0,s1))) (runStateT st s0))++{-# INLINE extendStateSndT #-}+extendStateSndT :: Monad m => StateT s m a -> StateT (s,t) m a+extendStateSndT st =+   StateT (\(s0,t0) -> liftM (mapSnd (\s1 -> (s1,t0))) (runStateT st s0))+++{-# INLINE liftKleisli #-}+liftKleisli ::+   (forall s.+    Kleisli (StateT s Maybe) a0 a1 ->+    Kleisli (StateT s Maybe) b0 b1) ->+   T a0 a1 -> T b0 b1+liftKleisli op (Cons f s) =+   Cons (runKleisli $ op $ Kleisli f) s++{-# INLINE liftKleisli2 #-}+liftKleisli2 ::+   (forall s.+      Kleisli (StateT s Maybe) a0 a1 ->+      Kleisli (StateT s Maybe) b0 b1 ->+      Kleisli (StateT s Maybe) c0 c1) ->+   T a0 a1 -> T b0 b1 -> T c0 c1+liftKleisli2 op (Cons f s) (Cons g t) =+   Cons+      (runKleisli+         (Kleisli (extendStateSndT . f) `op`+          Kleisli (extendStateFstT . g)))+      (s,t)+++{-# INLINE id #-}+id :: T a a+id = returnA++{-# INLINE map #-}+map :: (a -> b) -> T a b+map f = fromState (return . f) ()++{-# INLINE compose #-}+compose :: T a b -> T b c -> T a c+compose = liftKleisli2 (>>>)++{-# INLINE split #-}+split :: T a b -> T c d -> T (a,c) (b,d)+split = liftKleisli2 (***)++{-# INLINE fanout #-}+fanout :: T a b -> T a c -> T a (b,c)+fanout = liftKleisli2 (&&&)+++{-# INLINE getNext #-}+getNext :: StateT (Sig.T a) Maybe a+getNext = StateT Sig.viewL++{-# INLINE apply #-}+apply :: T a b -> Sig.T a -> Sig.T b+apply (Cons f s) =+   Sig.crochetL (runStateT . f) s++{- |+I think this function does too much.+Better use 'feedFst' and (>>>).+-}+{-# INLINE applyFst #-}+applyFst, applyFst' :: T (a,b) c -> Sig.T a -> T b c+applyFst c as =+   c <<< feedFst as++applyFst' (Cons f s) as =+   Cons (\b ->+           do a <- extendStateFstT getNext+              extendStateSndT (f (a,b)))+        (s,as)++{- |+I think this function does too much.+Better use 'feedSnd' and (>>>).+-}+{-# INLINE applySnd #-}+applySnd, applySnd' :: T (a,b) c -> Sig.T b -> T a c+applySnd c as =+   c <<< feedSnd as++applySnd' (Cons f s) bs =+   Cons (\a ->+           do b <- extendStateFstT getNext+              extendStateSndT (f (a,b)))+        (s,bs)++{-# INLINE applyGeneric #-}+applyGeneric :: (SigG2.Transform sig a b) =>+   T a b -> sig a -> sig b+applyGeneric (Cons f s) =+   SigG2.crochetL (runStateT . f) s++{-# INLINE applyGenericSameType #-}+applyGenericSameType :: (SigG.Transform sig a) =>+   T a a -> sig a -> sig a+applyGenericSameType (Cons f s) =+   SigG.crochetL (runStateT . f) s+++{- |+applyConst c x == apply c (repeat x)+-}+{-# INLINE applyConst #-}+applyConst :: T a b -> a -> Sig.T b+applyConst (Cons f s) a =+   Sig.unfoldR (runStateT (f a)) s++{-+Can be easily done by converting the result of applyConst to generic signal+{-# INLINE applyConstGeneric #-}+applyConstGeneric :: SigG.LazySize -> T a b -> a -> sig b+applyConstGeneric size (Cons f s) a =+   SigG.unfoldR size (runStateT (f a)) s+-}+++{-# INLINE apply2 #-}+apply2 :: T (a,b) c -> Sig.T a -> Sig.T b -> Sig.T c+apply2 f x y =+   apply (applyFst f x) y++{-# INLINE apply3 #-}+apply3 :: T (a,b,c) d -> Sig.T a -> Sig.T b -> Sig.T c -> Sig.T d+apply3 f x y z =+   apply2 (applyFst ((\(a,(b,c)) -> (a,b,c)) ^>> f) x) y z+++{-# INLINE feed #-}+feed :: Sig.T a -> T () a+feed = fromStateMaybe (const getNext)++{-# INLINE feedFst #-}+feedFst :: Sig.T a -> T b (a,b)+feedFst = fromStateMaybe (\b -> fmap (flip (,) b) getNext)++{-# INLINE feedSnd #-}+feedSnd :: Sig.T a -> T b (b,a)+feedSnd = fromStateMaybe (\b -> fmap ((,) b) getNext)++{-# INLINE feedConstFst #-}+feedConstFst :: a -> T b (a,b)+feedConstFst a = map (\b -> (a,b))++{-# INLINE feedConstSnd #-}+feedConstSnd :: a -> T b (b,a)+feedConstSnd a = map (\b -> (b,a))++{-# INLINE feedGenericFst #-}+feedGenericFst :: (SigG.Read sig a) =>+   sig a -> T b (a,b)+feedGenericFst =+   feedFst . SigG.toState++{-# INLINE feedGenericSnd #-}+feedGenericSnd :: (SigG.Read sig a) =>+   sig a -> T b (b,a)+feedGenericSnd =+   feedSnd . SigG.toState++++-- * list like functions++{-# INLINE crochetL #-}+crochetL :: (x -> acc -> Maybe (y, acc)) -> acc -> T x y+crochetL f s = fromStateMaybe (StateT . f) s++{-# INLINE scanL #-}+scanL :: (acc -> x -> acc) -> acc -> T x acc+scanL f start =+   fromState (\x -> state $ \acc -> (acc, f acc x)) start++{-# INLINE scanL1 #-}+scanL1 :: (x -> x -> x) -> T x x+scanL1 f =+   crochetL (\x acc -> Just (x, Just $ maybe x (flip f x) acc)) Nothing++{-# INLINE zipWith #-}+zipWith :: (a -> b -> c) -> Sig.T a -> T b c+zipWith f = applyFst (map (uncurry f))++{- |+Prepend an element to a signal,+but keep the signal length,+i.e. drop the last element.+-}+{-# INLINE consInit #-}+consInit :: x -> T x x+consInit =+   crochetL (\x acc -> Just (acc, x))++++{-# INLINE chainControlled #-}+chainControlled :: [T (c,x) x] -> T (c,x) x+chainControlled =+   foldr+      (\p rest -> map fst &&& p  >>>  rest)+      (map snd)++{- |+If @T@ would be the function type @->@+then @replicateControlled 3 f@ computes+@\(c,x) -> f(c, f(c, f(c, x)))@.+-}+{-# INLINE replicateControlled #-}+replicateControlled :: Int -> T (c,x) x -> T (c,x) x+replicateControlled n p =+   nest n+      (map fst &&& p  >>> )+      (map snd)+++{-# INLINE feedback #-}+feedback :: T (a,c) b -> T b c -> T a b+feedback forth back =+   loop (forth >>>  id &&& back)++{-# INLINE feedbackControlled #-}+feedbackControlled :: T ((ctrl,a),c) b -> T (ctrl,b) c -> T (ctrl,a) b+feedbackControlled forth back =+   loop (map (fst.fst) &&& forth  >>>  map snd &&& back)++{-+{-# INLINE feedbackControlled #-}+feedbackControlled :: T (ctrl, (a,c)) b -> T (ctrl,b) c -> T (ctrl,a) b+feedbackControlled forth back =+   loop ((\((ctrl,a),c) -> (ctrl, (a,c)))  ^>>+         map fst &&& forth  >>>+         map snd &&& back)+-}
+ src-4/Synthesizer/Inference/DesignStudy/Applicative.hs view
@@ -0,0 +1,42 @@+{- |+  A design study about how to design signal processors+  that adapt to a common sample rate.+  I simplified "Synthesizer.Inference.DesignStudy.Arrow" to this module+  which uses only Applicative functors.+-}+module Synthesizer.Inference.DesignStudy.Applicative where++import Data.List (intersect)+import Control.Applicative (Applicative(..), liftA3, )++data Rates = Rates [Int] | Any deriving Show+-- it is a Reader monad with context processing+data Processor a = P Rates (Rates -> a)++intersectRates :: Rates -> Rates -> Rates+intersectRates Any y = y+intersectRates x Any = x+intersectRates (Rates xs) (Rates ys) = Rates $ intersect xs ys++instance Functor Processor where+   fmap f (P r f0) = P r (f . f0)++instance Applicative Processor where+   pure x = P Any (const x)+   (P r0 f0) <*> (P r1 f1)  =+      P (intersectRates r0 r1) (\r -> f0 r (f1 r))++runProcessor :: Processor a -> a+runProcessor (P r f) = f r++-- test processors+processor1, processor2, processor3 :: Processor Rates+processor1 = P (Rates [44100, 48000]) id+processor2 = P Any                    id+processor3 = P (Rates [48000])        id++process :: Processor (Rates, Rates, Rates)+process = liftA3 (,,) processor1 processor2 processor3++test :: (Rates, Rates, Rates)+test = runProcessor process
+ src-4/Synthesizer/Inference/DesignStudy/Arrow.hs view
@@ -0,0 +1,50 @@+module Synthesizer.Inference.DesignStudy.Arrow where++{-+  A hint from Haskell cafe about how to design signal processors+  that adapt to a common sample rate.+-}++{-+Date: Fri, 12 Nov 2004 02:59:31 +0900+From: Koji Nakahara <yu-@div.club.ne.jp>+To: haskell-cafe@haskell.org+-}++import Control.Category+import Control.Arrow+import Data.List (intersect)+data Rates = Rates [Int] | Any deriving Show+data Processor b c = P Rates (Rates -> b -> c)++-- test Stream+type Stream = String++intersectRates :: Rates -> Rates -> Rates+intersectRates Any y = y+intersectRates x Any = x+intersectRates (Rates xs) (Rates ys) = Rates $ intersect xs ys++instance Category Processor where+  id = P Any (const Prelude.id)+  (P r1 f1) . (P r0 f0) =+	  P (intersectRates r0 r1) (\r -> f1 r Prelude.. f0 r)++instance Arrow Processor where+  arr f = P Any (const f)+  first (P r0 f) = P r0 (\r (x, s) -> (f r x, s))+++runProcessor :: Processor b c -> b -> c+runProcessor (P r f) s = f r s++-- test processors+process, processor1, processor2, processor3 :: Processor String String+processor1 = P (Rates [44100, 48000]) (\r -> ( ++ show r))+processor2 = P Any                    (\r -> ( ++ show r))+processor3 = P (Rates [48000])        (\r -> ( ++ show r))++process = processor1 >>> processor2 >>> processor3++test :: String+test = runProcessor process "bla"
+ src-4/Synthesizer/Inference/DesignStudy/Monad.hs view
@@ -0,0 +1,44 @@+{- |+  A design study about how to design signal processors+  that adapt to a common sample rate.+  I tried to simplify "Synthesizer.Inference.DesignStudy.Arrow" to this module which uses only Monads.+  However the module is now very weird and does not really represent,+  what I intended to do.+-}+module Synthesizer.Inference.DesignStudy.Monad where++import Control.Monad.Trans.Writer (Writer, execWriter, tell)+import Data.List (intersect)++data Rates = Rates [Int] | Any deriving Show+-- it is a combination of Reader and Writer monad with context processing+data Processor a = P Rates (Rates -> Writer Stream a)++-- test Stream+type Stream = String++intersectRates :: Rates -> Rates -> Rates+intersectRates Any y = y+intersectRates x Any = x+intersectRates (Rates xs) (Rates ys) = Rates $ intersect xs ys++instance Monad Processor where+   return x = P Any (\_ -> return x)+   -- maybe we should turn this into an Applicative instance+   (P r0 f0) >> (P r1 f1)  =+       P (intersectRates r0 r1) (\r -> f0 r >> f1 r)+   (P _ _) >>= _ = error "Is it possible to implement that?"++runProcessor :: Processor a -> Stream+runProcessor (P r f) = execWriter (f r)++-- test processors+process, processor1, processor2, processor3 :: Processor ()+processor1 = P (Rates [44100, 48000]) (tell . show)+processor2 = P Any                    (tell . show)+processor3 = P (Rates [47000])        (tell . show)++process = processor1 >> processor2 >> processor3++test :: Stream+test = runProcessor process
− src/BinarySample.hs 
@@ -1,210 +0,0 @@-{-# OPTIONS -fno-implicit-prelude #-}-module BinarySample-   (C(..),-    signalToBinary, signalToBinaryMono, signalToBinaryStereo,-    writeInt16Stream, readInt16Stream,-    writeLEInt16Stream, readLEInt16Stream,-    int16ToNum, putInt16Stream,-    numToInt16Packed, int16PackedToNum,-    floatToInt16Packed, doubleToInt16Packed,-    ) where--import Foreign (Int16, Ptr, alloca, sizeOf, poke, peek)-import System.IO (openBinaryFile, IOMode(WriteMode,ReadMode), hClose, Handle, hPutBuf, hGetBuf)-import Control.Exception (bracket)-import Control.Monad (liftM)--import qualified Algebra.Field     as Field-import qualified Algebra.RealField as RealField-import qualified Algebra.Ring      as Ring--import Synthesizer.Utility (clip)--import Data.Char(ord)--import GHC.Float (float2Int, double2Int)--import qualified Prelude as P98--import PreludeBase-import NumericPrelude-----class C a where-   toInt16 :: a -> [Int]-   numChannels :: a -> Int--instance C Float where---   toInt16 = (:[]) . numToInt16-   toInt16 x =-      [float2Int (if x<0-                    then scale16 x - 0.5-                    else scale16 x + 0.5)]-   numChannels _ = 1--instance C Double where---   toInt16 = (:[]) . numToInt16-   toInt16 x =-      [double2Int (if x<0-                     then scale16 x - 0.5-                     else scale16 x + 0.5)]-   numChannels _ = 1--instance (C a, C b) => C (a,b) where-   toInt16 (x0,x1) = toInt16 x0 ++ toInt16 x1-   numChannels ~(x0,x1) = numChannels x0 + numChannels x1----{-# INLINE scale16 #-}-scale16 :: (Ring.C a, Ord a) => a -> a-scale16 x = 32767 * clip (-1) 1 x--{-# INLINE numToInt16 #-}-numToInt16 :: (RealField.C a) => a -> Int-numToInt16 = round . scale16--{-# INLINE numToInt16Packed #-}-numToInt16Packed :: (RealField.C a) => a -> Int16-numToInt16Packed = P98.fromIntegral . numToInt16--{-# INLINE floatToInt16Packed #-}-floatToInt16Packed :: Float -> Int16-floatToInt16Packed = P98.fromIntegral . float2Int . scale16---{--{-# INLINE scale16Double #-}-scale16Double :: (Ring.C a, Ord a) => a -> a-scale16Double x = 32767 * clip (-1) 1 x--}--{-# INLINE doubleToInt16Packed #-}-doubleToInt16Packed :: Double -> Int16-{- Why is scale16 not inlined here? See FusionTest.mixTest3-doubleToInt16Packed = P98.fromIntegral . double2Int . scale16--}--- doubleToInt16Packed = P98.fromIntegral . double2Int . scale16Double--- doubleToInt16Packed x = P98.fromIntegral (double2Int (scale16 x))-doubleToInt16Packed = P98.fromIntegral . double2Int . (32767*) . clip (-1) 1--{-# INLINE int16ToNum #-}-int16ToNum :: (Field.C a) => Int -> a-int16ToNum x = fromIntegral x / 32768--{-# INLINE int16PackedToNum #-}-int16PackedToNum :: (Field.C a) => Int16 -> a-int16PackedToNum = int16ToNum . P98.fromIntegral---- | little endian (Intel)-{-# INLINE int16ToLEChars #-}-int16ToLEChars :: Int -> [Char]-int16ToLEChars x =-   let (hi,lo) = divMod x 256-   in  [toEnum lo, toEnum (mod hi 256)]---- | little endian (Intel)-{-# INLINE leCharsToInt16 #-}-leCharsToInt16 :: Char -> Char -> Int-leCharsToInt16 hi lo =-   let unsigned = ord lo + 256 * ord hi-   in  mod (unsigned + 32768) 65536 - 32768---{-# INLINE signalToBinary #-}-signalToBinary :: (C v) => [v] -> [Int]-signalToBinary = concatMap toInt16--{-# INLINE signalToBinaryMono #-}-signalToBinaryMono :: (RealField.C a) => [a] -> [Int]-signalToBinaryMono = map numToInt16--{-# INLINE signalToBinaryStereo #-}-signalToBinaryStereo :: (RealField.C a) => [(a,a)] -> [Int]-signalToBinaryStereo =-   concatMap (\(l,r) -> [numToInt16 l, numToInt16 r])---{-# INLINE binaryToIntsMono16 #-}-binaryToIntsMono16 :: [Char] -> [Int]-binaryToIntsMono16 sig =-   case sig of-      (lo:hi:xs) ->-         leCharsToInt16 hi lo : binaryToIntsMono16 xs-      (_:[]) ->-         error "binaryToIntsMono16: 16 bit sample files must have even length"-      [] -> []----{- * I\/O -}--{- |-Write a little endian 16 bit integer stream-via String data and 'writeFile'.--}-writeLEInt16Stream :: FilePath -> [Int] -> IO ()-writeLEInt16Stream fileName =-   writeFile fileName . concatMap int16ToLEChars--{- |-Uses endianess of the machine, like Sox does.--}-writeInt16Stream :: FilePath -> [Int] -> IO ()-writeInt16Stream fileName stream =-   bracket (openBinaryFile fileName WriteMode) hClose-      (flip putInt16Stream stream)--putInt16Stream :: Handle -> [Int] -> IO ()-putInt16Stream h stream =-   alloca $-      \p -> mapM_ (putInt16 h p . P98.fromIntegral) stream--putInt16 :: Handle -> Ptr Int16 -> Int16 -> IO ()-putInt16 h p n =-   poke p n >> hPutBuf h p (sizeOf n)---{- |-The end of the list is undefined,-if the file has odd length.-It would be better if it throws an exception.--}-readLEInt16Stream :: FilePath -> IO [Int]-readLEInt16Stream fileName =-   fmap binaryToIntsMono16 (readFile fileName)--{- |-The end of the list is undefined,-if the file has odd length.-It would be better if it throws an exception.--}-readInt16Stream :: FilePath -> IO [Int]-readInt16Stream fileName =-   bracket (openBinaryFile fileName ReadMode) hClose-      getInt16Stream--{- |-In contrast to hGetContents this is strict!--}-getInt16Stream :: Handle -> IO [Int]-getInt16Stream h =-   alloca $-      \p -> fmap (map P98.fromIntegral)-                 (unfoldM (getInt16 h p))---- candidate for Utility-unfoldM :: Monad m => m (Maybe a) -> m [a]-unfoldM act =-   let listM = maybe (return []) (\x -> liftM (x:) listM) =<< act-   in  listM--getInt16 :: Handle -> Ptr Int16 -> IO (Maybe Int16)-getInt16 h p =-   do cnt <- hGetBuf h p (sizeOf (undefined::Int16))-      case cnt of-        0 -> return Nothing-        2 -> fmap Just (peek p)-        _ -> return (error "getInt16: only one byte found")
+ src/Demonstration.hs view
@@ -0,0 +1,6 @@+module Main where++import qualified Synthesizer.Dimensional.RateAmplitude.Demonstration as Demo++main :: IO ()+main = Demo.main
− src/Filter/Basic.hs 
@@ -1,57 +0,0 @@-{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}-module Filter.Basic where--import qualified Algebra.Transcendental as Trans-import qualified Algebra.Module         as Module-import qualified Algebra.RealField      as RealField-import qualified Number.Complex         as Complex--import NumericPrelude-import PreludeBase--{- todo:-    - support of data before time 0-       - the problem is that all past data has to be kept,-         the garbage collector can't flush it :-(-       - this means we will also need functions for plain lists,-         in this case we can't provide initial conditions to recursive filters-       - the question of initial conditions is especially problematic-         since for Graphs we have no explicit feed back-         where initial conditions can be plugged in-       - thus for two-way signal we must request the user-         to insert initial conditions in every loop of a Graph-         using the Past constructor-    - all of the following filter primitives in static and modulated form:-       - mask-       - integer delay-       - fractional delay-          - shall the fractional delay constructor store the interpolation type?-            (this discussion is similar to the one concerning-             initial conditions for recursive filters)-             - yes, because each delay may use a different interpolation type,-                    if no fractional delay is used,-                     no interpolation type needs to be specified-             - no, because the interpolation is only of interest for filter-                   application not for the transfer function-    - Is there a way to avoid the multi-parameter type class?-       - Can we provide a class for lists (OneWay and TwoWay)-         that help implementing filters and filter networks?-       - The 'transferFunction' obviously does not depend on the signal list type.-    - 'transferFunction' should not be restricted to complex numbers.-       - For arguments of type 'Ratio (Polynomial Rational)'-         you could compute the transfer function in terms of a rational function.--}--screw :: Trans.C a => a -> [Complex.T a]-screw w = iterate (Complex.cis w *) 1---class Filter list filter | filter -> list where-   {-| Apply a filter to a signal. -}-   apply :: (RealField.C t, Trans.C t,-             Module.C a v, Module.C a (list v)) =>-               filter t a v -> list v -> list v-   {-| Compute the complex amplification factor-       that is applied to the given frequency. -}-   transferFunction :: (Trans.C t, Module.C a t) =>-               filter t a v -> t -> Complex.T t
− src/Filter/Composition.hs 
@@ -1,146 +0,0 @@-{-# OPTIONS -fglasgow-exts -fno-implicit-prelude -fallow-undecidable-instances #-}-module Filter.Composition where--import Filter.Basic (Filter,apply,transferFunction)--import qualified Algebra.Module         as Module-import qualified Algebra.Transcendental as Trans-import qualified Algebra.RealField      as RealField-import qualified Algebra.Field          as Field-import qualified Algebra.Additive       as Additive-import qualified Number.Complex         as Complex--import Algebra.Additive ((+))--import PreludeBase-import NumericPrelude--{- todo:-    - functions that build a FilterComposition for specific filters-        (1st order, universal, allpass, butterworth, chebyshev)-    - functions that turn physical filter parameters into-        internal ones-    - How can these function be combined?-      A function like-         [ FilterComposition v [m] ] -> FilterComposition v [[m]]-      is not satisfying, since the conversion function cannot rely-      that the structure of all FilterComposition v [m] is equal.-      If the list is empty the structure can't even be reconstructed.--}--{-|-  This describes a generic filter with one input and one main output-  that consists of non-recursive and recursive parts.-  If you use Feedback, make sure that at least-  one of the filters of a circle includes a delay,-  otherwise the recursion will fail.-  The main output is used to glue different parts together.-  Additionally the functions 'apply' and 'transferFunction'-  provide the signals at every node of the network.--}-data T filter t a v =-     Prim (filter t a v)-       {-^ a filter primitve -}-   | Serial   [T filter t a v]-       {-^ serial chain of filters -}-   | Parallel [T filter t a v]-       {-^ filters working parallel, there output is mixed together -}-   | Feedback (T filter t a v) (T filter t a v)-       {-^ filter the signal in the forward direction and-           feed back the output signal filtered by the second filter -}--{-|-  This is the data structure is used for the results-  of 'apply' and 'transferFunction'.-  Each constructor corresponds to one of 'Filter.Composition.T'.-  By choosing only some of the outputs-  the lazy evaluation will content-  with applying the necessary filter steps, only.--}-data Sockets s = Sockets {output :: s, socket :: SocketSpec s}--data SocketSpec s =-     Output-   | Multiplier [Sockets s]-   | Adder [Sockets s]-   | Loop (Sockets s) (Sockets s)--instance (Filter list filter) =>-      Filter (list) (T filter) where-{--   apply :: (Module.C a v) =>-      FilterComposition a v -> TwoWayList v -> TwoWayList v--}-   apply f x = output (applyMulti f x)-{--   transferFunction :: (Trans.C b, Module.C a (Complex.T b)) =>-      T filter a v -> b -> (Complex.T b)--}-   transferFunction f w = output (transferFunctionMulti f w)---{-| Apply a filter network to a signal and keep the output of all nodes.-    Generic function that is wrapped by 'apply'. -}-applyMulti :: (RealField.C t, Trans.C t,-      Module.C a v, Module.C a (list v), Filter list filter) =>-   T filter t a v -> list v -> Sockets (list v)-applyMulti (Prim f) x =-   Sockets (apply f x) Output-applyMulti (Serial fs) x =-   let sq = scanl (\(Sockets y _) -> flip applyMulti y) (Sockets x Output) fs-   in  Sockets (output (last sq)) (Multiplier (tail sq))-applyMulti (Parallel fs) x =-   let socks = map (flip applyMulti x) fs-       y = foldr (Additive.+) zero (map output socks)-   in  Sockets y (Adder socks)-{- the distinction between 'feed' and 'back'-   can be dropped in a more general net structure -}-applyMulti (Feedback feed back) x =-   let sockY@(Sockets y _) = applyMulti feed ((Additive.+) x z)-       sockZ@(Sockets z _) = applyMulti back y-   in  Sockets y (Loop sockY sockZ)---transferFunctionMulti ::-   (Trans.C t, Module.C a t, Filter list filter) =>-      T filter t a v -> t -> Sockets (Complex.T t)-transferFunctionMulti f w = tfAbsolutize 1 (tfRelative w f)--{-| Compute the transitivity for each part of the filter network.-    We must do this in such a relative manner to be able-    to compute feedback. -}-tfRelative ::-   (Trans.C t, Module.C a t, Filter list filter) =>-      t -> T filter t a v -> Sockets (Complex.T t)-tfRelative w (Prim f) =-   Sockets (Filter.Basic.transferFunction f w) Output-tfRelative w (Serial fs) =-   let sq = map (tfRelative w) fs-   in  Sockets (product (map output sq)) (Multiplier sq)-tfRelative w (Parallel fs) =-   let sq = map (tfRelative w) fs-   in  Sockets (sum (map output sq)) (Adder sq)-tfRelative w (Feedback feed back) =-   let sockY = tfRelative w feed-       sockZ = tfRelative w back-       q = output sockY / (1 - output sockZ)-   in  Sockets q (Loop sockY sockZ)---{-| Make the results from 'tfRelative' absolute. -}-tfAbsolutize :: (Field.C a) => a -> Sockets a -> Sockets a-tfAbsolutize x (Sockets y spec) = Sockets (x*y)-   (case spec of-      (Multiplier socks) ->-         let sq = scanl (\(Sockets z _) -> tfAbsolutize z)-                        (Sockets x Output) socks-         in  Multiplier (tail sq)-      (Adder socks) ->-         let sq = map (tfAbsolutize x) socks-         in  Adder sq-      (Loop feed back) ->-         let sockY = tfAbsolutize (x / (1 - output back)) feed-             sockZ = tfAbsolutize (output sockY) back-             -- it should be  x*y == output sockY-         in  Loop sockY sockZ-      Output -> spec)
− src/Filter/Example.hs 
@@ -1,241 +0,0 @@-{-# OPTIONS -fno-implicit-prelude #-}-module Filter.Example where--import Filter.Basic-import qualified Filter.OneWay-import qualified Filter.TwoWay-import Filter.Composition-import qualified Filter.Graph-import qualified Synthesizer.Plain.Interpolation as Interpolation--import qualified Synthesizer.Plain.Oscillator as Osci-import qualified Synthesizer.Basic.Wave       as Wave-import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1-import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR--import qualified Algebra.Module         as Module-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 Data.Maybe (fromMaybe)--import PreludeBase-import NumericPrelude----{-* Reconstruction of the sound of a plucked guitar string -}--guitarInit :: Field.C a => [a]-guitarInit = map (/128) (-      1 :    1 :    1 :    1 :    1 :    1 :    1 :    1 :-      1 :    2 :    2 :    2 :    2 :    2 :    2 :    2 :-      2 :    2 :    2 :    2 :    2 :    2 :    2 :    2 :-      2 :    2 :    2 :    3 :    3 :    3 :    3 :    3 :-      3 :    3 :    3 :    3 :    3 :    3 :    3 :    3 :-      3 :    3 :    3 :    4 :    4 :    4 :    4 :    4 :-      4 :    4 :    4 :    4 :    4 :    4 :    4 :    4 :-      5 :    5 :    5 :    5 :    5 :    5 :    5 :    5 :-      6 :    6 :    6 :    7 :    7 :    8 :    8 :    9 :-     10 :   11 :   12 :   13 :   14 :   15 :   15 :   16 :-     17 :   17 :   17 :   18 :   18 :   18 :   18 :   18 :-     18 :   18 :   18 :   17 :   17 :   16 :   16 :   15 :-     15 :   14 :   14 :   14 :   13 :   13 :   14 :   14 :-     15 :   16 :   17 :   18 :   19 :   20 :   22 :   23 :-     25 :   27 :   30 :   32 :   35 :   37 :   39 :   41 :-     43 :   45 :   47 :   48 :   49 :   49 :   48 :   46 :-     41 :   34 :   24 :   11 :   -6 :  -26 :  -48 :  -72 :-    -96 : -114 : -128 : -128 : -128 : -128 : -128 : -128 :-   -128 : -125 : -110 :  -93 :  -75 :  -57 :  -41 :  -27 :-    -17 :  -10 :   -6 :   -4 :   -2 :   -2 :   -2 :   -2 :-     -2 :   -3 :   -4 :   -4 :   -5 :   -6 :   -7 :   -8 :-     -9 :  -10 :  -11 :  -12 :  -12 :  -12 :  -13 :  -13 :-    -13 :  -13 :  -13 :  -13 :  -12 :  -12 :  -11 :  -10 :-     -9 :   -9 :   -8 :   -8 :   -7 :   -6 :   -6 :   -5 :-     -5 :   -5 :   -5 :   -4 :   -4 :   -4 :   -4 :   -4 :-     -4 :   -4 :   -4 :   -4 :   -4 :   -5 :   -7 :   -8 :-     -8 :   -9 :  -10 :  -11 :  -12 :  -13 :  -13 :  -14 :-    -14 :  -14 :  -13 :  -10 :   -7 :   -2 :    5 :   15 :-     26 :   37 :   49 :   61 :   73 :   83 :   92 :   99 :-    105 :  109 :  111 :  112 :  110 :  105 :   99 :   90 :-     80 :   71 :   63 :   57 :   52 :   49 :   47 :   47 :-     48 :   49 :   51 :   51 :   52 :   52 :   50 :   48 :-     42 :   34 :   22 :    7 :  -12 :  -32 :  -56 :  -78 :-    -96 : -114 : -127 : -128 : -128 : -128 : -128 : -128 :-   -128 : -118 : -102 :  -83 :  -67 :  -50 :  -37 :  -26 :-    -17 :  -12 :   -8 :   -5 :   -3 :   -3 :   -2 :   -2 :-     -2 :   -3 :   -4 :   -4 :   -6 :   -7 :   -8 :  -10 :-    -11 :  -12 :  -12 :  -13 : [])--guitarCompShort, guitarCompLong ::-   Field.C a => [a] -> Filter.Composition.T Filter.TwoWay.T Double a a-guitarCompShort past = Feedback (Prim (Filter.TwoWay.Past past)) (Parallel [-   Serial [Prim (Filter.TwoWay.Delay   1),-           Prim (Filter.TwoWay.Mask [0.6519177892575342, 0.2331904728998289])],-   Serial [Prim (Filter.TwoWay.Delay 126),-           Prim (Filter.TwoWay.Mask [0.08253506238277844,-               0.2369601607320473,   0.18367848836060044,-              -0.06422525077173147, -0.31836517142623727])]])-guitarCompLong past = Feedback (Prim (Filter.TwoWay.Past past)) (-   Serial [Prim (Filter.TwoWay.Delay 122),-           Prim (Filter.TwoWay.Mask [-              -0.23742303494466988,-               0.020278040917954415,-               0.12495333789385828,-               0.16125537461091102,-               0.1993410924766678,-               0.24673057006071691,-               0.25438881375430467,-               0.1424676847770117,-               0.03848071949084291,-              -0.016618282409355676,-              -0.04517323927531556,-              -0.0061713683480988475,-               0.11137126130878339-             ])])--{-| Reconstruct the guitar sound from the sampled initial wave-    and the analysed feedback factors.-    This sounds pretty like the sampled sound. -}-guitarRaw :: (Field.C a, Module.C a a) => [a]-guitarRaw =-   let gi = guitarInit  -- assert monomorphism-       y = Filter.TwoWay.future-              (Filter.TwoWay.delay (length gi)-                 (apply (guitarCompLong (reverse gi))-                        (Filter.TwoWay.Signal [] [])))-   in  y--{-| Reconstruct the guitar sound from the sampled initial wave-    but with simple smoothing on feedback.-    This sounds more statically. -}-guitarRawSimple :: (Field.C a, Module.C a a) => [a]-guitarRawSimple =-   let gi = guitarInit  -- assert monomorphism-       y  = gi ++ drop (length gi)-              (FiltNR.delay 128 (Filt1.lowpass-                 (repeat (Filt1.Parameter (0.4  `asTypeOf` head y))) y))-   in  y--{-| Reconstruct the guitar sound with the analysed feedback factors-    but with an synthetic initial wave.-    The sharpness of the initial wave can be controlled.-    This is used to implement various velocities. -}-guitarRawVelo :: (Real.C a, Trans.C a, Module.C a a) => a -> [a]-guitarRawVelo velo =-   let len  = 128::Int-       wave =-          map (Wave.power01Normed velo)-             (take len (iterate (+ 2 / fromIntegral len) (-1)))-       y = Filter.TwoWay.future-              (Filter.TwoWay.delay len-                 (apply (guitarCompLong wave)-                        (Filter.TwoWay.Signal [] [])))-   in  y---{-| Resample the reconstructed string sound-    so that notes can be played. -}-guitar :: (RealField.C a, Module.C a a) => a -> [a]-guitar freq =-   let srcFreq = 128 * freq-   in  Interpolation.multiRelativeZeroPadLinear 0-          (repeat (srcFreq `asTypeOf` freq)) guitarRawSimple----{-* Tests for FilterGraphs -}--type CompositionDouble =-        Filter.Composition.T Filter.TwoWay.T Double Double Double--{-| a simple lowpass used to create an exponential2 -}---expo :: (RealField.C a, Module.C a a) => Filter.TwoWay.Signal a-expo :: Filter.TwoWay.Signal Double-expo =-   let _flt1 = Feedback (Serial [Prim (Filter.OneWay.Delay ([0] `asTypeOf` past))])-                       (Serial [Prim (Filter.OneWay.Mask-                                        ([0.9] `asTypeOf` past))])-       _flt2 = (Prim (Filter.TwoWay.Mask ([0.5] `asTypeOf` past)))-                 :: CompositionDouble-       flt3 = (Feedback (Serial [])-                        (Prim (Filter.TwoWay.Delay 1)))-                 :: CompositionDouble-       Filter.TwoWay.Signal past future = apply flt3 (Filter.TwoWay.Signal [] [1])-   in  Filter.TwoWay.Signal past (take 10 future)--type GraphDouble f = Filter.Graph.T f Int Double Double Double--simpleGraph :: Filter.TwoWay.Signal Double-simpleGraph =-   let out =-          Filter.Graph.apply-             (Filter.Graph.fromList-                [(0, []),-                 (1, [(0, Filter.TwoWay.Delay (-1))]),-                 (2, [(1, Filter.TwoWay.Mask [0.95])])] ::-                    GraphDouble Filter.TwoWay.T)-             (Filter.Graph.signalFromList-                [(0, Filter.TwoWay.Signal [] [1])])-   in  fromMaybe (error "requested output of non-existing socket")-                 (Filter.Graph.lookupSignal out (2::Int))--expoGraphTwoWay :: [Double]-expoGraphTwoWay =-   let out =-          Filter.Graph.apply-             (Filter.Graph.fromList-                [(0, [(2, Filter.TwoWay.Past [1])]),-                 (1, [(0, Filter.TwoWay.Delay 1)]),-                 (2, [(1, Filter.TwoWay.Mask [0.95])])] ::-                    GraphDouble Filter.TwoWay.T)-             (Filter.Graph.signalFromList-                [(0, Filter.TwoWay.Signal [] [])])-   in  Filter.TwoWay.take 20 $ Filter.TwoWay.delay 10-          (fromMaybe (error "requested output of non-existing socket")-             (Filter.Graph.lookupSignal out (0::Int)))---expoGraph :: [Double]-expoGraph =-   let out =-          Filter.Graph.apply-             (Filter.Graph.fromList-                [(0, [(1, Filter.OneWay.Delay [0])]),-                 (1, [(0, Filter.OneWay.Mask [0.99])])] ::-                    GraphDouble Filter.OneWay.T)-             (Filter.Graph.signalFromList-                [(0, [1])])-   in  fromMaybe (error "requested output of non-existing socket")-                 (Filter.Graph.lookupSignal out (0::Int))--{-| make recursive flanger with help of the two way interpolation -}-flangedSaw :: Double -> [Double]-flangedSaw sampleRate =-   let {- The flanger's principal filter frequency will vary between-          flangeFreq * 2**flangeRange and flangeFreq / 2**flangeRange -}-       flangeFreq  = 1000-       flangeRange = 2-       sawFreq     = 440-       gain = 0.6-       vol  = 0.5--       {- 'control' contains the feedback times -}-       control  = map (\c -> sampleRate/flangeFreq * 2**(-flangeRange*c))-                      (map sin (iterate (pi/(0.5*sampleRate)+) 0))-       sawPast   = Osci.freqModSaw 0 (repeat (-sawFreq/sampleRate))-       sawFuture = Osci.freqModSaw 0 (repeat ( sawFreq/sampleRate))-       --lowNoise = amplify vol noise-       flt = Feedback-                (Prim (Filter.TwoWay.Mask [vol]))-                (Serial [Prim (Filter.TwoWay.Mask [gain]),-                         Prim (Filter.TwoWay.Past []),-                         Prim (Filter.TwoWay.ModFracDelay-                                  Interpolation.linear -                                     (Filter.TwoWay.Signal [] control))])-                :: CompositionDouble--   in  Filter.TwoWay.future-          (apply flt (Filter.TwoWay.Signal sawPast sawFuture))
− src/Filter/Fix.hs 
@@ -1,38 +0,0 @@-module Filter.Fix where--import qualified Filter.Graph as Graph---{-|-A 'Graph.T' with numbered nodes is not very comfortable.-Better provide a 'Control.Monad.Fix.fix'-like function-which allows to enter a graph this way:--> fix $ \[v,w,y] ->-> [a·(u + d·w),->  b·(v + e·y),->  c· w]---}--type T filter t a v  =-   [Channel filter t a v] -> [[(Channel filter t a v, filter t a v)]]--type ChannelId = Int--data Channel filter t a v =-   Channel {channelId     :: ChannelId,-            channelInputs :: [(ChannelId, filter t a v)]}---fix :: T filter t a v -> [Channel filter t a v]-fix f =-   let cs = zipWith (\n inputs ->-               Channel n (map (\(c,filt) -> (channelId c, filt)) inputs))-               [0 ..] (f cs)-   in  cs---toGraph :: T filter t a v -> Graph.T filter Int t a v-toGraph =-   Graph.fromList . map (\(Channel n inputs) -> (n, inputs)) . fix
− src/Filter/Graph.hs 
@@ -1,178 +0,0 @@-{-# OPTIONS -fglasgow-exts -fallow-undecidable-instances -fno-implicit-prelude #-}-module Filter.Graph where--import qualified Prelude as P-import PreludeBase-import NumericPrelude--import Filter.Basic(Filter,apply,transferFunction)-import qualified Data.Map as Map-import Data.Map(Map)-import MathObj.DiscreteMap()  {- Module.C instances for Map -}--import qualified Number.Complex         as Complex-import qualified Algebra.RealField      as RealField-import qualified Algebra.Additive       as Additive-import qualified Algebra.Transcendental as Trans-import qualified Algebra.Module         as Module-import Algebra.Module((*>))-import Orthogonals(Scalar,inverse,add_to_diagonal)---{-|-A filter network is a graph consisting-of nodes (input and output signals)-and edges (filter processes).-Output signals can be taken from every node,-inputs can be injected in some nodes-which means that the signal at this node is superposed with-the injected signal.-The same can be achieved by duplicating the network,-one duplicate per input,-and superposing the corresponding outputs.-It is also sensible to setup a graph without inputs,-e.g. a recursive filter with some initial conditions-that works independent from any input.--In opposition to electric filter networks-digital filter networks must be directed.--Test-case: leap-frog filters like-->     +-----------[d]-----------+->     v                         |->(u) -+-> [a] (v) -+-> [b] (w) -+-> [c] (y) -+->->                  ^                         |->                  +-----------[e]-----------+--@-v = a·(u + d·w)-w = b·(v + e·y)-y = c· w-@--We model the general network by a list of nodes,-where each node is an adder that holds a list of its inputs.-Each input of a node is an output-of another node that has gone through a processor.-Additionally there may be one input from outside.-In principle a processor could be a simple filter network-as defined by the structure 'Filter'.--The network is an applyable filter-whenever each circle contains a delay.-To compute the transfer function-we have to solve a system of linear equations-which we can construct quite straight forward-from the processors' input lists.--The current design can be abstractly seen-as the system of linear equations:--  y = A*y + u--where A is a matrix containing the edges hosting the filters,-y the vector of output signals,-u the vector of input signals.-In this formulation the number of inputs and outputs must match-but since you are free to ignore some of the inputs and outputs-you can use nodes for pure output, pure input or both of them.---}--newtype T filter i t a v =-   C (Map i-      [(i,          {- index of the processor whose output goes in here -}-        filter t a v  {- description of the filter -}-        )])---newtype Signal list i v = Signal (Map i (list v))---fromList :: (Ord i) => [(i, [(i, filter t a v)])] -> T filter i t a v-fromList = C . Map.fromList--toList :: T filter i t a v -> [(i, [(i, filter t a v)])]-toList (C fg) = Map.toList fg--signalFromList :: (Ord i) => [(i, list v)] -> Signal list i v-signalFromList = Signal . Map.fromList--signalToList :: Signal list i v -> [(i, list v)]-signalToList (Signal x) = Map.toList x--lookupSignal :: (Ord i) => Signal list i v -> i -> Maybe (list v)-lookupSignal (Signal x) = flip Map.lookup x---{--  These instance may help to include FilterGraphs-  in even bigger structures.--}-instance (Ord i, Additive.C (list v), Eq (list v))-            => Additive.C (Signal list i v) where-   zero                      = Signal Additive.zero-   (+) (Signal x) (Signal y) = Signal ((Additive.+) x y)-   (-) (Signal x) (Signal y) = Signal ((Additive.-) x y)-   negate (Signal x)         = Signal (Additive.negate x)--instance (Ord i, Eq a, Additive.C a, Additive.C (list v), Eq (list v),-              Module.C a v, Module.C a (list v))-                 => Module.C a (Signal list i v) where-   s *> (Signal x) = Signal (s *> x)---{--   It would be interesting to make FilterGraphs-   an instance of Filter.-   To achieve that we had to make GraphSignals an instance of Module.C-   and the transferFunction would no longer return a factor-   but a function that maps input amplitudes-   of a given frequency to output amplitudes.--instance (Ord i, Show i, Filter list filter) =>-      Filter (Signal list i) (T filter i) where--}--apply :: (Ord i, Show i, Additive.C t, Trans.C t, RealField.C t,-          Module.C a v, Module.C a (list v),-          Filter list filter) =>-   T filter i t a v -> Signal list i v -> Signal list i v-apply (C fg) (Signal inputs) =-   let getInput  i = Map.findWithDefault Additive.zero i inputs-       getOutput i = Map.findWithDefault-                         (error ("Unknown processor: "++show i)) i outputs-       output i edges =-          foldl (Additive.+) (getInput i) (map (\(j,f) ->-                   Filter.Basic.apply f (getOutput j)) edges)-       outputs = Map.mapWithKey output fg-   in  Signal outputs--{-| Compute a matrix that tells how an input frequency-    is mapped to the various output nodes.--   According to the formulation given above-   we have to invert the matrix (I-A).--   Currently this is done by a QR decomposition for each frequency.-   It would be probably faster if we decompose-   the matrix containing polynomial elements.-   Then the inverted matrix would consist of some-   polynomial ratios which can be evaluated for each frequency.--}-transferFunction ::-   (Ord i, Show i, Trans.C t,-    P.Fractional (Complex.T t), Scalar (Complex.T t),-      Module.C a t, Filter list filter) =>-         T filter i t a v -> t -> [[Complex.T t]]-transferFunction (C fg) w =-   let keys = Map.keys fg-       elts = Map.elems fg-       inputsToMap procs =-          Map.mapWithKey (\_ f -> Filter.Basic.transferFunction f w)-                         (Map.fromList procs)-       makeRow procs =-          map (flip (Map.findWithDefault 0) (inputsToMap procs)) keys-       matrix = map makeRow elts-   in  inverse (add_to_diagonal (-1) matrix)
− src/Filter/Graphic.hs 
@@ -1,7 +0,0 @@-module Filter.Graphic where--{-|-  This module should be populated with functions-  that create flowchart graphics from the filter networks-  of the 'Composition' module.--}
− src/Filter/MonadFix.hs 
@@ -1,43 +0,0 @@-module Filter.MonadFix where--import qualified Filter.Graph as Graph-import qualified Filter.Fix   as FFix--import Filter.Fix (Channel(Channel), ChannelId)--import Control.Monad.State (StateT, evalStateT, get, modify, lift)-import Control.Monad.Writer (Writer, execWriter, tell)---{-|-If you find 'Filter.Fix.T' still inconvenient,-and if you don't care about portability,-you can also use the following monad with the @mdo@ notation.--> mdo->   v <- a·(u + d·w)->   w <- b·(v + e·y)->   y <- c· w---}---type T filter t a v x  =  StateT ChannelId (Writer [Channel filter t a v]) x--makeChannel ::-   [(ChannelId, filter t a v)] ->-   T filter t a v ChannelId-makeChannel inputs =-   do n <- get-      modify succ-      lift $ tell [Channel n inputs]-      return n---run :: T filter t a v x -> [Channel filter t a v]-run m = execWriter (evalStateT m 0)---toGraph :: T filter t a v x -> Graph.T filter Int t a v-toGraph =-   Graph.fromList . map (\(Channel n inputs) -> (n, inputs)) . run
− src/Filter/OneWay.hs 
@@ -1,74 +0,0 @@-{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}-module Filter.OneWay where--import Filter.Basic--import qualified Synthesizer.Plain.Interpolation as Interpolation-import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR-import Number.Complex(cis)--import qualified Algebra.Module   as Module-import qualified Algebra.Ring     as Ring-import qualified Algebra.Additive as Additive--import Algebra.Module(linearComb)-import Algebra.Additive(zero)--import PreludeBase-import NumericPrelude--type Signal = []--{-| shift signal in time -}-delay :: (Additive.C v) =>-   Int -> Signal v -> Signal v-delay = FiltNR.delayPad zero--delayOnce :: (Additive.C v) =>-   Signal v -> Signal v-delayOnce = (zero:)---{-| Unmodulated non-recursive filter -}-nonRecursiveFilter :: Module.C a v =>-      [a] -> [v] -> [v]-nonRecursiveFilter = FiltNR.generic--{-| Modulated non-recursive filter. -}-nonRecursiveFilterMod :: Module.C a v =>-   [[a]] -> [v] -> [v]-nonRecursiveFilterMod ms x =-   zipWith linearComb ms (tail (scanl (flip (:)) [] x))---{-| Description of a basic filter that can be used in larger networks. -}-data T t a v =-     Mask [a]-        {-^ A static filter described by its mask -}-   | ModMask (Signal [a])-        {-^ A modulated filter described by a list of masks -}-   | FracDelay (Interpolation.T t v) t-        {-^ Delay the signal by a fractional amount of samples.-            This is achieved by interpolation. -}-   | ModFracDelay (Interpolation.T t v) (Signal t)-        {-^ Delay with varying delay times.-            The delay times sequence must monotonically decrease.-            (This includes constant parts!) -}-   | Delay [v]-        {-^ Delay the signal by prepending another one -}--instance Filter [] T where--   apply (Mask         m)     = nonRecursiveFilter m-   apply (ModMask      m)     = nonRecursiveFilterMod m-   apply (FracDelay    ip t)  = Interpolation.multiRelativeZeroPad zero-                                   ip (-t) (repeat 1)-   apply (ModFracDelay ip ts) = Interpolation.multiRelativeZeroPad zero-                                   ip (- head ts) (repeat 1 - FiltNR.differentiate ts)-   apply (Delay        x)     = (x++)--   transferFunction (Mask        m) w = linearComb m (screw (negate w))-   transferFunction (FracDelay _ t) w = cis (negate w * t)-   transferFunction (Delay       x) w = cis (negate w * fromIntegral (length x))-   transferFunction _ _ =-      error "transfer function can't be computed for modulated filters"
− src/Filter/TwoWay.hs 
@@ -1,245 +0,0 @@-{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}-module Filter.TwoWay where--import Filter.Basic--import Synthesizer.Plain.Interpolation (minLength,)-import qualified Synthesizer.Plain.Interpolation as Ip-import qualified Synthesizer.Plain.Interpolation as Interpolation--import Algebra.Module(linearComb,(*>))--import qualified Algebra.Module    as Module-import qualified Algebra.RealField as RealField-import qualified Algebra.Ring      as Ring-import qualified Algebra.Additive  as Additive--import Number.Complex(cis)-import Synthesizer.Utility(nest)-import qualified Data.List as List--import PreludeBase hiding (take)-import NumericPrelude---{-| A TwoWay.Signal stores values of the past and the future -}-data Signal v = Signal {past, future :: [v]}-   deriving (Show, Eq)--{-| Take n values starting from time zero.-    If you want clips from elsewhere,-    call 'take' after 'delay'. -}-take :: Int -> Signal v -> [v]-take n (Signal _ x) = List.take n x--zipSignalWith :: (a -> b -> c) -> Signal a -> Signal b -> Signal c-zipSignalWith f (Signal xPast xFuture) (Signal yPast yFuture) =-   (Signal (zipWith f xPast yPast) (zipWith f xFuture yFuture))--{-| Take the value at time zero. -}-origin :: Ring.C a => Signal a -> a-origin (Signal _ (x:_)) = x-origin _ = 0--{-| A signal that consists entirely of ones -}-ones :: Ring.C a => Signal a-ones = Signal (repeat 1) (repeat 1)--{-| shift signal in time,-    keep all values but if required pad with zeros -}-delay :: (Additive.C v) =>-   Int -> Signal v -> Signal v-delay = delayGen delayOnce--delayPad :: v -> Int -> Signal v -> Signal v-delayPad z = delayGen (delayPadOnce z)--{-| shift signal in time,-    zero values at either ends will be flushed -}-delayOpt :: (Eq v, Additive.C v) =>-   Int -> Signal v -> Signal v-delayOpt = delayGen delayOptOnce---{-| Delay by one sample. -}-delayOnce :: (Additive.C v) =>-   Signal v -> Signal v---delayOnce (Signal []     []) = ([],[])-delayOnce (Signal []     ys) = Signal [] (zero:ys)-delayOnce (Signal (x:xs) ys) = Signal xs (x:ys)--delayPadOnce :: v -> Signal v -> Signal v---delayPadOnce _ (Signal []     []) = ([],[])-delayPadOnce z (Signal []     ys) = Signal [] (z:ys)-delayPadOnce _ (Signal (x:xs) ys) = Signal xs (x:ys)--delayOptOnce :: (Eq v, Additive.C v) =>-   Signal v -> Signal v---delayOptOnce (Signal []     []) = Signal [] []-delayOptOnce (Signal []     ys) = Signal [] (zero:ys)-delayOptOnce (Signal (x:xs) []) = Signal xs (if x==zero then [] else x:[])-delayOptOnce (Signal (x:xs) ys) = Signal xs (x:ys)---{-| General routine that supports delaying and prefetching-    using a general one-sample delaying routine. -}-delayGen :: (Signal v -> Signal v) ->-               Int -> Signal v -> Signal v-{- Using this optimization applications of recursive filters-   with zero initial conditions represented by an empty list will fail.-   This is because in this case the value of the first item of the future list-   depends on the first item of the input future list,-   whereas normally the first future value depends on no input future value,-   at all.-delayGen _ _ (Signal [] []) = Signal [] []-   cf. the next example -}-delayGen delOnce t =-    if t < 0-    then reverseTwoWay . nest (negate t) delOnce . reverseTwoWay-    else nest t delOnce--reverseTwoWay :: Signal v -> Signal v-reverseTwoWay (Signal x y) = Signal y x---instance (Additive.C v) => Additive.C (Signal v) where-   zero                                = Signal zero zero-   (+)   (Signal y0 y1) (Signal x0 x1) = Signal (y0 + x0)   (y1 + x1)-   (-)   (Signal y0 y1) (Signal x0 x1) = Signal (y0 - x0)   (y1 - x1)-   negate               (Signal x0 x1) = Signal (negate x0) (negate x1)--instance (Module.C a v) => Module.C a (Signal v) where-   (*>)  s      (Signal x0 x1) = Signal (s *> x0) (s *> x1)-----{-| for a Signal this means a reversion of the elements -}-flipPair :: (a,b) -> (b,a)-flipPair (x,y) = (y,x)--{- This example simulates what happens if you call-     apply (Feedback (Serial []) (Prim (Delay 1)) []) ([],[1])-   depending on the implementation of delayGen it may work or-   loop infinitely when yFuture is computed.-   It's even before the first element of yFuture is computed.-   Note, that the equivalent-     apply (Feedback (Serial []) (Prim (Delay 1)) [0]) ([],[1])-   works! (i.e. set yPast = [0] -}-testDelayGen :: Signal Double-testDelayGen =-   let yPast = []-       x = Signal [] [1]-       y = Signal yPast yFuture-       Signal _ yFuture = delayOnce (x + y)-       -- Signal _ yFuture = delayOptOnce (add x y)-       -- Signal _ yFuture = delayGen delayOnce 1 (add x y)-   in  Signal yPast (List.take 10 yFuture)----{-| Unmodulated non-recursive filter -}-nonRecursiveFilter :: Module.C a v =>-      [a] -> Signal v -> Signal v-nonRecursiveFilter m x =-   linearComb m (iterate delayOnce x)--{-| Modulated non-recursive filter.-    The number of values before time 0 (past) or-    the filter mask lengths must be at most finite. -}-nonRecursiveFilterMod :: Module.C a v =>-   Signal [a] -> Signal v -> Signal v-nonRecursiveFilterMod (Signal mpre msuf) x =-   let (pre, suf) = unzip (map (\(Signal a b) -> (a,b)) (iterate delayOnce x))-   in  Signal (zipWith linearComb mpre pre) (zipWith linearComb msuf suf)---{-| Interpolation allowing negative frequencies,-    but requires storage of all past values. -}-interpolatePaddedZero :: (Ord a, RealField.C a) =>-   b -> Interpolation.T a b-      -> a -> Signal a -> Signal b -> Signal b-interpolatePaddedZero z ip phase fs (Signal xPast xFuture) =-   let (phInt, phFrac) = splitFraction phase-       xPadded = Signal (xPast ++ repeat z) (xFuture ++ repeat z)-   in  interpolateCore ip phFrac fs-          (delayPad z (Ip.offset ip - phInt) xPadded)--interpolatePaddedCyclic :: (Ord a, RealField.C a) =>-   Interpolation.T a b-      -> a -> Signal a -> Signal b -> Signal b-interpolatePaddedCyclic ip phase fs (Signal xPast xFuture) =-   let (phInt, phFrac) = splitFraction phase-       xCyclic = xFuture ++ reverse xPast-   in  interpolateCore ip phFrac fs-          -- mod is for efficiency, only-          (delayPad (error "interpolate: infinite signal needs no zero padding")-                    (mod (Ip.offset ip - phInt) (length xCyclic))-                    (Signal (cycle (reverse xCyclic)) (cycle xCyclic)))---- note that the extrapolation may miss some of the first and some of the last points-interpolatePaddedExtrapolation :: (Ord a, RealField.C a) =>-   Interpolation.T a b-      -> a -> Signal a -> Signal b -> Signal b-interpolatePaddedExtrapolation ip phase fs x =-   interpolateCore ip (phase - fromIntegral (Ip.offset ip)) fs x--interpolateCore :: (Ord a, Ring.C a) =>-   Interpolation.T a b -> a -> Signal a -> Signal b -> Signal b-interpolateCore ip phase (Signal freqPast freqFuture) x =-   Signal (interpolateHalfWay ip (1-phase) freqPast-             (delayPadOnce (error "interpolateCore: infinite signal needs no zero padding")-                           (reverseTwoWay x)))-          (interpolateHalfWay ip phase freqFuture x)--interpolateHalfWay :: (Ord a, Ring.C a) =>-   Interpolation.T a b -> a -> [a] -> Signal b -> [b]-interpolateHalfWay ip phase freqs (Signal xPast xFuture) =-    if phase >= 1 && minLength (1+Ip.number ip) xFuture-    then interpolateHalfWay ip (phase-1) freqs-            (Signal (head xFuture : xPast) (tail xFuture))-    else if phase < 0 && minLength 1 xPast-         then interpolateHalfWay ip (phase + 1) freqs-                 (Signal (tail xPast) (head xPast : xFuture))-         else Ip.func ip phase xFuture :-              interpolateHalfWay ip (phase + head freqs) (tail freqs)-                 (Signal xPast xFuture)---{-| Description of a basic filter that can be used in larger networks. -}-data T t a v =-     Mask [a]-        {-^ A static filter described by its mask -}-   | ModMask (Signal [a])-        {-^ A modulated filter described by a list of masks -}-   | FracDelay (Interpolation.T t v) t-        {-^ Delay the signal by a fractional amount of samples.-            This is achieved by interpolation. -}-   | ModFracDelay (Interpolation.T t v) (Signal t)-        {-^ Delay with varying delay times. -}-   | Delay Int-        {-^ Delay the signal by given amount of samples. -}-   | Past [v]-        {-^ Replace the past by the given one.-            This must be present in each recursive filter cycle-            to let the magic work! -}--instance Filter Signal T where--   apply (Mask         m)     = nonRecursiveFilter m-   apply (ModMask      m)     = nonRecursiveFilterMod m-   apply (FracDelay    ip t)  = interpolatePaddedZero zero-                                   ip (-t) ones-   apply (ModFracDelay ip ts) = interpolatePaddedZero zero-                                   ip (- origin ts) (ts - delay (-1) ts + ones)-   apply (Delay        t)     = delay t-   apply (Past         x)     = Signal x . future--   {- This is in principle the same as for one way filters.-      How can one merge them? -}-   transferFunction (Mask        m) w = linearComb m (screw (negate w))-   transferFunction (FracDelay _ t) w = cis (negate w * t)-   transferFunction (Delay       t) w = cis (negate w * fromIntegral t)-   transferFunction (Past        _) _ = 1-   transferFunction _ _ =-      error "transfer function can't be computed for modulated filters"
src/OsciDiffEq.hs view
@@ -1,7 +1,7 @@ module OsciDiffEq where  {--ghci -fglasgow-exts -fno-implicit-prelude ../numericprelude/MyPrelude.hs ../numericprelude/NumExtras.lhs ../numericprelude/VectorSpace.lhs ../numericprelude/PreludeBase.lhs ../numericprelude/NumericPrelude.lhs OsciDiffEq.hs+ghci -XNoImplicitPrelude -fglasgow-exts ../numericprelude/MyPrelude.hs ../numericprelude/NumExtras.lhs ../numericprelude/VectorSpace.lhs ../numericprelude/PreludeBase.lhs ../numericprelude/NumericPrelude.lhs OsciDiffEq.hs  import MyPrelude but then (+) ends up in a loop Exception :-(
src/Sound/Signal.hs view
@@ -1,9 +1,12 @@-{-# OPTIONS_GHC -O -fglasgow-exts #-}+{-# OPTIONS_GHC -fglasgow-exts #-} {- glasgow-exts are for the rules -} module Sound.Signal where -import Synthesizer.Utility (viewListL)-import NumericPrelude.Condition (toMaybe)+import qualified Synthesizer.Plain.Signal as Sig++import qualified Data.List.HT as ListHT+import qualified Data.List    as List+import Data.Maybe.HT (toMaybe, ) import Prelude hiding    ((++), iterate, foldl, map, repeat, replicate,     zipWith, zipWith3, take, takeWhile)@@ -27,6 +30,15 @@    zipWith   :: (a -> b -> c) -> s a -> s b -> s c  +instance C [] where+   singleton = (:[])+   unfoldR   = Sig.unfoldR+   reduceL   = Sig.reduceL+   mapAccumL = Sig.mapAccumL+   (++)      = (List.++)+   zipWith   = List.zipWith++ {- Typical examples for neither generate nor crochet:    data from disk@@ -74,7 +86,7 @@  {-# INLINE fromList #-} fromList :: C s => [y] -> s y-fromList = generate viewListL+fromList = generate ListHT.viewL   {-# INLINE iterate #-}@@ -100,8 +112,8 @@ lengthSlow :: C s => s a -> Int lengthSlow = foldL' (const succ) 0 -recurse :: (acc -> Maybe acc) -> acc -> acc-recurse f =+recourse :: (acc -> Maybe acc) -> acc -> acc+recourse f =    let aux x = maybe x aux (f x)    in  aux @@ -216,7 +228,7 @@   "reduceL/generate" forall f g a b.      reduceL g b (generate f a) =         snd-          (recurse (\(a0,b0) ->+          (recourse (\(a0,b0) ->               do (y,a1) <- f a0                  b1 <- g y b0                  return (a1, b1)) (a,b)) ;
src/Sound/Signal/Block.hs view
@@ -7,7 +7,7 @@  import qualified Data.List as List -import NumericPrelude.Condition (toMaybe)+import Data.Maybe.HT (toMaybe) import Prelude hiding ((++), iterate, foldl, zipWith, tail, head)  @@ -85,14 +85,14 @@  fromList :: ChunkSize -> [a] -> T a fromList chunkSize =-   let recurse [] = []-       recurse xs =+   let recourse [] = []+       recourse xs =           let actSize = minLength chunkSize xs           in  Chunk 0 actSize (listArray (0,actSize-1) xs) :                 if actSize < chunkSize                   then []-                  else recurse (drop chunkSize xs)-   in  Cons . recurse+                  else recourse (drop chunkSize xs)+   in  Cons . recourse  {- @minLength n x = min n (length x)@,@@ -100,14 +100,14 @@ -} minLength :: Int -> [a] -> Int minLength =-   let recurse seenSoFar expected xt =+   let recourse seenSoFar expected xt =           case xt of              [] -> seenSoFar              (_:xs) ->                  if expected == 0                    then seenSoFar-                   else recurse (succ seenSoFar) (pred expected) xs-   in  recurse 0+                   else recourse (succ seenSoFar) (pred expected) xs+   in  recourse 0  {- poor man's implementation via lists
src/Sound/Signal/StrictBlock.hs view
@@ -1,4 +1,6 @@-{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-} {- | Needs generalized instances for IArray. -}
− src/Sox.hs 
@@ -1,16 +0,0 @@-module Sox where--import qualified Algebra.RealField as RealField---channelOption :: Int -> [String]-channelOption n =-   ["-c", show n]-{--   if n == 1-     then []-     else ["-c", show n]--}--sampleRateOption :: (RealField.C a) => a -> [String]-sampleRateOption r = ["-r", show (RealField.round r :: Int)]
− src/Sox/File.hs 
@@ -1,101 +0,0 @@-{-# OPTIONS -fno-implicit-prelude #-}-module Sox.File where--import qualified BinarySample as BinSmp-import qualified Sox          as Sox--import System.Cmd(rawSystem)-import System.Exit(ExitCode)-import Data.List(isSuffixOf)--import qualified Algebra.RealField          as RealField-import qualified Algebra.Field              as Field--import PreludeBase-import NumericPrelude---render :: (RealField.C a, BinSmp.C v) =>-   FilePath -> a -> (a -> [v]) -> IO ExitCode-render fileName sampleRate renderer =-   write fileName sampleRate (renderer sampleRate)--renderMono :: (RealField.C a) =>-   FilePath -> a -> (a -> [a]) -> IO ExitCode-renderMono fileName sampleRate renderer =-   writeMono fileName sampleRate (renderer sampleRate)--renderStereo :: (RealField.C a) =>-   FilePath -> a -> (a -> [(a,a)]) -> IO ExitCode-renderStereo fileName sampleRate renderer =-   writeStereo fileName sampleRate (renderer sampleRate)---write :: (RealField.C a, BinSmp.C v) =>-   FilePath -> a -> [v] -> IO ExitCode-write fileName sampleRate signal =-   writeSignalRaw fileName [] sampleRate-      (BinSmp.numChannels (head signal))-      (BinSmp.signalToBinary signal)--writeMono :: (RealField.C a) =>-   FilePath -> a -> [a] -> IO ExitCode-writeMono fileName sampleRate signal =-   writeSignalRaw fileName []-      sampleRate 1 (BinSmp.signalToBinaryMono signal)--writeStereo :: (RealField.C a) =>-   FilePath -> a -> [(a,a)] -> IO ExitCode-writeStereo fileName sampleRate signal =-   writeSignalRaw fileName []-      sampleRate 2 (BinSmp.signalToBinaryStereo signal)---writeSignalRaw :: (RealField.C a) =>-   FilePath -> [String] -> a -> Int -> [Int] -> IO ExitCode-writeSignalRaw fileName soxOptions sampleRate numChannels stream =-   let fileNameRaw  = fileName ++ ".sw"-   in  do BinSmp.writeInt16Stream fileNameRaw stream-          rawToAIFF fileName soxOptions sampleRate numChannels-          encode fileName--rawToAIFF :: (RealField.C a) =>-   FilePath -> [String] -> a -> Int -> IO ExitCode-rawToAIFF fileName soxOptions sampleRate numChannels =-   let fileNameRaw  = fileName ++ ".sw"-       fileNameAIFF = fileName ++ ".aiff"-   in  rawSystem "sox"-          (soxOptions ++-           Sox.sampleRateOption sampleRate ++-           Sox.channelOption numChannels ++-           [fileNameRaw, fileNameAIFF])--encode :: FilePath -> IO ExitCode-encode fileName =-     let fileNameAIFF = fileName ++ ".aiff"-         --fileNameOGG  = fileName ++ ".ogg"-         fileNameMP3  = fileName ++ ".mp3"-     in do rawSystem "oggenc" ["--quality", "5", fileNameAIFF]-           rawSystem "lame"   ["-h", fileNameAIFF, fileNameMP3]---{- This implementation doesn't work properly.-   It seems like readFile is run-   after all system calls to Sox are performed.-   Aren't the calls serialized?-readAIFFMono :: (RealField.C a, Floating a) => FilePath -> IO [a]-readAIFFMono file =-   do putStrLn ("sox "++file++" /tmp/sample.sw")-      system ("sox "++file++" /tmp/sample.sw")-      str <- readFile "/tmp/sample.sw"-      return (binaryToSignalMono str)--}-readAIFFMono :: (Field.C a) => FilePath -> IO [a]-readAIFFMono file =-   let stem = if isSuffixOf ".aiff" file-                then take (length file - 5) file-                else file-       tmp  = stem ++ ".sw"-   in  do --putStrLn ("sox "++file++" "++tmp)-          rawSystem "sox" [file, tmp]-          fmap (map BinSmp.int16ToNum) (BinSmp.readInt16Stream tmp)
− src/Sox/Play.hs 
@@ -1,95 +0,0 @@-{-# OPTIONS -fno-implicit-prelude #-}-module Sox.Play where--import qualified BinarySample as BinSmp-import qualified Sox          as Sox--import System.IO(IO)-import qualified System.IO as IO--import qualified System.Process as Proc-import Control.Exception(bracket)--{--import qualified Shell--}-import qualified System.Posix.Signals as Signals--import qualified Algebra.RealField      as RealField--import PreludeBase-import NumericPrelude---autoR :: (RealField.C a, BinSmp.C v) => a -> (a -> [v]) -> IO ()-autoR sampleRate renderer =-   auto sampleRate (renderer sampleRate)--monoR :: (RealField.C a) => a -> (a -> [a]) -> IO ()-monoR sampleRate renderer =-   mono sampleRate (renderer sampleRate)--stereoR :: (RealField.C a) => a -> (a -> [(a,a)]) -> IO ()-stereoR sampleRate renderer =-   stereo sampleRate (renderer sampleRate)---auto :: (RealField.C a, BinSmp.C v) => a -> [v] -> IO ()-auto sampleRate signal =-   raw [] sampleRate (BinSmp.numChannels (head signal))-      (BinSmp.signalToBinary signal)--mono :: (RealField.C a) => a -> [a] -> IO ()-mono sampleRate signal =-   raw [] sampleRate 1 (BinSmp.signalToBinaryMono signal)--stereo :: (RealField.C a) => a -> [(a,a)] -> IO ()-stereo sampleRate signal =-   raw [] sampleRate 2 (BinSmp.signalToBinaryStereo signal)--{- |-Disable sigPIPE.-This means that the whole program won't crash when the tool exits.-Unfortunately there doesn't seem to be another way of doing this.--If we don't call this, GHCi quits,-when the playing command is aborted with CTRL-C.--}-catchCtrlC :: IO Signals.Handler-catchCtrlC =-      Signals.installHandler Signals.sigPIPE -		  Signals.Ignore Nothing--{--raw :: Show a => [String] -> a -> [Int] -> IO ()-raw args sampleRate stream =-   do catchCtrlC-      (input,_,_) <- Shell.launch "play"-          (["auto"] ++ Sox.sampleRateOption sampleRate ++-           ["-t","sw","-"] ++ args)-      BinSmp.putInt16Stream input stream-      IO.hClose input--}--{- |-This routine is probably portable-if there were not the CTRL-C problem.--}-raw :: (RealField.C a) => [String] -> a -> Int -> [Int] -> IO ()-raw args sampleRate numChannels stream =-   bracket-      (Proc.runInteractiveProcess "play"-          (Sox.channelOption numChannels ++-           Sox.sampleRateOption sampleRate ++-           ["-t","sw","-"] ++ args)-          Nothing Nothing)-      (\(input,output,err,proc) -> do-          mapM IO.hClose [input, output, err]-          -- wait for end of replay-          Proc.waitForProcess proc)-      (\(input,_,_,_) ->-         catchCtrlC >>-         BinSmp.putInt16Stream input stream)--example :: IO ()-example = auto (11025::Double) (map sin [0::Double,0.1..])
− src/StorableInstance.hs 
@@ -1,78 +0,0 @@-{--This should be in the standard library.--}-module StorableInstance where--import Foreign.Storable (Storable (..), )-import Foreign.Ptr (castPtr, )-import qualified Number.Complex as Complex-import qualified Number.Ratio   as Ratio-import qualified Algebra.PrincipalIdealDomain as PID---roundUp :: Int -> Int -> Int-roundUp m x = x + mod (-x) m---- is handling of alignment correct?-instance (Storable a, Storable b) => Storable (a,b) where-   sizeOf ~(a,b) =-      roundUp (alignment b) (sizeOf a) + sizeOf b-   alignment ~(a,b) = gcd (alignment a) (alignment b)-{- doesn't work - no monomorphism-   peek ptr =-      do a <- peekByteOff ptr 0-         let bu = undefined-         b <- peekByteOff ptr (roundUp (alignment bu) (sizeOf a))-         return (a, asTypeOf b bu)--}-   peek ptr =-      do a <- peekByteOff ptr 0-         let peekSecond :: Storable b => b -> IO b-             peekSecond bu =-                peekByteOff ptr (roundUp (alignment bu) (sizeOf a))-         b <- peekSecond undefined-         return (a, b)-   poke ptr (a,b) =-      pokeByteOff ptr 0 a >>-      pokeByteOff ptr (roundUp (alignment b) (sizeOf a)) b---instance (Storable a, Storable b, Storable c) => Storable (a,b,c) where-   sizeOf    = sizeOf    . tripleToPair-   alignment = alignment . tripleToPair-   peek ptr = fmap (\ ~(~(a,b),c) -> (a,b,c)) (peek (castPtr ptr))-   poke ptr = poke (castPtr ptr) . tripleToPair--tripleToPair :: (a,b,c) -> ((a,b),c)-tripleToPair ~(a,b,c) = ((a,b),c)--instance (Storable a) => Storable (Complex.T a) where-   sizeOf    = sizeOf    . complexToPair-   alignment = alignment . complexToPair-   peek ptr = fmap (uncurry (Complex.+:)) (peek (castPtr ptr))-   poke ptr = poke (castPtr ptr) . complexToPair--complexToPair :: Complex.T a -> (a,a)-complexToPair a = (Complex.real a, Complex.imag a)--instance (Storable a, PID.C a) => Storable (Ratio.T a) where-   sizeOf    = sizeOf    . ratioToPair-   alignment = alignment . ratioToPair-   peek ptr = fmap (uncurry (Ratio.%)) (peek (castPtr ptr))-   poke ptr = poke (castPtr ptr) . ratioToPair--ratioToPair :: Ratio.T a -> (a,a)-ratioToPair x = (Ratio.numerator x, Ratio.denominator x)---{--{- Why is this allowed? -}-test :: Char-test = const 'a' undefined--{- Why is type defaulting applied here? The type of 'c' should be fixed. -}-test1 :: (Integral a, RealField.C a) => a-test1 =-   let c = undefined-   in  asTypeOf (round c) c--}
src/Synthesizer/ApplicativeUtility.hs view
@@ -6,15 +6,27 @@ import Control.Monad.Fix (fix, )  +{-# INLINE liftA4 #-} liftA4 :: Applicative f =>    (a -> b -> c -> d -> e) -> f a -> f b -> f c -> f d -> f e liftA4 f a b c d = f <$> a <*> b <*> c <*> d +{-# INLINE liftA5 #-}+liftA5 :: Applicative f =>+   (a -> b -> c -> d -> e -> g) -> f a -> f b -> f c -> f d -> f e -> f g+liftA5 f a b c d e = f <$> a <*> b <*> c <*> d <*> e +{-# INLINE liftA6 #-}+liftA6 :: Applicative f =>+   (a -> b -> c -> d -> e -> g -> h) -> f a -> f b -> f c -> f d -> f e -> f g -> f h+liftA6 f a b c d e g = f <$> a <*> b <*> c <*> d <*> e <*> g++ {- | Create a loop (feedback) from one node to another one. That is, compute the fix point of a process iteration. -}+{-# INLINE loop #-} loop :: (Functor f) =>       f (a -> a)  {-^ process chain that shall be looped -}    -> f a@@ -27,6 +39,7 @@ {- | This corresponds to 'Control.Applicative.<*>' -}+{-# INLINE ($:) #-} ($:) :: (Applicative f) => f (a -> b) -> f a -> f b ($:) = (<*>) @@ -35,25 +48,30 @@ the caller should write @mixMulti $: mapM f xs@ in order to save the user from learning another infix operator. -}+{-# INLINE ($::) #-} ($::) :: (Applicative f, Traversable t) =>    f (t a -> b) -> t (f a) -> f b ($::) f arg = f $: sequenceA arg -- ($::) f arg sr = f sr (map ($sr) arg) +{-# INLINE (.:) #-} (.:) :: (Applicative f) => f (b -> c) -> f (a -> b) -> f (a -> c) (.:) = liftA2 (.) -- (.:) f g sr x = f sr (g sr x) -- (.:) f g sr x = ($:) f (flip g x) sr +{-# INLINE ($^) #-} ($^) :: (Functor f) => (a -> b) -> f a -> f b ($^) = fmap -- ($^) = (.) -- ($^) f x = pure f $: x +{-# INLINE (.^) #-} (.^) :: (Functor f) => (b -> c) -> f (a -> b) -> f (a -> c) (.^) f = fmap (f.) -- (.^) f = (.:) (pure f) +{-# INLINE ($#) #-} ($#) :: (Applicative f) => f (a -> b) -> a -> f b ($#) f x = f $: pure x -- ($#) = flip@@ -71,18 +89,22 @@ that can be defined purely in the 'Control.Applicative.Applicative' class. -} +{-# INLINE liftP #-} liftP :: (Applicative f) =>    f (a -> b) -> f a -> f b liftP = ($:) +{-# INLINE liftP2 #-} liftP2 :: (Applicative f) =>    f (a -> b -> c) -> f a -> f b -> f c liftP2 f a b = f $: a $: b +{-# INLINE liftP3 #-} liftP3 :: (Applicative f) =>    f (a -> b -> c -> d) -> f a -> f b -> f c -> f d liftP3 f a b c = f $: a $: b $: c +{-# INLINE liftP4 #-} liftP4 :: (Applicative f) =>    f (a -> b -> c -> d -> e) -> f a -> f b -> f c -> f d -> f e liftP4 f a b c d = f $: a $: b $: c $: d
+ src/Synthesizer/Basic/Binary.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.Basic.Binary+   (C(..), toCanonical, fromCanonicalWith,+    numberOfSignalChannels,+    int16ToCanonical, int16FromCanonical,+    int16FromFloat, int16FromDouble,+    ) where++import qualified Synthesizer.Frame.Stereo as Stereo++import Data.Monoid (Monoid, mappend, )++import qualified Algebra.ToInteger as ToInteger+import qualified Algebra.RealField as RealField+import qualified Algebra.Real      as Real+import qualified Algebra.Field     as Field+import qualified Algebra.Ring      as Ring++import Data.Ord.HT (limit, )++import Data.Int (Int16, )+import GHC.Float (float2Int, double2Int, )++import qualified Prelude as P98++import PreludeBase+import NumericPrelude+++++class C a where+   outputFromCanonical ::+      (Bounded int, ToInteger.C int, Monoid out) =>+      (int -> out) -> a -> out+   numberOfChannels :: a -> Int++instance C Float where+   outputFromCanonical pack =+      pack .+      fromCanonicalWith+         (fromIntegral . truncToRound float2Int)+   numberOfChannels _ = 1++instance C Double where+   outputFromCanonical pack =+      pack .+      fromCanonicalWith+         (fromIntegral . truncToRound double2Int)+   numberOfChannels _ = 1++instance (C a, C b) => C (a,b) where+   outputFromCanonical pack x =+      outputFromCanonical pack (fst x) `mappend`+      outputFromCanonical pack (snd x)+   numberOfChannels x =+      numberOfChannels (fst x) ++      numberOfChannels (snd x)++instance (C a) => C (Stereo.T a) where+   outputFromCanonical pack x =+      outputFromCanonical pack (Stereo.left x) `mappend`+      outputFromCanonical pack (Stereo.right x)+   numberOfChannels x =+      numberOfChannels (Stereo.left x) ++      numberOfChannels (Stereo.right x)++++{-# INLINE numberOfSignalChannels #-}+numberOfSignalChannels ::+   C yv => sig yv -> Int+numberOfSignalChannels sig =+   let aux :: C yv => sig yv -> yv -> Int+       aux _ dummy = numberOfChannels dummy+   in  aux sig undefined++{-# INLINE fromCanonicalWith #-}+fromCanonicalWith ::+   (Real.C real, Bounded int, ToInteger.C int) =>+   (real -> int) -> (real -> int)+fromCanonicalWith rnd r =+   let s = fromIntegral (maxBound `asTypeOf` i)+       i = rnd (s * limit (-1, 1) r)+   in  i++{-# INLINE truncToRound #-}+truncToRound ::+   (RealField.C real) =>+   (real -> int) -> (real -> int)+truncToRound trunc x =+   trunc $+   if x<0+     then x - 0.5+     else x + 0.5++{-# INLINE scale16 #-}+scale16 :: (Ring.C a, Ord a) => a -> a+scale16 x = 32767 * limit (-1, 1) x++{-# INLINE int16FromCanonical #-}+int16FromCanonical :: (RealField.C a) => a -> Int16+int16FromCanonical = (P98.fromIntegral :: Int -> Int16) . round . scale16+{- in GHC-6.4 inefficient, since 'round' for target Int16 is not optimized+int16FromCanonical = round . scale16+-}++{-# INLINE int16FromFloat #-}+int16FromFloat :: Float -> Int16+int16FromFloat = P98.fromIntegral . float2Int . scale16+++{-+{-# INLINE scale16Double #-}+scale16Double :: (Ring.C a, Ord a) => a -> a+scale16Double x = 32767 * clip (-1) 1 x+-}++{-# INLINE int16FromDouble #-}+int16FromDouble :: Double -> Int16+{- Why is scale16 not inlined here? See FusionTest.mixTest3+int16FromDouble = P98.fromIntegral . double2Int . scale16+-}+-- int16FromDouble = P98.fromIntegral . double2Int . scale16Double+-- int16FromDouble x = P98.fromIntegral (double2Int (scale16 x))+int16FromDouble = P98.fromIntegral . double2Int . (32767*) . limit (-1, 1)+++++{-# INLINE toCanonical #-}+toCanonical ::+   (Field.C real, Bounded int, ToInteger.C int) =>+   (int -> real)+toCanonical i =+   let s = fromIntegral (maxBound `asTypeOf` i)+   in  fromIntegral i / s++{-# INLINE int16ToCanonical #-}+int16ToCanonical :: (Field.C a) => Int16 -> a+int16ToCanonical x = fromIntegral x / 32767
src/Synthesizer/Basic/Distortion.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} module Synthesizer.Basic.Distortion (    clip, logit,    zigZag, sine,@@ -12,7 +12,7 @@ import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive -import qualified Synthesizer.Utility as Util+import Data.Ord.HT (limit, )  -- import qualified Prelude as P -- import PreludeBase@@ -25,7 +25,7 @@ limit, fuzz booster -} clip :: (Real.C a) => a -> a-clip = Util.clip (negate one) one+clip = limit (negate one, one)  {- | logit, tanh
src/Synthesizer/Basic/DistortionControlled.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} module Synthesizer.Basic.DistortionControlled (    clip, logit,    zigZag, sine,@@ -14,7 +14,7 @@ import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive -import qualified Synthesizer.Utility as Util+import Data.Ord.HT (limit, )  -- import qualified Prelude as P -- import PreludeBase@@ -26,7 +26,7 @@ limit, fuzz booster -} clip :: (Real.C a) => a -> a -> a-clip c = Util.clip (negate c) c+clip c = limit (negate c, c)  {- | logit, tanh
src/Synthesizer/Basic/Phase.hs view
@@ -3,6 +3,7 @@     fromRepresentative,     toRepresentative,     increment,+    decrement,     multiply,    ) where @@ -15,15 +16,15 @@ import System.Random (Random(..)) import Test.QuickCheck (Arbitrary(..), choose) -import qualified Synthesizer.Generic.SampledValue as Sample import Foreign.Storable (Storable(..), ) import Foreign.Ptr (castPtr, ) -import Synthesizer.Utility (mapFst)+import Data.Tuple.HT (mapFst, ) import qualified NumericPrelude as NP   newtype T a = Cons {decons :: a}+   deriving Eq   instance Show a => Show (T a) where@@ -41,9 +42,7 @@    {-# INLINE poke #-}    poke ptr = poke (castPtr ptr) . toRepresentative -instance Sample.C a => Sample.C (T a) -- where - instance (Ring.C a, Random a) => Random (T a) where    randomR = error "Phase.randomR makes no sense"    random = mapFst Cons . randomR (NP.zero, NP.one)@@ -64,8 +63,12 @@  {-# INLINE increment #-} increment :: RealField.C a => a -> T a -> T a-increment d x = fromRepresentative (toRepresentative x Additive.+ d)+increment d = lift (d Additive.+) +{-# INLINE decrement #-}+decrement :: RealField.C a => a -> T a -> T a+decrement d = lift (Additive.subtract d)+ {-# INLINE multiply #-} multiply :: (RealField.C a, ToInteger.C b) => b -> T a -> T a multiply n x = fromRepresentative (toRepresentative x Ring.* NP.fromIntegral n)@@ -79,4 +82,9 @@    zero = Cons Additive.zero    x + y = fromRepresentative (toRepresentative x Additive.+ toRepresentative y)    x - y = fromRepresentative (toRepresentative x Additive.- toRepresentative y)-   negate = fromRepresentative . Additive.negate . toRepresentative+   negate = lift Additive.negate++{-# INLINE lift #-}+lift :: RealField.C a => (a -> a) -> T a -> T a+lift f =+   fromRepresentative . f . toRepresentative
+ src/Synthesizer/Basic/ToneModulation.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.Basic.ToneModulation where++import qualified Synthesizer.Basic.Phase as Phase++import Synthesizer.Interpolation (Margin, marginOffset, marginNumber, )++-- 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.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import NumericPrelude++-- import qualified Prelude as P+import PreludeBase+++{- |+Convert from the (shape,phase) parameter pair+to the index within a wave (step) and the index of a wave (leap)+in the sampled prototype tone.++For this routine it would be simpler,+if @shape@ would measure in multiples of @period@+(we would only need a Ring instance),+but for 'shapeLimit' it is better the way it is.+-}+untangleShapePhase :: (Field.C a) =>+   Int -> a -> (a, a) -> (a, a)+untangleShapePhase periodInt period (shape,phase) =+   let leap = shape/period - phase+       step = shape - leap * fromIntegral periodInt+   in  (leap, step)++untangleShapePhaseAnalytic :: (Field.C a) =>+   Int -> a -> (a, a) -> (a, a)+untangleShapePhaseAnalytic periodInt period (shape,phase) =+   let periodRound = fromIntegral periodInt+       vLeap = (periodRound, periodRound-period)+       vStep = (1,1)+   in  solveSLE2 (vLeap,vStep) (shape,period*phase)++{-+Cramer's rule++see HTam/Numerics/ZeroFinder/Root, however the matrix is transposed+-}+solveSLE2 :: Field.C a => ((a,a), (a,a)) -> (a,a) -> (a,a)+solveSLE2 a@(a0,a1) b =+   let det = det2 a+   in  (det2 (b, a1) / det,+        det2 (a0, b) / det)++det2 :: Ring.C a => ((a,a), (a,a)) -> a+det2 ((a00,a10),(a01,a11)) =+   a00*a11 - a10*a01++{-+transpose :: ((a,a), (a,a)) -> ((a,a), (a,a))+transpose ((a00,a10),(a01,a11)) = ((a00,a01),(a10,a11))+-}+++flattenShapePhase, flattenShapePhaseAnalytic :: RealField.C a =>+      Int+   -> a+   -> (a, Phase.T a)+   -> (Int, (a, a))+flattenShapePhase periodInt period (shape,phase) =+   let xLeap = shape/period - Phase.toRepresentative phase+       qLeap = fraction xLeap+       xStep = shape - qLeap * fromIntegral periodInt+       (n,qStep) = splitFraction xStep+   in  (n,(qLeap,qStep))++flattenShapePhaseAnalytic periodInt period (shape,phase) =+   let (xLeap,xStep) =+          untangleShapePhase periodInt period (shape, Phase.toRepresentative phase)+       (nLeap,qLeap) = splitFraction xLeap+       (nStep,qStep) = splitFraction xStep+       {- reverse solveSLE2 for the shape parameter+          with respect to the rounded (wave,shape) coordinates -}+       n = nStep + nLeap * periodInt+   in  (n,(qLeap,qStep))+++shapeLimits :: Ring.C t =>+   Margin ->+   Margin ->+   Int ->+   t ->+   (t, t)+shapeLimits marginLeap marginStep periodInt len =+   let minShape =+          fromIntegral $+          interpolationOffset marginLeap marginStep periodInt ++          periodInt+       maxShape =+          minShape + len -+          fromIntegral (interpolationNumber marginLeap marginStep periodInt)+   in  (minShape, maxShape)++interpolationOffset ::+   Margin ->+   Margin ->+   Int ->+   Int+interpolationOffset marginLeap marginStep periodInt =+   marginOffset marginStep ++   marginOffset marginLeap * periodInt++interpolationNumber ::+   Margin ->+   Margin ->+   Int ->+   Int+interpolationNumber marginLeap marginStep periodInt =+   marginNumber marginStep ++   marginNumber marginLeap * periodInt++++type Coords t = (Int,(Int,(t,t)))+type Skip   t = (Int, (t, Phase.T t))
src/Synthesizer/Basic/Wave.hs view
@@ -1,4 +1,6 @@-{-# OPTIONS -O2 -fno-implicit-prelude -fglasgow-exts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-} {- | Copyright   :  (c) Henning Thielemann 2006 License     :  GPL@@ -14,10 +16,6 @@ -} module Synthesizer.Basic.Wave where -import qualified Synthesizer.Plain.ToneModulation as ToneMod-import qualified Synthesizer.Plain.Interpolation  as Interpolation-import Data.Array ((!), listArray)- import qualified Synthesizer.Basic.Phase as Phase  import qualified Algebra.RealTranscendental    as RealTrans@@ -29,13 +27,12 @@ import qualified Algebra.Real                  as Real import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive+import qualified Algebra.ToInteger             as ToInteger  import qualified MathObj.Polynomial as Poly import qualified Number.Complex     as Complex -import Synthesizer.Utility (swap)--import NumericPrelude.Condition (select, )+import Data.Bool.HT (select, if', ) import NumericPrelude  -- import qualified Prelude as P@@ -66,6 +63,10 @@ distort :: (y -> z) -> T t y -> T t z distort g (Cons f) = Cons (g . f) +{-# INLINE overtone #-}+overtone :: (RealField.C t, ToInteger.C n) => n -> T t y -> T t y+overtone n (Cons f) = Cons (f . Phase.multiply n)+ {-# INLINE apply #-} apply :: T t y -> (Phase.T t -> y) apply = decons@@ -294,19 +295,7 @@ x + 1/9*x^3 + 1/25*x^5 + 1/49*x^7 + 1/81*x^9 + O(x^11) -} -sample :: (RealField.C a) =>-   Interpolation.T a v -> [v] -> T a v-sample ip wave =-   let len = length wave-       arr = listArray (0, pred len) wave-   in  fromFunction $ \ phase ->-           let (n,q) = splitFraction (phase * fromIntegral len)-               xs = map (arr!) (map (flip mod len)-                      (enumFrom (n - Interpolation.offset ip)))---                map (arr!) (enumFromTo (n - Interpolation.offset ip)) ++ cycle wave-           in  Interpolation.func ip q xs - {- ** discretely parameterized -}  {- |@@ -697,7 +686,9 @@      else max (-1) ((abs (4*x-3) - 1) / (1-w))  {- |-trapezoid with distinct high and low time+Trapezoid with distinct high and low time.+That is the high and low trapezoids are symmetric itself,+but the whole waveform is not symmetric. -} {-# SPECULATE trapezoidAsymmetric :: Double -> Double -> Double -> Double #-} {-# INLINE trapezoidAsymmetric #-}@@ -727,7 +718,7 @@ -}  {- |-trapezoid with distinct high and low time+trapezoid with distinct high and low time and zero direct current offset -} {-# SPECULATE trapezoidBalanced :: Double -> Double -> Double -> Double #-} {-# INLINE trapezoidBalanced #-}@@ -736,63 +727,20 @@    raise (-w*r) $ trapezoidAsymmetric w r  -{- |-We assume that a tone was generated by a shape modulated oscillator.-We try to reconstruct the wave function-(with parameters shape control and phase)-from a tone by interpolation.--The unit for the shape control parameter is the sampling period.-That is the shape parameter is a time parameter-pointing to a momentary shape of the prototype signal.-Of course this momentary shape does not exist-and we can only guess it using interpolation.--At the boundaries we repeat the outermost shapes-that can be reconstructed entirely from interpolated data-(that is, no extrapolation is needed).-This way we cannot reproduce the shape at the boundaries-because we have no data for cyclically extending it.-On the other hand this method guarantees a nice wave shape-with the required fractional period.--It must be-   @length tone >=-       Interpolation.number ipStep +-       Interpolation.number ipLeap * ceiling period@.--}-sampledTone :: (RealField.C a) =>-   Interpolation.T a v ->-   Interpolation.T a v ->-   a -> [v] -> a -> T a v-sampledTone ipLeap ipStep period tone shape = Cons $ \phase ->-   uncurry (ToneMod.interpolateCell ipLeap ipStep) $-   ToneMod.sampledToneCell-      (ToneMod.makePrototype ipLeap ipStep period tone)-      shape phase-+-- could also be generated by amplifying and clipping a saw ramp {- |-Interpolate first within waves and then across waves,-which is simpler but maybe less efficient.--}-sampledToneAlt :: (RealField.C a) =>-   Interpolation.T a v ->-   Interpolation.T a v ->-   a -> [v] -> a -> T a v-sampledToneAlt ipLeap ipStep period tone shape = Cons $ \phase ->-   uncurry (ToneMod.interpolateCell ipStep ipLeap . swap) $-   ToneMod.sampledToneAltCell-      (ToneMod.makePrototype ipLeap ipStep period tone)-      shape phase--{--*Synthesizer.Basic.Wave>-GNUPlot.plotFunc [] (GNUPlot.linearScale 1000 (0,12)) (\t -> sampledTone Interpolation.linear Interpolation.linear (6::Double) ([-5,-3,-1,1,3,5,-4,-4,-4,4,4,4]++replicate 20 0) t (t/6))--*Synthesizer.Plain.Oscillator>-let period = 6.3::Double in GNUPlot.plotFunc [] (GNUPlot.linearScale 1000 (-10,20)) (\t -> Wave.sampledTone Interpolation.linear Interpolation.cubic period (take 20 $ staticSine 0 (1/period)) t (t/period))+parametrized trapezoid that can range from a saw ramp to a square waveform. -}-+trapezoidSkew :: (Ord a, Field.C a) =>+      a   {- ^ width of the ramp,+               that is 1 yields a downwards saw ramp+               and 0 yields a square wave. -}+   -> T a a+trapezoidSkew w =+   fromFunction $ \t ->+   if' (2*t<=1-w)   1  $+   if' (2*t>=1+w) (-1) $+   (1-2*t)/w  {- | This is similar to Polar coordinates,
src/Synthesizer/Basic/WaveSmoothed.hs view
@@ -1,4 +1,6 @@-{-# OPTIONS -O2 -fno-implicit-prelude -fglasgow-exts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-} {- | Copyright   :  (c) Henning Thielemann 2006 License     :  GPL
src/Synthesizer/Causal/Displacement.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} module Synthesizer.Causal.Displacement where  import qualified Synthesizer.Causal.Process as Causal
src/Synthesizer/Causal/Interpolation.hs view
@@ -1,15 +1,6 @@-{-# OPTIONS -fno-implicit-prelude #-}-{- |-ToDo:-use AffineSpace instead of Module for the particular interpolation types,-since affine combinations assert reconstruction of constant functions.-They are more natural for interpolation of internal control parameters.-However, how can cubic interpolation expressed by affine combinations-without divisions?--}+{-# LANGUAGE NoImplicitPrelude #-} module Synthesizer.Causal.Interpolation (    Interpolation.T,-   Interpolation.toGeneric,     relative,    relativeZeroPad,@@ -21,7 +12,9 @@    relativeZeroPadCubic,    ) where -import qualified Synthesizer.State.Interpolation as Interpolation+import qualified Synthesizer.Interpolation.Module as IpExample+import qualified Synthesizer.Interpolation as Interpolation+import qualified Synthesizer.State.Interpolation as InterpolationS  import qualified Synthesizer.Causal.Process as Causal import qualified Synthesizer.State.Signal   as Sig@@ -46,7 +39,7 @@ relative ip phase0 x0 =    Causal.crochetL       (\freq pos ->-          let (phase,x) = Interpolation.skip ip pos+          let (phase,x) = InterpolationS.skip ip pos           in  Just (Interpolation.func ip phase x, (phase+freq,x)))       (phase0,x0) @@ -55,19 +48,19 @@ relativeZeroPad :: (RealField.C t) =>    y -> Interpolation.T t y -> t -> Sig.T y -> Causal.T t y relativeZeroPad z ip phase x =-   Interpolation.zeroPad relative z ip phase x+   InterpolationS.zeroPad relative z ip phase x  {-# INLINE relativeConstantPad #-} relativeConstantPad :: (RealField.C t) =>    Interpolation.T t y -> t -> Sig.T y -> Causal.T t y relativeConstantPad ip phase x =-   Interpolation.constantPad relative ip phase x+   InterpolationS.constantPad relative ip phase x  {-# INLINE relativeCyclicPad #-} relativeCyclicPad :: (RealField.C t) =>    Interpolation.T t y -> t -> Sig.T y -> Causal.T t y relativeCyclicPad ip phase x =-   Interpolation.cyclicPad relative ip phase x+   InterpolationS.cyclicPad relative ip phase x  {- | The extrapolation may miss some of the first and some of the last points@@ -76,7 +69,7 @@ relativeExtrapolationPad :: (RealField.C t) =>    Interpolation.T t y -> t -> Sig.T y -> Causal.T t y relativeExtrapolationPad ip phase x =-   Interpolation.extrapolationPad relative ip phase x+   InterpolationS.extrapolationPad relative ip phase x {-   This example shows pikes, although there shouldn't be any:    plotList (take 100 $ interpolate (Zero (0::Double)) ipCubic (-0.9::Double) (repeat 0.03) [1,0,1,0.8])@@ -89,19 +82,19 @@    (RealField.C t, Additive.C y) =>    t -> Sig.T y -> Causal.T t y relativeZeroPadConstant =-   relativeZeroPad zero Interpolation.constant+   relativeZeroPad zero IpExample.constant  {-# INLINE relativeZeroPadLinear #-} relativeZeroPadLinear ::    (RealField.C t, Module.C t y) =>    t -> Sig.T y -> Causal.T t y relativeZeroPadLinear =-   relativeZeroPad zero Interpolation.linear+   relativeZeroPad zero IpExample.linear  {-# INLINE relativeZeroPadCubic #-} relativeZeroPadCubic ::    (RealField.C t, Module.C t y) =>    t -> Sig.T y -> Causal.T t y relativeZeroPadCubic =-   relativeZeroPad zero Interpolation.cubic+   relativeZeroPad zero IpExample.cubic
src/Synthesizer/Causal/Oscillator.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -O2 -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright   :  (c) Henning Thielemann 2006 License     :  GPL@@ -18,8 +18,14 @@ import qualified Synthesizer.Causal.Process as Causal import qualified Synthesizer.State.Signal as Sig -import qualified Synthesizer.Causal.Interpolation as Interpolation+import qualified Synthesizer.Causal.Interpolation as InterpolationC+import qualified Synthesizer.Causal.ToneModulation as ToneMod+import qualified Synthesizer.Interpolation as Interpolation +import qualified Synthesizer.Generic.Signal as SigG++import Synthesizer.State.ToneModulation (freqsToPhases, )+ {- import qualified Algebra.RealTranscendental    as RealTrans import qualified Algebra.Field                 as Field@@ -33,7 +39,7 @@ import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive -import Control.Arrow ((<<<), (&&&), second, returnA, )+import Control.Arrow ((^<<), (<<^), (<<<), (&&&), (***), second, returnA, )  import NumericPrelude @@ -50,18 +56,7 @@ freqToPhases phase freq =    Sig.iterate (Phase.increment freq) phase -{-# INLINE freqsToPhases #-}-{- |-Convert a list of phase steps into a list of momentum phases.-phase is a number in the interval [0,1).-freq contains the phase steps.--}-freqsToPhases :: RealField.C a =>-   Phase.T a -> Causal.T a (Phase.T a)-freqsToPhases phase =-   Causal.scanL (flip Phase.increment) phase - {- {-# INLINE static #-} {- | oscillator with constant frequency -}@@ -135,10 +130,62 @@     Interpolation.T a b -> Sig.T b -> Phase.T a -> Causal.T a b freqModSample ip wave phase =     let len = Sig.length wave-        pr  = Phase.toRepresentative $ Phase.multiply len phase-    in  Interpolation.relativeCyclicPad ip pr wave+        pr  = fromIntegral len * Phase.toRepresentative phase+    in  InterpolationC.relativeCyclicPad ip pr wave           <<< Causal.map (fromIntegral len *) ++{-# INLINE shapeFreqModSample #-}+shapeFreqModSample :: (RealField.C c, RealField.C b) =>+    Interpolation.T c (Wave.T b a) -> Sig.T (Wave.T b a) ->+    c -> Phase.T b ->+    Causal.T (c, b) a+shapeFreqModSample ip waves shape0 phase =+    uncurry Wave.apply ^<<+       (InterpolationC.relativeConstantPad ip shape0 waves ***+        freqsToPhases phase)++{-# INLINE shapeFreqModFromSampledTone #-}+shapeFreqModFromSampledTone ::+    (RealField.C t, SigG.Transform sig y) =>+    Interpolation.T t y ->+    Interpolation.T t y ->+    t -> sig y ->+    t -> Phase.T t ->+    Causal.T (t,t) y+shapeFreqModFromSampledTone+      ipLeap ipStep period sampledTone shape0 phase =+   uncurry (ToneMod.interpolateCell ipLeap ipStep) ^<<+   ToneMod.oscillatorCells+      (Interpolation.margin ipLeap) (Interpolation.margin ipStep)+      (round period) period sampledTone+      (shape0, phase)++{-# INLINE shapePhaseFreqModFromSampledTone #-}+shapePhaseFreqModFromSampledTone ::+    (RealField.C t, SigG.Transform sig y) =>+    Interpolation.T t y ->+    Interpolation.T t y ->+    t -> sig y ->+    t -> Phase.T t ->+    Causal.T (t,t,t) y+shapePhaseFreqModFromSampledTone+      ipLeap ipStep period sampledTone shape0 phase =+   let periodInt = round period+       marginLeap = Interpolation.margin ipLeap+       marginStep = Interpolation.margin ipStep+   in  (\(dp, ((s,p), suffix)) ->+          uncurry (ToneMod.interpolateCell ipLeap ipStep) $+          ToneMod.seekCell periodInt period $+          ((s, Phase.increment dp p), suffix))+       ^<<+       Causal.second+          (ToneMod.oscillatorSuffixes+             marginLeap marginStep+             periodInt period sampledTone+             (shape0, phase))+       <<^+       (\(s,p,f) -> (p,(s,f)))   {- * Oscillators with specific waveforms -}
− src/Synthesizer/Causal/Process.hs 
@@ -1,214 +0,0 @@-{-# OPTIONS -fglasgow-exts #-}-{- |-Processes that use only the current and past data.-Essentially this is a data type for the 'Synthesizer.State.Signal.crochetL' function.--}-module Synthesizer.Causal.Process (-   T,-   fromStateMaybe,-   fromState,-   fromSimpleModifier,--   map,-   first,-   second,-   compose,-   split,-   fanout,-   loop,--{--   We don't re-export these identifiers-   because people could abuse them for other Arrows.--   (>>>), (***), (&&&),-   (Arrow.^<<), (Arrow.^>>), (Arrow.<<^), (Arrow.>>^),--}--   apply,-   applyFst,-   applySnd,-   apply2,-   feed,--   crochetL,-   scanL,-   zipWith,-) where--import qualified Synthesizer.State.Signal as Sig--import qualified Synthesizer.Plain.Modifier as Modifier---- import qualified Control.Arrow as Arrow--import Control.Arrow-          (Arrow(..), {- ArrowApply(..), -} ArrowLoop(..),-           Kleisli(Kleisli), runKleisli, )-import Control.Monad.State-          (State(State), runState,-           StateT(StateT), runStateT, liftM, )--import Synthesizer.Utility (mapSnd)-import Prelude hiding (map, zipWith, )------ TODO: include ST monad for mutable arrays---- | Cf. StreamFusion  'Synthesizer.State.Signal.T'-data T a b =-   forall s. -- Seq s =>-      Cons !(a -> StateT s Maybe b)  -- compute next value-           !s                        -- initial state----{-# INLINE fromStateMaybe #-}-fromStateMaybe :: (a -> StateT s Maybe b) -> s -> T a b-fromStateMaybe = Cons--{-# INLINE fromState #-}-fromState :: (a -> State s b) -> s -> T a b-fromState f s0 =-   fromStateMaybe (\x -> StateT (Just . runState (f x))) s0--{-# INLINE fromSimpleModifier #-}-fromSimpleModifier ::-   Modifier.Simple s ctrl a b -> T (ctrl,a) b-fromSimpleModifier (Modifier.Simple s f) =-   fromState (uncurry f) s---{--It's almost a Kleisli Arrow,-but the hidden type of the state disturbs.--}-instance Arrow T where-   {-# INLINE pure #-}-   {-# INLINE (>>>) #-}-   {-# INLINE first #-}-   {-# INLINE second #-}-   {-# INLINE (***) #-}-   {-# INLINE (&&&) #-}--   pure   = map-   (>>>)  = compose-   first  = liftKleisli first-   second = liftKleisli second-   (***)  = split-   (&&&)  = fanout---{--I think we cannot define an ArrowApply instance,-because we must extract the initial state somehow-from the inner (T a b) which is not possible.--instance ArrowApply T where---   app = Cons (runKleisli undefined) ()-   app = first (arr (flip Cons () . runKleisli)) >>> app--}---instance ArrowLoop T where-   {-# INLINE loop #-}-   loop = liftKleisli loop---{-# INLINE extendStateFstT #-}-extendStateFstT :: Monad m => StateT s m a -> StateT (t,s) m a-extendStateFstT st =-   StateT (\(t0,s0) -> liftM (mapSnd (\s1 -> (t0,s1))) (runStateT st s0))--{-# INLINE extendStateSndT #-}-extendStateSndT :: Monad m => StateT s m a -> StateT (s,t) m a-extendStateSndT st =-   StateT (\(s0,t0) -> liftM (mapSnd (\s1 -> (s1,t0))) (runStateT st s0))---{-# INLINE liftKleisli #-}-liftKleisli ::-   (forall s.-    Kleisli (StateT s Maybe) a0 a1 ->-    Kleisli (StateT s Maybe) b0 b1) ->-   T a0 a1 -> T b0 b1-liftKleisli op (Cons f s) =-   Cons (runKleisli $ op $ Kleisli f) s--{-# INLINE liftKleisli2 #-}-liftKleisli2 ::-   (forall s.-      Kleisli (StateT s Maybe) a0 a1 ->-      Kleisli (StateT s Maybe) b0 b1 ->-      Kleisli (StateT s Maybe) c0 c1) ->-   T a0 a1 -> T b0 b1 -> T c0 c1-liftKleisli2 op (Cons f s) (Cons g t) =-   Cons-      (runKleisli-         (Kleisli (extendStateSndT . f) `op`-          Kleisli (extendStateFstT . g)))-      (s,t)---{-# INLINE map #-}-map :: (a -> b) -> T a b-map f = fromState (return . f) ()--{-# INLINE compose #-}-compose :: T a b -> T b c -> T a c-compose = liftKleisli2 (>>>)--{-# INLINE split #-}-split :: T a b -> T c d -> T (a,c) (b,d)-split = liftKleisli2 (***)--{-# INLINE fanout #-}-fanout :: T a b -> T a c -> T a (b,c)-fanout = liftKleisli2 (&&&)---{-# INLINE apply #-}-apply :: T a b -> Sig.T a -> Sig.T b-apply (Cons f s) =-   Sig.crochetL (runStateT . f) s--{-# INLINE applyFst #-}-applyFst :: T (a,b) c -> Sig.T a -> T b c-applyFst (Cons f s) x =-   Cons (\b ->-           do a <- extendStateFstT $ StateT $ Sig.viewL-              extendStateSndT (f (a,b)))-        (s,x)--{-# INLINE applySnd #-}-applySnd :: T (a,b) c -> Sig.T b -> T a c-applySnd (Cons f s) x =-   Cons (\b ->-           do a <- extendStateFstT $ StateT $ Sig.viewL-              extendStateSndT (f (b,a)))-        (s,x)--{-# INLINE apply2 #-}-apply2 :: T (a,b) c -> Sig.T a -> Sig.T b -> Sig.T c-apply2 f x y =-   apply (applyFst f x) y---{-# INLINE feed #-}-feed :: Sig.T a -> T () a-feed = fromStateMaybe (const (StateT Sig.viewL))---{-# INLINE crochetL #-}-crochetL :: (x -> acc -> Maybe (y, acc)) -> acc -> T x y-crochetL f s = fromStateMaybe (StateT . f) s--{-# INLINE scanL #-}-scanL :: (acc -> x -> acc) -> acc -> T x acc-scanL f start =-   fromState (\x -> State $ \acc -> (acc, f acc x)) start--{-# INLINE zipWith #-}-zipWith :: (a -> b -> c) -> Sig.T a -> T b c-zipWith f = applyFst (map (uncurry f))
+ src/Synthesizer/Causal/ToneModulation.hs view
@@ -0,0 +1,235 @@+module Synthesizer.Causal.ToneModulation (+   ToneModS.interpolateCell,+   seekCell,+   oscillatorCells,+   oscillatorSuffixes,+   integrateFractional,+   integrateFractionalClip,+   -- for testing+   limitRelativeShapes,+   limitMinRelativeValues,+   ) where++import qualified Synthesizer.Basic.ToneModulation as ToneMod+import qualified Synthesizer.State.ToneModulation as ToneModS+import qualified Synthesizer.Interpolation as Interpolation++import Synthesizer.State.ToneModulation (freqsToPhases, freqsToPhasesSync, )++{- for testing in GHCi+import qualified Synthesizer.Plain.ToneModulation as ToneModL+import qualified Synthesizer.State.Signal as SigS+import Data.Tuple.HT (mapFst, mapSnd, swap, )+-}+import Data.Tuple.HT (mapFst, )++import qualified Synthesizer.Causal.Process as Causal++import qualified Synthesizer.Generic.Signal as SigG++import qualified Synthesizer.Basic.Phase as Phase++-- 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.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import Control.Arrow (first, (<<<), (<<^), (^<<), (&&&), (***), )+import Control.Monad.Trans.State (state, )++import NumericPrelude+-- import qualified Prelude as P+import PreludeBase+import Prelude ()++++oscillatorCells :: (RealField.C t, SigG.Transform sig y) =>+    Interpolation.Margin ->+    Interpolation.Margin ->+    Int -> t -> sig y -> (t, Phase.T t) ->+    Causal.T (t,t) ((t,t), ToneModS.Cell sig y)+oscillatorCells+       marginLeap marginStep periodInt period sampledTone (shape0, phase) =+    seekCell periodInt period+     ^<< oscillatorSuffixes marginLeap marginStep+            periodInt period sampledTone (shape0, phase)+{-+*Synthesizer.Causal.ToneModulation> let shapes = [0.3,2.4,0.2,2.1,1.2,1.5::Double]; phases = [0.43,0.72,0.91,0.37,0.42,0.22::Double]+*Synthesizer.Causal.ToneModulation> let marginLeap = Interpolation.Margin 3 1; marginStep = Interpolation.Margin 2 0+*Synthesizer.Causal.ToneModulation> mapM_ (print . mapSnd List.transpose) $ ToneModL.oscillatorCells marginLeap marginStep 5 5.3 ['a'..'z'] (2.3,shapes) (Phase.fromRepresentative 0.6, phases)+*Synthesizer.Causal.ToneModulation> mapM_ print $ SigS.toList $ oscillatorCells marginLeap marginStep 5 5.3 ['a'..'z'] (2.3, Phase.fromRepresentative 0.6) `Causal.apply` (SigS.fromList $ List.zip shapes phases)+-}+++seekCell :: (RealField.C t, SigG.Transform sig y) =>+    Int -> t ->+    ((t, Phase.T t), sig y) ->+    ((t,t), ToneModS.Cell sig y)+seekCell periodInt period =+    {-+    n will be zero within the data body.+    It's only needed for extrapolation at the end.+    Is it really needed?+    -}+    (\(sp,ptr) ->+       let (k,q) = ToneMod.flattenShapePhase periodInt period sp+       in  (q, ToneModS.makeCell periodInt $+               SigG.drop (ToneModS.checkNonNeg $ periodInt+k) ptr))+++{- |+In contrast to the counterpart of this function for plain lists,+it does not use sophisticated list transposition tricks,+but seeks through the prototype signal using 'drop'.+Since 'drop' is used in an inner loop, it must be fast.+This is true for StorableVectors.+-}+oscillatorSuffixes :: (RealField.C t, SigG.Transform sig y) =>+    Interpolation.Margin ->+    Interpolation.Margin ->+    Int -> t ->+    sig y -> (t, Phase.T t) ->+    Causal.T (t,t) ((t, Phase.T t), sig y)+oscillatorSuffixes+       marginLeap marginStep periodInt period sampledTone (shape0, phase) =+    let margin =+           ToneMod.interpolationNumber marginLeap marginStep periodInt+        ipOffset =+           periodInt ++           ToneMod.interpolationOffset marginLeap marginStep periodInt+        (shape0min, shapeLimiter) =+           limitMinRelativeValues (fromIntegral ipOffset) shape0+        ((skip0,coord0), coordinator) =+           integrateFractional period (shape0min, phase)+    in  (\(((b,n),ptr), sp@(_,p)) ->+           (if b+              then (zero, Phase.increment (fromIntegral n / period) p)+              else sp,+            ptr))+        ^<<+        (Causal.scanL+           (\ ((_,n),ptr) d -> dropMargin margin (n+d) ptr)+           (dropMargin margin (skip0 - ipOffset) sampledTone)+         ***+         Causal.consInit coord0)+        <<<+        coordinator+        <<<+        Causal.first shapeLimiter+{-+*Synthesizer.Causal.ToneModulation> let shapes = replicate 10 (2.6::Double); phases = cycle [0.43,0.72,0.91,0.37,0.42,0.22::Double]+*Synthesizer.Causal.ToneModulation> let marginLeap = Interpolation.Margin 3 1; marginStep = Interpolation.Margin 2 0+*Synthesizer.Causal.ToneModulation> mapM_ (print . swap . mapSnd (mapSnd (map head))) $ ToneModL.oscillatorSuffixes marginLeap marginStep 5 5.3 ['a'..'z'] (2.3,shapes) (Phase.fromRepresentative 0.6, phases)+*Synthesizer.Causal.ToneModulation> mapM_ print $ SigS.toList $ oscillatorSuffixes marginLeap marginStep 5 5.3 ['a'..'z'] (2.3, Phase.fromRepresentative 0.6) `Causal.apply` (SigS.fromList $ List.zip shapes phases)+-}++{- ToDo:+Both lengthAtMost and dropMarginRem seek through the list.+Maybe an improved version of dropMargin could avoid this.+E.g. dropMarginRem :: dropMarginRem :: Int -> Int -> sig y -> (Maybe Int, sig y),+where return value (Just 0) means,+that drop could actually drop the requested number of elements,+but that we reached the end of the list.+-}+dropMargin :: (SigG.Transform sig y) =>+   Int -> Int -> sig y -> ((Bool, Int), sig y)+dropMargin margin n xs =+   mapFst ((,) (SigG.lengthAtMost (margin+n) xs)) $+   SigG.dropMarginRem margin+      (ToneModS.checkNonNeg n) xs++regroup :: (Int,t) -> Phase.T t -> ToneMod.Skip t+regroup (d,s) p = (d, (s,p))++integrateFractional :: (RealField.C t) =>+    t ->+    (t, Phase.T t) ->+    (ToneMod.Skip t, Causal.T (t,t) (ToneMod.Skip t))+integrateFractional period (shape0, phase) =+    let sf0 = splitFraction shape0+        -- shapeOffsets :: RealField.C t => Causal.T t (Int,t)+        shapeOffsets =+           Causal.fromState+              (\c -> state $ \s0 ->+                 let s1 = splitFraction (s0+c)+                 in  (s1, snd s1))+              (snd sf0)+        scale (n,_) = fromIntegral n / period+        -- phases :: RealField.C t => Causal.T ((Int,t), t) (Phase.T t)+        phase0 = Phase.decrement (scale sf0) phase+        phases =+           freqsToPhasesSync phase0+              <<^ (\(s,f) -> f - scale s)+    in  (regroup sf0 phase0,+         uncurry regroup+         ^<<+         (Causal.map fst &&& phases)+         <<<+         first shapeOffsets)++{- |+Delays output by one element and shorten it by one element at the end.+-}+integrateFractionalClip :: (RealField.C t) =>+    t ->+    (t, Phase.T t) ->+    Causal.T (t,t) (ToneMod.Skip t)+integrateFractionalClip period (shape0, phase) =+    let sf0 = splitFraction shape0+        -- shapeOffsets :: RealField.C t => Causal.T t (Int,t)+        shapeOffsets =+           Causal.fromState+              (\c -> state $ \s0 ->+                 let s1 = splitFraction (s0+c)+                 in  (s1, snd s1))+              (snd sf0)+        scale (n,_) = fromIntegral n / period+        -- phases :: RealField.C t => Causal.T ((Int,t), t) (Phase.T t)+        phases =+           freqsToPhases+              (Phase.decrement (scale sf0) phase)+              <<^ (\(s,f) -> f - scale s)+    in  uncurry regroup+        ^<<+        ((Causal.consInit sf0 <<^ fst) &&& phases)+        <<<+        first shapeOffsets+{-+test to automate:+*Synthesizer.Generic.ToneModulation> let shapes = [0.3,0.4,0.2::Double]; phases = [0.43,0.72,0.91::Double]+*Synthesizer.Generic.ToneModulation> ToneMod.oscillatorCoords 9 10 (2.3,shapes) (Phase.fromRepresentative 0.6, phases)+[(2,(-6,(0.63,0.6299999999999999))),(0,(-2,(0.22999999999999998,0.53))),(0,(-4,(0.5500000000000002,4.9999999999998934e-2))),(1,(-6,(0.6600000000000001,0.2599999999999989)))]++*Synthesizer.Generic.ToneModulation> ToneModS.oscillatorCoords 9 10 (2.3, SigS.fromList shapes) (Phase.fromRepresentative 0.6, SigS.fromList phases)+StateSignal.fromList [(2,(-6,(0.63,0.6299999999999999))),(0,(-2,(0.22999999999999998,0.53))),(0,(-4,(0.5500000000000002,4.9999999999998934e-2)))]++*Synthesizer.Generic.ToneModulation> Data.Tuple.HT.mapSnd (flip Causal.apply $ SigS.fromList (zip shapes phases)) $ oscillatorCoords 9 10 (2.3, Phase.fromRepresentative 0.6)+((2,(-6,(0.63,0.6299999999999999))),StateSignal.fromList [(0,(-2,(0.22999999999999998,0.53))),(0,(-4,(0.5500000000000002,4.9999999999998934e-2))),(1,(-6,(0.6600000000000001,0.2599999999999989)))])++*Synthesizer.Generic.ToneModulation> oscillatorCoords' 9 10 (2.3, Phase.fromRepresentative 0.6) `Causal.apply` SigS.fromList (zip shapes phases)+StateSignal.fromList [(2,(-6,(0.63,0.6299999999999999))),(0,(-2,(0.22999999999999998,0.53))),(0,(-4,(0.5500000000000002,4.9999999999998934e-2)))]+-}++limitRelativeShapes :: (Ring.C t, Ord t) =>+    Interpolation.Margin ->+    Interpolation.Margin ->+    Int -> t -> (t, Causal.T t t)+limitRelativeShapes marginLeap marginStep periodInt =+    limitMinRelativeValues $ fromIntegral $+    ToneMod.interpolationOffset marginLeap marginStep periodInt + periodInt++limitMinRelativeValues :: (Additive.C t, Ord t) =>+   t -> t -> (t, Causal.T t t)+limitMinRelativeValues xMin x0 =+   let x1 = xMin-x0+   in  if x1<=zero+         then (x0, Causal.id)+         else (xMin,+               Causal.crochetL+                  (\x lim ->+                     let d = x-lim+                     in  Just $ if d>=zero+                           then (d,zero) else (zero, negate d)) x1)
src/Synthesizer/Dimensional/Abstraction/Flat.hs view
@@ -1,4 +1,5 @@-{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-} {- | Copyright   :  (c) Henning Thielemann 2008 License     :  GPL@@ -13,6 +14,7 @@ -} module Synthesizer.Dimensional.Abstraction.Flat where +import qualified Synthesizer.Dimensional.Amplitude as Amp import qualified Synthesizer.Dimensional.RatePhantom as RP import qualified Synthesizer.Dimensional.Straight.Signal as SigS import qualified Synthesizer.Dimensional.Amplitude.Signal as SigA@@ -50,15 +52,39 @@   {--instance (Dim.IsScalar scalar, Module.C y yv) => C (SigA.T scalar y) yv where+instance (Dim.IsScalar scalar, Module.C y yv) => C (SigA.D scalar y) yv where    toSamples =       SigA.vectorSamples (DN.toNumber . DN.rewriteDimension Dim.toScalar) -} -instance (C flat y, Dim.IsScalar scalar, Ring.C y) =>-             C (SigA.T scalar y flat) y where+{-+instance (C flat y, OccScalar.C y amp, Amp.C amp, Ring.C y) =>+             C (SigA.T amp flat) y where    unwrappedToSamples =-      SigA.scalarSamples (DN.toNumber . DN.rewriteDimension Dim.toScalar) .+      SigA.scalarSamples OccScalar.toScalar .+      (\x ->+         SigA.fromSamples+            (SigA.privateAmplitude x)+            (unwrappedToSamples (SigA.signal x)))+-}++{-+we could use OccasionallyScalar class,+but this would flood user code with OccScalar.C y y constraints+-}+class Amp.C amp => Amplitude y amp where+   toScalar :: amp -> y++instance Ring.C y => Amplitude y Amp.Flat where+   toScalar = const Ring.one++instance (Dim.IsScalar v) => Amplitude y (DN.T v y) where+   toScalar = DN.toNumber . DN.rewriteDimension Dim.toScalar++instance (C flat y, Amplitude y amp, Ring.C y) =>+             C (SigA.T amp flat) y where+   unwrappedToSamples =+      SigA.scalarSamples toScalar .       (\x ->          SigA.fromSamples             (SigA.privateAmplitude x)
src/Synthesizer/Dimensional/Abstraction/Homogeneous.hs view
@@ -1,5 +1,5 @@ {- |-Copyright   :  (c) Henning Thielemann 2008+Copyright   :  (c) Henning Thielemann 2008-2009 License     :  GPL  Maintainer  :  synthesizer@henning-thielemann.de@@ -7,7 +7,7 @@ Portability :  requires multi-parameter type classes  Class that allows unified handling of-@SigS.T@ and @Sig.D s u@+@SigS.T@ and @SigA.R s u@ whenever the applied function is homogeneous (with degree one), that is scaling of the input must only result in scaling of the output. Unfortunately, Haskell's type system cannot check this property,@@ -19,11 +19,12 @@ import qualified Synthesizer.Dimensional.RatePhantom as RP import qualified Synthesizer.Dimensional.Straight.Signal as SigS import qualified Synthesizer.Dimensional.Amplitude.Signal as SigA+import qualified Synthesizer.Dimensional.Amplitude as Amp --- import qualified Number.DimensionTerm        as DN+{-+import qualified Number.DimensionTerm        as DN import qualified Algebra.DimensionTerm       as Dim -{- import qualified Algebra.Module         as Module import qualified Algebra.Field          as Field import qualified Algebra.Ring           as Ring@@ -62,9 +63,9 @@ instance C sig => C (SigS.T sig) where --   processSamples = SigS.processSamples    unwrappedProcessSamples f =-      SigS.Cons . unwrappedProcessSamples f . SigS.samples+      SigS.processSamplesPrivate (unwrappedProcessSamples f) -instance (C sig, Dim.C u) => C (SigA.T u y sig) where+instance (C sig, Amp.C amp) => C (SigA.T amp sig) where    unwrappedProcessSamples f =       (\(SigA.Cons amp sig) ->          SigA.Cons amp (unwrappedProcessSamples f sig))
+ src/Synthesizer/Dimensional/Abstraction/HomogeneousGen.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{- |+Copyright   :  (c) Henning Thielemann 2009+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++Class similar to "Synthesizer.Dimensional.Abstraction.Homogeneous"+but it can be used for different storage types.+-}+module Synthesizer.Dimensional.Abstraction.HomogeneousGen where++import Synthesizer.Dimensional.Amplitude (Flat(Flat))+import qualified Synthesizer.Dimensional.Amplitude as Amp+import qualified Synthesizer.State.Signal as Sig+import qualified Synthesizer.Storable.Signal as SigSt+import qualified Synthesizer.Basic.WaveSmoothed as WaveSmooth+import qualified Synthesizer.Basic.Wave         as Wave+import qualified Synthesizer.Dimensional.RatePhantom as RP+import qualified Synthesizer.Dimensional.Straight.Signal as SigS+import qualified Synthesizer.Dimensional.Amplitude.Signal as SigA++{-+import qualified Number.DimensionTerm        as DN+import qualified Algebra.DimensionTerm       as Dim++import qualified Algebra.Module         as Module+import qualified Algebra.Field          as Field+import qualified Algebra.Ring           as Ring+-}++-- import Number.DimensionTerm ((&/&))++import Data.Tuple.HT (mapSnd, )++-- import NumericPrelude+-- import PreludeBase+-- import Prelude ()++{-# INLINE processSamples #-}+processSamples ::+   (C amp storage0 signal0, C amp storage1 signal1) =>+   (storage0 y0 -> storage1 y1) -> RP.T s signal0 y0 -> RP.T s signal1 y1+processSamples f =+   RP.fromSignal . plainProcessSamples f . RP.toSignal+++plainProcessSamples ::+   (C amp storage0 signal0, C amp storage1 signal1) =>+   (storage0 y0 -> storage1 y1) ->+   (signal0 y0 -> signal1 y1)+plainProcessSamples f =+   plainWrap . mapSnd f . plainUnwrap+++wrap ::+   (C amp storage signal) =>+   (amp, storage y) -> RP.T s signal y+wrap =+   RP.fromSignal . plainWrap++unwrap ::+   (C amp storage signal) =>+   RP.T s signal y -> (amp, storage y)+unwrap =+   plainUnwrap . RP.toSignal+++{- |+Functions using this class might define their own class with functional dependencies,+that allow to infer automatically, say,+that an amplitude input signal requires an amplitude output signal.+-}+class C amp storage signal |+     signal -> amp storage where+   plainWrap   :: (amp, storage y) -> signal y+   plainUnwrap :: signal y -> (amp, storage y)++instance C Flat Sig.T Sig.T where+   plainWrap = snd+   plainUnwrap = (,) Flat++instance C Flat SigSt.T SigSt.T where+   plainWrap = snd+   plainUnwrap = (,) Flat++instance C Flat sig (SigS.T sig) where+   plainWrap = SigS.Cons . snd+   plainUnwrap = (,) Flat . SigS.samples++instance (Amp.C amp) => C amp sig (SigA.T amp (SigS.T sig)) where+   plainWrap = uncurry SigA.Cons . mapSnd SigS.Cons+   plainUnwrap (SigA.Cons amp sig) = (amp, SigS.samples sig)++++++{- |+These instances are used in oscillator+where we even do not need homogenity,+since values from the waveform+go untouched to the output signal.+-}++instance C Flat (Wave.T t) (Wave.T t) where+   plainWrap = snd+   plainUnwrap = (,) Flat++instance C Flat (WaveSmooth.T t) (WaveSmooth.T t) where+   plainWrap = snd+   plainUnwrap = (,) Flat++instance (Amp.C amp) => C amp (Wave.T t) (SigA.T amp (Wave.T t)) where+   plainWrap = uncurry SigA.Cons+   plainUnwrap (SigA.Cons amp sig) = (amp, sig)++instance (Amp.C amp) => C amp (WaveSmooth.T t) (SigA.T amp (WaveSmooth.T t)) where+   plainWrap = uncurry SigA.Cons+   plainUnwrap (SigA.Cons amp sig) = (amp, sig)
+ src/Synthesizer/Dimensional/Amplitude.hs view
@@ -0,0 +1,27 @@+module Synthesizer.Dimensional.Amplitude where++import qualified Number.DimensionTerm        as DN+import qualified Algebra.DimensionTerm       as Dim++{- |+Can be used as amplitude value in 'Synthesizer.Dimensional.Causal.Process.T'+or in 'Synthesizer.Dimensional.Abstraction.HomogeneousGen',+whenever the signal has no amplitude.+It would be a bad idea to omit the @Flat@ parameter+in 'Synthesizer.Dimensional.Causal.Process.applyFlat' routine,+since 'Synthesizer.Dimensional.Causal.Process.apply' can still be used+but the correspondence between amplitude type and sample type is lost.+-}+data Flat = Flat++{- |+This class is used to make 'Synthesizer.Dimensional.Causal.Process.mapAmplitude'+both flexible and a bit safe.+Its instances are dimensional numbers 'DN.T' and 'Flat'.+It should not be necessary to add more instances.+-}+class C amp where++instance C Flat where++instance Dim.C v => C (DN.T v y) where
src/Synthesizer/Dimensional/Amplitude/Analysis.hs view
@@ -51,9 +51,6 @@ import qualified Algebra.Ring                as Ring  --- import qualified Data.List as List--- import NumericPrelude.List (zipWithMatch, )- import PreludeBase (Ord, Bool, (<=), ($), (.), uncurry, ) -- import NumericPrelude import qualified Prelude as P@@ -144,7 +141,7 @@ {-# INLINE flipFlopHysteresis #-} flipFlopHysteresis :: (Ind.C w, Ord y, Field.C y, Dim.C u) =>    (DN.T u y, DN.T u y) -> Bool ->-   w (SigA.S u y) y -> w (SigS.T Sig.T) Bool+   w (SigA.S u y) y -> w SigS.S Bool --   SigA.R s u y y -> SigS.Binary s flipFlopHysteresis (lower,upper) start x =    let l = SigA.toAmplitudeScalar x lower
src/Synthesizer/Dimensional/Amplitude/Cut.hs view
@@ -40,7 +40,6 @@ -- import qualified Algebra.Ring                as Ring  import qualified Data.List as List--- import NumericPrelude.List (zipWithMatch, )  import PreludeBase (Ord, max, ) -- import NumericPrelude
src/Synthesizer/Dimensional/Amplitude/Displacement.hs view
@@ -40,8 +40,10 @@  {- * Mixing -} -{-| Mix two signals.-    In opposition to 'zipWith' the result has the length of the longer signal. -}+{- |+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 u) =>@@ -60,11 +62,13 @@    -> SigA.R s u y yv mixVolume v x y =    let z = SigA.fromSamples v-              (toAmplitudeScalar z (SigA.amplitude x) *> SigA.samples x +-               toAmplitudeScalar z (SigA.amplitude y) *> SigA.samples y)+              (SigA.vectorSamples (toAmplitudeScalar z) x ++               SigA.vectorSamples (toAmplitudeScalar z) y)    in  z -{-| Mix one or more signals. -}+{- |+Mix one or more signals.+-} {-# INLINE mixMulti #-} mixMulti ::    (Real.C y, Field.C y, Module.C y yv, Dim.C u) =>@@ -81,12 +85,13 @@    ->  SigA.R s u y yv mixMultiVolume v x =    let z = SigA.fromSamples v-              (foldr (\y -> (toAmplitudeScalar z (SigA.amplitude y) *>-                             SigA.samples y +)) Sig.empty x)+              (foldr (\y -> (SigA.vectorSamples (toAmplitudeScalar z) y +)) Sig.empty x)    in  z -{-| Add a number to all of the signal values.-    This is useful for adjusting the center of a modulation. -}+{- |+Add a number to all of the signal values.+This is useful for adjusting the center of a modulation.+-} {-# INLINE raise #-} raise :: (Ind.C w, Field.C y, Module.C y yv, Dim.C u) =>       DN.T u y@@ -97,6 +102,16 @@    SigA.processSamples       (Disp.raise (toAmplitudeScalar x y' *> yv)) x +{- |+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 u) =>       (yv -> yv)
src/Synthesizer/Dimensional/Amplitude/Signal.hs view
@@ -13,6 +13,7 @@ -} module Synthesizer.Dimensional.Amplitude.Signal where +import qualified Synthesizer.Dimensional.Amplitude as Amp import qualified Synthesizer.Format as Format import qualified Synthesizer.Dimensional.Abstraction.RateIndependent as Ind @@ -24,7 +25,6 @@  import qualified Synthesizer.Generic.Filter.NonRecursive as FiltG import qualified Synthesizer.Generic.Signal as SigG-import qualified Synthesizer.Generic.SampledValue as Sample  import qualified Number.DimensionTerm        as DN import qualified Algebra.DimensionTerm       as Dim@@ -41,71 +41,76 @@ import Prelude ()  -data T v y sig yv =+data T amp sig yv =    Cons {-        privateAmplitude :: DN.T v y   {-^ scaling of the values -}-      , signal           :: sig yv     {-^ the embedded signal -}+        privateAmplitude :: amp     {-^ scaling of the values -}+      , signal           :: sig yv  {-^ the embedded signal -}      } --   deriving (Eq, Show) -instance (Dim.C v, Show y, Format.C sig) => Format.C (T v y sig) where+instance (Show amp, Format.C sig) => Format.C (T amp sig) where    format p (Cons amp sig) =       showParen (p >= 10)          (showString "amplitudeSignal " . showsPrec 11 amp .           showString " " . Format.format 11 sig) -instance (Dim.C v, Show y, Show yv, Format.C sig) => Show (T v y sig yv) where+instance (Show amp, Show yv, Format.C sig) => Show (T amp sig yv) where    showsPrec = Format.format  type R s v y yv = RP.T s (S v y) yv-type S v y = T v y (SigS.T Sig.T)  -- kind * -> *+type S v y = D v y SigS.S  -- kind * -> *+type D v y = T (DN.T v y)  {- We removed that instance because 'fmap' is too dangerous for application code. You may write functions that depend on the particular amplitude scaling. -instance Dim.C v => Functor (T v y s) where+instance Dim.C v => Functor (D v y s) where    fmap f (Cons amp ss) = Cons amp (map f ss) -}  {-# INLINE amplitude #-} amplitude :: (Ind.C w, Dim.C v) =>-   w (T v y sig) yv -> DN.T v y+   w (D v y sig) yv -> DN.T v y amplitude = privateAmplitude . Ind.toSignal  {-# INLINE samples #-} samples :: (Ind.C w, Dim.C v) =>-   w (T v y (SigS.T sig)) yv -> sig yv+   w (D v y (SigS.T sig)) yv -> sig yv samples = privateSamples . Ind.toSignal  {-# INLINE privateSamples #-}-privateSamples :: (Dim.C v) =>-   T v y (SigS.T sig) yv -> sig yv+privateSamples :: (Amp.C amp) =>+   T amp (SigS.T sig) yv -> sig yv privateSamples = SigS.samples . signal  {-# INLINE phantomSignal #-} phantomSignal ::-   RP.T s (T v y sig) yv -> RP.T s sig yv+   RP.T s (D v y sig) yv -> RP.T s sig yv phantomSignal =    RP.fromSignal . signal . RP.toSignal   {-# INLINE toAmplitudeScalar #-} toAmplitudeScalar :: (Ind.C w, Field.C y, Dim.C v) =>-   w (T v y sig) yv -> DN.T v y -> y+   w (D v y sig) yv -> DN.T v y -> y toAmplitudeScalar sig y =    DN.divToScalar y (amplitude sig)  {-# INLINE scalarSamples #-}+{- scalarSamples :: (Ind.C w, Ring.C y, Dim.C v) =>    (DN.T v y -> y) -> w (S v y) y -> Sig.T y+-}+scalarSamples :: (Ind.C w, Ring.C y, Amp.C amp) =>+   (amp -> y) -> w (T amp SigS.S) y -> Sig.T y scalarSamples toAmpScalar =    scalarSamplesPrivate toAmpScalar . Ind.toSignal  {-# INLINE scalarSamplesGeneric #-} scalarSamplesGeneric ::-   (Ind.C w, Ring.C y, Dim.C v, Sample.C y, SigG.C sig) =>-   (DN.T v y -> y) -> w (T v y (SigS.T sig)) y -> sig y+   (Ind.C w, Ring.C y, Dim.C v, SigG.Transform sig y) =>+   (DN.T v y -> y) -> w (D v y (SigS.T sig)) y -> sig y scalarSamplesGeneric toAmpScalar =    scalarSamplesPrivateGeneric toAmpScalar . Ind.toSignal @@ -118,42 +123,47 @@  {-# INLINE rewriteDimension #-} rewriteDimension :: (Dim.C v0, Dim.C v1) =>-   (v0 -> v1) -> T v0 y sig yv -> T v1 y sig yv+   (v0 -> v1) -> D v0 y sig yv -> D v1 y sig yv rewriteDimension f (Cons amp ss) =    Cons (DN.rewriteDimension f amp) ss   {-# INLINE fromSignal #-}-fromSignal :: DN.T v y -> SigS.R s yv -> R s v y yv+-- fromSignal :: DN.T v y -> SigS.R s yv -> R s v y yv+fromSignal :: amp -> SigS.R s yv -> RP.T s (T amp SigS.S) yv fromSignal amp  =  RP.fromSignal . Cons amp . RP.toSignal   {-# INLINE toScalarSignal #-} toScalarSignal :: (Ind.C w, Field.C y, Dim.C v) =>-   DN.T v y -> w (S v y) y -> w (SigS.T Sig.T) y+   DN.T v y -> w (S v y) y -> w SigS.S y toScalarSignal amp  =    Ind.processSignal       (SigS.Cons . scalarSamplesPrivate (flip DN.divToScalar amp))  {-# INLINE toVectorSignal #-} toVectorSignal :: (Ind.C w, Field.C y, Module.C y yv, Dim.C v) =>-   DN.T v y -> w (S v y) yv -> w (SigS.T Sig.T) yv+   DN.T v y -> w (S v y) yv -> w SigS.S yv toVectorSignal amp  =    Ind.processSignal       (SigS.Cons . vectorSamplesPrivate (flip DN.divToScalar amp))   {-# INLINE scalarSamplesPrivate #-}+{- scalarSamplesPrivate :: (Ring.C y, Dim.C v) =>    (DN.T v y -> y) -> S v y y -> Sig.T y+-}+scalarSamplesPrivate :: (Ring.C y, Amp.C amp) =>+   (amp -> y) -> T amp SigS.S y -> Sig.T y scalarSamplesPrivate toAmpScalar sig =    let y = toAmpScalar (privateAmplitude sig)    in  Filt.amplify y (privateSamples sig)  {-# INLINE scalarSamplesPrivateGeneric #-} scalarSamplesPrivateGeneric ::-   (Ring.C y, Dim.C v, Sample.C y, SigG.C sig) =>-   (DN.T v y -> y) -> T v y (SigS.T sig) y -> sig y+   (Ring.C y, Dim.C v, SigG.Transform sig y) =>+   (DN.T v y -> y) -> D v y (SigS.T sig) y -> sig y scalarSamplesPrivateGeneric toAmpScalar sig =    let y = toAmpScalar (privateAmplitude sig)    in  FiltG.amplify y (privateSamples sig)@@ -167,53 +177,56 @@   {-# INLINE fromSamples #-}-fromSamples :: DN.T v y -> Sig.T yv -> R s v y yv+-- fromSamples :: (Dim.C v) => DN.T v y -> Sig.T yv -> R s v y yv+fromSamples :: {- (Amp.C amp) => -} amp -> Sig.T yv -> RP.T s (T amp SigS.S) yv fromSamples amp  =  fromSignal amp . SigS.fromSamples  {-# INLINE fromScalarSamples #-}-fromScalarSamples :: DN.T v y -> Sig.T y -> R s v y y+fromScalarSamples :: {- (Amp.C amp) => -}+   amp -> Sig.T y -> RP.T s (T amp SigS.S) y fromScalarSamples  =  fromSamples  {-# INLINE fromVectorSamples #-}-fromVectorSamples :: DN.T v y -> Sig.T yv -> R s v y yv+fromVectorSamples :: {- (Amp.C amp) => -}+   amp -> Sig.T yv -> RP.T s (T amp SigS.S) yv fromVectorSamples  =  fromSamples  {-# INLINE replaceAmplitude #-} replaceAmplitude :: (Ind.C w, Dim.C v0, Dim.C v1) =>-   DN.T v1 y -> w (T v0 y sig) yv -> w (T v1 y sig) yv+   DN.T v1 y -> w (D v0 y sig) yv -> w (D v1 y sig) yv replaceAmplitude amp  =  Ind.processSignal (replaceAmplitudePrivate amp)  {-# INLINE replaceSamples #-} replaceSamples :: (Ind.C w, Dim.C v) =>-   sig1 yv1 -> w (T v y sig0) yv0 -> w (T v y (SigS.T sig1)) yv1+   sig1 yv1 -> w (D v y sig0) yv0 -> w (D v y (SigS.T sig1)) yv1 replaceSamples ss  =  Ind.processSignal (replaceSamplesPrivate ss)  {-# INLINE replaceAmplitudePrivate #-} replaceAmplitudePrivate :: (Dim.C v0, Dim.C v1) =>-   DN.T v1 y -> T v0 y sig yv -> T v1 y sig yv+   DN.T v1 y -> D v0 y sig yv -> D v1 y sig yv replaceAmplitudePrivate amp  =  Cons amp . signal  {-# INLINE replaceSamplesPrivate #-} replaceSamplesPrivate :: (Dim.C v) =>-   sig1 yv1 -> T v y sig0 yv0 -> T v y (SigS.T sig1) yv1+   sig1 yv1 -> D v y sig0 yv0 -> D v y (SigS.T sig1) yv1 replaceSamplesPrivate ss x  =  Cons (privateAmplitude x) (SigS.Cons ss)   {-# INLINE processSamples #-} processSamples :: (Ind.C w, Dim.C v) =>    (sig0 yv0 -> sig1 yv1) ->-   w (T v y (SigS.T sig0)) yv0 -> w (T v y (SigS.T sig1)) yv1+   w (D v y (SigS.T sig0)) yv0 -> w (D v y (SigS.T sig1)) yv1 processSamples f =    Ind.processSignal (processSamplesPrivate f)  {-# INLINE processSamplesPrivate #-} processSamplesPrivate :: (Dim.C v) =>    (sig0 yv0 -> sig1 yv1) ->-   T v y (SigS.T sig0) yv0 -> T v y (SigS.T sig1) yv1+   D v y (SigS.T sig0) yv0 -> D v y (SigS.T sig1) yv1 processSamplesPrivate f (Cons amp sig) =    Cons amp (SigS.processSamplesPrivate f sig)   {-# INLINE asTypeOfAmplitude #-}-asTypeOfAmplitude :: y -> w (T v y sig) yv -> y+asTypeOfAmplitude :: y -> w (D v y sig) yv -> y asTypeOfAmplitude = const
+ src/Synthesizer/Dimensional/Arrow.hs view
@@ -0,0 +1,140 @@+{- |+Adaption of "Control.Arrow" to signal processes involving amplitudes.+This class unifies "Synthesizer.Dimensional.Map"+and "Synthesizer.Dimensional.Causal.Process".+-}+module Synthesizer.Dimensional.Arrow where++import qualified Synthesizer.Dimensional.Map as Map+import Data.Tuple.HT (mapFst, mapSnd, mapPair, )++import qualified Prelude as P+import Prelude hiding (map, id, fst, snd, )+++class C arrow where+   map ::+      Map.T amp0 amp1 yv0 yv1 ->+      arrow amp0 amp1 yv0 yv1+   (>>>) ::+      arrow amp0 amp1 yv0 yv1 ->+      arrow amp1 amp2 yv1 yv2 ->+      arrow amp0 amp2 yv0 yv2+   first ::+      arrow amp0 amp1 yv0 yv1 ->+      arrow (amp0, amp) (amp1, amp) (yv0, yv) (yv1, yv)+   second ::+      arrow amp0 amp1 yv0 yv1 ->+      arrow (amp, amp0) (amp, amp1) (yv, yv0) (yv, yv1)+   (***) ::+      arrow amp0 amp1 yv0 yv1 ->+      arrow amp2 amp3 yv2 yv3 ->+      arrow (amp0, amp2) (amp1, amp3) (yv0, yv2) (yv1, yv3)+   (&&&) ::+      arrow amp amp0 yv yv0 ->+      arrow amp amp1 yv yv1 ->+      arrow amp (amp0, amp1) yv (yv0, yv1)++   {-# INLINE second #-}+   second arr = Map.swap ^<< first arr <<^ Map.swap+   {-# INLINE (***) #-}+   f *** g = first f <<< second g+   {-# INLINE (&&&) #-}+   f &&& g = f***g <<^ Map.double+++instance C Map.T where+   map = P.id+   (Map.Cons f) >>> (Map.Cons g) =+      Map.Cons $ \x ->+         let (y, h) = f x+             (z, k) = g y+         in  (z, k . h)+   first (Map.Cons f) =+      Map.Cons $ \(x,z) ->+         let (y, g) = f x+         in  ((y,z), mapFst g)+   second (Map.Cons f) =+      Map.Cons $ \(z,x) ->+         let (y, g) = f x+         in  ((z,y), mapSnd g)+   (Map.Cons f) *** (Map.Cons g) =+      Map.Cons $ \(x,y) ->+         let (z, h) = f x+             (w, k) = g y+         in  ((z,w), mapPair (h,k))+   (Map.Cons f) &&& (Map.Cons g) =+      Map.Cons $ \x ->+         let (y, h) = f x+             (z, k) = g x+         in  ((y,z), \s -> (h s, k s))+++infixr 3 ***+infixr 3 &&&+infixr 1 >>>, ^>>, >>^+infixr 1 <<<, ^<<, <<^+++{-# INLINE compose #-}+compose :: (C arrow) =>+   arrow amp0 amp1 yv0 yv1 ->+   arrow amp1 amp2 yv1 yv2 ->+   arrow amp0 amp2 yv0 yv2+compose = (>>>)++{-# INLINE (<<<) #-}+(<<<) :: (C arrow) =>+   arrow amp1 amp2 yv1 yv2 ->+   arrow amp0 amp1 yv0 yv1 ->+   arrow amp0 amp2 yv0 yv2+(<<<) = flip (>>>)+++{-# INLINE split #-}+split :: (C arrow) =>+   arrow amp0 amp1 yv0 yv1 ->+   arrow amp2 amp3 yv2 yv3 ->+   arrow (amp0, amp2) (amp1, amp3) (yv0, yv2) (yv1, yv3)+split = (***)++{-# INLINE fanout #-}+fanout :: (C arrow) =>+   arrow amp amp0 yv yv0 ->+   arrow amp amp1 yv yv1 ->+   arrow amp (amp0, amp1) yv (yv0, yv1)+fanout = (&&&)++-- * map functions++{-# INLINE (^>>) #-}+-- | Precomposition with a pure function.+(^>>) :: (C arrow) =>+   Map.T amp0 amp1 yv0 yv1 ->+   arrow amp1 amp2 yv1 yv2 ->+   arrow amp0 amp2 yv0 yv2+f ^>> a = map f >>> a++{-# INLINE (>>^) #-}+-- | Postcomposition with a pure function.+(>>^) :: (C arrow) =>+   arrow amp0 amp1 yv0 yv1 ->+   Map.T amp1 amp2 yv1 yv2 ->+   arrow amp0 amp2 yv0 yv2+a >>^ f = a >>> map f++{-# INLINE (<<^) #-}+-- | Precomposition with a pure function (right-to-left variant).+(<<^) :: (C arrow) =>+   arrow amp1 amp2 yv1 yv2 ->+   Map.T amp0 amp1 yv0 yv1 ->+   arrow amp0 amp2 yv0 yv2+a <<^ f = a <<< map f++{-# INLINE (^<<) #-}+-- | Postcomposition with a pure function (right-to-left variant).+(^<<) :: (C arrow) =>+   Map.T amp1 amp2 yv1 yv2 ->+   arrow amp0 amp1 yv0 yv1 ->+   arrow amp0 amp2 yv0 yv2+f ^<< a = map f <<< a
+ src/Synthesizer/Dimensional/Causal/ControlledProcess.hs view
@@ -0,0 +1,502 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE Rank2Types #-}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes (Flat)+++Basic definitions for causal signal processors+which are controlled by another signal.+Additionally to "Synthesizer.Dimensional.ControlledProcess"+you can convert those processes to plain causal processes+in the case of equal audio and control rates (synchronous control).++It is sensible to bundle the functions+"computation of internal parameters" and+"running the main process",+since computation of the internal parameters+depends on the sample rate of the main process+in case of frequency control values+even though the computation of internal parameters happens+at a different sample rate.++ToDo:+ - Is it better to provide the conversion method not by a record+   but by a type class?+   The difficulty with this is,+   how to handle global parameters like the filter order?+ - Note, that parameters might be computed by different ways.+   Thus a type class with functional dependencies+   for automatic selection of input types and conversion+   will not always be flexible enough.+ - Is it possible and reasonable to hide the type parameter+   for the internal control parameter+   since the user does not need to know it?+ - The internal parameters that the converter generate+   usually depend on the sample rate of the (target) audio signal.+   However, it does not depend on the sample rate of control signal+   where it is applied to.+   How can we ensure that it is not used somewhere else?+   We could discourage access to it at all.+   But it might be sensible to define new external parameters+   in terms of existing ones.+   We could add a phantom 's' type parameter+   to internal control parameters.+   Would this do the trick? Is this convenient?+-}+module Synthesizer.Dimensional.Causal.ControlledProcess where++import qualified Synthesizer.Dimensional.Process as Proc+import qualified Synthesizer.Dimensional.Rate as Rate+import qualified Synthesizer.Dimensional.RatePhantom as RP+import qualified Synthesizer.Dimensional.RateWrapper as SigP+import qualified Synthesizer.Dimensional.Straight.Signal as SigS+import qualified Synthesizer.Dimensional.Straight.Displacement as DispS+import qualified Synthesizer.Dimensional.Amplitude.Signal as SigA+import qualified Synthesizer.Dimensional.Causal.Process as CausalD+import qualified Synthesizer.Dimensional.Map as MapD+import qualified Synthesizer.Dimensional.Amplitude as Amp+import qualified Synthesizer.Causal.Process       as Causal+import qualified Synthesizer.Causal.Interpolation as Interpolation+import qualified Synthesizer.Interpolation.Class as Interpol+import qualified Synthesizer.State.Signal as Sig+import qualified Number.DimensionTerm        as DN+import qualified Algebra.DimensionTerm       as Dim++-- import Synthesizer.Dimensional.Process (($:), ($#), )+-- import Synthesizer.Dimensional.RateAmplitude.Signal (($-))++-- import Number.DimensionTerm ((*&), ) -- ((&*&), (&/&))++import qualified Algebra.RealField      as RealField+-- import qualified Algebra.Field          as Field+-- import qualified Algebra.Ring           as Ring+import qualified Algebra.Additive       as Additive++import Foreign.Storable.Newtype as Store+import Foreign.Storable (Storable(..))++import NumericPrelude+import PreludeBase as P+++{- |+This is quite analogous to Dimensional.Causal.Process+but adds the @conv@ parameter for conversion+from intuitive external parameters to internal parameters.+-}+data T conv proc = Cons {+      converter :: conv,+      processor :: proc+   }+++{- |+The Functor instance allows+to define an allpass phaser as ControlledProcess,+reusing the allpass cascade provided as ControlledProcess.+It is also possible to define a lowpass filter+with resonance as ControlledProcess+based on the universal filter ControlledProcess.+-}+instance Functor (T conv) where+   fmap f proc =+      Cons (converter proc) (f $ processor proc)++{- |+@ecAmp@ is a set of physical units for the external control parameters,+@ec@ is the type for the external control parameters,+@ic@ for internal control parameters.+-}+type Converter s ecAmp ec ic =+   MapD.T ecAmp Amp.Flat ec (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++instance Storable ic => Storable (RateDep s ic) where+   sizeOf = Store.sizeOf unRateDep+   alignment = Store.alignment unRateDep+   peek = Store.peek RateDep+   poke = Store.poke unRateDep+++{- |+This function is intended for implementing high-level dimensional processors+from low-level processors.+It introduces the sample rate tag @s@.+-}+{-# INLINE makeConverter #-}+makeConverter ::+   (ecAmp -> ec -> ic) -> Converter s ecAmp ec ic+makeConverter f =+   MapD.Cons $ (,) Amp.Flat . (RateDep.) . f++{-# INLINE causalFromConverter #-}+causalFromConverter ::+   Converter s ecAmp ec ic ->+   CausalD.T s ecAmp CausalD.Flat ec (RateDep s ic)+causalFromConverter = CausalD.map+++{-# INLINE joinSynchronousPlain #-}+joinSynchronousPlain ::+   T (Converter s ecAmp ec ic)+     (CausalD.T s (ampIn, CausalD.Flat) ampOut (sampIn, RateDep s ic) sampOut) ->+   CausalD.T s (ecAmp, ampIn) ampOut (ec, sampIn) sampOut+joinSynchronousPlain p =+   processor p CausalD.<<<+   MapD.swap CausalD.^<<+   CausalD.first (causalFromConverter (converter p))++{-# INLINE joinSynchronous #-}+joinSynchronous ::+   Proc.T s u t+      (T (Converter s ecAmp ec ic)+         (CausalD.T s (ampIn, CausalD.Flat) ampOut (sampIn, RateDep s ic) sampOut)) ->+   Proc.T s u t (CausalD.T s (ecAmp, ampIn) ampOut (ec, sampIn) sampOut)+joinSynchronous cp =+   fmap joinSynchronousPlain cp+++{-# INLINE joinFirstSynchronousPlain #-}+joinFirstSynchronousPlain ::+   T (Converter s ecAmp ec ic, a)+     (CausalD.T s (ampIn, CausalD.Flat) ampOut (sampIn, RateDep s ic) sampOut) ->+   T a+     (CausalD.T s (ecAmp, ampIn) ampOut (ec, sampIn) sampOut)+joinFirstSynchronousPlain p =+   Cons {+      converter = snd (converter p),+      processor = joinSynchronousPlain (Cons (fst (converter p)) (processor p))+   }++{-+With this signature we deconstruct a right biased pair tree in the ampIn parameter of T+and build a left biased pair tree in the corresponding output parameter.+We could also use a pair of heterogeneous lists.+But the effect is always, that the list is reversed.+-}+{-# INLINE joinFirstSynchronous #-}+joinFirstSynchronous ::+   Proc.T s u t+      (T (Converter s ecAmp ec ic, a)+         (CausalD.T s (ampIn, CausalD.Flat) ampOut (sampIn, RateDep s ic) sampOut)) ->+   Proc.T s u t+      (T a+         (CausalD.T s (ecAmp, ampIn) ampOut (ec, sampIn) sampOut))+joinFirstSynchronous cp =+   fmap joinFirstSynchronousPlain cp++{-+{-# INLINE runSynchronous #-}+runSynchronous ::+   Proc.T s u t (T s (Convert ecAmp ec ic) (CausalD.Flat, ampIn) ampOut (RateDep s ic, sampIn) sampOut) ->+   Proc.T s u t (CausalD.T s (ecAmp, ampIn) ampOut (ec, sampIn) sampOut)+runSynchronous cp =+   do p <- cp+      return (processor p . converter p)+-}++{-# INLINE runSynchronous1 #-}+runSynchronous1 :: (Dim.C v) =>+   Proc.T s u t+      (T (Converter s (DN.T v ecAmp) ec ic)+         (CausalD.T s (ampIn, CausalD.Flat) ampOut (sampIn, RateDep s ic) sampOut)) ->+   Proc.T s u t+      (SigA.R s v ecAmp ec -> CausalD.T s ampIn ampOut sampIn sampOut)+runSynchronous1 =+   fmap CausalD.applyFst . joinSynchronous+++{-# INLINE runSynchronousPlain2 #-}+runSynchronousPlain2 :: (Dim.C v0, Dim.C v1) =>+   (T (Converter s (DN.T v0 ecAmp0, DN.T v1 ecAmp1) (ec0, ec1) ic)+      (CausalD.T s (ampIn, CausalD.Flat) ampOut (sampIn, RateDep s ic) sampOut)) ->+   (SigA.R s v0 ecAmp0 ec0 ->+    SigA.R s v1 ecAmp1 ec1 ->+    CausalD.T s ampIn ampOut sampIn sampOut)+runSynchronousPlain2 causal =+   let causalPairs =+          joinSynchronousPlain causal CausalD.<<^ MapD.balanceLeft+   in  \x y ->+          (causalPairs `CausalD.applyFst` x) `CausalD.applyFst` y++{-# INLINE runSynchronous2 #-}+runSynchronous2 :: (Dim.C v0, Dim.C v1) =>+   Proc.T s u t+      (T (Converter s (DN.T v0 ecAmp0, DN.T v1 ecAmp1) (ec0, ec1) ic)+         (CausalD.T s (ampIn, CausalD.Flat) ampOut (sampIn, RateDep s ic) sampOut)) ->+   Proc.T s u t+      (SigA.R s v0 ecAmp0 ec0 ->+       SigA.R s v1 ecAmp1 ec1 ->+       CausalD.T s ampIn ampOut sampIn sampOut)+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 #-}+runAsynchronous ::+   (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, CausalD.Flat) ampOut (sampIn, RateDep s ic) sampOut)) ->+   Rate.T r u t ->+   SigS.R r (RateDep s ic) ->+   Proc.T s u t+      (CausalD.T s ampIn ampOut sampIn sampOut)+runAsynchronous ip cp srcRate sig =+   do p <- cp+      k <- fmap+              (DN.divToScalar (Rate.toDimensionNumber srcRate))+              Proc.getSampleRate+      return $+         CausalD.applyFlatFst (processor p CausalD.<<^ MapD.swap) $+         RP.fromSignal $+         Causal.apply+            (Interpolation.relativeConstantPad ip zero (SigS.toSamples sig))+            (Sig.repeat k)++{-# INLINE runAsynchronousBuffered #-}+runAsynchronousBuffered ::+   (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, CausalD.Flat) ampOut (sampIn, RateDep s ic) sampOut)) ->+   Rate.T r u t ->+   SigS.R r (RateDep s ic) ->+   Proc.T s u t+      (CausalD.T s ampIn ampOut sampIn sampOut)+runAsynchronousBuffered ip cp srcRate sig =+   do p <- cp+      k <- fmap+              (DN.divToScalar (Rate.toDimensionNumber srcRate))+              Proc.getSampleRate+      return $+         CausalD.applyFlatFst (processor p CausalD.<<^ MapD.swap) $+         RP.fromSignal $+         Causal.apply+            (Interpolation.relativeConstantPad ip zero+                (Sig.fromList $ Sig.toList $ SigS.toSamples sig))+            (Sig.repeat k)+++{-# INLINE applyConverter1 #-}+applyConverter1 :: (Dim.C v) =>+   Converter s (DN.T v ecAmp) ec ic ->+   SigA.R s v ecAmp ec -> SigS.R s (RateDep s ic)+applyConverter1 (MapD.Cons f) x =+   DispS.map (snd $ f (SigA.amplitude x)) (SigA.phantomSignal x)++{-# INLINE runAsynchronous1 #-}+runAsynchronous1 ::+   (Dim.C u, Dim.C v, RealField.C t) =>+   Interpolation.T t (RateDep s ic) ->+   Proc.T s u t+      (T (Converter s (DN.T v ecAmp) ec ic)+         (CausalD.T s (ampIn, CausalD.Flat) ampOut (sampIn, RateDep s ic) sampOut)) ->+   SigP.T u t (SigA.S v ecAmp) ec ->+   Proc.T s u t+      (CausalD.T s ampIn ampOut sampIn sampOut)+runAsynchronous1 ip cp x =+   let (srcRate,sig) = SigP.toSignal x+   in  do p <- cp+          runAsynchronous ip cp srcRate (applyConverter1 (converter p) sig)++{-# INLINE processAsynchronous1 #-}+processAsynchronous1 ::+   (Dim.C u, Dim.C v, RealField.C t) =>+   Interpolation.T t (RateDep s ic) ->+   Proc.T s u t+      (T (Converter s (DN.T v ecAmp) ec ic)+         (CausalD.T s (ampIn, CausalD.Flat) ampOut (sampIn, RateDep s ic) sampOut)) ->+   DN.T (Dim.Recip u) t ->+   (forall r. Proc.T r u t (SigA.R r v ecAmp ec)) ->+   Proc.T s u t+      (CausalD.T s ampIn ampOut sampIn sampOut)+processAsynchronous1 ip cp rate x =+   let sig = RP.fromSignal $ Proc.run rate (fmap RP.toSignal x)+   in  do p <- cp+          runAsynchronous ip cp (Rate.fromDimensionNumber rate)+             (applyConverter1 (converter p) sig)+++{-# INLINE applyConverter2 #-}+applyConverter2 :: (Dim.C v0, Dim.C v1) =>+   Converter s (DN.T v0 ecAmp0, DN.T v1 ecAmp1) (ec0, ec1) ic ->+   SigA.R s v0 ecAmp0 ec0 ->+   SigA.R s v1 ecAmp1 ec1 ->+   SigS.R s (RateDep s ic)+applyConverter2 (MapD.Cons f) x y =+   SigS.fromSamples $+   Sig.map (snd $ f (SigA.amplitude x, SigA.amplitude y)) $+   Sig.zip (SigA.samples x) (SigA.samples y)++{- |+Using two SigP.T's as input has the disadvantage+that their rates must be compared dynamically.+It is not possible with our data structures+to use one rate for multiple signals.+We could also allow the input of a Rate.T and two Proc.T's,+since this is the form we get from the computation routines.+But this way we lose sharing.+-}+{-# INLINE runAsynchronous2 #-}+runAsynchronous2 ::+   (Dim.C u, Dim.C v0, Dim.C v1, RealField.C t) =>+   Interpolation.T t (RateDep s ic) ->+   Proc.T s u t+      (T (Converter s (DN.T v0 ecAmp0, DN.T v1 ecAmp1) (ec0, ec1) ic)+         (CausalD.T s (ampIn, CausalD.Flat) ampOut (sampIn, RateDep s ic) sampOut)) ->+   SigP.T u t (SigA.S v0 ecAmp0) ec0 ->+   SigP.T u t (SigA.S v1 ecAmp1) ec1 ->+   Proc.T s u t+      (CausalD.T s ampIn ampOut sampIn sampOut)+runAsynchronous2 ip cp x y =+   let (srcRateX,sigX) = SigP.toSignal x+       (srcRateY,sigY) = SigP.toSignal y+       srcRate = Rate.common "ControlledProcess.runAsynchronous2" srcRateX srcRateY+   in  do p <- cp+          runAsynchronous ip cp srcRate+             (applyConverter2 (converter p) sigX sigY)+++{- |+This function will be more commonly used than 'runAsynchronous2',+but it disallows sharing of control signals.+It can be easily defined in terms of 'runAsynchronous2' and 'SigP.runProcess',+but the implementation here does not need the check for equal sample rates.+-}+{-# INLINE processAsynchronous2 #-}+processAsynchronous2 ::+   (Dim.C u, Dim.C v0, Dim.C v1, RealField.C t) =>+   Interpolation.T t (RateDep s ic) ->+   Proc.T s u t+      (T (Converter s (DN.T v0 ecAmp0, DN.T v1 ecAmp1) (ec0, ec1) ic)+         (CausalD.T s (ampIn, CausalD.Flat) ampOut (sampIn, RateDep s ic) sampOut)) ->+   DN.T (Dim.Recip u) t ->+   (forall r. Proc.T r u t (SigA.R r v0 ecAmp0 ec0)) ->+   (forall r. Proc.T r u t (SigA.R r v1 ecAmp1 ec1)) ->+   Proc.T s u t+      (CausalD.T s ampIn ampOut sampIn sampOut)+processAsynchronous2 ip cp rate x y =+   let sigX = RP.fromSignal $ Proc.run rate (fmap RP.toSignal x)+       sigY = RP.fromSignal $ Proc.run rate (fmap RP.toSignal y)+   in  do p <- cp+          runAsynchronous ip cp (Rate.fromDimensionNumber rate)+             (applyConverter2 (converter p) sigX sigY)+++{-# INLINE processAsynchronousNaive2 #-}+processAsynchronousNaive2 ::+   (Dim.C u, Dim.C v0, Dim.C v1, RealField.C t) =>+   Interpolation.T t (RateDep s ic) ->+   Proc.T s u t+      (T (Converter s (DN.T v0 ecAmp0, DN.T v1 ecAmp1) (ec0, ec1) ic)+         (CausalD.T s (ampIn, CausalD.Flat) ampOut (sampIn, RateDep s ic) sampOut)) ->+   DN.T (Dim.Recip u) t ->+   (forall r. Proc.T r u t (SigA.R r v0 ecAmp0 ec0)) ->+   (forall r. Proc.T r u t (SigA.R r v1 ecAmp1 ec1)) ->+   Proc.T s u t+      (CausalD.T s ampIn ampOut sampIn sampOut)+processAsynchronousNaive2 ip cp rate x y =+   runAsynchronous2 ip cp+      (SigP.runProcess rate x) (SigP.runProcess rate y)+++{-+This uses lazy StorableVector for buffering+of the internal control parameters.+This increases laziness granularity,+but it should be faster, since interpolation needs frequent look-ahead,+and this is faster on a Storable signal than on a plain stateful signal generator.+Since the look-ahead is constant,+it is interesting whether interpolation can be made more efficient+without Storable.++{-# INLINE processAsynchronousStorable2 #-}+processAsynchronousStorable2 ::+   (Dim.C u, Dim.C v0, Dim.C v1, Storable ic, RealField.C t) =>+   Interpolation.T t (RateDep s ic) ->+   Proc.T s u t+      (T (Converter s (DN.T v0 ecAmp0, DN.T v1 ecAmp1) (ec0, ec1) ic)+         (CausalD.T s (ampIn, CausalD.Flat) ampOut (sampIn, RateDep s ic) sampOut)) ->+   DN.T (Dim.Recip u) t ->+   (forall r. Proc.T r u t (SigA.R r v0 ecAmp0 ec0)) ->+   (forall r. Proc.T r u t (SigA.R r v1 ecAmp1 ec1)) ->+   Proc.T s u t+      (CausalD.T s ampIn ampOut sampIn sampOut)+processAsynchronousStorable2 ip cp rate x y =+   let sigX = RP.fromSignal $ Proc.run rate (fmap RP.toSignal x)+       sigY = RP.fromSignal $ Proc.run rate (fmap RP.toSignal y)+   in  do p <- cp+          runAsynchronous ip cp (Rate.fromDimensionNumber rate)+             (applyConverter2 (converter p) sigX sigY)+-}++{- |+This buffers internal control parameters before interpolation.+This should be faster, since interpolation needs frequent look-ahead,+and this is faster on a buffered signal than on a plain stateful signal generator.++Since the look-ahead is constant,+it is interesting whether interpolation can be made more efficient+without the inefficient intermediate list structure.+-}+{-# INLINE processAsynchronousBuffered2 #-}+processAsynchronousBuffered2 ::+   (Dim.C u, Dim.C v0, Dim.C v1, RealField.C t) =>+   Interpolation.T t (RateDep s ic) ->+   Proc.T s u t+      (T (Converter s (DN.T v0 ecAmp0, DN.T v1 ecAmp1) (ec0, ec1) ic)+         (CausalD.T s (ampIn, CausalD.Flat) ampOut (sampIn, RateDep s ic) sampOut)) ->+   DN.T (Dim.Recip u) t ->+   (forall r. Proc.T r u t (SigA.R r v0 ecAmp0 ec0)) ->+   (forall r. Proc.T r u t (SigA.R r v1 ecAmp1 ec1)) ->+   Proc.T s u t+      (CausalD.T s ampIn ampOut sampIn sampOut)+processAsynchronousBuffered2 ip cp rate x y =+   let sigX = RP.fromSignal $ Proc.run rate (fmap RP.toSignal x)+       sigY = RP.fromSignal $ Proc.run rate (fmap RP.toSignal y)+   in  do p <- cp+          runAsynchronousBuffered ip cp (Rate.fromDimensionNumber rate)+             (applyConverter2 (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)+-}
+ src/Synthesizer/Dimensional/Causal/Displacement.hs view
@@ -0,0 +1,192 @@+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+-}+module Synthesizer.Dimensional.Causal.Displacement (+   mix, mixVolume,+   fanoutAndMixMulti, fanoutAndMixMultiVolume,+   raise, distort,+   ) where++import qualified Synthesizer.Dimensional.Process as Proc++import qualified Synthesizer.Dimensional.Causal.Process as CausalD+import qualified Synthesizer.Causal.Process as Causal+import Control.Arrow ((^<<), (&&&), )++import qualified Number.DimensionTerm        as DN+import qualified Algebra.DimensionTerm       as Dim++import qualified Algebra.Module         as Module+import qualified Algebra.Field          as Field+import qualified Algebra.Real           as Real+-- import qualified Algebra.Ring           as Ring+-- import qualified Algebra.Additive       as Additive++-- import Algebra.Module ((*>))++import Control.Monad.Trans.Reader (Reader, runReader, ask, )++import PreludeBase+import NumericPrelude+import Prelude ()+++{- * 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.T v y, DN.T v y) (DN.T v y) (yv,yv) yv)+mix =+   Proc.pure $+   fromAmplitudeReader $ \(amp0,amp1) ->+      (DN.abs amp0 + DN.abs amp1, mixCore amp0 amp1)++{-# 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.T v y, DN.T v y) (DN.T v y) (yv,yv) yv)+mixVolume amp =+   Proc.pure $+   fromAmplitudeReader $ \(amp0,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 ->+   Reader (DN.T v y) (Causal.T (yv,yv) yv)+mixCore amp0 amp1 =+   do toSamp0 <- toAmplitudeVector amp0+      toSamp1 <- toAmplitudeVector amp1+      return $+         Causal.map (\(y0,y1) -> toSamp0 y0 + toSamp1 y1)++{- |+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.T v y) yvIn yv)] ->+   Proc.T s u t (CausalD.T s ampIn (DN.T v y) yvIn 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.T v y) yvIn yv] ->+   CausalD.T s ampIn (DN.T v y) yvIn yv+fanoutAndMixMultiPlain cs =+   fromAmplitudeReader $ \ampIn ->+      let ampCs = map (\(CausalD.Cons f) -> f ampIn) cs+      in  (maximum (map fst ampCs),+           fanoutAndMixMultiVolumeCore ampCs)++{-# 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.T v y) yvIn yv)] ->+   Proc.T s u t (CausalD.T s ampIn (DN.T v y) yvIn yv)+fanoutAndMixMultiVolume amp =+   fmap (fanoutAndMixMultiVolumePlain amp) . sequence++{-# INLINE fanoutAndMixMultiVolumePlain #-}+fanoutAndMixMultiVolumePlain ::+   (Field.C y, Module.C y yv, Dim.C v) =>+   DN.T v y ->+   [CausalD.T s ampIn (DN.T v y) yvIn yv] ->+   CausalD.T s ampIn (DN.T v y) yvIn yv+fanoutAndMixMultiVolumePlain amp cs =+   fromAmplitudeReader $ \ampIn ->+      (amp, fanoutAndMixMultiVolumeCore $+               map (\(CausalD.Cons f) -> f ampIn) cs)++{-# INLINE fanoutAndMixMultiVolumeCore #-}+fanoutAndMixMultiVolumeCore ::+   (Field.C y, Module.C y yv, Dim.C v) =>+   [(DN.T v y, Causal.T yvIn yv)] ->+   Reader (DN.T v y) (Causal.T yvIn yv)+fanoutAndMixMultiVolumeCore cs =+   foldr+      (\(ampX,c) acc ->+         do toSamp <- toAmplitudeVector ampX+            rest   <- acc+            return $ uncurry (+) ^<< (toSamp ^<< c) &&& rest)+      (return $ Causal.map (const zero)) cs+++{- |+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.T v y) (DN.T v y) yv yv)+raise y' yv =+   Proc.pure $+   fromAmplitudeReader $ \amp ->+      (amp, do toSamp <- toAmplitudeVector y'+               return $ Causal.map (toSamp 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.T v y, DN.T v y) (DN.T v y) (y,yv) yv)+distort f =+   Proc.pure $+   fromAmplitudeReader $ \(ampCtrl,ampIn) ->+      (ampIn, do toSamp <- toAmplitudeScalar ampCtrl+                 return $+                    Causal.map (\(c,y) ->+                       let c' = toSamp c+                       in  c' *> f (recip c' *> y)))+++{-# INLINE toAmplitudeScalar #-}+toAmplitudeScalar ::+   (Field.C y, Dim.C u) =>+   DN.T u y -> Reader (DN.T u y) (y -> y)+toAmplitudeScalar ampIn =+   do ampOut <- ask+      return (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 =+   do ampOut <- ask+      return (DN.divToScalar ampIn ampOut *> )++{-# INLINE fromAmplitudeReader #-}+fromAmplitudeReader ::+   (ampIn -> (ampOut, Reader ampOut (Causal.T yv0 yv1))) ->+   CausalD.T s ampIn ampOut yv0 yv1+fromAmplitudeReader f =+   CausalD.Cons $ \ampIn ->+      let (ampOut, rd) = f ampIn+      in  (ampOut, runReader rd ampOut)
+ src/Synthesizer/Dimensional/Causal/Filter.hs view
@@ -0,0 +1,708 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+-}+module Synthesizer.Dimensional.Causal.Filter (+   {- * Non-recursive -}++   {- ** Amplification -}+   amplify,+   amplifyDimension,+   negate,+   envelope,+   envelopeVector,+   envelopeVectorDimension,++   {- ** Filter operators from calculus -}+   differentiate,++{-+   {- ** Smooth -}+   meanStatic,+   mean,++   {- ** Delay -}+   delay,+   phaseModulation,+   frequencyModulation,+   frequencyModulationDecoupled,+   phaser,+   phaserStereo,+-}+++   {- * Recursive -}+   ResonantFilter,+   FrequencyFilter,++   {- ** Without resonance -}+   firstOrderLowpass,+   firstOrderHighpass,++   butterworthLowpass,+   butterworthHighpass,+   chebyshevALowpass,+   chebyshevAHighpass,+   chebyshevBLowpass,+   chebyshevBHighpass,++   butterworthLowpassPole,+   butterworthHighpassPole,+   chebyshevALowpassPole,+   chebyshevAHighpassPole,+   chebyshevBLowpassPole,+   chebyshevBHighpassPole,++   {- ** With resonance -}+   universal,+   highpassFromUniversal,+   bandpassFromUniversal,+   lowpassFromUniversal,+   bandlimitFromUniversal,+   moogLowpass,++   {- ** Allpass -}+   allpassCascade,+   allpassPhaser,+   FiltR.allpassFlangerPhase,++{-+   {- ** Reverb -}+   comb,+   combProc,+-}++   {- ** Filter operators from calculus -}+   integrate,+) where++import qualified Synthesizer.Dimensional.Process as Proc+-- import qualified Synthesizer.Dimensional.Rate as Rate+import qualified Synthesizer.Dimensional.Causal.ControlledProcess as CCProc+import qualified Synthesizer.Dimensional.Causal.Process as CausalD+import qualified Synthesizer.Causal.Process as Causal+import Control.Arrow ((<<^), (^<<), (&&&), )++-- import Synthesizer.Dimensional.Process ((.:), (.^), )++-- import qualified Synthesizer.Dimensional.Abstraction.Flat as Flat++-- import qualified Synthesizer.State.Signal as Sig+import qualified Synthesizer.Plain.Modifier as Modifier+import Synthesizer.Plain.Signal (Modifier)++import Synthesizer.Dimensional.RateAmplitude.Signal+   ({- toTimeScalar, -} toFrequencyScalar, DimensionGradient, )++import qualified Synthesizer.Dimensional.Rate.Filter as FiltR++-- import qualified Synthesizer.Interpolation as Interpolation+-- import qualified Synthesizer.State.Filter.Delay as Delay+import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder  as Filt1+import qualified Synthesizer.Plain.Filter.Recursive.Allpass     as Allpass+import qualified Synthesizer.Plain.Filter.Recursive.Universal   as UniFilter+import qualified Synthesizer.Plain.Filter.Recursive.Moog        as Moog+import qualified Synthesizer.Plain.Filter.Recursive.Butterworth as Butter+import qualified Synthesizer.Plain.Filter.Recursive.Chebyshev   as Cheby+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.Generic.Filter.Recursive.Comb as Comb+-- import qualified Synthesizer.Dimensional.Causal.Displacement as DispC++import Synthesizer.Utility (affineComb, )++import qualified Number.DimensionTerm        as DN+import qualified Algebra.DimensionTerm       as Dim++import Number.DimensionTerm ((&*&), (&/&))++import qualified Number.NonNegative     as NonNeg++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.Ring           as Ring+import qualified Algebra.Additive       as Additive+-- import qualified Algebra.VectorSpace    as VectorSpace+import qualified Algebra.Module         as Module++import Foreign.Storable (Storable)++-- import Control.Monad(liftM2)++import Data.Tuple.HT (swap, mapFst, )++import NumericPrelude hiding (negate)+import PreludeBase as P+import Prelude ()+++{- | The amplification factor must be positive. -}+{-# INLINE amplify #-}+amplify :: (Module.C y amp) =>+   y ->+   Proc.T s u t (CausalD.T s amp amp yv yv)+amplify volume =+   Proc.pure $ CausalD.mapAmplitudeSameType (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 (DN.T v1 y) (DN.T (Dim.Mul v0 v1) y) yv yv)+amplifyDimension volume =+   Proc.pure $ CausalD.mapAmplitude (volume &*&)+++{-# INLINE negate #-}+negate :: (Additive.C yv) =>+   Proc.T s u t (CausalD.T s amp amp yv yv)+negate =+   Proc.pure $ homogeneousMap Additive.negate+++{-# INLINE envelope #-}+envelope :: (Ring.C y) =>+   Proc.T s u t (CausalD.T s (CausalD.Flat, amp) amp (y,y) y)+envelope =+   Proc.pure $ CausalD.Cons $ \(CausalD.Flat, amp) ->+      (amp, Causal.map (uncurry (*)))++{-# INLINE envelopeVector #-}+envelopeVector :: (Module.C y yv) =>+   Proc.T s u t (CausalD.T s (CausalD.Flat, amp) amp (y,yv) yv)+envelopeVector =+   Proc.pure $ CausalD.Cons $ \(CausalD.Flat, amp) ->+      (amp, Causal.map (uncurry (*>)))++{-# 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 (DN.T v0 y, DN.T v1 y) (DN.T (Dim.Mul v0 v1) y) (y0,yv) yv)+envelopeVectorDimension =+   Proc.pure $ CausalD.Cons $ \(ampEnv, ampSig) ->+      (ampEnv &*& ampSig, Causal.map (uncurry (*>)))+++{-# INLINE differentiate #-}+differentiate :: (Additive.C yv, Ring.C q, Dim.C u, Dim.C v) =>+   Proc.T s u q+      (CausalD.T s (DN.T v q) (DN.T (DimensionGradient u v) q) yv yv)+differentiate =+   do rate <- Proc.getSampleRate+      return $ CausalD.Cons $ \ amp ->+         (rate &*& amp,+          uncurry (-) ^<< Causal.id &&& Causal.consInit zero)+--          Causal.crochetL (\x0 x1 -> Just (x0-x1, x0)) zero)+++{-+{- | needs a good handling of boundaries, yet -}+{-# INLINE meanStatic #-}+meanStatic ::+   (RealField.C q, Module.C q yv, Dim.C u, Dim.C v) =>+      DN.T (Dim.Recip u) q   {- ^ cut-off freqeuncy -}+   -> Proc.T s u q (+        SigA.R s v q yv+     -> SigA.R s v q yv)+meanStatic time =+   FiltR.meanStatic time++meanStaticSeparateTY :: (Additive.C yv, Field.C y, RealField.C t,+         Module.C y yv, Dim.C u, Dim.C v) =>+      DN.T (Dim.Recip u) t   {- ^ cut-off freqeuncy -}+   -> Proc.T s u t (+        SigA.R s v y yv+     -> SigA.R s v y yv)+meanStaticSeparateTY time =+   -- FiltR.meanStatic time, means that 't' = 'y'+   do f <- toFrequencyScalar time+      return $ \ x ->+         let tInt  = round ((recip f - 1)/2)+             width = tInt*2+1+         in  SigA.processSamples+                ((SigA.asTypeOfAmplitude (recip (fromIntegral width)) x *> ) .+                 Delay.staticNeg tInt .+                 MA.sumsStaticInt width) x+++{- | needs a better handling of boundaries, yet -}+{-# INLINE mean #-}+mean :: (Additive.C yv, RealField.C q,+         Module.C q yv, Dim.C u, Dim.C v) =>+      DN.T (Dim.Recip u) q    {- ^ minimum cut-off freqeuncy -}+   -> Proc.T s u q (+        SigA.R s (Dim.Recip u) q q+                              {- v cut-off freqeuncies -}+     -> SigA.R s v q yv+     -> SigA.R s v q yv)+mean minFreq =+   FiltR.mean minFreq+++{-# INLINE delay #-}+delay :: (Additive.C yv, Field.C y, RealField.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)+delay time =+   do t <- toTimeScalar time+      return $ SigA.processSamples (Delay.static (round t))+++{-# INLINE phaseModulation #-}+phaseModulation ::+   (Additive.C yv, RealField.C q, Dim.C u, Dim.C v,+    Sample.C q, Sample.C yv) =>+      Interpolation.T q yv+   -> DN.T u q+          {- ^ minDelay, minimal delay, may be negative -}+   -> DN.T u q+          {- ^ maxDelay, maximal delay, it must be @minDelay <= maxDelay@+               and the modulation must always be+               in the range [minDelay,maxDelay]. -}+   -> Proc.T s u q (+        SigA.R s u q q+          {- v delay control, positive numbers meanStatic delay,+               negative numbers meanStatic prefetch -}+     -> SigA.R s v q yv+     -> SigA.R s v q yv)+phaseModulation ip minDelay maxDelay =+   FiltR.phaseModulation ip minDelay maxDelay++{-# INLINE frequencyModulation #-}+frequencyModulation ::+   (Flat.C flat q, Additive.C yv, RealField.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 -}+     -> SigA.R s v q yv+     -> SigA.R s v q yv)+frequencyModulation ip =+   Proc.pure $+      \ factors ->+          SigA.processSamples+             (FiltR.interpolateMultiRelativeZeroPad ip (Flat.toSamples factors))++{- |+Frequency modulation where the input signal can have a sample rate+different from the output.+(The sample rate values can differ, the unit must be the same.+We could lift that restriction,+but then the unit handling becomes more complicated,+and I didn't have a use for it so far.)++The function can be used for resampling.+-}+{-# INLINE frequencyModulationDecoupled #-}+frequencyModulationDecoupled ::+   (Flat.C flat q, Additive.C yv, RealField.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 -}+     -> SigP.T u q (SigA.D v q SigS.S) yv+     -> SigA.R s v q yv)+frequencyModulationDecoupled ip =+   fmap+      (\toFreq factors y ->+         flip SigA.processSamples (RP.fromSignal (SigP.signal y)) $+            FiltR.interpolateMultiRelativeZeroPad ip+               (SigA.scalarSamples toFreq+                  (SigA.fromSamples (SigP.sampleRate y) (Flat.toSamples factors))))+      (Proc.withParam Proc.toFrequencyScalar)+++{- | symmetric phaser -}+{-# INLINE phaser #-}+phaser ::+   (Additive.C yv, RealField.C q,+    Module.C q yv, Dim.C u, Dim.C v,+    Sample.C q, Sample.C yv) =>+      Interpolation.T q yv+   -> DN.T u q  {- ^ maxDelay, must be positive -}+   -> Proc.T s u q (+        SigA.R s u q q+                {- v delay control -}+     -> SigA.R s v q yv+     -> SigA.R s v q yv)+phaser = FiltR.phaser++{-# INLINE phaserStereo #-}+phaserStereo ::+   (Additive.C yv, RealField.C q,+    Module.C q yv, Dim.C u, Dim.C v,+    Sample.C q, Sample.C yv) =>+      Interpolation.T q yv+   -> DN.T u q   {- ^ maxDelay, must be positive -}+   -> Proc.T s u q (+        SigA.R s u q q+                 {- v delay control -}+     -> SigA.R s v q yv+     -> SigA.R s v q (Stereo.T yv))+phaserStereo = FiltR.phaserStereo+-}+++type FrequencyFilter s u q ic amp yv0 yv1 =+   Proc.T s u q+      (CCProc.T+         (CCProc.Converter s+             (DN.T (Dim.Recip u) q)+             q     {- v signal for cut off and band center frequency -}+             ic)+         (CausalD.T s+             (amp, CausalD.Flat) amp+             (yv0, CCProc.RateDep s ic) yv1))++{-# INLINE firstOrderLowpass #-}+{-# INLINE firstOrderHighpass #-}+firstOrderLowpass, firstOrderHighpass ::+   (Trans.C q, Module.C q yv, Dim.C u) =>+   FrequencyFilter s u q (Filt1.Parameter q) amp yv yv+firstOrderLowpass  = firstOrderGen Filt1.lowpassModifier+firstOrderHighpass = firstOrderGen Filt1.highpassModifier++{-# INLINE firstOrderGen #-}+firstOrderGen ::+   (Trans.C q, Module.C q yv, Dim.C u) =>+      (Modifier yv (Filt1.Parameter q) yv yv)+--      (Sig.T (Filt1.Parameter q) -> Sig.T yv -> Sig.T yv)+   -> FrequencyFilter s u q (Filt1.Parameter q) amp yv yv+firstOrderGen modif =+   frequencyControl Filt1.parameter (Causal.fromSimpleModifier modif)++++{-# INLINE butterworthLowpass #-}+{-# INLINE butterworthHighpass #-}+{-# INLINE chebyshevALowpass #-}+{-# INLINE chebyshevAHighpass #-}+{-# INLINE chebyshevBLowpass #-}+{-# INLINE chebyshevBHighpass #-}++butterworthLowpass, butterworthHighpass ::+   (Trans.C a, Module.C a yv, Storable a, Storable yv, Dim.C u) =>+   NonNeg.Int   {- ^ Order of the filter, must be even,+                     the higher the order, the sharper is the separation of frequencies. -}  ->+   ResonantFilter s u a (Butter.Parameter a) amp yv yv++chebyshevALowpass, chebyshevAHighpass ::+   (Trans.C a, Module.C a yv, Storable a, Storable yv, Dim.C u) =>+   NonNeg.Int ->+   ResonantFilter s u a (Cheby.ParameterA a) amp yv yv++chebyshevBLowpass, chebyshevBHighpass ::+   (Trans.C a, Module.C a yv, Storable a, Storable yv, Dim.C u) =>+   NonNeg.Int ->+   ResonantFilter s u a (Cheby.ParameterB a) amp yv yv++butterworthLowpass  = higherOrderNoResoGen (Butter.parameter FiltRec.Lowpass)  Butter.causal+butterworthHighpass = higherOrderNoResoGen (Butter.parameter FiltRec.Highpass) Butter.causal+chebyshevALowpass   = higherOrderNoResoGen (Cheby.parameterA FiltRec.Lowpass)  Cheby.causalA+chebyshevAHighpass  = higherOrderNoResoGen (Cheby.parameterA FiltRec.Highpass) Cheby.causalA+chebyshevBLowpass   = higherOrderNoResoGen (Cheby.parameterB FiltRec.Lowpass)  Cheby.causalB+chebyshevBHighpass  = higherOrderNoResoGen (Cheby.parameterB FiltRec.Highpass) Cheby.causalB+++{- TODO:+initial value+-}+{-# INLINE higherOrderNoResoGen #-}+higherOrderNoResoGen ::+   (Field.C a, Module.C a yv, Storable a, Storable yv, Dim.C u) =>+   (Int -> FiltRec.Pole a -> param) ->+   (Int -> Causal.T (param, yv) yv) ->+   NonNeg.Int ->+   ResonantFilter s u a param amp yv yv++higherOrderNoResoGen mkParam causal order =+   let orderInt = NonNeg.toNumber order+   in  frequencyResonanceControl+          (mkParam orderInt)+          (causal orderInt)++++{-# INLINE butterworthLowpassPole #-}+{-# INLINE butterworthHighpassPole #-}+{-# INLINE chebyshevALowpassPole #-}+{-# INLINE chebyshevAHighpassPole #-}+{-# INLINE chebyshevBLowpassPole #-}+{-# INLINE chebyshevBHighpassPole #-}++butterworthLowpassPole, butterworthHighpassPole,+   chebyshevALowpassPole, chebyshevAHighpassPole,+   chebyshevBLowpassPole, chebyshevBHighpassPole ::+   (Trans.C q, Module.C q yv, Dim.C u) =>+   NonNeg.Int   {- ^ Order of the filter, must be even,+                     the higher the order, the sharper is the separation of frequencies. -}  ->+   ResonantFilter s u q (FiltRec.Pole q) amp yv yv++butterworthLowpassPole  = higherOrderNoResoGenPole Butter.lowpassCausalPole+butterworthHighpassPole = higherOrderNoResoGenPole Butter.highpassCausalPole+chebyshevALowpassPole   = higherOrderNoResoGenPole Cheby.lowpassACausalPole+chebyshevAHighpassPole  = higherOrderNoResoGenPole Cheby.highpassACausalPole+chebyshevBLowpassPole   = higherOrderNoResoGenPole Cheby.lowpassBCausalPole+chebyshevBHighpassPole  = higherOrderNoResoGenPole Cheby.highpassBCausalPole+++{- TODO:+initial value+-}+{-# INLINE higherOrderNoResoGenPole #-}+higherOrderNoResoGenPole ::+   (Field.C q, Dim.C u) =>+   (Int -> Causal.T (FiltRec.Pole q, yv) yv) ->+   NonNeg.Int ->+   ResonantFilter s u q (FiltRec.Pole q) amp yv yv++higherOrderNoResoGenPole filt order =+   let orderInt = NonNeg.toNumber order+   in  frequencyResonanceControl id (filt orderInt)+++++type ResonantFilter s u q ic amp yv0 yv1 =+   Proc.T s u q+      (CCProc.T+         (CCProc.Converter s+             (DN.Scalar q, DN.T (Dim.Recip u) q)+             (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, CausalD.Flat) amp+             (yv0, CCProc.RateDep s ic) yv1))+++type ResonantFilterFlat s u q ic amp yv0 yv1 =+   Proc.T s u q+      (CCProc.T+         (CCProc.Converter s+             (CausalD.Flat, DN.T (Dim.Recip u) q)+             (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, CausalD.Flat) amp+             (yv0, CCProc.RateDep s ic) yv1))++++{-# INLINE highpassFromUniversal #-}+{-# INLINE bandpassFromUniversal #-}+{-# INLINE lowpassFromUniversal #-}+{-# INLINE bandlimitFromUniversal #-}+highpassFromUniversal, lowpassFromUniversal,+  bandpassFromUniversal, bandlimitFromUniversal ::+   CausalD.T 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+lowpassFromUniversal   = homogeneousMap UniFilter.lowpass+bandlimitFromUniversal = homogeneousMap UniFilter.bandlimit++homogeneousMap ::+   (yv0 -> yv1) ->+   CausalD.T s amp amp yv0 yv1+--   Proc.T s u t (CausalD.T s amp amp yv0 yv1)+homogeneousMap f =+   CausalD.homogeneous (Causal.map f)+--   Proc.pure (CausalD.homogeneous (Causal.map f))++{-# INLINE universal #-}+universal ::+   (Trans.C q, Module.C q yv, Dim.C u) =>+   ResonantFilter s u q (UniFilter.Parameter q) amp yv (UniFilter.Result yv)+universal =+   frequencyResonanceControl+      UniFilter.parameter+      UniFilter.causal++{-# INLINE moogLowpass #-}+moogLowpass ::+   (Trans.C q, Module.C q yv, Dim.C u) =>+      NonNeg.Int+   -> ResonantFilter s u q (Moog.Parameter q) amp yv yv+moogLowpass order =+   let orderInt = NonNeg.toNumber order+   in  frequencyResonanceControl+          (Moog.parameter orderInt)+          (Moog.lowpassCausal orderInt)+++{-# INLINE allpassCascade #-}+{- | the lowest comb frequency is used as the filter frequency -}+allpassCascade :: (Trans.C q, Module.C q yv, Dim.C u) =>+      NonNeg.Int  {- ^ order, number of filters in the cascade -}+   -> q           {- ^ the phase shift to be achieved for the given frequency -}+   -> FrequencyFilter s u q (Allpass.Parameter q) amp yv yv+allpassCascade order phase =+   let orderInt = NonNeg.toNumber order+   in  frequencyControl+          (Allpass.parameter orderInt phase)+          (Allpass.cascadeCausal orderInt)++{-# INLINE allpassPhaser #-}+{- |+We use the mixing ratio as resonance parameter.+Mixing ratio @r@ means:+Amplify input by @r@ and delayed signal by @1-r@.+Maximum effect is achieved for @r=0.5@.+-}+allpassPhaser :: (Trans.C q, Module.C q yv, Dim.C u) =>+      NonNeg.Int  {- ^ order, number of filters in the cascade -}+   -> ResonantFilter s u q (q, Allpass.Parameter q) amp yv yv+allpassPhaser order =+   let orderInt = NonNeg.toNumber order+   in  frequencyResonanceControl+          (\x ->+             (FiltRec.poleResonance x,+              Allpass.parameter orderInt Allpass.flangerPhase $+              FiltRec.poleFrequency x))+          (uncurry affineComb ^<<+           Causal.second (Causal.fanout+              (Allpass.cascadeCausal orderInt) (Causal.map snd))+            <<^ (\((r,p),x) -> (r,(p,x))))++{-+The handling of amplitudes is not efficient and the results may surprise.+Due to rounding errors the output amplitude may differ from input amplitude.+This problem can only be overcome by a specialised low-level routine.++allpassPhaser :: (Trans.C q, Module.C q yv, Dim.C u) =>+      NonNeg.Int  {- ^ order, number of filters in the cascade -}+   -> q           {- ^ mixing ratio @x@ means:+                       amplify input by @x@ and+                       amplify delayed signal by @1-x@.+                       Maximum effect is achieved for @x=0.5@. -}+   -> FrequencyFilter s u q (Allpass.Parameter q) amp yv yv+allpassPhaser order r =+-- incomplete+   fmap+      (fmap $ \ap ->+         mix CausalD.<<<+         CausalD.fanout+            (amplify r)+            (amplify (1-r) CausalD.<<< ap))+      (Filt.allpassCascade 20 Filt.allpassFlangerPhase)+-}+++{-# INLINE frequencyControl #-}+frequencyControl ::+   (Field.C q, Dim.C u) =>+   (q -> ic) ->+   Causal.T (ic, yv0) yv1 ->+   FrequencyFilter s u q ic amp yv0 yv1++frequencyControl mkParam filt =+   do toFreq <- Proc.withParam toFrequencyScalar+      return $ CCProc.Cons+         (CCProc.makeConverter $ \ freqAmp ->+            let k = toFreq freqAmp+            in  \ freq -> mkParam $ k*freq)+         (CausalD.Cons $ \ (xAmp, CausalD.Flat) ->+            (xAmp, filt <<^ mapFst CCProc.unRateDep . swap))+--         (\ params -> SigA.processSamples (filt params))+++{-# INLINE frequencyResonanceControl #-}+frequencyResonanceControl ::+   (Field.C q, Dim.C u) =>+   (FiltRec.Pole q -> ic) ->+   Causal.T (ic, yv0) yv1 ->+   ResonantFilter s u q ic amp yv0 yv1++frequencyResonanceControl mkParam filt =+   do toFreq <- Proc.withParam toFrequencyScalar+      return $ CCProc.Cons+         (CCProc.makeConverter $ \ (resoAmp, freqAmp) ->+            let k = toFreq freqAmp+            in  \ (reso, freq) -> mkParam $+                    FiltRec.Pole (DN.toNumber resoAmp * reso) (k*freq))+         (CausalD.Cons $ \ (xAmp, CausalD.Flat) ->+            (xAmp, filt <<^ mapFst CCProc.unRateDep . swap))+         -- CausalD.homogeneous almost fits, but it cannot handle the control input+++{-# 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 =+   do toFreq <- Proc.withParam toFrequencyScalar+      return $ CCProc.Cons+         (CCProc.makeConverter $ \ (CausalD.Flat, freqAmp) ->+            let k = toFreq freqAmp+            in  \ (reso, freq) ->+                    mkParam $ FiltRec.Pole reso (k*freq))+         (CausalD.Cons $ \ (xAmp, CausalD.Flat) ->+            (xAmp, Causal.fromSimpleModifier filt <<^ mapFst CCProc.unRateDep . swap))+         -- CausalD.homogeneous almost fits, but it cannot handle the control input+++{-+{- | 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) =>+   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+++{- | 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,+    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) ->+   Proc.T s u t (SigA.R s v y yv -> SigA.R s v y yv)+combProc time proc =+   do f <- proc+      t <- fmap round $ toTimeScalar time+      let chunkSize = SigSt.chunkSize t+      return $ \x ->+         SigA.processSamples+            (Sig.fromStorableSignal .+             Comb.runProc t+                (Sig.toStorableSignal chunkSize .+                 SigA.vectorSamples (SigA.toAmplitudeScalar x) .+                 f .+                 SigA.fromSamples (SigA.amplitude x) .+                 Sig.fromStorableSignal) .+             Sig.toStorableSignal chunkSize) x+-}+++{-# INLINE integrate #-}+integrate :: (Additive.C yv, Field.C q, Dim.C u, Dim.C v) =>+   Proc.T s u q+      (CausalD.T s (DN.T v q) (DN.T (Dim.Mul u v) q) yv yv)+integrate =+   do rate <- Proc.getSampleRate+      return $ CausalD.Cons $ \ amp ->+         (DN.rewriteDimension+              (Dim.commute . Dim.applyRightMul Dim.invertRecip) $+          amp &/& rate,+          Integrate.causal)
+ src/Synthesizer/Dimensional/Causal/Oscillator.hs view
@@ -0,0 +1,303 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE FlexibleContexts #-}+{- |+Copyright   :  (c) Henning Thielemann 2009+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++-}+module Synthesizer.Dimensional.Causal.Oscillator (+{-+   static,+   staticAntiAlias,+-}+   freqMod,+   freqModAntiAlias,+   phaseMod,+   phaseFreqMod,+   shapeMod,+   shapeFreqMod,+{-+   staticSample,+   freqModSample,+-}+--   shapeFreqModSample,+   shapeFreqModFromSampledTone,+   shapePhaseFreqModFromSampledTone,+   ) where++import qualified Synthesizer.Dimensional.Causal.Process as CausalD+import qualified Synthesizer.Causal.Process as Causal+import Control.Arrow ((<<^), (<<<), second, )++import qualified Synthesizer.Dimensional.Abstraction.HomogeneousGen as Hom+import qualified Synthesizer.Dimensional.RateWrapper as SigP+import qualified Synthesizer.Dimensional.Rate as Rate++import qualified Synthesizer.Causal.Oscillator as Osci++import qualified Synthesizer.Generic.Signal as SigG++import qualified Synthesizer.Basic.WaveSmoothed as WaveSmooth+import qualified Synthesizer.Basic.Wave         as Wave+import qualified Synthesizer.Basic.Phase        as Phase++-- import qualified Synthesizer.Dimensional.Straight.Signal as SigS+-- import qualified Synthesizer.Dimensional.Cyclic.Signal as SigC++-- import qualified Synthesizer.Dimensional.Amplitude.Signal as SigA+import qualified Synthesizer.Dimensional.Process as Proc+import Synthesizer.Dimensional.Process (toFrequencyScalar, )++import qualified Synthesizer.Interpolation as Interpolation++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+import PreludeBase as P+++{-+{- | oscillator with a functional waveform with constant frequency -}+{-# INLINE static #-}+static :: (RealField.C t, Dim.C u) =>+      Wave.T t y   {- ^ waveform -}+   -> Phase.T t    {- ^ start phase -}+   -> DN.T (Dim.Recip u) t+                   {- ^ frequency -}+   -> Proc.T s u t (SigS.R s y)+static wave phase =+   staticAuxHom (SigS.fromSamples . Osci.static wave phase)++{- | oscillator with a functional waveform with constant frequency -}+{-# INLINE staticAntiAlias #-}+staticAntiAlias :: (RealField.C t, Dim.C u) =>+      WaveSmooth.T t y+                   {- ^ waveform -}+   -> Phase.T t    {- ^ start phase -}+   -> DN.T (Dim.Recip u) t+                   {- ^ frequency -}+   -> Proc.T s u t (SigS.R s y)+staticAntiAlias wave phase =+   staticAuxHom (SigS.fromSamples . Osci.staticAntiAlias wave phase)+-}++{- | oscillator with a functional waveform with modulated frequency -}+{-# INLINE freqMod #-}+freqMod :: (RealField.C t, Dim.C u, Hom.C amp (Wave.T t) wave) =>+      wave y   {- ^ waveform -}+   -> Phase.T t    {- ^ start phase -}+   -> Proc.T s u t+         (CausalD.T s (DN.T (Dim.Recip u) t) amp t y)+freqMod wave phase =+   staticAuxHom wave $ \toFreq freqAmp w ->+      Osci.freqMod w phase <<< amplify (toFreq freqAmp)++{- | oscillator with a functional waveform with modulated frequency -}+{-# INLINE freqModAntiAlias #-}+freqModAntiAlias :: (RealField.C t, Dim.C u, Hom.C amp (WaveSmooth.T t) wave) =>+      wave y+                   {- ^ waveform -}+   -> Phase.T t    {- ^ start phase -}+   -> Proc.T s u t+         (CausalD.T s (DN.T (Dim.Recip u) t) amp t y)+freqModAntiAlias wave phase =+   freqModAuxHom wave $ \scaleFreq freqAmp w ->+      Osci.freqModAntiAlias w phase <<< scaleFreq freqAmp++{- | oscillator with modulated phase -}+{-# INLINE phaseMod #-}+phaseMod :: (RealField.C t, Dim.C u, Hom.C amp (Wave.T t) wave) =>+      wave y       {- ^ waveform -}+   -> DN.T (Dim.Recip u) t+                   {- ^ frequency -}+   -> Proc.T s u t+         (CausalD.T s CausalD.Flat amp t y)+phaseMod wave freq =+   staticAuxHom wave $ \toFreq CausalD.Flat w ->+      Osci.phaseMod w $ toFreq freq++{- | oscillator with modulated shape -}+{-# INLINE shapeMod #-}+shapeMod :: (RealField.C t, Dim.C u) =>+      (c -> Wave.T t y)+                   {- ^ waveform -}+   -> Phase.T t    {- ^ phase -}+   -> DN.T (Dim.Recip u) t+                   {- ^ frequency -}+   -> Proc.T s u t+         (CausalD.T s CausalD.Flat CausalD.Flat c y)+shapeMod wave phase freq =+   staticAux $ \toFreq CausalD.Flat ->+      Osci.shapeMod wave phase $ toFreq freq+++{- | oscillator with a functional waveform with modulated phase and frequency -}+{-# INLINE phaseFreqMod #-}+phaseFreqMod :: (RealField.C t, Dim.C u, Hom.C amp (Wave.T t) wave) =>+      wave y   {- ^ waveform -}+   -> Proc.T s u t+         (CausalD.T s (CausalD.Flat, DN.T (Dim.Recip u) t) amp (t,t) y)+phaseFreqMod wave =+   freqModAuxHom wave $ \scaleFreq (CausalD.Flat, freqAmp) w ->+      Osci.phaseFreqMod w <<< second (scaleFreq freqAmp)++{- | oscillator with both shape and frequency modulation -}+{-# INLINE shapeFreqMod #-}+shapeFreqMod :: (RealField.C t, Dim.C u) =>+      (c -> Wave.T t y)+                   {- ^ waveform -}+   -> Phase.T t    {- ^ phase -}+   -> Proc.T s u t+         (CausalD.T s (CausalD.Flat, DN.T (Dim.Recip u) t) CausalD.Flat (c,t) y)+shapeFreqMod wave phase =+   freqModAux $ \scaleFreq (CausalD.Flat, freqAmp) ->+      Osci.shapeFreqMod wave phase <<< second (scaleFreq freqAmp)+++{-+We could decouple source time and target time which yields++      DN.T (Dim.Recip u0) t+                   {- ^ source frequency -}+   -> SigP.T u0 (SigA.D v y (SigS.T sig)) y+   -> t -> Phase.T t+   -> Proc.T s u1 t (+        CausalD.T s (DN.T (Dim.Div u0 u1) t, DN.T (Dim.Recip u1) t) CausalD.Flat (t,t) y)++but most oftenly we do not need the conversion of the time scale.+If we need it, we can use the frequency modulation function.++We could measure the shape parameter in multiples of the source wave period.+This would yield++      DN.T (Dim.Recip u0) t+                   {- ^ source frequency -}+   -> SigP.T u0 (SigA.D v y (SigS.T sig)) y+   -> t -> Phase.T t+   -> Proc.T s u1 t (+        CausalD.T s (DN.T (Dim.Recip u1) t, DN.T (Dim.Recip u1) t) CausalD.Flat (t,t) y)++but this way, adjustment of the shape parameter is coupled to the source period.+-}+{-# INLINE shapeFreqModFromSampledTone #-}+shapeFreqModFromSampledTone ::+    (RealField.C t, SigG.Transform storage yv, Dim.C u,+     Hom.C amp storage signal) =>+      Interpolation.T t yv+   -> Interpolation.T t yv+   -> DN.T (Dim.Recip u) t+                   {- ^ source frequency -}+   -> SigP.T u t signal yv+   -> t -> Phase.T t+   -> Proc.T s u t+         (CausalD.T s+             (CausalD.Flat, DN.T (Dim.Recip u) t) amp+             (t,t) yv)+shapeFreqModFromSampledTone+      ipLeap ipStep srcFreq sampledTone shape0 phase =+   let (srcRate, srcSignal) = SigP.toSignal sampledTone+       (amp, samples) = Hom.unwrap srcSignal+   in  do toFreq <- Proc.withParam toFrequencyScalar+          return $+             CausalD.Cons $ \(CausalD.Flat, freqAmp) ->+              (amp,+               Osci.shapeFreqModFromSampledTone+                  ipLeap ipStep+                  (DN.divToScalar (Rate.toDimensionNumber srcRate) srcFreq)+                  samples+                  shape0 phase+                <<< second (amplify (toFreq freqAmp)))+++{-# INLINE shapePhaseFreqModFromSampledTone #-}+shapePhaseFreqModFromSampledTone ::+    (RealField.C t, SigG.Transform storage yv, Dim.C u,+     Hom.C amp storage signal) =>+      Interpolation.T t yv+   -> Interpolation.T t yv+   -> DN.T (Dim.Recip u) t+                   {- ^ source frequency -}+   -> SigP.T u t signal yv+   -> t -> Phase.T t+   -> Proc.T s u t+         (CausalD.T s+             (CausalD.Flat, CausalD.Flat, DN.T (Dim.Recip u) t) amp+             (t,t,t) yv)+shapePhaseFreqModFromSampledTone+      ipLeap ipStep srcFreq sampledTone shape0 phase =+   let (srcRate, srcSignal) = SigP.toSignal sampledTone+       (amp, samples) = Hom.unwrap srcSignal+   in  do toFreq <- Proc.withParam toFrequencyScalar+          return $+             CausalD.Cons $ \(CausalD.Flat, CausalD.Flat, freqAmp) ->+              (amp,+               Osci.shapePhaseFreqModFromSampledTone+                  ipLeap ipStep+                  (DN.divToScalar (Rate.toDimensionNumber srcRate) srcFreq)+                  samples+                  shape0 phase+                <<^+                (\(s,p,f) -> (s,p, toFreq freqAmp * f)))+{-+                Causal.packTriple+                ^<<+                second (amplify (toFreq freqAmp))+                <<^+                Causal.unpackTriple+-}+++-- helper functions++{-# INLINE freqModAux #-}+freqModAux :: (Dim.C u, Field.C t) =>+   ((DN.T (Dim.Recip u) t -> Causal.T t t) -> amp0 -> Causal.T yv0 yv1) ->+   Proc.T s u t (CausalD.T s1 amp0 CausalD.Flat yv0 yv1)+freqModAux f =+   staticAux $ \toFreq amp -> f (amplify . toFreq) amp++{-# INLINE staticAux #-}+staticAux :: (Dim.C u, Field.C t) =>+   ((DN.T (Dim.Recip u) t -> t) -> amp0 -> Causal.T yv0 yv1) ->+   Proc.T s u t (CausalD.T s1 amp0 CausalD.Flat yv0 yv1)+staticAux f =+   do toFreq <- Proc.withParam toFrequencyScalar+      return $ CausalD.Cons $ \amp ->+         (CausalD.Flat, f toFreq amp)+++{-# INLINE freqModAuxHom #-}+freqModAuxHom :: (Dim.C u, Field.C t, Hom.C amp1 waveStore wave) =>+   wave y ->+   ((DN.T (Dim.Recip u) t -> Causal.T t t) ->+    amp0 -> waveStore y -> Causal.T yv0 yv1) ->+   Proc.T s u t (CausalD.T s1 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, Hom.C amp1 waveStore wave) =>+   wave y ->+   ((DN.T (Dim.Recip u) t -> t) ->+    amp0 -> waveStore y -> Causal.T yv0 yv1) ->+   Proc.T s u t (CausalD.T s1 amp0 amp1 yv0 yv1)+staticAuxHom wave f =+   let (amp1, w) = Hom.plainUnwrap wave+   in  do toFreq <- Proc.withParam toFrequencyScalar+          return $ CausalD.Cons $ \amp ->+             (amp1, f toFreq amp w)+++-- move to Causal.Filter+amplify :: (Ring.C a) => a -> Causal.T a a+amplify x = Causal.map (x Ring.*)
src/Synthesizer/Dimensional/Causal/Process.hs view
@@ -1,11 +1,30 @@-module Synthesizer.Dimensional.Causal.Process where+{-# LANGUAGE FlexibleContexts #-}+module Synthesizer.Dimensional.Causal.Process (+   module Synthesizer.Dimensional.Causal.Process,+   Flat(Flat),+   ) where -import qualified Synthesizer.Causal.Process as Causal+import qualified Synthesizer.Dimensional.Arrow as ArrowD+import qualified Synthesizer.Dimensional.Map as Map +import qualified Synthesizer.Dimensional.RatePhantom as RP import qualified Synthesizer.Dimensional.Amplitude.Signal as SigA+import qualified Synthesizer.Dimensional.Abstraction.HomogeneousGen as Hom+import qualified Synthesizer.Dimensional.Amplitude as Amplitude+import qualified Synthesizer.Dimensional.Abstraction.Flat as Flat +import Synthesizer.Dimensional.Amplitude (Flat(Flat))++import qualified Synthesizer.Causal.Process as Causal++import Control.Applicative (Applicative, liftA, liftA2, )++import qualified Synthesizer.State.Signal as Sig+import qualified Synthesizer.Generic.Signal2 as SigG2+ import qualified Algebra.Module as Module import qualified Algebra.Field  as Field+import qualified Algebra.Ring   as Ring import Algebra.Module ((*>))  import qualified Number.DimensionTerm        as DN@@ -13,9 +32,13 @@  import qualified Control.Arrow as Arrow -import Prelude hiding (map, )+import Data.Tuple.HT as TupleHT (mapSnd, ) +import NumericPrelude (one)+import Prelude hiding (map, id, fst, snd, ) ++ {- TODO: This differs from Rate.Process and Amplitude.Signal in the following way:@@ -25,39 +48,177 @@ We need the additional flexibility here because @amp@ can also be a pair of amplitudes or a more complicated ensemble of amplitudes.++Should the 's' parameter be provided by a RatePhantom?+There are causal processes, namely @map@s,+which do not depend on the sample rate.+For these it would make sense to omit the 's'.+On the other hand what other wrappers could be useful?+RateWrapper around T is not sensible,+since it provides the sample rate as value,+not as an input parameter.+Note, that RatePhantom has the signal element type as parameter.+This would accidentally match here, but is it sensible? -}-newtype T amp0 amp1 yv0 yv1 =+newtype T s amp0 amp1 yv0 yv1 =    Cons (amp0 -> (amp1, Causal.T yv0 yv1)) +instance ArrowD.C (T s) where+   map = map+   (>>>) = (>>>)+   first = first+   second = second+   (***) = (***)+   (&&&) = (&&&) + {-# INLINE apply #-}-apply :: (Dim.C v0) =>-   T (DN.T v0 y0) (DN.T v1 y1) yv0 yv1 ->-   SigA.R s v0 y0 yv0 -> SigA.R s v1 y1 yv1+apply ::+   (Hom.C amp0 Sig.T signal0, Hom.C amp1 Sig.T signal1) =>+   T s amp0 amp1 yv0 yv1 ->+   RP.T s signal0 yv0 -> RP.T s signal1 yv1 apply (Cons f) x =-   let (yAmp, causal) = f (SigA.amplitude x)-   in  SigA.fromSamples yAmp (Causal.apply causal (SigA.samples x))+   let (xAmp, samples) = Hom.unwrap x+       (yAmp, causal) = f xAmp+   in  Hom.wrap (yAmp, Causal.apply causal samples) +{-# INLINE applyGeneric #-}+applyGeneric ::+   (Hom.C amp0 storage signal0, Hom.C amp1 storage signal1,+    SigG2.Transform storage yv0 yv1) =>+   T s amp0 amp1 yv0 yv1 ->+   RP.T s signal0 yv0 -> RP.T s signal1 yv1+applyGeneric (Cons f) x =+   let (xAmp, samples) = Hom.unwrap x+       (yAmp, causal) = f xAmp+   in  Hom.wrap (yAmp, Causal.applyGeneric causal samples) ++{-# INLINE applyConst #-}+applyConst :: (Dim.C v0, Dim.C v1, Ring.C y0) =>+   T s (DN.T v0 y0) (DN.T v1 y1) y0 yv1 ->+   DN.T v0 y0 -> SigA.R s v1 y1 yv1+applyConst (Cons f) x =+   let (yAmp, causal) = f x+   in  SigA.fromSamples yAmp (Causal.applyConst causal one)+++infixl 0 $/:, $/-++{-# INLINE ($/:) #-}+($/:) :: (Dim.C v0, Dim.C v1, Applicative f) =>+   f (T s (DN.T v0 y0) (DN.T v1 y1) yv0 yv1) ->+   f (SigA.R s v0 y0 yv0) -> f (SigA.R s v1 y1 yv1)+($/:) = liftA2 apply++{-# INLINE ($/-) #-}+($/-) :: (Dim.C v0, Dim.C v1, Applicative f, Ring.C y0) =>+   f (T s (DN.T v0 y0) (DN.T v1 y1) y0 yv1) ->+   DN.T v0 y0 -> f (SigA.R s v1 y1 yv1)+($/-) p x = liftA (flip applyConst x) p+++infixl 9 `apply`, `applyFst`, `applyFlat`, `applyFlatFst`+ {-# INLINE applyFst #-}-applyFst :: (Dim.C v0) =>-   T (DN.T v0 y0, restAmp) (DN.T v1 y1) (yv0, restSamp) yv1 ->-   SigA.R s v0 y0 yv0 ->-   T restAmp (DN.T v1 y1) restSamp yv1-applyFst (Cons f) x =+applyFst, applyFst' :: (Dim.C v) =>+   T s (DN.T v y, restAmpIn) restAmpOut (yv, restSampIn) restSampOut ->+   SigA.R s v y yv ->+   T s restAmpIn restAmpOut restSampIn restSampOut+applyFst c x = c <<< feedFst x++applyFst' (Cons f) x =    Cons $ \yAmp ->       let (zAmp, causal) = f (SigA.amplitude x, yAmp)       in  (zAmp, Causal.applyFst causal (SigA.samples x)) ++{-# INLINE feedFst #-}+feedFst :: (Dim.C v) =>+   SigA.R s v y yv ->+   T s restAmp (DN.T v y, restAmp) restSamp (yv, restSamp)+feedFst x =+   Cons $ \yAmp ->+      ((SigA.amplitude x, yAmp), Causal.feedFst (SigA.samples x))+++{-# INLINE applyFlat #-}+applyFlat :: (Dim.C v1, Flat.C sig yv0) =>+   T s Flat (DN.T v1 y1) yv0 yv1 ->+   RP.T s sig yv0 -> SigA.R s v1 y1 yv1+applyFlat (Cons f) x =+   let (yAmp, causal) = f Flat+   in  SigA.fromSamples yAmp (Causal.apply causal (Flat.toSamples x))+++{-# INLINE applyFlatFst #-}+applyFlatFst, applyFlatFst' :: (Flat.C sig yv) =>+   T s (Flat, restAmpIn) restAmpOut (yv, restSampIn) restSampOut ->+   RP.T s sig yv ->+   T s restAmpIn restAmpOut restSampIn restSampOut+applyFlatFst f x =+   f <<< feedFlatFst x++applyFlatFst' (Cons f) x =+   Cons $ \yAmp ->+      let (zAmp, causal) = f (Flat, yAmp)+      in  (zAmp, Causal.applyFst causal (Flat.toSamples x))++{-# INLINE feedFlatFst #-}+feedFlatFst :: (Flat.C sig yv) =>+   RP.T s sig yv ->+   T s restAmp (Flat, restAmp) restSamp (yv, restSamp)+feedFlatFst x =+   Cons $ \yAmp ->+      ((Flat, yAmp), Causal.feedFst (Flat.toSamples x))+++ {-# INLINE map #-} map ::+   Map.T amp0 amp1 yv0 yv1 ->+   T s amp0 amp1 yv0 yv1+map (Map.Cons f) =+   Cons $ mapSnd Causal.map . f+++{- |+We restrict the amplitude types to those of class 'Amplitude'.+Otherwise 'mapAmplitude' could be abused+for bringing amplitudes and respective sample values out of sync.+For mapping amplitudes that are nested in some pairs,+use it in combination with 'first' and 'second'.+-}+{-# INLINE mapAmplitude #-}+mapAmplitude ::+   (Amplitude.C amp0, Amplitude.C amp1) =>    (amp0 -> amp1) ->-   (yv0 -> yv1) ->-   T amp0 amp1 yv0 yv1-map f g =-   Cons $ \ xAmp -> (f xAmp, Causal.map g)+   T s amp0 amp1 yv yv+mapAmplitude f =+   Cons $ \ xAmp -> (f xAmp, Causal.id) +{-# INLINE mapAmplitudeSameType #-}+mapAmplitudeSameType ::+   (amp -> amp) ->+   T s amp amp yv yv+mapAmplitudeSameType f =+   Cons $ \ xAmp -> (f xAmp, Causal.id) +{- |+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 =+   Cons $ \ xAmp -> (xAmp, c)++ infixr 3 *** infixr 3 &&& infixr 1 >>>, ^>>, >>^@@ -67,9 +228,9 @@ {-# INLINE compose #-} {-# INLINE (>>>) #-} compose, (>>>) ::-   T amp0 amp1 yv0 yv1 ->-   T amp1 amp2 yv1 yv2 ->-   T amp0 amp2 yv0 yv2+   T s amp0 amp1 yv0 yv1 ->+   T s amp1 amp2 yv1 yv2 ->+   T s amp0 amp2 yv0 yv2 compose (Cons f) (Cons g) =    Cons $ \ xAmp ->       let (yAmp, causalXY) = f xAmp@@ -80,16 +241,16 @@  {-# INLINE (<<<) #-} (<<<) ::-   T amp1 amp2 yv1 yv2 ->-   T amp0 amp1 yv0 yv1 ->-   T amp0 amp2 yv0 yv2+   T s amp1 amp2 yv1 yv2 ->+   T s amp0 amp1 yv0 yv1 ->+   T s amp0 amp2 yv0 yv2 (<<<) = flip (>>>)   {-# INLINE first #-} first ::-   T amp0 amp1 yv0 yv1 ->-   T (amp0, amp) (amp1, amp) (yv0, yv) (yv1, yv)+   T s amp0 amp1 yv0 yv1 ->+   T s (amp0, amp) (amp1, amp) (yv0, yv) (yv1, yv) first (Cons f) =    Cons $ \ (xAmp, amp) ->       let (yAmp, causal) = f xAmp@@ -97,8 +258,8 @@  {-# INLINE second #-} second ::-   T amp0 amp1 yv0 yv1 ->-   T (amp, amp0) (amp, amp1) (yv, yv0) (yv, yv1)+   T s amp0 amp1 yv0 yv1 ->+   T s (amp, amp0) (amp, amp1) (yv, yv0) (yv, yv1) second (Cons f) =    Cons $ \ (amp, xAmp) ->       let (yAmp, causal) = f xAmp@@ -107,9 +268,9 @@ {-# INLINE split #-} {-# INLINE (***) #-} split, (***) ::-   T amp0 amp1 yv0 yv1 ->-   T amp2 amp3 yv2 yv3 ->-   T (amp0, amp2) (amp1, amp3) (yv0, yv2) (yv1, yv3)+   T s amp0 amp1 yv0 yv1 ->+   T s amp2 amp3 yv2 yv3 ->+   T s (amp0, amp2) (amp1, amp3) (yv0, yv2) (yv1, yv3) split f g =    compose (first f) (second g) @@ -118,46 +279,48 @@ {-# INLINE fanout #-} {-# INLINE (&&&) #-} fanout, (&&&) ::-   T amp amp0 yv yv0 ->-   T amp amp1 yv yv1 ->-   T amp (amp0, amp1) yv (yv0, yv1)+   T s amp amp0 yv yv0 ->+   T s amp amp1 yv yv1 ->+   T s amp (amp0, amp1) yv (yv0, yv1) fanout f g =-   compose (map (\amp -> (amp,amp)) (\y -> (y,y))) (split f g)+   compose (map Map.double) (split f g)  (&&&) = fanout  +-- * map functions+ {-# INLINE (^>>) #-} -- | Precomposition with a pure function. (^>>) ::-   (amp0 -> amp1, yv0 -> yv1) ->-   T amp1 amp2 yv1 yv2 ->-   T amp0 amp2 yv0 yv2-f ^>> a = uncurry map f >>> a+   Map.T amp0 amp1 yv0 yv1 ->+   T s amp1 amp2 yv1 yv2 ->+   T s amp0 amp2 yv0 yv2+f ^>> a = map f >>> a  {-# INLINE (>>^) #-} -- | Postcomposition with a pure function. (>>^) ::-   T amp0 amp1 yv0 yv1 ->-   (amp1 -> amp2, yv1 -> yv2) ->-   T amp0 amp2 yv0 yv2-a >>^ f = a >>> uncurry map f+   T s amp0 amp1 yv0 yv1 ->+   Map.T amp1 amp2 yv1 yv2 ->+   T s amp0 amp2 yv0 yv2+a >>^ f = a >>> map f  {-# INLINE (<<^) #-} -- | Precomposition with a pure function (right-to-left variant). (<<^) ::-   T amp1 amp2 yv1 yv2 ->-   (amp0 -> amp1, yv0 -> yv1) ->-   T amp0 amp2 yv0 yv2-a <<^ f = a <<< uncurry map f+   T s amp1 amp2 yv1 yv2 ->+   Map.T amp0 amp1 yv0 yv1 ->+   T s amp0 amp2 yv0 yv2+a <<^ f = a <<< map f  {-# INLINE (^<<) #-} -- | Postcomposition with a pure function (right-to-left variant). (^<<) ::-   (amp1 -> amp2, yv1 -> yv2) ->-   T amp0 amp1 yv0 yv1 ->-   T amp0 amp2 yv0 yv2-f ^<< a = uncurry map f <<< a+   Map.T amp1 amp2 yv1 yv2 ->+   T s amp0 amp1 yv0 yv1 ->+   T s amp0 amp2 yv0 yv2+f ^<< a = map f <<< a   @@ -166,11 +329,44 @@ loop ::    (Field.C y, Module.C y yv, Dim.C v) =>    DN.T v y ->-   T (restAmp0, DN.T v y) (restAmp1, DN.T v y) (restSamp0, yv) (restSamp1, yv) ->-   T restAmp0 restAmp1 restSamp0 restSamp1+   T s (restAmpIn, DN.T v y) (restAmpOut, DN.T v y) (restSampIn, yv) (restSampOut, yv) ->+   T s restAmpIn restAmpOut restSampIn restSampOut loop ampIn (Cons f) =-   Cons $ \restAmp0 ->-      let ((restAmp1, ampOut), causal) = f (restAmp0, ampIn)-      in  (restAmp1,+   Cons $ \restAmpIn ->+      let ((restAmpOut, ampOut), causal) = f (restAmpIn, ampIn)+      in  (restAmpOut,            Causal.loop (causal Arrow.>>^-              Arrow.second (DN.divToScalar ampOut ampIn *>)))+              mapSnd (DN.divToScalar ampOut ampIn *>)))++{-# INLINE loop2 #-}+-- loop2 :: a (b, (d,e)) (c, (d,e)) -> a b c+loop2 (amp0,amp1) p =+   loop amp0 $+   loop amp1 $+   (Map.balanceRight ^>> p >>^ Map.balanceLeft)++loop2, loop2' ::+   (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,  (DN.T v0 y0, DN.T v1 y1))+     (restAmpOut, (DN.T v0 y0, DN.T v1 y1))+     (restSampIn,  (yv0,yv1))+     (restSampOut, (yv0,yv1)) ->+   T s restAmpIn restAmpOut restSampIn restSampOut+loop2' ampIn@(ampIn0,ampIn1) (Cons f) =+   Cons $ \restAmpIn ->+      let ((restAmpOut, (ampOut0,ampOut1)), causal) = f (restAmpIn, ampIn)+      in  (restAmpOut,+           Causal.loop (causal Arrow.>>^+              Arrow.second ((DN.divToScalar ampOut0 ampIn0 *>) Arrow.***+                            (DN.divToScalar ampOut1 ampIn1 *>))))++++{-# INLINE id #-}+id ::+   T s amp amp yv yv+id =+   homogeneous Causal.id
src/Synthesizer/Dimensional/ControlledProcess.hs view
@@ -4,8 +4,7 @@  Maintainer  :  synthesizer@henning-thielemann.de Stability   :  provisional-Portability :  requires multi-parameter type classes (OccasionallyScalar)-               and local universal quantification+Portability :  Haskell 98   Basic definitions for signal processors@@ -17,8 +16,11 @@ then it can be more efficient to compute the control curve at a lower rate and interpolate the internal control parameters of a particular process. CSound and SuperCollider have a sample rate-that is common to all control curves+that is common to all control curves,+the ratio between audio and control rate must be integral, and they use constant interpolation exclusively.+With some more sophisticated interpolation+one may choose a larger gap between control and audio rate. -} module Synthesizer.Dimensional.ControlledProcess where @@ -60,34 +62,35 @@ @ec@ is the type for the curve of external control parameters, @ic@ for internal control parameters. -}-newtype T s u t ec ic a = Cons {-      process :: Proc.T s u t (ec -> Sig.T ic, Sig.T ic -> a)+data T s ec ic a = Cons {+      converter :: ec -> Sig.T ic,+      processor :: Sig.T ic -> a    }   {-# INLINE runSynchronous #-} runSynchronous ::-   T s u t ec ic a ->+   Proc.T s u t (T s ec ic a) ->    Proc.T s u t (ec -> a) runSynchronous cp =-   do (convert, func) <- process cp-      return (func . convert)+   do p <- cp+      return (processor p . converter p)  {-# INLINE runSynchronous1 #-} runSynchronous1 ::-   T s u t (RP.T s sig0 ec0) ic a ->+   Proc.T s u t (T s (RP.T s sig0 ec0) ic a) ->    Proc.T s u t (RP.T s sig0 ec0 -> a) runSynchronous1 = runSynchronous  {-# INLINE runSynchronous2 #-} runSynchronous2 ::-   T s u t (RP.T s sig0 ec0, RP.T s sig1 ec1) ic a ->+   Proc.T s u t (T s (RP.T s sig0 ec0, RP.T s sig1 ec1) ic a) ->    Proc.T s u t (RP.T s sig0 ec0 -> RP.T s sig1 ec1 -> a) runSynchronous2 = fmap curry . runSynchronous  {-# INLINE runSynchronous3 #-} runSynchronous3 ::-   T s u t (RP.T s sig0 ec0, RP.T s sig1 ec1, RP.T s sig2 ec2) ic a ->+   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@@ -98,25 +101,26 @@ runAsynchronous ::    (Dim.C u, Additive.C ic, RealField.C t) =>    Interpolation.T t ic ->-   T s u t ec ic a ->+   Proc.T s u t (T s ec ic a) ->    Rate.T r u t ->    ec ->    Proc.T s u t a runAsynchronous ip cp srcRate sig =-   do (convert, func) <- process cp+   do p <- cp       k <- fmap               (DN.divToScalar (Rate.toDimensionNumber srcRate))               Proc.getSampleRate-      return-         (func (Causal.apply-                   (Interpolation.relativeConstantPad ip zero (convert sig))-                   (Sig.repeat k)))+      return $+         processor p $+         Causal.apply+            (Interpolation.relativeConstantPad ip zero (converter p sig))+            (Sig.repeat k)  {-# INLINE runAsynchronous1 #-} runAsynchronous1 ::    (Dim.C u, Additive.C ic, RealField.C t) =>    Interpolation.T t ic ->-   T s u t (RP.T r sig0 ec0) ic a ->+   Proc.T s u t (T s (RP.T r sig0 ec0) ic a) ->    SigP.T u t sig0 ec0 ->    Proc.T s u t a runAsynchronous1 ip cp x =@@ -126,7 +130,7 @@ runAsynchronous2 ::    (Dim.C u, Additive.C ic, RealField.C t) =>    Interpolation.T t ic ->-   T s u t (RP.T r sig0 ec0, RP.T r sig1 ec1) ic a ->+   Proc.T s u t (T s (RP.T r sig0 ec0, RP.T r sig1 ec1) ic a) ->    SigP.T u t sig0 ec0 ->    SigP.T u t sig1 ec1 ->    Proc.T s u t a@@ -140,7 +144,7 @@ runAsynchronous3 ::    (Dim.C u, Additive.C ic, RealField.C t) =>    Interpolation.T t ic ->-   T s u t (RP.T r sig0 ec0, RP.T r sig1 ec1, RP.T r sig2 ec2) ic a ->+   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 ->
+ src/Synthesizer/Dimensional/Map.hs view
@@ -0,0 +1,91 @@+{- |+Maps that handle pairs of amplitudes and sampled values.+They are a special form of arrows.+-}+module Synthesizer.Dimensional.Map where++{-+import qualified Number.DimensionTerm        as DN+import qualified Algebra.DimensionTerm       as Dim+-}++import qualified Data.Tuple as Tuple+import Data.Tuple.HT as TupleHT (swap, )++import Prelude hiding (map, id, fst, snd, )++++{- |+This type shall ensure, that you do not accidentally+bring amplitudes and the corresponding low-level signal values out of sync.+We also use it for generation of internal control parameters+in "Synthesizer.Dimensional.Causal.ControlledProcess".+In principle this could also be 'Causal.T',+but maps are not bound to a sampling rate,+and thus do not need the @s@ type parameter.+-}+newtype T amp0 amp1 yv0 yv1 =+   Cons (amp0 -> (amp1, yv0 -> yv1))++independent ::+   (amp0 -> amp1) -> (yv0 -> yv1) ->+   T amp0 amp1 yv0 yv1+independent f g =+   Cons (\amp -> (f amp, g))++double ::+   T amp (amp, amp)+     y (y, y)+double =+   let aux = \x -> (x, x)+   in  independent aux aux++fst ::+   T (amp0,amp1) amp0+     (y0,y1) y0+fst =+   let aux = Tuple.fst+   in  independent aux aux++snd ::+   T (amp0,amp1) amp1+     (y0,y1) y1+snd =+   let aux = Tuple.snd+   in  independent aux aux++swap ::+   T (amp0,amp1) (amp1,amp0)+     (y0,y1) (y1,y0)+swap =+   let aux = TupleHT.swap+   in  independent aux aux++balanceRight ::+   T ((amp0,amp1), amp2) (amp0, (amp1,amp2))+     ((y0,y1), y2) (y0, (y1,y2))+balanceRight =+   let aux = \((a,b), c) -> (a, (b,c))+   in  independent aux aux++balanceLeft ::+   T (amp0, (amp1,amp2)) ((amp0,amp1), amp2)+     (y0, (y1,y2)) ((y0,y1), y2)+balanceLeft =+   let aux = \(a, (b,c)) -> ((a,b), c)+   in  independent aux aux++packTriple ::+   T (amp0,(amp1,amp2)) (amp0,amp1,amp2)+     (y0,(y1,y2)) (y0,y1,y2)+packTriple =+   let aux = \(a,(b,c)) -> (a,b,c)+   in  independent aux aux++unpackTriple ::+   T (amp0,amp1,amp2) (amp0,(amp1,amp2))+     (y0,y1,y2) (y0,(y1,y2))+unpackTriple =+   let aux = \(a,b,c) -> (a,(b,c))+   in  independent aux aux
+ src/Synthesizer/Dimensional/Overview.hs view
@@ -0,0 +1,180 @@+{- |+We use a hierarchy of signal wrappers+in order to capture all features of a signal.++At the bottom there is the signal storage as described in "Synthesizer.Storage".+With the element type of the storage+you decide whether you want mono or stereo signal+("Synthesizer.Frame.Stereo"),+and you decide on the precision, fixed point vs. floating point and so on.+However, due to Haskell's flexible type system+you don't need to decide finally on a type for your signal processing routines.+E.g. mono and stereo signals can be handled together+using the "Algebra.Module" class from the numeric-prelude package.+(An algebraic module is a vector space+without requiring availability of a division of scalars).++You can use the storage types directly+using the functions from "Synthesizer.Plain.Signal"+and "Synthesizer.Generic.Signal" and its cousins.+This is in a way simple,+since you do not have bother with units and complicated types,+but you miss type safety and re-usability.+E.g. you have to give frequencies in ratios of the sampling rate.+If you later decide to change the sampling rate, you must rewrite all time and frequency values.+If you anticipate changes in sampling rate,+you may write those values as ratios of a global sampling rate+right from the start.+But you might want different sample rates+for some parts of the computation,+or you may want sample rates that have no time dimension,+but say, length dimension.+The advanced system described below handles all these cases for you.++Ok, we said that at the bottom, there is the signal storage.+The next level is the decision+whether the raw data is interpreted as straight or as cyclic signal.+Most of the signals you are using,+will be "Synthesizer.Dimensional.Straight.Signal".+Currently, "Synthesizer.Dimensional.Cyclic.Signal"+is only needed for Fourier transform and as input to oscillators.+To get a straight signal out of storablevector data,+you will write++> import qualified Synthesizer.Storable.Signal as Store+> import qualified Synthesizer.Dimensional.Straight.Signal as Straight+>+> type MySignal y = Straight.T Store.T y++Note that @Straight.T@ has the type constructor @Store.T@ as first argument,+not the entire storage type @Store.T@.+This way compositions of such wrappers are automatically Functors.+However, I'm not completely certain, that this is good,+since 'fmap' allows to do unintended things+(e.g. switch from a numeric to a non-numeric element type).++The next level copes with amplitudes and their units.+An amplitude and its unit are provided per signal, not per sample.+We think that it is the most natural way, and it is also an efficient one.+Since the signal might be a stereo signal,+the numeric type of the amplitude can differ from the storage element type.+Usually, the first and the latter one are related by an "Algebra.Module" constraint.+You get a signal with amplitude by++> import qualified Synthesizer.Dimensional.Amplitude.Signal as Amp+>+> type MySignal v y yv = Amp.T v y (Straight.T Store.T) yv++where @v@ is the dimension of the amplitude of type @y@.+The storage element type, a vector with respect to @y@, is of type @yv@.++In some cases, an amplitude with a physical dimension just makes no sense.+Imagine a control signal consisting of @Bool@ elements like a gate signal,+or a signal containing elements of an enumeration+for switching between signals depending on the time.++For some control signals the amplitude unit is one.+We call these signals flat.+In this case you can choose+whether you use an explicit amplitude with @Scalar@ dimension+or you use no amplitude wrapper at all.+Most signal processors handle both kinds of flat signals+by the corresponding type class in "Synthesizer.Dimensional.Abstraction.Flat".++There is a special signal type for Dirac impulses,+that does not fit to that scheme,+that is, it cannot be equipped with an amplitude.+See "Synthesizer.Dimensional.Rate.Dirac".+++Last but not least we want to look on how to handle sample rates.+Our goal is to write signal processes+that do not depend on the sample rate.+E.g. we want to have an exponential decay with a half-life of one second.+A second means 44100 samples at 44100 Hz sample rate,+or 22050 samples at 22050 Hz sample rate.+We want to abstract from the particular number of samples+in order to be able generate a signal at any sample rate (i.e. quality) we like.+The ideal representation of a signal is be a real function,+and we try to come close to it.+(Not quite, because a Dirac impulse is not a real function,+but we need it as identity element of the convolution.)++To this end we can equip a discrete signal with a sample rate,+see "Synthesizer.Dimensional.RateWrapper".+This alone however, leads to several problems:++* When combining some signals,+  it is not clear how to cope with different sample rates.+  Say you want to mix signals @a@ and @b@.+  Shall @mix a b@ have the sample rate of @a@ or that of @b@ or a new one?+  How shall the signals convert to a new rate?+  Since an automatically chosen method+  can always be inappropriate (either too slow or too low quality),+  the caller have to explicitly give tell it to 'mix'.+  This is not only inconvenient for the caller,+  but also requires a lot of boilerplate code in functions like 'mix'.++* An alternative solution to the problem above is,+  to check before mixing whether sample rates are equal,+  and abort with an error if they differ.+  This way no decisions on the sample rate+  and subsequent conversions are necessary.+  This still needs boilerplate in signal processors.+  It also does not tell the user by types,+  whether a processor can handle differing sample rates.+  Generally, dynamic checks are both inefficient+  and an inferior way to indicate programming errors,+  since they are only catched at run-time, if at all.++* Both solutions suffer from the inconvenience+  to specify the sample rate in all leaves,+  e.g. @mix (oscillator 44100 10) (oscillator 44100 11)@.++Naturally, when you want to get a signal with rate 44100 Hz sample rate,+you perform all signal processes at this rate.+Even if want to use oversampling,+then you will perform all signal processes at the higher rate+and downsample only once at the end.+Thus we introduce a way+to run a set of signal processes in the context of a sample rate.+It is still sensible and possible+to escape from this context or enter it again.++* You need to be to enter a sample rate context+  with a signal read from disk,+  with a sample rate that is not known at compile time.+  You might also intensionally compute a control signal at a low sample rate+  and convert it to a sample rate context for filtering.+  Generally the scheme of functions that allow different sample rates is:+  Use the sample rate of the output signal as context.+  Take all signals with independent sample rate+  as inputs outside the context.+  The according function is 'Synthesizer.Dimensional.Rate.Filter.frequencyModulationDecoupled'.++* When you want to play a sound or write it to disk,+  you must choose a sample rate and fix the computation to that rate.+  This conversion however means to run the whole computation within one sample rate context,+  since everything in that context depends on the sample rate.+  The according function is 'Synthesizer.Dimensional.RateWrapper.runProcess'.++The sample rate context is provided by "Synthesizer.Dimensional.Process".+It is a Reader monad,+but we only need applicative functor methods for signal processing.+This context is equipped with the type parameter @s@,+just as we know it from the 'Control.Monad.ST.ST' monad.+It also serves the same purpose:+We tag both signals and the sample rate context with the type parameter @s@.+The @forall s@ constraint for @runProcess@ ensures,+that a signal with such a tag remains in the context.+You can only escape the sample rate context+by rendering the signal and attach the sample rate to the rendered signal.++The sample rate tag type is provided by+"Synthesizer.Dimensional.RatePhantom".+Haskell's type system does not allow to restrict the types that it can wrap.+So in principle you can abuse it to wrap many things.+However we do not provide such functions+and this way the wrappable types ar restricted anyway.+-}+module Synthesizer.Dimensional.Overview where
src/Synthesizer/Dimensional/Process.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE Rank2Types #-} {- | Copyright   :  (c) Henning Thielemann 2008 License     :  GPL@@ -43,7 +43,7 @@ import qualified Algebra.Ring           as Ring  import Control.Monad.Fix (MonadFix(mfix), )--- import Control.Monad.Reader ()+-- import Control.Monad.Trans.Reader () import Synthesizer.ApplicativeUtility import qualified Control.Applicative as App import Control.Applicative (Applicative)
src/Synthesizer/Dimensional/Rate.hs view
@@ -53,6 +53,10 @@ fromNumber :: Dim.C u => Dim.Recip u -> t -> T s u t fromNumber u = Cons . DN.fromNumberWithDimension u +{- |+This function is somehow dangerous+because it drops the 's' parameter.+-} {-# INLINE toNumber #-} toNumber :: Dim.C u => Dim.Recip u -> T s u t -> t toNumber u = DN.toNumberWithDimension u . decons@@ -61,6 +65,10 @@ fromDimensionNumber :: Dim.C u => DN.T (Dim.Recip u) t -> T s u t fromDimensionNumber = Cons +{- |+This function is somehow dangerous+because it drops the 's' parameter.+-} {-# INLINE toDimensionNumber #-} toDimensionNumber :: Dim.C u => T s u t -> DN.T (Dim.Recip u) t toDimensionNumber = decons
src/Synthesizer/Dimensional/Rate/Analysis.hs view
@@ -40,18 +40,18 @@  {-# INLINE centroid #-} centroid :: (Field.C q, Dim.C u) =>-   SigP.T u q (SigS.T Sig.T) q -> DN.T u q+   SigP.T u q SigS.S q -> DN.T u q centroid = makePhysicalLength Ana.centroid  {-# INLINE length #-} length :: (Field.C t, Dim.C u) =>-   SigP.T u t (SigS.T Sig.T) yv -> DN.T u t+   SigP.T u t SigS.S yv -> DN.T u t length = makePhysicalLength (fromIntegral . Sig.length)  {-# INLINE makePhysicalLength #-} makePhysicalLength :: (Field.C t, Dim.C u) =>    (Sig.T y -> t) ->-   SigP.T u t (SigS.T Sig.T) y -> DN.T u t+   SigP.T u t SigS.S y -> DN.T u t makePhysicalLength f x =    f (SigS.samples (SigP.signal x))  *&  DN.unrecip (SigP.sampleRate x)
src/Synthesizer/Dimensional/Rate/Cut.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright   :  (c) Henning Thielemann 2008 License     :  GPL
+ src/Synthesizer/Dimensional/Rate/Dirac.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE FlexibleContexts #-}+module Synthesizer.Dimensional.Rate.Dirac where++import qualified Synthesizer.Generic.Cut as Cut++import qualified Synthesizer.Dimensional.RatePhantom as RP+import qualified Synthesizer.Dimensional.Amplitude.Signal as SigA+import qualified Synthesizer.Dimensional.Straight.Signal  as SigS+import qualified Synthesizer.Dimensional.Process as Proc++import qualified Data.Monoid as Mn++-- import qualified Number.DimensionTerm        as DN+import qualified Algebra.DimensionTerm       as Dim++-- import qualified Algebra.Field              as Field+import qualified Algebra.Ring               as Ring++import Data.Tuple.HT (mapPair, mapSnd, )++import NumericPrelude (zero, one, )+++{- |+We want to represent streams of discrete events+in a manner that is more safe than plain @[Bool]@.+Each peak can be imagined as a Dirac impulse.++A @[Bool]@ could be used accidentally for 'Synthesizer.Dimensional.Amplitude.Cut.selectBool',+where @selectBool@ is intended for piecewise constant control curves.++You may think that a type like @Peak = Peak Bool@ as sample type+in @T s Peak@ would also do the job.+Actually, this wouldn't be a good idea+since you can apply constant interpolation on it,+which obviously fools the idea of a peak.+-}+newtype T s sig = Cons {decons :: sig Bool}++instance Mn.Monoid (sig Bool) => Mn.Monoid (T s sig) where+   mempty = Cons Mn.mempty+   mappend (Cons x) (Cons y) = Cons (Mn.mappend x y)++instance Cut.Read (sig Bool) => Cut.Read (T s sig) where+   {-# INLINE null #-}+   null = Cut.null . decons+   {-# INLINE length #-}+   length = Cut.length . decons++instance Cut.Transform (sig Bool) => Cut.Transform (T s sig) where+   {-# INLINE take #-}+   take n = Cons . Cut.take n . decons+   {-# INLINE drop #-}+   drop n = Cons . Cut.drop n . decons+   {-# INLINE splitAt #-}+   splitAt n = mapPair (Cons, Cons) . Cut.splitAt n . decons+   {-# INLINE dropMarginRem #-}+   dropMarginRem n m = mapSnd Cons . Cut.dropMarginRem n m . decons+   {-# INLINE reverse #-}+   reverse = Cons . Cut.reverse . decons++{- |+This is the most frequently needed transformation+of a stream of peaks, if not the only one.+It converts to a signal of peaks with area 1.+This convention is especially useful for smoothing filters+that produce frequency progress curves from zero crossings.+-}+{-# INLINE toAmplitudeSignal #-}+toAmplitudeSignal ::+   (Ring.C q, Dim.C u, Functor sig) =>+   Proc.T s u q (T s sig -> RP.T s (SigA.D (Dim.Recip u) q (SigS.T sig)) q)+toAmplitudeSignal =+   fmap+      (\rate ->+         RP.fromSignal . SigA.Cons rate . SigS.Cons .+         fmap (\c -> if c then one else zero) .+         decons)+      Proc.getSampleRate
src/Synthesizer/Dimensional/Rate/Filter.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright   :  (c) Henning Thielemann 2008 License     :  GPL@@ -45,10 +45,12 @@    highpassFromUniversal,    bandpassFromUniversal,    lowpassFromUniversal,+   bandlimitFromUniversal,    moogLowpass,     {- ** Allpass -}    allpassCascade,+   allpassFlangerPhase,     {- ** Reverb -}    comb,@@ -59,7 +61,7 @@  -- import qualified Synthesizer.Dimensional.Abstraction.Linear as Lin import qualified Synthesizer.Dimensional.Abstraction.Homogeneous as Hom--- import qualified Synthesizer.Dimensional.Abstraction.RateIndependent as Ind+import qualified Synthesizer.Dimensional.Abstraction.RateIndependent as Ind import qualified Synthesizer.Dimensional.Abstraction.Flat as Flat  import qualified Synthesizer.Dimensional.RatePhantom as RP@@ -74,7 +76,7 @@ import qualified Synthesizer.Dimensional.RateAmplitude.Signal as SigA import qualified Synthesizer.Dimensional.RateWrapper      as SigP import qualified Synthesizer.State.Signal as Sig-import Synthesizer.Plain.Signal (Modifier)+import Synthesizer.Plain.Signal (Modifier, )  import Synthesizer.Dimensional.RateAmplitude.Signal    (toTimeScalar, toFrequencyScalar, )@@ -92,17 +94,17 @@ import qualified Synthesizer.Plain.Filter.Recursive.Moog        as Moog import qualified Synthesizer.Plain.Filter.Recursive.Butterworth as Butter import qualified Synthesizer.Plain.Filter.Recursive.Chebyshev   as Cheby-import qualified Synthesizer.Plain.Filter.Recursive    as FiltR+import qualified Synthesizer.Plain.Filter.Recursive             as FiltRec  import qualified Synthesizer.Storable.Signal as SigSt-import qualified Synthesizer.Storable.Filter.Recursive.Comb as Comb+import qualified Synthesizer.Generic.Filter.Recursive.Comb as Comb  -- import qualified Synthesizer.Generic.Interpolation as InterpolationG import qualified Synthesizer.Generic.Filter.Recursive.MovingAverage as MAG import qualified Synthesizer.Generic.Filter.NonRecursive as FiltG import qualified Synthesizer.Generic.Filter.Delay as DelayG-import qualified Synthesizer.Generic.Signal as SigG-import qualified Synthesizer.Generic.SampledValue as Sample+import qualified Synthesizer.Generic.Signal  as SigG+import qualified Synthesizer.Generic.Signal2 as SigG2  import qualified Synthesizer.Frame.Stereo as Stereo @@ -117,10 +119,10 @@ -- import qualified Algebra.Real           as Real import qualified Algebra.Ring           as Ring import qualified Algebra.Additive       as Additive-import qualified Algebra.VectorSpace    as VectorSpace+-- import qualified Algebra.VectorSpace    as VectorSpace import qualified Algebra.Module         as Module --- import Synthesizer.Utility(clip)+import Foreign.Storable (Storable, )  -- import qualified Data.List as List @@ -158,7 +160,7 @@  {-# INLINE convolveVector #-} convolveVector ::-   (Hom.C sig, Module.C q yv, Field.C q, Dim.C u, Sample.C q) =>+   (Hom.C sig, Module.C q yv, Field.C q, Dim.C u) =>       Proc.T s u q (         SigA.R s (Dim.Recip u) q q                               {- v the filter window -}@@ -192,7 +194,7 @@ {- | needs a better handling of boundaries, yet -} {-# INLINE mean #-} mean :: (Hom.C sig, Additive.C yv, RealField.C q,-         Module.C q yv, Dim.C u, Sample.C q, Sample.C yv) =>+         Module.C q yv, Dim.C u, Storable q, Storable yv) =>       DN.T (Dim.Recip u) q    {- ^ minimum cut-off freqeuncy -}    -> Proc.T s u q (         SigA.R s (Dim.Recip u) q q@@ -223,17 +225,17 @@   {-# INLINE toStorable #-}-toStorable :: (Sample.C a) => Sig.T a -> SigSt.T a+toStorable :: (Storable a) => Sig.T a -> SigSt.T a toStorable = Sig.toStorableSignal SigSt.defaultChunkSize  {-# INLINE fromStorable #-}-fromStorable :: (Sample.C a) => SigSt.T a -> Sig.T a+fromStorable :: (Storable a) => SigSt.T a -> Sig.T a fromStorable = Sig.fromStorableSignal  {-# INLINE phaseModulation #-} phaseModulation ::    (Hom.C sig, Additive.C yv, RealField.C q, Dim.C u,-    Sample.C q, Sample.C yv) =>+    Storable q, Storable yv) =>       Interpolation.T q yv    -> DN.T u q           {- ^ minimal deviation from current time, usually negative -}@@ -260,7 +262,7 @@ {-# INLINE phaseModulationGeneric #-} phaseModulationGeneric ::    (Additive.C yv, RealField.C q, Dim.C u,-    Sample.C q, Sample.C yv, SigG.C sig) =>+    SigG2.Transform sig q yv, SigG.Write sig yv) =>       Interpolation.T q yv    -> DN.T u q           {- ^ minimal deviation from current time, usually negative -}@@ -269,7 +271,7 @@                and the modulation must always be                in the range [minDev,maxDev]. -}    -> Proc.T s u q (-        RP.T s (SigA.T u q (SigS.T sig)) q+        RP.T s (SigA.D u q (SigS.T sig)) q           {- v deviation control,                positive numbers meanStatic prefetch,                negative numbers meanStatic delay -}@@ -280,7 +282,7 @@       (\toTime devs ->           let t0    = toTime minDev               tInt0 = floor t0-          in  DelayG.modulated (Interpolation.toGeneric ip) tInt0+          in  DelayG.modulated ip tInt0                  (SigG.map (max t0) (SigA.scalarSamplesGeneric toTime devs)))       (Proc.withParam toTimeScalar) @@ -290,10 +292,11 @@ -} {-# INLINE frequencyModulation #-} frequencyModulation ::-   (Hom.C sig, Flat.C flat q, Additive.C yv, RealField.C q, Dim.C u) =>-      Interpolation.T q yv-   -> Proc.T s u q (-        RP.T s flat q    {- v frequency factors -}+   (Hom.C sig, Flat.C flat t,+    Additive.C yv, RealField.C t, Dim.C u) =>+      Interpolation.T t yv+   -> Proc.T s u t (+        RP.T s flat t    {- v frequency factors -}      -> RP.T s sig yv      -> RP.T s sig yv) frequencyModulation ip =@@ -314,19 +317,23 @@ -} {-# INLINE frequencyModulationDecoupled #-} frequencyModulationDecoupled ::-   (Additive.C yv, RealField.C q, Dim.C u) =>-      Interpolation.T q yv-   -> Proc.T s u q (-        SigS.R s q {- v frequency factors -}-     -> SigP.T u q (SigS.T Sig.T) yv-     -> SigS.R s yv)-frequencyModulationDecoupled ip =+   (Hom.C sig, Flat.C flat t,+    Additive.C yv, RealField.C t, Dim.C u) =>+      Interpolation.T t yv+   -> SigP.T u t sig yv+                   {- ToDo: We could also allow any signal from Generic.Read class. -}+   -> Proc.T s u t (+        RP.T s flat t {- v frequency factors -}+     -> RP.T s sig yv)+frequencyModulationDecoupled ip y =    fmap-      (\toFreq factors y ->-         flip SigS.processSamples (RP.fromSignal (SigP.signal y)) $-            (interpolateMultiRelativeZeroPad ip-               (SigA.scalarSamples toFreq-                  (SigA.fromSignal (SigP.sampleRate y) factors))))+      (\toFreq factors ->+         RP.fromSignal $+         flip Hom.unwrappedProcessSamples (SigP.signal y) $+         interpolateMultiRelativeZeroPad ip $+         SigA.scalarSamples toFreq $+         SigA.fromSamples (SigP.sampleRate y) $+         Flat.toSamples factors)       (Proc.withParam Proc.toFrequencyScalar)  @@ -346,7 +353,7 @@ phaser ::    (Hom.C sig, Additive.C yv, RealField.C q,     Module.C q yv, Dim.C u,-    Sample.C q, Sample.C yv) =>+    Storable q, Storable yv) =>       Interpolation.T q yv    -> DN.T u q  {- ^ maxDev, must be positive -}    -> Proc.T s u q (@@ -366,7 +373,7 @@ phaserStereo ::    (Hom.C sig, Additive.C yv, RealField.C q,     Module.C q yv, Dim.C u,-    Sample.C q, Sample.C yv) =>+    Storable q, Storable yv) =>       Interpolation.T q yv    -> DN.T u q   {- ^ maxDev, must be positive -}    -> Proc.T s u q (@@ -384,7 +391,7 @@ phaserCore ::    (Additive.C yv, RealField.C q,     Module.C q yv, Dim.C u,-    Sample.C q, Sample.C yv) =>+    Storable q, Storable yv) =>       Interpolation.T q yv    -> DN.T u q   {- ^ maxDev, must be positive -}    -> Proc.T s u q (@@ -439,51 +446,84 @@ butterworthLowpass, butterworthHighpass,    chebyshevALowpass, chebyshevAHighpass,    chebyshevBLowpass, chebyshevBHighpass ::-      (Hom.C sig, Trans.C q, VectorSpace.C q yv, Dim.C u) =>+      (Hom.C sig, Flat.C flat q, Trans.C q, Module.C q yv, Dim.C u) =>       NonNeg.Int   {- ^ Order of the filter, must be even,                         the higher the order, the sharper is the separation of frequencies. -}-   -> q            {- ^ The attenuation at the cut-off frequency.-                        Should be between 0 and 1. -}    -> Proc.T s u q (-        SigA.R s (Dim.Recip u) q q+        RP.T s flat q {- v The attenuation at the cut-off frequency.+                           Should be between 0 and 1. -}+     -> SigA.R s (Dim.Recip u) q q                       {- v Control signal for the cut-off frequency. -}      -> RP.T s sig yv {- v Input signal -}      -> RP.T s sig yv) -butterworthLowpass  = higherOrderNoResoGen Butter.lowpass-butterworthHighpass = higherOrderNoResoGen Butter.highpass-chebyshevALowpass   = higherOrderNoResoGen Cheby.lowpassA-chebyshevAHighpass  = higherOrderNoResoGen Cheby.highpassA-chebyshevBLowpass   = higherOrderNoResoGen Cheby.lowpassB-chebyshevBHighpass  = higherOrderNoResoGen Cheby.highpassB+butterworthLowpass  = higherOrderNoResoGen Butter.lowpassPole+butterworthHighpass = higherOrderNoResoGen Butter.highpassPole+chebyshevALowpass   = higherOrderNoResoGen Cheby.lowpassAPole+chebyshevAHighpass  = higherOrderNoResoGen Cheby.highpassAPole+chebyshevBLowpass   = higherOrderNoResoGen Cheby.lowpassBPole+chebyshevBHighpass  = higherOrderNoResoGen Cheby.highpassBPole   {-# INLINE higherOrderNoResoGen #-} higherOrderNoResoGen ::-   (Hom.C sig, Field.C q, Dim.C u) =>-      (Int -> q -> [q] -> [yv] -> [yv])+   (Hom.C sig, Flat.C flat q, Field.C q, Dim.C u) =>+      (Int -> [q] -> [q] -> [yv] -> [yv])    -> NonNeg.Int-   -> q    -> Proc.T s u q (-        SigA.R s (Dim.Recip u) q q+        RP.T s flat q+     -> SigA.R s (Dim.Recip u) q q      -> RP.T s sig yv      -> RP.T s sig yv)-higherOrderNoResoGen filt order ratio =-   frequencyControl $ \ freqs ->-      Hom.processSampleList (filt (NonNeg.toNumber order) ratio (Sig.toList freqs))+higherOrderNoResoGen filt order =+   fmap flip $ frequencyControl $ \ freqs ratios ->+      Hom.processSampleList+         (filt (NonNeg.toNumber order) (Sig.toList (Flat.toSamples ratios)) (Sig.toList freqs))   -highpassFromUniversal, bandpassFromUniversal, lowpassFromUniversal ::+{-# INLINE highpassFromUniversal #-}+{-# INLINE bandpassFromUniversal #-}+{-# INLINE lowpassFromUniversal #-}+{-# INLINE bandlimitFromUniversal #-}+highpassFromUniversal, lowpassFromUniversal,+  bandpassFromUniversal, bandlimitFromUniversal ::+   (Hom.C sig) =>+        RP.T s sig (UniFilter.Result yv)+     -> RP.T s sig yv+{-    (Hom.C sig, Dim.C u) =>       Proc.T s u q (         RP.T s sig (UniFilter.Result yv)      -> RP.T s sig yv)-highpassFromUniversal = return (Hom.processSamples (Sig.map UniFilter.highpass))-bandpassFromUniversal = return (Hom.processSamples (Sig.map UniFilter.bandpass))-lowpassFromUniversal  = return (Hom.processSamples (Sig.map UniFilter.lowpass))+-}+highpassFromUniversal  = homogeneousMap UniFilter.highpass+bandpassFromUniversal  = homogeneousMap UniFilter.bandpass+lowpassFromUniversal   = homogeneousMap UniFilter.lowpass+bandlimitFromUniversal = homogeneousMap UniFilter.bandlimit +homogeneousMap ::+   (Hom.C sig, Ind.C w) =>+   (y0 -> y1) ->+   w sig y0 -> w sig y1+homogeneousMap f =+   Ind.processSignal (Hom.unwrappedProcessSamples (Sig.map f)) +{-+homogeneousMap0 :: (Hom.C sig) =>+   (y0 -> y1) ->+   RP.T s sig y0 -> RP.T s sig y1+homogeneousMap0 f =+   Hom.processSamples (Sig.map f)++homogeneousMap1 :: (Hom.C sig) =>+   (y0 -> y1) ->+   Proc.T s1 u t (RP.T s sig y0 -> RP.T s sig y1)+homogeneousMap1 f =+   Proc.pure (Hom.processSamples (Sig.map f))+-}++ {-# INLINE universal #-} universal ::    (Hom.C sig, Flat.C flat q, Trans.C q, Module.C q yv, Dim.C u) =>@@ -504,7 +544,7 @@       in  modifyModulated              UniFilter.parameter              UniFilter.modifier-             (Sig.zipWith FiltR.Pole resos freqs)+             (Sig.zipWith FiltRec.Pole resos freqs)  {-# INLINE moogLowpass #-} moogLowpass :: (Hom.C sig, Flat.C flat q, Trans.C q, Module.C q yv, Dim.C u) =>@@ -525,7 +565,7 @@       in  modifyModulated              (Moog.parameter orderInt)              (Moog.lowpassModifier orderInt)-             (Sig.zipWith FiltR.Pole resos freqs)+             (Sig.zipWith FiltRec.Pole resos freqs)   {-# INLINE allpassCascade #-}@@ -544,10 +584,14 @@              (Allpass.cascadeModifier orderInt)              freqs +{-# INLINE allpassFlangerPhase #-}+allpassFlangerPhase :: Trans.C a => a+allpassFlangerPhase = Allpass.flangerPhase + {- | Infinitely many equi-delayed exponentially decaying echos. -} {-# INLINE comb #-}-comb :: (Hom.C sig, RealField.C t, Module.C y yv, Dim.C u, Sample.C yv) =>+comb :: (Hom.C sig, RealField.C t, Module.C y yv, Dim.C u, Storable yv) =>    DN.T u t -> y -> Proc.T s u t (RP.T s sig yv -> RP.T s sig yv) comb time gain =    do t <- toTimeScalar time
src/Synthesizer/Dimensional/Rate/Oscillator.hs view
@@ -1,6 +1,10 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-} {- |-Copyright   :  (c) Henning Thielemann 2008+Copyright   :  (c) Henning Thielemann 2008, 2009 License     :  GPL  Maintainer  :  synthesizer@henning-thielemann.de@@ -20,15 +24,27 @@    shapeFreqMod,    staticSample,    freqModSample,-) where+--   shapeFreqModSample,+   shapeFreqModFromSampledTone,+   shapePhaseFreqModFromSampledTone,+   ) where +import qualified Synthesizer.Dimensional.Abstraction.HomogeneousGen as Hom import qualified Synthesizer.Dimensional.Abstraction.Flat as Flat +import qualified Synthesizer.Dimensional.Amplitude as Amp import qualified Synthesizer.Dimensional.RatePhantom as RP+import qualified Synthesizer.Dimensional.RateWrapper as SigP  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 as OsciC+import qualified Synthesizer.Dimensional.Map as MapD++import qualified Synthesizer.Generic.Signal as SigG+ import qualified Synthesizer.Basic.WaveSmoothed as WaveSmooth import qualified Synthesizer.Basic.Wave         as Wave import qualified Synthesizer.Basic.Phase        as Phase@@ -40,7 +56,7 @@ import qualified Synthesizer.Dimensional.Process as Proc import Synthesizer.Dimensional.Process (toFrequencyScalar, ) -import qualified Synthesizer.State.Interpolation as Interpolation+import qualified Synthesizer.Interpolation as Interpolation  import qualified Number.DimensionTerm        as DN import qualified Algebra.DimensionTerm       as Dim@@ -52,74 +68,130 @@ -- import NumericPrelude import PreludeBase as P +{- |+This class is similar to the Homogeneous class+in the implementation,+but it is even more strict semantically.+It requires that values from the waveform+go untouched to the output signal,+whereas Homogeneous class still allows homogeneous+(aka amplitude-unit-independent) operations. +We could use the Homogeneous constraints+immediately in the oscillator functions,+but with the functional dependencies+we get more from type inference.+This way, the compiler knows,+that when we apply an oscillator to a flat wave,+that we want a flat signal as output.+-}+class (Hom.C amp (Wave.T t) wave, Hom.C amp Sig.T signal) =>+      Simple amp t wave signal+      | wave -> t, signal t -> wave, wave -> signal,+        signal -> amp, wave -> amp where++instance Simple CausalD.Flat t (Wave.T t) (SigS.T Sig.T) where++instance (Amp.C amp) =>+   Simple amp t (SigA.T amp (Wave.T t)) (SigA.T amp (SigS.T Sig.T)) where+++class (Hom.C amp (WaveSmooth.T t) wave, Hom.C amp Sig.T signal) =>+      Smooth amp t wave signal+      | wave -> t, signal t -> wave, wave -> signal,+        signal -> amp, wave -> amp where++instance Smooth CausalD.Flat t (WaveSmooth.T t) (SigS.T Sig.T) where++instance (Amp.C amp) =>+   Smooth amp t (SigA.T amp (WaveSmooth.T t)) (SigA.T amp (SigS.T Sig.T)) where+++withWave ::+   (Hom.C amp waveStore wave, Hom.C amp Sig.T sig) =>+   wave y -> (waveStore y -> Sig.T y) -> RP.T s sig y+withWave w f =+   RP.fromSignal $ Hom.plainProcessSamples f w++ {- * Oscillators with constant waveforms -}  {- | oscillator with a functional waveform with constant frequency -} {-# INLINE static #-}-static :: (RealField.C t, Dim.C u) =>-      Wave.T t y   {- ^ waveform -}-   -> Phase.T t    {- ^ start phase from the range [0,1] -}+static ::+   (RealField.C t, Dim.C u,+    Simple amp t wave sig) =>+      wave y       {- ^ waveform -}+   -> Phase.T t    {- ^ start phase -}    -> DN.T (Dim.Recip u) t                    {- ^ frequency -}-   -> Proc.T s u t (SigS.R s y)+   -> Proc.T s u t (RP.T s sig y) static wave phase =-   staticAux (SigS.fromSamples . Osci.static wave phase)+   staticAux (\freq -> withWave wave $ \w -> Osci.static w phase freq)  {- | oscillator with a functional waveform with constant frequency -} {-# INLINE staticAntiAlias #-}-staticAntiAlias :: (RealField.C t, Dim.C u) =>-      WaveSmooth.T t y+staticAntiAlias ::+   (RealField.C t, Dim.C u,+    Smooth amp t wave sig) =>+      wave y                    {- ^ waveform -}-   -> Phase.T t    {- ^ start phase from the range [0,1] -}+   -> Phase.T t    {- ^ start phase -}    -> DN.T (Dim.Recip u) t                    {- ^ frequency -}-   -> Proc.T s u t (SigS.R s y)+   -> Proc.T s u t (RP.T s sig y) staticAntiAlias wave phase =-   staticAux (SigS.fromSamples . Osci.staticAntiAlias wave phase)+   staticAux (\freq -> withWave wave $ \w -> Osci.staticAntiAlias w phase freq)  {- | oscillator with a functional waveform with modulated frequency -} {-# INLINE freqMod #-}-freqMod :: (RealField.C t, Dim.C u) =>-      Wave.T t y   {- ^ waveform -}-   -> Phase.T t    {- ^ start phase from the range [0,1] -}+freqMod ::+   (RealField.C t, Dim.C u,+    Simple amp t wave sig) =>+      wave y       {- ^ waveform -}+   -> Phase.T t    {- ^ start phase -}    -> Proc.T s u t (         SigA.R s (Dim.Recip u) t t                    {- v frequency control -}-     -> SigS.R s y)+     -> RP.T s sig y) freqMod wave phase =-   freqModAux (SigS.fromSamples . Osci.freqMod wave phase)+   freqModAux (\t -> withWave wave $ \w -> Osci.freqMod w phase t)  {- | oscillator with a functional waveform with modulated frequency -} {-# INLINE freqModAntiAlias #-}-freqModAntiAlias :: (RealField.C t, Dim.C u) =>-      WaveSmooth.T t y+freqModAntiAlias ::+   (RealField.C t, Dim.C u,+    Smooth amp t wave sig) =>+      wave y                    {- ^ waveform -}-   -> Phase.T t    {- ^ start phase from the range [0,1] -}+   -> Phase.T t    {- ^ start phase -}    -> Proc.T s u t (         SigA.R s (Dim.Recip u) t t                    {- v frequency control -}-     -> SigS.R s y)+     -> RP.T s sig y) freqModAntiAlias wave phase =-   freqModAux (SigS.fromSamples . Osci.freqModAntiAlias wave phase)+   freqModAux (\t -> withWave wave $ \w -> Osci.freqModAntiAlias w phase t)  {- | oscillator with modulated phase -} {-# INLINE phaseMod #-}-phaseMod :: (Flat.C flat t, RealField.C t, Dim.C u) =>-      Wave.T t y   {- ^ waveform -}+phaseMod ::+   (Flat.C flat t, RealField.C t, Dim.C u,+    Simple amp t wave sig) =>+      wave y       {- ^ waveform -}    -> DN.T (Dim.Recip u) t                    {- ^ frequency -}    -> Proc.T s u t (         RP.T s flat t-                   {- v phase modulation, phases must have no unit and-                        are from range [0,1] -}-     -> SigS.R s y)+                   {- v phase modulation, phases must have no unit -}+     -> RP.T s sig y) phaseMod wave =-   staticAux (\freq -> SigS.fromSamples . Osci.phaseMod wave freq . Flat.toSamples)+   staticAux (\freq sig ->+      withWave wave $ \w -> Osci.phaseMod w freq . Flat.toSamples $ sig)  {- | oscillator with modulated shape -} {-# INLINE shapeMod #-}-shapeMod :: (Flat.C flat c, RealField.C t, Dim.C u) =>+shapeMod ::+   (Flat.C flat c, RealField.C t, Dim.C u) =>       (c -> Wave.T t y)                    {- ^ waveform -}    -> Phase.T t    {- ^ phase -}@@ -134,19 +206,21 @@  {- | oscillator with a functional waveform with modulated phase and frequency -} {-# INLINE phaseFreqMod #-}-phaseFreqMod :: (Flat.C flat t, RealField.C t, Dim.C u) =>-      Wave.T t y   {- ^ waveform -}+phaseFreqMod ::+   (Flat.C flat t, RealField.C t, Dim.C u,+    Simple amp t wave sig) =>+      wave y       {- ^ waveform -}    -> Proc.T s u t (         RP.T s flat t                      {- v phase control -}      -> SigA.R s (Dim.Recip u) t t                      {- v frequency control -}-     -> SigS.R s y)+     -> RP.T s sig y) phaseFreqMod wave =    fmap flip $-      freqModAux-         (\ freqs phases ->-              SigS.fromSamples $ Osci.phaseFreqMod wave (Flat.toSamples phases) freqs)+      freqModAux (\ freqs phases ->+         withWave wave $ \w ->+            Osci.phaseFreqMod w (Flat.toSamples phases) freqs)  {- | oscillator with both shape and frequency modulation -} {-# INLINE shapeFreqMod #-}@@ -170,12 +244,13 @@ {- | oscillator with a sampled waveform with constant frequency This is essentially an interpolation with cyclic padding.+You can also achieve this with a waveform constructed by 'Wave.sample'. -} {-# INLINE staticSample #-} staticSample :: (RealField.C t, Dim.C u) =>       Interpolation.T t y    -> SigC.R r y   {- ^ waveform -}-   -> Phase.T t    {- ^ start phase from the range [0,1] -}+   -> Phase.T t    {- ^ start phase -}    -> DN.T (Dim.Recip u) t                    {- ^ frequency -}    -> Proc.T s u t (SigS.R s y)@@ -190,7 +265,7 @@ freqModSample :: (RealField.C t, Dim.C u) =>       Interpolation.T t y    -> SigC.R r y   {- ^ waveform -}-   -> Phase.T t    {- ^ start phase from the range [0,1] -}+   -> Phase.T t    {- ^ start phase -}    -> Proc.T s u t (         SigA.R s (Dim.Recip u) t t                    {- v frequency control -}@@ -199,6 +274,90 @@    freqModAux (SigS.fromSamples . Osci.freqModSample ip (SigC.toPeriod wave) phase)  +{-+{-# INLINE shapeFreqModSample #-}+shapeFreqModSample :: (RealField.C c, RealField.C t) =>+      Interpolation.T c (Wave.T t y)+   -> sig (Wave.T t y)+   -> c -> Phase.T t+   -> Proc.T s u t (+        RP.T s flat c+                   {- v shape control -}+     -> SigA.R s (Dim.Recip u) t t+                   {- v frequency control -}+     -> SigS.R s y)+shapeFreqModSample ip waves shape0 phase =+    uncurry Wave.apply ^<<+       (InterpolationC.relativeConstantPad ip shape0 waves ***+        freqsToPhases phase)+-}++{-# INLINE shapeFreqModFromSampledTone #-}+shapeFreqModFromSampledTone ::+    (RealField.C t, SigG.Transform storage yv, Dim.C u,+     Hom.C amp storage input, Hom.C amp Sig.T output,+     Flat.C flat t) =>+      Interpolation.T t yv+   -> Interpolation.T t yv+   -> DN.T (Dim.Recip u) t+                   {- ^ source frequency -}+   -> SigP.T u t input yv+   -> t -> Phase.T t+   -> Proc.T s u t (+        RP.T s flat t+                   {- v shape control -}+     -> SigA.R s (Dim.Recip u) t t+                   {- v frequency control -}+     -> RP.T s output yv)+shapeFreqModFromSampledTone+      ipLeap ipStep srcFreq sampledTone shape0 phase =+   flip fmap+      (OsciC.shapeFreqModFromSampledTone+         ipLeap ipStep srcFreq sampledTone shape0 phase)+      (\osci ->+         \shapes freqs ->+            osci+            `CausalD.applyFlatFst`+            shapes+            `CausalD.apply`+            freqs)+++{-# INLINE shapePhaseFreqModFromSampledTone #-}+shapePhaseFreqModFromSampledTone ::+    (RealField.C t, SigG.Transform storage yv, Dim.C u,+     Hom.C amp storage input, Hom.C amp Sig.T output,+     Flat.C flatS t, Flat.C flatP t) =>+      Interpolation.T t yv+   -> Interpolation.T t yv+   -> DN.T (Dim.Recip u) t+                   {- ^ source frequency -}+   -> SigP.T u t input yv+   -> t -> Phase.T t+   -> Proc.T s u t (+        RP.T s flatS t+                   {- v shape control -}+     -> RP.T s flatP t+                   {- v phase control -}+     -> SigA.R s (Dim.Recip u) t t+                   {- v frequency control -}+     -> RP.T s output yv)+shapePhaseFreqModFromSampledTone+      ipLeap ipStep srcFreq sampledTone shape0 phase =+   flip fmap+      (OsciC.shapePhaseFreqModFromSampledTone+         ipLeap ipStep srcFreq sampledTone shape0 phase)+      (\osci ->+         \shapes phaseDistort freqs ->+            (osci CausalD.<<^ MapD.packTriple)+            `CausalD.applyFlatFst`+            shapes+            `CausalD.applyFlatFst`+            phaseDistort+            `CausalD.apply`+            freqs)++ {-# INLINE freqModAux #-} freqModAux :: (Field.C t, Dim.C u) =>       (Sig.T t -> c)@@ -206,8 +365,9 @@         SigA.R s (Dim.Recip u) t t      -> c) freqModAux f =-   do toFreq <- Proc.withParam toFrequencyScalar-      return $ f . SigA.scalarSamples toFreq+   fmap+      (\toFreq -> f . SigA.scalarSamples toFreq)+      (Proc.withParam toFrequencyScalar)  {-# INLINE staticAux #-} staticAux :: (Dim.C u, Field.C t) =>
src/Synthesizer/Dimensional/RateAmplitude/Analysis.hs view
@@ -35,6 +35,7 @@ import qualified Synthesizer.Dimensional.Straight.Signal      as SigS import qualified Synthesizer.Dimensional.Cyclic.Signal        as SigC import qualified Synthesizer.Dimensional.RateWrapper          as SigP+import qualified Synthesizer.Dimensional.Rate.Dirac           as Dirac  import Synthesizer.Dimensional.RateAmplitude.Signal (DimensionGradient) @@ -57,9 +58,6 @@ import qualified Algebra.Real                as Real  --- import qualified Data.List as List--- import NumericPrelude.List (takeMatch)- import PreludeBase (Ord, ($), (.), return, fmap, id, ) import NumericPrelude ((+), negate, (/), sqr, abs, fromIntegral, pi, ) import Prelude (Int, )@@ -86,13 +84,13 @@  {-# INLINE period #-} period :: (Field.C t, Dim.C u, Dim.C v) =>-   SigP.T u t (SigA.T v y (SigC.T Sig.T)) yv -> DN.T u t+   SigP.T u t (SigA.D v y (SigC.T Sig.T)) yv -> DN.T u t period = makePhysicalPeriod (fromIntegral . Sig.length)  {-# INLINE makePhysicalPeriod #-} makePhysicalPeriod :: (Field.C t, Dim.C u, Dim.C v) =>    (Sig.T yv -> t) ->-   SigP.T u t (SigA.T v y (SigC.T Sig.T)) yv -> DN.T u t+   SigP.T u t (SigA.D v y (SigC.T Sig.T)) yv -> DN.T u t makePhysicalPeriod f x =    f (SigC.samples (SigA.signal (SigP.signal x)))        *&  DN.unrecip (SigP.sampleRate x)@@ -171,7 +169,7 @@ normAux :: (Dim.C v0, Dim.C v1, Dim.C u, Field.C t) =>    (DN.T v0 y -> DN.T v1 t) ->    (Sig.T yv -> t) ->-   SigP.T u t (SigA.T v0 y (SigS.T Sig.T)) yv ->+   SigP.T u t (SigA.D v0 y SigS.S) yv ->    DN.T (Dim.Mul u v1) t normAux amp norm x =    norm (SigA.samples x)@@ -308,8 +306,9 @@ zeros :: (Ord q, Ring.C q, Dim.C u, Dim.C v) =>    Proc.T s u q (SigA.R s v q q -> SigA.R s (Dim.Recip u) q q) zeros =-   do fp <- SigRA.fromPeaks-      return (fp . SigRA.Peaks . Ana.zeros . SigA.samples)+   fmap+      (\fp -> fp . Dirac.Cons . Ana.zeros . SigA.samples)+      Dirac.toAmplitudeSignal   @@ -318,8 +317,8 @@ -} {-# INLINE toFrequencySpectrum #-} toFrequencySpectrum :: (Trans.C q, Dim.C u, Dim.C v) =>-   SigP.T u q (SigA.T v q (SigC.T Sig.T)) (Complex.T q) ->-   SigP.T (Dim.Recip u) q (SigA.T (Dim.Mul u v) q (SigC.T Sig.T)) (Complex.T q)+   SigP.T u q (SigA.D v q (SigC.T Sig.T)) (Complex.T q) ->+   SigP.T (Dim.Recip u) q (SigA.D (Dim.Mul u v) q (SigC.T Sig.T)) (Complex.T q) toFrequencySpectrum x =    let len = DN.rewriteDimension Dim.doubleRecip (period x)        amp = SigA.amplitude x@@ -342,8 +341,8 @@ -} {-# INLINE fromFrequencySpectrum #-} fromFrequencySpectrum :: (Trans.C q, Dim.C u, Dim.C v) =>-   SigP.T (Dim.Recip u) q (SigA.T (Dim.Mul u v) q (SigC.T Sig.T)) (Complex.T q) ->-   SigP.T u q (SigA.T v q (SigC.T Sig.T)) (Complex.T q)+   SigP.T (Dim.Recip u) q (SigA.D (Dim.Mul u v) q (SigC.T Sig.T)) (Complex.T q) ->+   SigP.T u q (SigA.D v q (SigC.T Sig.T)) (Complex.T q) fromFrequencySpectrum x =    let len = period x        amp = SigA.amplitude x
src/Synthesizer/Dimensional/RateAmplitude/Cut.hs view
@@ -31,7 +31,7 @@ import qualified Synthesizer.State.Signal as Sig  import qualified Synthesizer.Frame.Stereo as Stereo-import qualified Synthesizer.Generic.SampledValue as Sample+import Foreign.Storable (Storable, )  import qualified Synthesizer.Dimensional.RateAmplitude.Signal as SigA import qualified Synthesizer.Dimensional.Process as Proc@@ -63,7 +63,7 @@ {- * dissection -}  {-# INLINE splitAt #-}-splitAt :: (RealField.C t, Dim.C u, Dim.C v, Sample.C yv) =>+splitAt :: (RealField.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'
src/Synthesizer/Dimensional/RateAmplitude/Demonstration.hs view
@@ -1,6 +1,7 @@-{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}-module Main (main) where--- module Synthesizer.Dimensional.RateAmplitude.Demonstration where+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ExistentialQuantification #-}+module Synthesizer.Dimensional.RateAmplitude.Demonstration where  import qualified Synthesizer.Dimensional.Rate.Oscillator as Osci import qualified Synthesizer.Dimensional.Rate.Filter     as Filt@@ -10,7 +11,6 @@ -- import qualified Synthesizer.SampleRateDimension.Filter.NonRecursive as FiltNR import qualified Synthesizer.Dimensional.RateAmplitude.Filter     as FiltA import qualified Synthesizer.Dimensional.RateAmplitude.Cut        as Cut-import qualified Synthesizer.Dimensional.Amplitude.Cut            as CutA import qualified Synthesizer.Dimensional.Rate.Cut                 as CutR  import qualified Synthesizer.Dimensional.RateAmplitude.Control    as Ctrl@@ -18,27 +18,31 @@  import qualified Synthesizer.Dimensional.Straight.Displacement as DispS -import qualified Synthesizer.Dimensional.Amplitude.Analysis       as Ana+import qualified Synthesizer.Dimensional.Causal.Filter            as FiltC+import qualified Synthesizer.Dimensional.Causal.Displacement      as DispC+import qualified Synthesizer.Dimensional.Causal.Process           as CausalD+import qualified Synthesizer.Dimensional.Causal.ControlledProcess as CProc  import qualified Synthesizer.Dimensional.Process as Proc-import qualified Synthesizer.Dimensional.Cyclic.Signal   as SigC import qualified Synthesizer.Dimensional.Straight.Signal as SigS import qualified Synthesizer.Dimensional.RateAmplitude.Signal as SigA  import qualified Synthesizer.Dimensional.RateAmplitude.File as File-import qualified Synthesizer.Dimensional.RateAmplitude.Play as Play-import qualified Synthesizer.Dimensional.RateWrapper as SigP+-- import qualified Synthesizer.Dimensional.RateAmplitude.Play as Play+-- import qualified Synthesizer.Dimensional.RateWrapper as SigP -import Synthesizer.Dimensional.RateAmplitude.Signal (($-), ($&), (&*^), (&*>^), )-import Synthesizer.Dimensional.Process (($:), ($::), (.:), ($^), (.^), ($#))+import Synthesizer.Dimensional.Causal.Process (($/:))+import Synthesizer.Dimensional.RateAmplitude.Signal (($-), (&*^), )+import Synthesizer.Dimensional.Process (($:), ($::), ($^), ) import Synthesizer.Dimensional.Amplitude.Control (mapLinear, mapExponential, ) import Synthesizer.Dimensional.RateAmplitude.Instrument (wasp, )  import qualified Synthesizer.Frame.Stereo as Stereo-import qualified Synthesizer.Generic.SampledValue as Sample+import Foreign.Storable (Storable, ) -import qualified Synthesizer.State.Interpolation as Interpolation-import           Synthesizer.Plain.Instrument (choirWave)+import qualified Synthesizer.Interpolation.Custom as Interpolation+import qualified Synthesizer.Interpolation.Module as IpMod+import qualified Synthesizer.Interpolation.Class  as Interpol import qualified Synthesizer.Basic.WaveSmoothed as WaveSmooth import qualified Synthesizer.Basic.Wave         as Wave import qualified Synthesizer.Basic.Phase        as Phase@@ -48,19 +52,20 @@  import Number.DimensionTerm ((*&)) -import qualified Number.NonNegative     as NonNeg- import qualified Algebra.Transcendental as Trans import qualified Algebra.Module         as Module import qualified Algebra.RealField      as RealField import qualified Algebra.Field          as Field import qualified Algebra.Ring           as Ring -import System.Random (Random, randomRs, mkStdGen)+import System.Time (getClockTime, diffClockTimes, tdSec, tdPicosec, )+import System.IO (hFlush, stdout, )+import System.Exit (ExitCode) -import Synthesizer.Utility (snd3, thd3, )-import Data.List(zip4)+import System.Random (Random, randomRs, mkStdGen, ) +import Data.Tuple.HT (snd3, )+ import PreludeBase import NumericPrelude @@ -69,7 +74,7 @@  {-# INLINE sineLow #-} sineLow ::-   (RealField.C q, Trans.C q, Module.C q q, Sample.C q) =>+   (RealField.C q, Trans.C q, Module.C q q, Storable q) =>    Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q) sineLow =    DN.voltage 1 &*^@@ -77,7 +82,7 @@  {-# INLINE sineHigh #-} sineHigh ::-   (RealField.C q, Trans.C q, Module.C q q, Sample.C q) =>+   (RealField.C q, Trans.C q, Module.C q q, Storable q) =>    Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q) sineHigh =    DN.voltage 1 &*^@@ -85,7 +90,7 @@  {-# INLINE sineMix #-} sineMix ::-   (RealField.C q, Trans.C q, Module.C q q, Sample.C q) =>+   (RealField.C q, Trans.C q, Module.C q q, Storable q) =>    Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q) sineMix =    FiltA.amplify 0.5 $: (Disp.mix $: sineLow $: sineHigh)@@ -93,7 +98,7 @@  {-# INLINE exponential #-} exponential ::-   (RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) =>+   (RealField.C q, Trans.C q, Module.C q q, Random q, Storable q) =>    Proc.T s Dim.Time q (SigS.R s q) exponential =    CtrlR.exponential (DN.time 0.3)@@ -101,7 +106,7 @@  {-# INLINE ping #-} ping ::-   (RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) =>+   (RealField.C q, Trans.C q, Module.C q q, Random q, Storable q) =>    Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q) ping =    Filt.envelope@@ -117,7 +122,7 @@ {- {-# INLINE saw #-} saw ::-   (RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) =>+   (RealField.C q, Trans.C q, Module.C q q, Random q, Storable q) =>    Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q) saw =    DN.voltage 1 &*^ Osci.static sawWave zero (DN.frequency 440)@@ -125,7 +130,7 @@  {-# INLINE sawVibrato #-} sawVibrato ::-   (RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) =>+   (RealField.C q, Trans.C q, Module.C q q, Random q, Storable q) =>    Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q) sawVibrato =    DN.voltage 1 &*^@@ -134,7 +139,7 @@  {-# INLINE sawChorus #-} sawChorus ::-   (RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) =>+   (RealField.C q, Trans.C q, Module.C q q, Random q, Storable q) =>    Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q) sawChorus =    let v = DN.voltage (1/4)@@ -163,7 +168,7 @@  {-# INLINE airplane #-} airplane ::-   (RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) =>+   (RealField.C q, Trans.C q, Module.C q q, Random q, Storable q) =>    Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q) airplane =    SigA.share@@ -171,7 +176,7 @@       (\noise ->           Cut.take (DN.time 5) $: (Disp.mix              $: noise-             $: (Filt.frequencyModulation Interpolation.linear+             $: (Filt.frequencyModulation IpMod.linear                     $- DN.scalar 1.001                     $: noise))) @@ -191,10 +196,10 @@  {-# INLINE wind #-} wind ::-   (RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) =>+   (RealField.C q, Trans.C q, Module.C q q, Random q, Storable q) =>    Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q) wind =-   Filt.lowpassFromUniversal $:+   Filt.lowpassFromUniversal $^       (Filt.universal          $- DN.scalar 20          $: (mapExponential 2 (DN.frequency 1000) $^@@ -205,7 +210,7 @@  {-# INLINE windStereo #-} windStereo ::-   (RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) =>+   (RealField.C q, Trans.C q, Module.C q q, Random q, Storable q) =>    Proc.T s Dim.Time q (SigA.R s Dim.Voltage q (Stereo.T q)) windStereo =    SigA.share@@ -213,6 +218,140 @@       (\w -> Cut.mergeStereo $: w $: (Cut.drop (DN.time 0.5) $: w))  ++{-# INLINE sweepFrequency #-}+sweepFrequency ::+   (Trans.C q, RealField.C q) =>+   Proc.T s Dim.Time q (SigA.R s Dim.Frequency q q)+sweepFrequency =+   mapExponential 2 (DN.frequency 1000) $^+   Osci.static Wave.sine zero (DN.frequency 0.2)++{-# INLINE deepSaw #-}+deepSaw ::+   (RealField.C q) =>+   Proc.T s Dim.Time q (SigS.R s q)+deepSaw =+   Osci.static Wave.saw zero (DN.frequency 110)++{-# INLINE universalLowpassDirect #-}+universalLowpassDirect ::+   (RealField.C q, Trans.C q, Module.C q q, Random q, Storable q) =>+   Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)+universalLowpassDirect =+   Filt.lowpassFromUniversal $^+      (Filt.universal+         $- DN.scalar 20+         $: sweepFrequency+         $: DN.voltage 0.2 &*^ deepSaw)++{-# INLINE universalLowpassSync #-}+universalLowpassSync ::+   (RealField.C q, Trans.C q, Module.C q q, Random q, Storable q) =>+   Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)+universalLowpassSync =+   Filt.lowpassFromUniversal $^+      (CProc.runSynchronous2 FiltC.universal+         $- DN.scalar 20+         $: sweepFrequency+         $/: DN.voltage 0.2 &*^ deepSaw)++{-# INLINE universalLowpassAsyncLinear #-}+universalLowpassAsyncLinear ::+   (RealField.C q, Trans.C q, Module.C q q, Interpol.C q q, Random q, Storable q) =>+   Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)+universalLowpassAsyncLinear =+   Filt.lowpassFromUniversal $^+      (CProc.processAsynchronousBuffered2 Interpolation.linear FiltC.universal+         (DN.frequency 10)+--         (Rate.fromNumber Dim.frequency 100)+         (Ctrl.constant (DN.scalar 20))+         sweepFrequency+         $/: DN.voltage 0.2 &*^ deepSaw)++{-# INLINE universalLowpassAsyncConstant #-}+universalLowpassAsyncConstant ::+   (RealField.C q, Trans.C q, Module.C q q, Random q, Storable q) =>+   Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)+universalLowpassAsyncConstant =+   Filt.lowpassFromUniversal $^+      (CProc.processAsynchronousBuffered2 Interpolation.constant FiltC.universal+         (DN.frequency 100)+--         (Rate.fromNumber Dim.frequency 100)+         (Ctrl.constant (DN.scalar 20))+         sweepFrequency+         $/: DN.voltage 0.2 &*^ deepSaw)+++{-# INLINE allpassPhaserDirect #-}+allpassPhaserDirect ::+   (RealField.C q, Trans.C q, Module.C q q, Random q, Storable q) =>+   Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)+allpassPhaserDirect =+   let tone = DN.voltage 0.5 &*^ deepSaw+   in  Disp.mix+          $: (Filt.allpassCascade 20 Filt.allpassFlangerPhase+                $: sweepFrequency+                $: tone)+          $: tone++{-# INLINE allpassPhaserCausal #-}+allpassPhaserCausal ::+   (RealField.C q, Trans.C q, Module.C q q, Random q, Storable q) =>+   Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)+allpassPhaserCausal =+   let tone = DN.voltage 0.5 &*^ deepSaw+       phaser =+          do mix     <- DispC.mix+             apcCtrl <- CProc.joinSynchronous (FiltC.allpassCascade 20 FiltC.allpassFlangerPhase)+             ctrl    <- sweepFrequency+             return $+                mix CausalD.<<<+                CausalD.fanout CausalD.id (CausalD.applyFst apcCtrl ctrl)+   in  phaser $/: tone+++{-# INLINE moogSawDirect #-}+moogSawDirect ::+   (RealField.C q, Trans.C q, Module.C q q, Random q, Storable q) =>+   Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)+moogSawDirect =+   Filt.moogLowpass 10+      $- DN.scalar 20+      $: sweepFrequency+      $: DN.voltage 0.2 &*^ deepSaw++{-# INLINE moogSawCausal #-}+moogSawCausal ::+   (RealField.C q, Trans.C q, Module.C q q, Random q, Storable q) =>+   Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)+moogSawCausal =+   CProc.runSynchronous2 (FiltC.moogLowpass 10)+      $- DN.scalar 20+      $: sweepFrequency+      $/: DN.voltage 0.2 &*^ deepSaw+++data Filter a v =+   forall param. Interpol.C a param => Filter {+      filterResonance :: a,+      filterDirect :: forall s. Proc.T s Dim.Time a+         (-- SigS.R s a ->+          SigA.R s Dim.Scalar a a ->+          SigA.R s Dim.Frequency a a ->+          SigA.R s Dim.Voltage a v ->+          SigA.R s Dim.Voltage a v),+      filterCausal :: forall s.+         FiltC.ResonantFilter s Dim.Time a param (DN.Voltage a) v v}++++{- |+We do not create noise at a low sampling and resample it by intention.+Resampling is intended for maintaining maximum quality+and not for relying on the bad quality of constant interpolation.+Instead we generate a piecewise constant function manually.+-} {-# INLINE glissandoControl #-} glissandoControl ::    (RealField.C q, Trans.C q, Module.C q q, Random q) =>@@ -232,7 +371,7 @@    (RealField.C q, Trans.C q, Module.C q q, Random q) =>    Proc.T s Dim.Time q (SigA.R s Dim.Voltage q (Stereo.T q)) bassFilter =-   Filt.lowpassFromUniversal $:+   Filt.lowpassFromUniversal $^       (Filt.universal          $- DN.scalar 5 {-@@ -282,7 +421,7 @@  {-# INLINE bubbles #-} bubbles ::-   (RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) =>+   (RealField.C q, Trans.C q, Module.C q q, Random q, Storable q) =>    Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q) bubbles =    let delay = 0.24@@ -297,7 +436,7 @@  {-# INLINE bubblesStereo #-} bubblesStereo ::-   (RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) =>+   (RealField.C q, Trans.C q, Module.C q q, Random q, Storable q) =>    Proc.T s Dim.Time q (SigA.R s Dim.Voltage q (Stereo.T q)) bubblesStereo =    let delay = 0.24@@ -317,7 +456,7 @@  {-# INLINE dampedEcho #-} dampedEcho ::-   (RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) =>+   (RealField.C q, Trans.C q, Module.C q q, Random q, Storable q) =>    Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q) dampedEcho =    FiltA.combProc (DN.time 0.2)@@ -329,7 +468,7 @@  {-# INLINE trapezoid #-} trapezoid ::-   (RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) =>+   (RealField.C q, Trans.C q, Module.C q q, Random q, Storable q) =>    Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q) trapezoid =    Filt.mean (DN.frequency 500)@@ -372,7 +511,7 @@    [(FilePath, Sound q q)] harmonicExamples =    do expo <- [0,1,2]-      (harmName,harm::[Int])+      (harmName,harm)            <- [("all", take 10 [1 ..]), ("odd", take 10 [1,3 ..])]       (phaseName,phase)            <- [("sin", Phase.fromRepresentative 0),@@ -385,7 +524,7 @@                              recip (n ^ expo),                              phase))                       . fromIntegral)-                     harm)))+                     (harm::[Int]))))  {- | Morphing shapes with constant sound.@@ -401,7 +540,7 @@    [(FilePath, Sound q q)] harmonicMorph =    do expo <- [0,1,2]-      (harmName,harm::[Int])+      (harmName,harm)            <- [("all", take 10 [1 ..]), ("odd", take 10 [1,3 ..])]       return          ("power" ++ show expo ++ harmName ++ "-shift",@@ -411,7 +550,7 @@                              recip (n ^ expo),                              zero))                       . fromIntegral)-                     harm)))+                     (harm::[Int]))))   {-# INLINE waveforms #-}@@ -455,6 +594,27 @@                  Ctrl.line (DN.time 10) (DN.frequency (-30000), DN.frequency 30000))))  +measureTime :: String -> IO ExitCode -> IO ()+measureTime name act =+   do putStr (name++": ")+      hFlush stdout+      timeA <- getClockTime+      act+      timeB <- getClockTime+      let td = diffClockTimes timeB timeA+      print (fromIntegral (tdSec td) ++             fromInteger (tdPicosec td) * 1e-12 :: Double)++renderToAIFF :: (Ring.C a) =>+   (DN.Frequency a -> String -> t -> IO ExitCode) ->+   String ->+   t ->+   IO ()+renderToAIFF render name sound =+   measureTime name $+   render (DN.frequency 44100) (name++".aiff") sound++ main :: IO () main =    do@@ -469,9 +629,9 @@ -}       mapM_          (\(name, sound) ->-             putStrLn name >>-             File.renderTimeVoltageStereoDouble-                (DN.frequency 44100) name (fromSound sound)) $+             renderToAIFF+             File.renderTimeVoltageStereoDoubleToInt16+             name (fromSound sound)) $           ("bass-filter", Sound (Cut.take (DN.time 15) $: bassFilter)) :          ("wind",        Sound (Cut.take (DN.time 10) $: windStereo)) :@@ -479,11 +639,107 @@          []        mapM_+         (\(name, filt@(Filter _filtResonance _filtDirect filtCausal)) ->+              let render :: String -> (forall s. Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double Double)) -> IO ()+                  render ext sound =+                     let subName = name ++ "-" ++ ext+                     in  renderToAIFF+                         File.renderTimeVoltageMonoDoubleToInt16+                         subName+                         (Cut.take (DN.time 10) $: sound)+              in  do render "direct"+                        (filterDirect filt+                           $- DN.scalar (filterResonance filt)+                           $: sweepFrequency+                           $: DN.voltage 1 &*^ deepSaw)+                     render "sync"+                        (CProc.runSynchronous2 (filtCausal)+                           $- DN.scalar (filterResonance filt)+                           $: sweepFrequency+                           $/: DN.voltage 1 &*^ deepSaw)+                     render "async-constant"+                        (CProc.processAsynchronousBuffered2 Interpolation.constant (filtCausal)+                           (DN.frequency 100)+                           (Ctrl.constant (DN.scalar (filterResonance filt)))+                           sweepFrequency+                           $/: DN.voltage 1 &*^ deepSaw)+                     render "async-linear"+                        (CProc.processAsynchronousBuffered2 Interpolation.linear (filtCausal)+                           (DN.frequency 10)+                           (Ctrl.constant (DN.scalar (filterResonance filt)))+                           sweepFrequency+                           $/: DN.voltage 1 &*^ deepSaw)) $+         ("allpass-phaser",+              Filter 0.5+--                 (Filt.allpassPhaser 10)+                 (fmap (\p q f -> CausalD.apply (p q f)) $+                  CProc.runSynchronous2 (FiltC.allpassPhaser 10))+                 (FiltC.allpassPhaser 10)) :+         ("moog-lowpass",+              Filter 20+                 (Filt.moogLowpass 10)+                 (FiltC.moogLowpass 10)) :+         ("universal-lowpass",+              Filter 20+                 (fmap (\p r f -> Filt.lowpassFromUniversal . p r f) $+                  Filt.universal)+                 (fmap (fmap (\p -> FiltC.lowpassFromUniversal CausalD.<<< p)) $+                  FiltC.universal)) :+         ("butterworth-lowpass",+              Filter 0.5+                 (Filt.butterworthLowpass 10)+                 (FiltC.butterworthLowpass 10)) :+         ("butterworth-highpass",+              Filter 0.5+                 (Filt.butterworthHighpass 10)+                 (FiltC.butterworthHighpass 10)) :+         ("chebyshev-a-lowpass",+              Filter 0.5+                 (Filt.chebyshevALowpass 10)+                 (FiltC.chebyshevALowpass 10)) :+         ("chebyshev-a-highpass",+              Filter 0.5+                 (Filt.chebyshevAHighpass 10)+                 (FiltC.chebyshevAHighpass 10)) :+         ("chebyshev-b-lowpass",+              Filter 0.5+                 (Filt.chebyshevBLowpass 10)+                 (FiltC.chebyshevBLowpass 10)) :+         ("chebyshev-b-highpass",+              Filter 0.5+                 (Filt.chebyshevBHighpass 10)+                 (FiltC.chebyshevBHighpass 10)) :+         []++      mapM_          (\(name, sound) ->-             putStrLn name >>-             File.renderTimeVoltageMonoDouble-                (DN.frequency 44100) name (fromSound sound)) $+             renderToAIFF+             File.renderTimeVoltageMonoDoubleToInt16+             name (fromSound sound)) $ +         {-+         Moog, Allpass, Universal.lowPass are redundant here,+         but we leave them for demonstration purposes.+         -}+         ("moog-saw-direct",+                         Sound (Cut.take (DN.time 10) $: moogSawDirect)) :+         ("moog-saw-causal",+                         Sound (Cut.take (DN.time 10) $: moogSawCausal)) :++         ("allpass-phaser-direct",+                         Sound (Cut.take (DN.time 10) $: allpassPhaserDirect)) :+         ("allpass-phaser-causal",+                         Sound (Cut.take (DN.time 10) $: allpassPhaserCausal)) :++         ("universal-lowpass",+                         Sound (Cut.take (DN.time 10) $: universalLowpassDirect)) :+         ("universal-lowpass-sync",+                         Sound (Cut.take (DN.time 10) $: universalLowpassSync)) :+         ("universal-lowpass-async-linear",+                         Sound (Cut.take (DN.time 10) $: universalLowpassAsyncLinear)) :+         ("universal-lowpass-async-constant",+                         Sound (Cut.take (DN.time 10) $: universalLowpassAsyncConstant)) :+          ("sine-low",    Sound (Cut.take (DN.time 1) $: sineLow)) :          ("sine-high",   Sound (Cut.take (DN.time 1) $: sineHigh)) :          ("sine-mix",    Sound (Cut.take (DN.time 1) $: sineMix)) :@@ -509,17 +765,17 @@        flip mapM_ waveformsBandlimited $          \(fileName, tone) ->-            putStrLn fileName >>-            File.renderTimeVoltageMonoDouble-               (DN.frequency 44100) fileName-               (fromSound tone)+            renderToAIFF+            File.renderTimeVoltageMonoDoubleToInt16+            fileName+            (fromSound tone)        flip mapM_ (harmonicExamples ++ harmonicMorph ++ waveforms) $          \(fileName, tone) ->-            putStrLn fileName >>-            File.renderTimeVoltageMonoDouble-               (DN.frequency 44100) fileName-               (Cut.take (DN.time 1) $: fromSound tone)+            renderToAIFF+            File.renderTimeVoltageMonoDoubleToInt16+            fileName+            (Cut.take (DN.time 1) $: fromSound tone)   {-
src/Synthesizer/Dimensional/RateAmplitude/Displacement.hs view
@@ -55,7 +55,9 @@      -> SigA.R s v y yv) mixVolume v = Proc.pure $ DispV.mixVolume v -{-| Mix one or more signals. -}+{- |+Mix one or more signals.+-} {-# INLINE mixMulti #-} mixMulti ::    (Real.C y, Field.C y, Module.C y yv, Dim.C v) =>@@ -73,8 +75,10 @@      ->  SigA.R s v y yv) mixMultiVolume v = Proc.pure $ DispV.mixMultiVolume v -{-| Add a number to all of the signal values.-    This is useful for adjusting the center of a modulation. -}+{- |+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@@ -84,8 +88,16 @@      -> SigA.R s v y yv) raise y' yv = Proc.pure $ DispV.raise y' yv -{-| Add a number to all of the signal values.-    This is useful for adjusting the center of a modulation. -}+{- |+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)
src/Synthesizer/Dimensional/RateAmplitude/File.hs view
@@ -1,16 +1,20 @@-{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}--- glasgow-exts for all quantifier+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE Rank2Types #-} module Synthesizer.Dimensional.RateAmplitude.File (    write,    writeTimeVoltage,-   writeTimeVoltageMonoDouble,-   writeTimeVoltageStereoDouble,-   renderTimeVoltageMonoDouble,-   renderTimeVoltageStereoDouble,+   writeTimeVoltageMonoDoubleToInt16,+   writeTimeVoltageStereoDoubleToInt16,+   renderTimeVoltageMonoDoubleToInt16,+   renderTimeVoltageStereoDoubleToInt16,   ) where -import qualified Sox.File-import qualified BinarySample as BinSmp+import qualified Sound.Sox.Write as Write+import qualified Sound.Sox.Option.Format as SoxOpt+import qualified Sound.Sox.Frame as Frame+import qualified Synthesizer.Basic.Binary as BinSmp+import qualified Data.StorableVector.Lazy.Builder as Builder+import Foreign.Storable (Storable, )  import qualified Synthesizer.Dimensional.Process as Proc @@ -25,6 +29,7 @@ -- import qualified Synthesizer.Dimensional.Straight.Signal as SigS import qualified Synthesizer.State.Signal as Sig +import qualified Algebra.ToInteger      as ToInteger -- import qualified Algebra.Transcendental as Trans import qualified Algebra.Module         as Module import qualified Algebra.RealField      as RealField@@ -42,78 +47,92 @@   +{- |+The output format is determined by SoX by the file name extension.+The sample precision is determined by the provided 'Builder.Builder' function.++Example:++> import qualified Data.StorableVector.Lazy.Builder as Builder+>+> write (DN.frequency one) (DN.voltage one) (\i -> Builder.put (i::Int16)) "test.aiff" sound+-} {-# INLINE write #-} write ::-    (RealField.C t, BinSmp.C yv,-     Dim.C u, Field.C t,+    (Bounded int, ToInteger.C int, Storable int, Frame.C int, BinSmp.C yv,+     Dim.C u, RealField.C t,      Dim.C v, Module.C y yv, Field.C y) =>    DN.T (Dim.Recip u) t ->    DN.T v y ->+   (int -> Builder.Builder int) ->    FilePath ->    SigP.T u t (SigA.S v y) yv ->---   SigP.T u t (SigA.T v y (SigS.T Sig.T)) yv ->+--   SigP.T u t (SigA.D v y SigS.S) yv ->    IO ExitCode-write freqUnit amp name sig =-   Sox.File.write name-      (DN.divToScalar (SigP.sampleRate sig) freqUnit)-      (Sig.toList (SigA.vectorSamples (flip DN.divToScalar amp) sig))+write freqUnit amp put name sig =+   let opts =+          SoxOpt.numberOfChannels (BinSmp.numberOfSignalChannels sig)+       sampleRate =+          DN.divToScalar (SigP.sampleRate sig) freqUnit+   in  Write.extended SigSt.hPut opts SoxOpt.none name+          (round sampleRate)+          (Builder.toLazyStorableVector SigSt.defaultChunkSize $+           Sig.monoidConcatMap (BinSmp.outputFromCanonical put) $+           SigA.vectorSamples (flip DN.divToScalar amp) sig)   {-# INLINE writeTimeVoltage #-} writeTimeVoltage ::-    (RealField.C t, BinSmp.C yv,-     Field.C t,+    (Bounded int, ToInteger.C int, Storable int, Frame.C int, BinSmp.C yv,+     RealField.C t,      Module.C y yv, Field.C y) =>+   (int -> Builder.Builder int) ->    FilePath ->    SigP.T Dim.Time t (SigA.S Dim.Voltage y) yv ->---   SigP.T Dim.Time t (SigA.T Dim.Voltage y (SigS.T Sig.T)) yv ->+--   SigP.T Dim.Time t (SigA.D Dim.Voltage y SigS.S) yv ->    IO ExitCode writeTimeVoltage =    write (DN.frequency one) (DN.voltage one)   -{-# INLINE writeTimeVoltageMonoDouble #-}-writeTimeVoltageMonoDouble ::+{-# INLINE writeTimeVoltageMonoDoubleToInt16 #-}+writeTimeVoltageMonoDoubleToInt16 ::    FilePath ->    SigP.T Dim.Time Double (SigA.S Dim.Voltage Double) Double ->---   SigP.T Dim.Time t (SigA.T Dim.Voltage y (SigS.T Sig.T)) yv ->-   IO ()-writeTimeVoltageMonoDouble name sig =+--   SigP.T Dim.Time t (SigA.D Dim.Voltage y SigS.S) yv ->+   IO ExitCode+writeTimeVoltageMonoDoubleToInt16 name sig =    let rate = DN.toNumberWithDimension Dim.frequency (SigP.sampleRate sig)-   in  do SigSt.writeFile (name ++ ".sw")-             (SigP.signal (SigRA.toStorableInt16Mono sig))-          Sox.File.rawToAIFF name [] rate 1-          return ()+   in  Write.simple SigSt.hPut SoxOpt.none name (round rate)+          (SigP.signal (SigRA.toStorableInt16Mono sig))  -{-# INLINE writeTimeVoltageStereoDouble #-}-writeTimeVoltageStereoDouble ::+{-# INLINE writeTimeVoltageStereoDoubleToInt16 #-}+writeTimeVoltageStereoDoubleToInt16 ::    FilePath ->    SigP.T Dim.Time Double (SigA.S Dim.Voltage Double) (Stereo.T Double) ->---   SigP.T Dim.Time t (SigA.T Dim.Voltage y (SigS.T Sig.T)) yv ->-   IO ()-writeTimeVoltageStereoDouble name sig =+--   SigP.T Dim.Time t (SigA.D Dim.Voltage y SigS.S) yv ->+   IO ExitCode+writeTimeVoltageStereoDoubleToInt16 name sig =    let rate = DN.toNumberWithDimension Dim.frequency (SigP.sampleRate sig)-   in  do SigSt.writeFile (name ++ ".sw")-             (SigP.signal (SigRA.toStorableInt16Stereo sig))-          Sox.File.rawToAIFF name [] rate 2-          return ()+   in  Write.simple SigSt.hPut SoxOpt.none name (round rate)+          (SigP.signal (SigRA.toStorableInt16Stereo sig)) -{-# INLINE renderTimeVoltageMonoDouble #-}-renderTimeVoltageMonoDouble ::+{-# INLINE renderTimeVoltageMonoDoubleToInt16 #-}+renderTimeVoltageMonoDoubleToInt16 ::    DN.T Dim.Frequency Double ->    FilePath ->    (forall s. Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double Double)) ->-   IO ()-renderTimeVoltageMonoDouble rate name sig =-   writeTimeVoltageMonoDouble name (SigP.runProcess rate sig)+   IO ExitCode+renderTimeVoltageMonoDoubleToInt16 rate name sig =+   writeTimeVoltageMonoDoubleToInt16 name (SigP.runProcess rate sig) -{-# INLINE renderTimeVoltageStereoDouble #-}-renderTimeVoltageStereoDouble ::+{-# INLINE renderTimeVoltageStereoDoubleToInt16 #-}+renderTimeVoltageStereoDoubleToInt16 ::    DN.T Dim.Frequency Double ->    FilePath ->    (forall s. Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double (Stereo.T Double))) ->-   IO ()-renderTimeVoltageStereoDouble rate name sig =-   writeTimeVoltageStereoDouble name (SigP.runProcess rate sig)+   IO ExitCode+renderTimeVoltageStereoDoubleToInt16 rate name sig =+   writeTimeVoltageStereoDoubleToInt16 name (SigP.runProcess rate sig)
src/Synthesizer/Dimensional/RateAmplitude/Filter.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright   :  (c) Henning Thielemann 2008 License     :  GPL@@ -49,10 +49,12 @@    FiltR.highpassFromUniversal,    FiltR.bandpassFromUniversal,    FiltR.lowpassFromUniversal,+   FiltR.bandlimitFromUniversal,    moogLowpass,     {- ** Allpass -}    allpassCascade,+   FiltR.allpassFlangerPhase,     {- ** Reverb -}    comb,@@ -75,11 +77,10 @@ import qualified Synthesizer.Dimensional.Abstraction.Flat as Flat import qualified Synthesizer.Dimensional.Abstraction.Homogeneous as Hom -import qualified Synthesizer.Dimensional.RatePhantom as RP- import qualified Synthesizer.Dimensional.Straight.Signal      as SigS import qualified Synthesizer.Dimensional.RateAmplitude.Signal as SigA-import qualified Synthesizer.Dimensional.RateWrapper      as SigP+import qualified Synthesizer.Dimensional.RateWrapper          as SigP+import qualified Synthesizer.Dimensional.RatePhantom          as RP -- import qualified Synthesizer.Dimensional.Amplitude.Signal as SigPA import qualified Synthesizer.State.Signal as Sig import Synthesizer.Plain.Signal (Modifier)@@ -87,12 +88,11 @@ import Synthesizer.Dimensional.RateAmplitude.Signal    (toTimeScalar, toFrequencyScalar, DimensionGradient, ) -import qualified Synthesizer.Generic.SampledValue as Sample- import qualified Synthesizer.Frame.Stereo as Stereo+import Foreign.Storable (Storable, )  -- import qualified Synthesizer.State.Displacement as Disp-import qualified Synthesizer.State.Interpolation as Interpolation+import qualified Synthesizer.Interpolation as Interpolation import qualified Synthesizer.State.Filter.Delay as Delay import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder  as Filt1 import qualified Synthesizer.Plain.Filter.Recursive.Allpass     as Allpass@@ -100,13 +100,13 @@ import qualified Synthesizer.Plain.Filter.Recursive.Moog        as Moog import qualified Synthesizer.Plain.Filter.Recursive.Butterworth as Butter import qualified Synthesizer.Plain.Filter.Recursive.Chebyshev   as Cheby-import qualified Synthesizer.Plain.Filter.Recursive    as FiltR 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-import qualified Synthesizer.Storable.Filter.Recursive.Comb as Comb+import qualified Synthesizer.Generic.Filter.Recursive.Comb as Comb  import qualified Number.DimensionTerm        as DN import qualified Algebra.DimensionTerm       as Dim@@ -121,7 +121,7 @@ import qualified Algebra.Real           as Real import qualified Algebra.Ring           as Ring import qualified Algebra.Additive       as Additive-import qualified Algebra.VectorSpace    as VectorSpace+-- import qualified Algebra.VectorSpace    as VectorSpace import qualified Algebra.Module         as Module  -- import Control.Monad(liftM2)@@ -227,8 +227,10 @@  {- | needs a better handling of boundaries, yet -} {-# INLINE mean #-}-mean :: (Additive.C yv, RealField.C q,-         Module.C q yv, Dim.C u, Dim.C v, Sample.C q, Sample.C yv) =>+mean ::+   (Additive.C yv, RealField.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 freqeuncy -}    -> Proc.T s u q (         SigA.R s (Dim.Recip u) q q@@ -253,7 +255,7 @@ {-# INLINE phaseModulation #-} phaseModulation ::    (Additive.C yv, RealField.C q, Dim.C u, Dim.C v,-    Sample.C q, Sample.C yv) =>+    Storable q, Storable yv) =>       Interpolation.T q yv    -> DN.T u q           {- ^ minDelay, minimal delay, may be negative -}@@ -300,7 +302,7 @@       Interpolation.T q yv    -> Proc.T s u q (         RP.T s flat q    {- v frequency factors -}-     -> SigP.T u q (SigA.T v q (SigS.T Sig.T)) yv+     -> SigP.T u q (SigA.D v q SigS.S) yv      -> SigA.R s v q yv) frequencyModulationDecoupled ip =    fmap@@ -317,7 +319,7 @@ phaser ::    (Additive.C yv, RealField.C q,     Module.C q yv, Dim.C u, Dim.C v,-    Sample.C q, Sample.C yv) =>+    Storable q, Storable yv) =>       Interpolation.T q yv    -> DN.T u q  {- ^ maxDelay, must be positive -}    -> Proc.T s u q (@@ -338,7 +340,7 @@ phaserStereo ::    (Additive.C yv, RealField.C q,     Module.C q yv, Dim.C u, Dim.C v,-    Sample.C q, Sample.C yv) =>+    Storable q, Storable yv) =>       Interpolation.T q yv    -> DN.T u q   {- ^ maxDelay, must be positive -}    -> Proc.T s u q (@@ -358,7 +360,7 @@ phaserCore ::    (Additive.C yv, RealField.C q,     Module.C q yv, Dim.C u, Dim.C v,-    Sample.C q, Sample.C yv) =>+    Storable q, Storable yv) =>       Interpolation.T q yv    -> DN.T u q   {- ^ maxDelay, must be positive -}    -> Proc.T s u q (@@ -376,18 +378,22 @@ -}  +type FrequencyFilter s u q r ic v yv0 yv1 =+   Proc.T s u q+      (CProc.T s+          (SigA.R r (Dim.Recip u) q q)+                    {- v Control signal for the cut-off frequency. -}+          ic+          (SigA.R s v q yv0 ->+                    {- v Input signal -}+           SigA.R s v q yv1))+                    {- v Output signal -}  {-# INLINE firstOrderLowpass #-} {-# INLINE firstOrderHighpass #-} firstOrderLowpass, firstOrderHighpass ::    (Trans.C q, Module.C q yv, Dim.C u, Dim.C v) =>-      CProc.T s u q-          (SigA.R s (Dim.Recip u) q q-                    {- v Control signal for the cut-off frequency. -} )-          (Filt1.Parameter q) (-        SigA.R s v q yv-                    {- v Input signal -}-     -> SigA.R s v q yv)+   FrequencyFilter s u q r (Filt1.Parameter q) v yv yv firstOrderLowpass  = firstOrderGen Filt1.lowpassModifier firstOrderHighpass = firstOrderGen Filt1.highpassModifier @@ -396,9 +402,7 @@    (Trans.C q, Module.C q yv, Dim.C u, Dim.C v) =>       (Modifier yv (Filt1.Parameter q) yv yv) --      (Sig.T (Filt1.Parameter q) -> Sig.T yv -> Sig.T yv)-   -> CProc.T s u q (SigA.R s (Dim.Recip u) q q) (Filt1.Parameter q) (-        SigA.R s v q yv-     -> SigA.R s v q yv)+   -> FrequencyFilter s u q r (Filt1.Parameter q) v yv yv firstOrderGen modif =    frequencyControl Filt1.parameter       (Sig.modifyModulated modif)@@ -415,24 +419,17 @@ butterworthLowpass, butterworthHighpass,    chebyshevALowpass, chebyshevAHighpass,    chebyshevBLowpass, chebyshevBHighpass ::-      (Trans.C q, VectorSpace.C q yv, Dim.C u, Dim.C v) =>+      (Flat.C flat q, Trans.C q, Module.C q yv, Dim.C u, Dim.C v) =>       NonNeg.Int   {- ^ Order of the filter, must be even,                         the higher the order, the sharper is the separation of frequencies. -}-   -> q            {- ^ The attenuation at the cut-off frequency.-                        Should be between 0 and 1. -}-   -> CProc.T s u q-         (SigA.R s (Dim.Recip u) q q-                      {- v Control signal for the cut-off frequency. -}  )-         q (-        SigA.R s v q yv {- v Input signal -}-     -> SigA.R s v q yv)+   -> ResonantFilter s u q r flat (FiltRec.Pole q) v yv yv -butterworthLowpass  = higherOrderNoResoGen Butter.lowpass-butterworthHighpass = higherOrderNoResoGen Butter.highpass-chebyshevALowpass   = higherOrderNoResoGen Cheby.lowpassA-chebyshevAHighpass  = higherOrderNoResoGen Cheby.highpassA-chebyshevBLowpass   = higherOrderNoResoGen Cheby.lowpassB-chebyshevBHighpass  = higherOrderNoResoGen Cheby.highpassB+butterworthLowpass  = higherOrderNoResoGen Butter.lowpassPole+butterworthHighpass = higherOrderNoResoGen Butter.highpassPole+chebyshevALowpass   = higherOrderNoResoGen Cheby.lowpassAPole+chebyshevAHighpass  = higherOrderNoResoGen Cheby.highpassAPole+chebyshevBLowpass   = higherOrderNoResoGen Cheby.lowpassBPole+chebyshevBHighpass  = higherOrderNoResoGen Cheby.highpassBPole  {- FIXME: currently only frequencies can be interpolated not the filter parameters,@@ -443,36 +440,39 @@ -} {-# INLINE higherOrderNoResoGen #-} higherOrderNoResoGen ::-   (Field.C q, Dim.C u, Dim.C v) =>-      (Int -> q -> [q] -> [yv] -> [yv])+   (Flat.C flat q, Field.C q, Dim.C u, Dim.C v) =>+      (Int -> [q] -> [q] -> [yv] -> [yv])    -> NonNeg.Int-   -> q-   -> CProc.T s u q (SigA.R s (Dim.Recip u) q q) q (-        SigA.R s v q yv-     -> SigA.R s v q yv)-higherOrderNoResoGen filt order ratio =-   frequencyControl id+   -> ResonantFilter s u q r flat (FiltRec.Pole q) v yv yv++higherOrderNoResoGen filt order =+   frequencyResonanceControl id       (\ cs xs ->-           Sig.fromList (filt (NonNeg.toNumber order) ratio-               (Sig.toList cs) (Sig.toList xs)))+          let csl = Sig.toList cs+          in  Sig.fromList (filt (NonNeg.toNumber order)+                 (map FiltRec.poleResonance csl)+                 (map FiltRec.poleFrequency csl)+                 (Sig.toList xs)))  +type ResonantFilter s u q r flat ic v yv0 yv1 =+   Proc.T s u q+      (CProc.T s+         (RP.T r flat q+                   {- v signal for resonance,+                        i.e. factor of amplification at the resonance frequency+                        relatively to the transition band. -},+          SigA.R r (Dim.Recip u) q q+                   {- v signal for cut off frequency -} )+         ic+         (SigA.R s v q yv0 ->+          SigA.R s v q yv1)) + {-# INLINE universal #-} universal ::    (Flat.C flat q, Trans.C q, Module.C q yv, Dim.C u, Dim.C v) =>-      CProc.T s u q-         (RP.T s flat q-                   {- v signal for resonance,-                        i.e. factor of amplification at the resonance frequency-                        relatively to the transition band. -},-          SigA.R s (Dim.Recip u) q q-                   {- v signal for cut off and band center frequency -} )-         (UniFilter.Parameter q) (-        SigA.R s v q yv-                    {- v input signal -}-     -> SigA.R s v q (UniFilter.Result yv))-                    {- ^ highpass, bandpass, lowpass filter -}+   ResonantFilter s u q r flat (UniFilter.Parameter q) v yv (UniFilter.Result yv) universal =    frequencyResonanceControl       UniFilter.parameter@@ -481,31 +481,20 @@ {-# INLINE moogLowpass #-} moogLowpass :: (Flat.C flat q, Trans.C q, Module.C q yv, Dim.C u, Dim.C v) =>       NonNeg.Int-   -> CProc.T s u q-         (RP.T s flat q-                   {- v signal for resonance,-                        i.e. factor of amplification at the resonance frequency-                        relatively to the transition band. -},-          SigA.R s (Dim.Recip u) q q-                   {- v signal for cut off frequency -} )-         (Moog.Parameter q) (-        SigA.R s v q yv-     -> SigA.R s v q yv)+   -> ResonantFilter s u q r flat (Moog.Parameter q) v yv yv moogLowpass order =    let orderInt = NonNeg.toNumber order    in  frequencyResonanceControl           (Moog.parameter orderInt)           (Sig.modifyModulated (Moog.lowpassModifier orderInt)) + {-# INLINE allpassCascade #-}+{- | the lowest comb frequency is used as the filter frequency -} allpassCascade :: (Trans.C q, Module.C q yv, Dim.C u, Dim.C v) =>       NonNeg.Int  {- ^ order, number of filters in the cascade -}    -> q           {- ^ the phase shift to be achieved for the given frequency -}-   -> CProc.T s u q-         (SigA.R s (Dim.Recip u) q q {- v lowest comb frequency -})-         (Allpass.Parameter q) (-        SigA.R s v q yv-     -> SigA.R s v q yv)+   -> FrequencyFilter s u q r (Allpass.Parameter q) v yv yv allpassCascade order phase =    let orderInt = NonNeg.toNumber order    in  frequencyControl@@ -515,43 +504,39 @@  {-# INLINE frequencyControl #-} frequencyControl ::-   (Field.C y, Dim.C u, Dim.C v) =>-   (y -> ic) ->+   (Field.C q, Dim.C u, Dim.C v) =>+   (q -> ic) ->    (Sig.T ic -> Sig.T yv0 -> Sig.T yv1) ->-   CProc.T s u y-      (SigA.R s (Dim.Recip u) y y) ic-      (SigA.R s v y1 yv0 -> SigA.R s v y1 yv1)+   FrequencyFilter s u q r ic v yv0 yv1 -frequencyControl mkParam filt = CProc.Cons $+frequencyControl mkParam filt =    do toFreq <- Proc.withParam toFrequencyScalar-      return-         (\ freqs -> Sig.map mkParam (SigA.scalarSamples toFreq freqs),-          \ params -> SigA.processSamples (filt params))+      return $ CProc.Cons+         (\ freqs -> Sig.map mkParam (SigA.scalarSamples toFreq freqs))+         (\ params -> SigA.processSamples (filt params))   {-# INLINE frequencyResonanceControl #-} frequencyResonanceControl ::-   (Flat.C flat y, Field.C y, Dim.C u, Dim.C v) =>-   (FiltR.Pole y -> ic) ->+   (Flat.C flat q, Field.C q, Dim.C u, Dim.C v) =>+   (FiltRec.Pole q -> ic) ->    (Sig.T ic -> Sig.T yv0 -> Sig.T yv1) ->-   CProc.T s u y-      (RP.T s flat y, SigA.R s (Dim.Recip u) y y) ic-      (SigA.R s v y1 yv0 -> SigA.R s v y1 yv1)+   ResonantFilter s u q r flat ic v yv0 yv1 -frequencyResonanceControl mkParam filt = CProc.Cons $+frequencyResonanceControl mkParam filt =    do toFreq <- Proc.withParam toFrequencyScalar-      return+      return $ CProc.Cons          (\ (resos, freqs) ->                Sig.map mkParam $-               Sig.zipWith FiltR.Pole+               Sig.zipWith FiltRec.Pole                   (Flat.toSamples resos)-                  (SigA.scalarSamples toFreq freqs),-          \ params -> SigA.processSamples (filt params))+                  (SigA.scalarSamples toFreq freqs))+         (\ params -> SigA.processSamples (filt params))   {- | 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 :: (RealField.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 @@ -559,8 +544,8 @@ {- | 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,-    Dim.C u, Dim.C v) =>+   (RealField.C t, Real.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) ->    Proc.T s u t (SigA.R s v y yv -> SigA.R s v y yv)
src/Synthesizer/Dimensional/RateAmplitude/Instrument.hs view
@@ -1,4 +1,6 @@-{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-} module Synthesizer.Dimensional.RateAmplitude.Instrument where  import qualified Synthesizer.Dimensional.Rate.Oscillator as Osci@@ -26,17 +28,17 @@ import Synthesizer.Dimensional.RateAmplitude.Signal (($-), ($&), (&*^), (&*>^), ) import Synthesizer.Dimensional.RateAmplitude.Control ((-|#), ( #|-), (|#), ( #|), ) -import Synthesizer.Dimensional.Process (($:), ($::), (.:), ($^), ($#))+import Synthesizer.Dimensional.Process (($:), ($::), ($^), (.^), ($#), ) import Synthesizer.Dimensional.Amplitude.Control (mapLinear, mapExponential, ) -import qualified Synthesizer.Generic.SampledValue as Sample+import Foreign.Storable (Storable, )  import qualified Algebra.DimensionTerm as Dim import qualified Number.DimensionTerm  as DN  import Number.DimensionTerm ((*&), (&*&), ) -import qualified Synthesizer.State.Interpolation as Interpolation+import qualified Synthesizer.Interpolation.Module as Interpolation import           Synthesizer.Plain.Instrument (choirWave) import qualified Synthesizer.Basic.Wave       as Wave import qualified Synthesizer.Basic.Phase      as Phase@@ -95,7 +97,7 @@       FiltA.amplify 0.3 $:          (Disp.mix              $# x-             $: (Filt.allpassCascade order (-2*pi)+             $: (Filt.allpassCascade order Filt.allpassFlangerPhase                     $: filterfreq &*^ CtrlR.exponential2 halfLife                     $# x)) @@ -168,7 +170,7 @@    Proc.T s Dim.Time a (SigA.R s Dim.Voltage a a) filterSaw filterFreq freq =    FiltA.amplify 0.1 $:-   (Filt.lowpassFromUniversal $:+   (Filt.lowpassFromUniversal $^      (Filt.universal          $- DN.fromNumber 10          $: filterFreq &*^ CtrlR.exponential2 (DN.time 0.1)@@ -254,7 +256,7 @@        freqs = randomRsBalanced (mkStdGen 384) 3 1 0.03    in  Disp.mixMulti $:: map (\k -> osci (k *& freq)) freqs {--renderTimeVoltageMonoDouble (DN.frequency 44100) "fat-pad" (Cut.take (DN.time 1.5) $: fatPad (DN.frequency 220))+renderTimeVoltageMonoDoubleToInt16 (DN.frequency 44100) "fat-pad" (Cut.take (DN.time 1.5) $: fatPad (DN.frequency 220)) -}  @@ -284,7 +286,7 @@           $: adsr           $: (Disp.mixMulti $:: zipWith (\b k -> osci b (k *& freq)) blobAmps freqs) {--Synthesizer.Dimensional.RateAmplitude.File.renderTimeVoltageMonoDouble (DN.frequency 44100) "brass" (brass (DN.frequency 440))+Synthesizer.Dimensional.RateAmplitude.File.renderTimeVoltageMonoDoubleToInt16 (DN.frequency 44100) "brass" (brass (DN.frequency 440)) -}  @@ -296,7 +298,7 @@       SigA.R s Dim.Voltage a v ->       SigA.R s Dim.Voltage a v) filterSweep phase =-   Filt.lowpassFromUniversal .:+   Filt.lowpassFromUniversal .^     (Filt.universal        $- DN.fromNumber 10        $: (mapExponential 2 (DN.frequency 1800) $^@@ -311,7 +313,7 @@  fatSawChordFilter freq =    FiltA.amplify (1/2) $:-   (Filt.lowpassFromUniversal $:+   (Filt.lowpassFromUniversal $^      (Filt.universal          $- DN.fromNumber 10          $: filterDown@@ -407,7 +409,7 @@ A good choice is @freq = DN.frequency 110@ -} wasp ::-   (RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q, Dim.C u) =>+   (RealField.C q, Trans.C q, Module.C q q, Random q, Dim.C u) =>    DN.T (Dim.Recip u) q ->    Proc.T s u q (SigA.R s Dim.Voltage q q) wasp freq =@@ -492,7 +494,7 @@       $: Noise.white (DN.frequency 20000) (DN.voltage 1.0)  {-# INLINE noiseBass #-}-noiseBass :: (Random a, RealField.C a, Trans.C a, Module.C a a, Sample.C a) =>+noiseBass :: (Random a, RealField.C a, Trans.C a, Module.C a a, Storable a) =>    DN.T Dim.Frequency a ->    Proc.T s Dim.Time a (SigA.R s Dim.Voltage a a) noiseBass freq =@@ -509,7 +511,8 @@ to give a falling frequency. -} {-# INLINE electroTom #-}-electroTom :: (Ring.C a, Random a, RealField.C a, Trans.C a, Module.C a a, Sample.C a) =>+electroTom ::+   (Random a, RealField.C a, Trans.C a, Module.C a a, Storable a) =>    Proc.T s Dim.Time a (SigA.R s Dim.Voltage a a) electroTom =    let ks =
src/Synthesizer/Dimensional/RateAmplitude/Noise.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright   :  (c) Henning Thielemann 2008 License     :  GPL@@ -20,6 +20,7 @@ import qualified Synthesizer.RandomKnuth as Knuth  import qualified Synthesizer.Dimensional.RateAmplitude.Signal as SigA+import qualified Synthesizer.Dimensional.Rate.Dirac as Dirac import qualified Synthesizer.Dimensional.Process as Proc  import Synthesizer.Dimensional.Process (($#), )@@ -110,11 +111,11 @@    (Field.C q, Random q, Ord q, Dim.C u) =>     Proc.T s u q (        SigA.R s (Dim.Recip u) q q-          {- v momentary densities (frequency),+          {- v instantaneous densities (frequency),                @p@ means that there is about one peak                in the time range of @1\/p@. -}     -> SigA.R s (Dim.Recip u) q q)-          {- ^ Every occurence is represented by a peak of area 1.+          {- ^ Every occurrence is represented by a peak of area 1.                If you smooth the input and the output signal to the same degree                they should be rather similar. -} randomPeeks =@@ -132,12 +133,12 @@                @p@ means that there is about one peak                in the time range of @1\/p@. -}       -> SigA.R s (Dim.Recip u) q q)-          {- ^ Every occurence is represented by a peak of area 1. -}+          {- ^ Every occurrence is represented by a peak of area 1. -} randomPeeksGen g =    Proc.withParam $ \ dens ->       do freq <- SigA.toFrequencyScalar (SigA.amplitude dens)-         SigA.fromPeaks $#-            (SigA.Peaks $+         Dirac.toAmplitudeSignal $#+            (Dirac.Cons $              Sig.zipWith (<)                 (Noise.randomRs (0, recip freq) g)                 (SigA.samples dens))
src/Synthesizer/Dimensional/RateAmplitude/Play.hs view
@@ -1,16 +1,20 @@-{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}--- glasgow-exts for all quantifier+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE Rank2Types #-} module Synthesizer.Dimensional.RateAmplitude.Play (-   timeVoltageMonoDouble,-   timeVoltageStereoDouble,-   timeVoltageMonoDoubleR,-   timeVoltageStereoDoubleR,+   auto,+   timeVoltage,+   timeVoltageMonoDoubleToInt16,+   timeVoltageStereoDoubleToInt16,+   renderTimeVoltageMonoDoubleToInt16,+   renderTimeVoltageStereoDoubleToInt16,   ) where -import qualified Sox--- import qualified Sox.File-import qualified Sox.Play--- import qualified BinarySample as BinSmp+import qualified Sound.Sox.Play as Play+import qualified Sound.Sox.Option.Format as SoxOpt+import qualified Sound.Sox.Frame as Frame+import qualified Synthesizer.Basic.Binary as BinSmp+import qualified Data.StorableVector.Lazy.Builder as Builder+import Foreign.Storable (Storable, )  import qualified Synthesizer.Dimensional.Process as Proc @@ -19,83 +23,95 @@ import qualified Synthesizer.Dimensional.RateWrapper as SigP  import qualified Synthesizer.Storable.Signal as SigSt---- import qualified Synthesizer.Dimensional.Straight.Signal as SigS--- import qualified Synthesizer.State.Signal as Sig+import qualified Synthesizer.State.Signal as Sig --- import qualified Algebra.Transcendental as Trans--- import qualified Algebra.Module         as Module-import qualified Algebra.RealField      as RealField--- import qualified Algebra.Field          as Field--- import qualified Algebra.Ring           as Ring+import qualified Synthesizer.Frame.Stereo as Stereo  import qualified Algebra.DimensionTerm as Dim import qualified Number.DimensionTerm  as DN -import qualified Synthesizer.Frame.Stereo as Stereo---- import System.Exit(ExitCode)-import Control.Exception(bracket)-import Foreign.Storable (Storable)+import qualified Algebra.ToInteger      as ToInteger+-- import qualified Algebra.Transcendental as Trans+import qualified Algebra.Module         as Module+import qualified Algebra.RealField      as RealField+import qualified Algebra.Field          as Field+-- import qualified Algebra.Ring           as Ring -import qualified System.IO as IO-import qualified System.Process as Proc+import System.Exit(ExitCode)  import NumericPrelude import PreludeBase  -raw :: (RealField.C a, Storable y) =>-   [String] -> a -> Int -> SigSt.T y -> IO ()-raw args sampleRate numChannels stream =-   bracket-      (Proc.runInteractiveProcess "play"-          (args ++-           Sox.sampleRateOption sampleRate ++-           Sox.channelOption numChannels ++-           ["-t","sw","-"])-          Nothing Nothing)-      (\(input,output,err,proc) -> do-          mapM IO.hClose [input, output, err]-          -- wait for end of replay-          Proc.waitForProcess proc)-      (\(input,_,_,_) ->-         Sox.Play.catchCtrlC >>-         SigSt.hPut input stream)+{-# INLINE auto #-}+auto ::+    (Bounded int, ToInteger.C int, Storable int, Frame.C int, BinSmp.C yv,+     Dim.C u, RealField.C t,+     Dim.C v, Module.C y yv, Field.C y) =>+   DN.T (Dim.Recip u) t ->+   DN.T v y ->+   (int -> Builder.Builder int) ->+   SigP.T u t (SigA.S v y) yv ->+--   SigP.T u t (SigA.D v y SigS.S) yv ->+   IO ExitCode+auto freqUnit amp put sig =+   let opts =+          SoxOpt.numberOfChannels (BinSmp.numberOfSignalChannels sig)+       sampleRate =+          DN.divToScalar (SigP.sampleRate sig) freqUnit+   in  Play.extended SigSt.hPut opts SoxOpt.none+          (round sampleRate)+          (Builder.toLazyStorableVector SigSt.defaultChunkSize $+           Sig.monoidConcatMap (BinSmp.outputFromCanonical put) $+           SigA.vectorSamples (flip DN.divToScalar amp) sig)  -{-# INLINE timeVoltageMonoDouble #-}-timeVoltageMonoDouble ::+{-# INLINE timeVoltage #-}+timeVoltage ::+    (Bounded int, ToInteger.C int, Storable int, Frame.C int, BinSmp.C yv,+     RealField.C t,+     Module.C y yv, Field.C y) =>+   (int -> Builder.Builder int) ->+   SigP.T Dim.Time t (SigA.S Dim.Voltage y) yv ->+--   SigP.T Dim.Time t (SigA.D Dim.Voltage y SigS.S) yv ->+   IO ExitCode+timeVoltage =+   auto (DN.frequency one) (DN.voltage one)+++{-# INLINE timeVoltageMonoDoubleToInt16 #-}+timeVoltageMonoDoubleToInt16 ::    SigP.T Dim.Time Double (SigA.S Dim.Voltage Double) Double ->-   IO ()-timeVoltageMonoDouble sig =+   IO ExitCode+timeVoltageMonoDoubleToInt16 sig =    let rate = DN.toNumberWithDimension Dim.frequency (SigP.sampleRate sig)-   in  raw [] rate 1+   in  Play.simple SigSt.hPut SoxOpt.none (round rate)           (SigP.signal (SigRA.toStorableInt16Mono sig))  -{-# INLINE timeVoltageStereoDouble #-}-timeVoltageStereoDouble ::+{-# INLINE timeVoltageStereoDoubleToInt16 #-}+timeVoltageStereoDoubleToInt16 ::    SigP.T Dim.Time Double (SigA.S Dim.Voltage Double) (Stereo.T Double) ->---   SigP.T Dim.Time t (SigA.T Dim.Voltage y (SigS.T Sig.T)) yv ->-   IO ()-timeVoltageStereoDouble sig =+--   SigP.T Dim.Time t (SigA.D Dim.Voltage y SigS.S) yv ->+   IO ExitCode+timeVoltageStereoDoubleToInt16 sig =    let rate = DN.toNumberWithDimension Dim.frequency (SigP.sampleRate sig)-   in  raw [] rate 2+   in  Play.simple SigSt.hPut SoxOpt.none (round rate)           (SigP.signal (SigRA.toStorableInt16Stereo sig)) -{-# INLINE timeVoltageMonoDoubleR #-}-timeVoltageMonoDoubleR ::++{-# INLINE renderTimeVoltageMonoDoubleToInt16 #-}+renderTimeVoltageMonoDoubleToInt16 ::    DN.T Dim.Frequency Double ->    (forall s. Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double Double)) ->-   IO ()-timeVoltageMonoDoubleR rate sig =-   timeVoltageMonoDouble (SigP.runProcess rate sig)+   IO ExitCode+renderTimeVoltageMonoDoubleToInt16 rate sig =+   timeVoltageMonoDoubleToInt16 (SigP.runProcess rate sig) -{-# INLINE timeVoltageStereoDoubleR #-}-timeVoltageStereoDoubleR ::+{-# INLINE renderTimeVoltageStereoDoubleToInt16 #-}+renderTimeVoltageStereoDoubleToInt16 ::    DN.T Dim.Frequency Double ->    (forall s. Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double (Stereo.T Double))) ->-   IO ()-timeVoltageStereoDoubleR rate sig =-   timeVoltageStereoDouble (SigP.runProcess rate sig)+   IO ExitCode+renderTimeVoltageStereoDoubleToInt16 rate sig =+   timeVoltageStereoDoubleToInt16 (SigP.runProcess rate sig)
src/Synthesizer/Dimensional/RateAmplitude/Signal.hs view
@@ -9,7 +9,7 @@ For a description see "Synthesizer.Dimensional.Process". -} module Synthesizer.Dimensional.RateAmplitude.Signal (-   T, R,+   D, R,    Proc.toTimeScalar,    Proc.toFrequencyScalar,    toAmplitudeScalar,@@ -25,7 +25,6 @@    asTypeOfAmplitude,    ($-),  ($&),    (&*^), (&*>^),-   Peaks(Peaks), fromPeaks,    cache, bindCached, share,     toStorableInt16Mono,@@ -44,11 +43,11 @@ import qualified Synthesizer.Dimensional.Straight.Signal   as SigS import qualified Synthesizer.State.Signal as Sig import qualified Synthesizer.Storable.Signal as SigSt-import qualified Synthesizer.Generic.SampledValue as Sample-import qualified Synthesizer.Frame.Stereo as Stereo -import qualified BinarySample as BinSmp+import qualified Synthesizer.Frame.Stereo as Stereo+import qualified Synthesizer.Basic.Binary as BinSmp import Data.Int (Int16)+import Foreign.Storable (Storable, )  import qualified Number.DimensionTerm        as DN import qualified Algebra.DimensionTerm       as Dim@@ -62,9 +61,9 @@  -- import qualified Data.List as List -import NumericPrelude (zero, one, )+-- import NumericPrelude (zero, one, ) -- import PreludeBase-import Prelude (($), (.), Bool, Ord, fmap, return, (=<<), )+import Prelude (($), (.), Bool, fmap, return, (=<<), )   @@ -79,41 +78,6 @@     steepness &/& amp)  -{- |-We want to represent streams of discrete events-in a manner that is more safe than plain @[Bool]@.-Each peak can be imagined as a Dirac impulse.--A @[Bool]@ could be used accidentally for 'Synthesizer.Dimensional.Amplitude.Cut.selectBool',-where @selectBool@ is intended for piecewise constant control curves.--You may think that a type like @Peak = Peak Bool@ as sample type-in @T s Peak@ would also do the job.-Actually, this wouldn't be a good idea-since you can apply constant interpolation on it,-which obviously fools the idea of a peak.--}-newtype Peaks s = Peaks {getPeaks :: Sig.T Bool}--{- |-This is the most frequently needed transformation (if not the only one)-of a stream of peaks.-It converts to a signal of peaks with area 1.-This convention is especially useful for smoothing filters-that eventually produce frequency progress curves.--}-{-# INLINE fromPeaks #-}-fromPeaks ::-   (Ord q, Ring.C q, Dim.C u) =>-   Proc.T s u q (Peaks s -> R s (Dim.Recip u) q q)-fromPeaks =-   do rate <- Proc.getSampleRate-      return $-         fromScalarSamples rate .-         Sig.map (\c -> if c then one else zero) .-         getPeaks-- infixl 0 $-, $&  {- |@@ -128,6 +92,9 @@ {- | Take a signal with 'DN.Scalar' unit in amplitude where the process expects a plain 'Sig.T'.+This is no longer important+since the processes which expects those inputs+can use the Flat type class. -} {-# INLINE ($&) #-} ($&) :: (Ring.C y) =>@@ -167,27 +134,27 @@  {-# INLINE cache #-} cache ::-   (Dim.C v, Ind.C w, Sample.C yv0) =>-   Proc.T s u t (w (T v y (SigS.T Sig.T)) yv0) ->-   Proc.T s u t (w (T v y (SigS.T Sig.T)) yv0)+   (Dim.C v, Ind.C w, Storable yv0) =>+   Proc.T s u t (w (D v y SigS.S) yv0) ->+   Proc.T s u t (w (D v y SigS.S) yv0) cache =    fmap (processSamples       (Sig.fromStorableSignal . Sig.toStorableSignal SigSt.defaultChunkSize))  {-# INLINE bindCached #-} bindCached ::-   (Dim.C v, Ind.C w, Sample.C yv0) =>-   Proc.T s u t (w (T v y (SigS.T Sig.T)) yv0) ->-   (w (T v y (SigS.T Sig.T)) yv0 -> Proc.T s u t b) ->+   (Dim.C v, Ind.C w, Storable yv0) =>+   Proc.T s u t (w (D v y SigS.S) yv0) ->+   (w (D v y SigS.S) yv0 -> Proc.T s u t b) ->    Proc.T s u t b bindCached x y =    y =<< cache x  {-# INLINE share #-} share ::-   (Dim.C v, Ind.C w, Sample.C yv0) =>-   Proc.T s u t (w (T v y (SigS.T Sig.T)) yv0) ->-   (Proc.T s u t (w (T v y (SigS.T Sig.T)) yv0) -> Proc.T s u t b) ->+   (Dim.C v, Ind.C w, Storable yv0) =>+   Proc.T s u t (w (D v y SigS.S) yv0) ->+   (Proc.T s u t (w (D v y SigS.S) yv0) -> Proc.T s u t b) ->    Proc.T s u t b share x y = bindCached x (y . return) @@ -195,22 +162,22 @@  {-# INLINE toStorableInt16Mono #-} toStorableInt16Mono ::-   (Ind.C w, RealField.C a, BinSmp.C a) =>+   (Ind.C w, RealField.C a) =>    w (SigA.S Dim.Voltage a) a ->    w SigSt.T Int16 toStorableInt16Mono =    Ind.processSignal       (Sig.toStorableSignal SigSt.defaultChunkSize .-       Sig.map BinSmp.numToInt16Packed .+       Sig.map BinSmp.int16FromCanonical .        SigA.scalarSamplesPrivate (DN.toNumberWithDimension Dim.voltage))  {-# INLINE toStorableInt16Stereo #-} toStorableInt16Stereo ::-   (Ind.C w, Module.C a a, RealField.C a, BinSmp.C a) =>+   (Ind.C w, Module.C a a, RealField.C a) =>    w (SigA.S Dim.Voltage a) (Stereo.T a) ->    w SigSt.T (Stereo.T Int16) toStorableInt16Stereo =    Ind.processSignal       (Sig.toStorableSignal SigSt.defaultChunkSize .-       Sig.map (Stereo.map BinSmp.numToInt16Packed) .+       Sig.map (Stereo.map BinSmp.int16FromCanonical) .        SigA.vectorSamplesPrivate (DN.toNumberWithDimension Dim.voltage))
src/Synthesizer/Dimensional/RateAmplitude/Traumzauberbaum.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} module Main (main) where -- module Synthesizer.Dimensional.RateAmplitude.Traumzauberbaum where @@ -31,11 +31,9 @@ import Synthesizer.Dimensional.Process (($:), ($::), ($^), ($#)) import Synthesizer.Dimensional.Amplitude.Control (mapExponential, ) -import qualified Synthesizer.Generic.SampledValue as Sample- import qualified Synthesizer.Frame.Stereo as Stereo --- import qualified Synthesizer.State.Interpolation as Interpolation+-- import qualified Synthesizer.Interpolation as Interpolation import qualified Synthesizer.Basic.Wave as Wave  import qualified Algebra.DimensionTerm as Dim@@ -200,7 +198,7 @@ filteredPitchControl ::    Proc.T s Dim.Time Double (SigA.R s Dim.Scalar Double Double) filteredPitchControl =-   Filt.lowpassFromUniversal $:+   Filt.lowpassFromUniversal $^       (Filt.universal          $- DN.scalar 3          $- DN.frequency 4@@ -232,7 +230,7 @@ filteredMusic ::    Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double Double) filteredMusic =-   Filt.lowpassFromUniversal $:+   Filt.lowpassFromUniversal $^       (Filt.universal          $- DN.scalar 10          $: (mapExponential 20 (DN.frequency 100) $^ envelope)@@ -411,7 +409,7 @@ filteredAccompaniment ::    Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double (Stereo.T Double)) filteredAccompaniment =-   Filt.lowpassFromUniversal $:+   Filt.lowpassFromUniversal $^       (Filt.universal          $- DN.scalar 5          $: (mapExponential 2 (DN.frequency 440) $^@@ -437,18 +435,18 @@  main :: IO () main =-   Play.timeVoltageStereoDoubleR+   Play.renderTimeVoltageStereoDoubleToInt16       (DN.frequency (44100::Double)) --      (Cut.take (DN.time 2) $: songSignal)       songSignal --      accompaniment --      bassSignal+     >> return ()  {--   File.writeTimeVoltage "traumzauberbaum"-      (SigP.runProcess-          (DN.frequency (44100::Double))-          songSignal)+   File.renderTimeVoltageStereoDoubleToInt16 "traumzauberbaum"+      (DN.frequency (44100::Double))+      songSignal      >> return () -}
src/Synthesizer/Dimensional/RateWrapper.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE Rank2Types #-} {- | Copyright   :  (c) Henning Thielemann 2008 License     :  GPL@@ -71,6 +71,15 @@       Proc.getSampleRate  +{- |+Render a signal generated by a signal processor+at the given sample rate,+and leave the sample rate context.+If you want to render multiple signals,+then convert them with 'fromProcess'+and move them out of the sample rate context+all at once using 'Proc.run'.+-} {-# INLINE runProcess #-} runProcess :: (Dim.C u) =>    DN.T (Dim.Recip u) t ->
src/Synthesizer/Dimensional/Straight/Displacement.hs view
@@ -24,7 +24,7 @@ mix :: (Additive.C v) => SigS.R s v -> SigS.R s v -> SigS.R s v {- we can't assert equal sample rates of mixer inputs if 'w = RateWrapper' mix :: (Ind.C w, Additive.C v) =>-   w (SigS.T Sig.T) v -> w (SigS.T Sig.T) v -> w (SigS.T Sig.T) v+   w SigS.S v -> w SigS.S v -> w SigS.S v -} mix x = SigS.processSamples (SigS.toSamples x Additive.+) @@ -32,7 +32,7 @@     This is useful for adjusting the center of a modulation. -} {-# INLINE raise #-} raise :: (Ind.C w, Additive.C v) =>-    v -> w (SigS.T Sig.T) v -> w (SigS.T Sig.T) v+    v -> w SigS.S v -> w SigS.S v raise x = SigS.processSamples (Disp.raise x)  @@ -42,7 +42,7 @@ map :: (Ind.C w, Flat.C flat y0) =>     (y0 -> y1) ->     w flat y0 ->-    w (SigS.T Sig.T) y1+    w SigS.S y1 map f =    Ind.processSignal       (SigS.Cons .@@ -58,8 +58,8 @@ {- we can't assert equal sample rates of inputs if 'w = RateWrapper' distort :: (Ind.C w) =>    (c -> a -> a) ->-   w (SigS.T Sig.T) c ->-   w (SigS.T Sig.T) a ->-   w (SigS.T Sig.T) a+   w SigS.S c ->+   w SigS.S a ->+   w SigS.S a -} distort f c = SigS.processSamples (Disp.distort f (SigS.toSamples c))
src/Synthesizer/Dimensional/Straight/Signal.hs view
@@ -50,10 +50,11 @@    showsPrec = Format.format  -type R s yv = RP.T s (T Sig.T) yv+type R s yv = RP.T s S yv+type S = T Sig.T  {- |-In contrast to 'Synthesizer.Dimensional.RateAmplitude.Peaks'+In contrast to 'Synthesizer.Dimensional.Rate.Dirac' where only booleans are possible (peak or not peak) we can also have signals of booleans or other enumerations. In this case we consider the signal as piecewise constant.
+ src/Synthesizer/Filter/Basic.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+module Synthesizer.Filter.Basic where++import qualified Algebra.Transcendental as Trans+import qualified Algebra.Module         as Module+import qualified Algebra.RealField      as RealField+import qualified Number.Complex         as Complex++import NumericPrelude+import PreludeBase++{- todo:+    - support of data before time 0+       - the problem is that all past data has to be kept,+         the garbage collector can't flush it :-(+       - this means we will also need functions for plain lists,+         in this case we can't provide initial conditions to recursive filters+       - the question of initial conditions is especially problematic+         since for Graphs we have no explicit feed back+         where initial conditions can be plugged in+       - thus for two-way signal we must request the user+         to insert initial conditions in every loop of a Graph+         using the Past constructor+    - all of the following filter primitives in static and modulated form:+       - mask+       - integer delay+       - fractional delay+          - shall the fractional delay constructor store the interpolation type?+            (this discussion is similar to the one concerning+             initial conditions for recursive filters)+             - yes, because each delay may use a different interpolation type,+                    if no fractional delay is used,+                     no interpolation type needs to be specified+             - no, because the interpolation is only of interest for filter+                   application not for the transfer function+    - Is there a way to avoid the multi-parameter type class?+       - Can we provide a class for lists (OneWay and TwoWay)+         that help implementing filters and filter networks?+       - The 'transferFunction' obviously does not depend on the signal list type.+    - 'transferFunction' should not be restricted to complex numbers.+       - For arguments of type 'Ratio (Polynomial Rational)'+         you could compute the transfer function in terms of a rational function.+-}++screw :: Trans.C a => a -> [Complex.T a]+screw w = iterate (Complex.cis w *) 1+++class Filter list filter | filter -> list where+   {-| Apply a filter to a signal. -}+   apply :: (RealField.C t, Trans.C t,+             Module.C a v, Module.C a (list v)) =>+               filter t a v -> list v -> list v+   {-| Compute the complex amplification factor+       that is applied to the given frequency. -}+   transferFunction :: (Trans.C t, Module.C a t) =>+               filter t a v -> t -> Complex.T t
+ src/Synthesizer/Filter/Composition.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+module Synthesizer.Filter.Composition where++import qualified Synthesizer.Filter.Basic as FilterBasic+import Synthesizer.Filter.Basic (Filter, apply, )++import qualified Algebra.Module         as Module+import qualified Algebra.Transcendental as Trans+import qualified Algebra.RealField      as RealField+import qualified Algebra.Field          as Field+import qualified Algebra.Additive       as Additive+import qualified Number.Complex         as Complex++import Algebra.Additive ((+))++import PreludeBase+import NumericPrelude++{- todo:+    - functions that build a FilterComposition for specific filters+        (1st order, universal, allpass, butterworth, chebyshev)+    - functions that turn physical filter parameters into+        internal ones+    - How can these function be combined?+      A function like+         [ FilterComposition v [m] ] -> FilterComposition v [[m]]+      is not satisfying, since the conversion function cannot rely+      that the structure of all FilterComposition v [m] is equal.+      If the list is empty the structure can't even be reconstructed.+-}++{-|+  This describes a generic filter with one input and one main output+  that consists of non-recursive and recursive parts.+  If you use Feedback, make sure that at least+  one of the filters of a circle includes a delay,+  otherwise the recursion will fail.+  The main output is used to glue different parts together.+  Additionally the functions 'apply' and 'transferFunction'+  provide the signals at every node of the network.+-}+data T filter t a v =+     Prim (filter t a v)+       {-^ a filter primitve -}+   | Serial   [T filter t a v]+       {-^ serial chain of filters -}+   | Parallel [T filter t a v]+       {-^ filters working parallel, there output is mixed together -}+   | Feedback (T filter t a v) (T filter t a v)+       {-^ filter the signal in the forward direction and+           feed back the output signal filtered by the second filter -}++{-|+  This is the data structure is used for the results+  of 'apply' and 'transferFunction'.+  Each constructor corresponds to one of 'Filter.Composition.T'.+  By choosing only some of the outputs+  the lazy evaluation will content+  with applying the necessary filter steps, only.+-}+data Sockets s = Sockets {output :: s, socket :: SocketSpec s}++data SocketSpec s =+     Output+   | Multiplier [Sockets s]+   | Adder [Sockets s]+   | Loop (Sockets s) (Sockets s)++instance (Filter list filter) =>+      Filter (list) (T filter) where+{-+   apply :: (Module.C a v) =>+      FilterComposition a v -> TwoWayList v -> TwoWayList v+-}+   apply f x = output (applyMulti f x)+{-+   transferFunction :: (Trans.C b, Module.C a (Complex.T b)) =>+      T filter a v -> b -> (Complex.T b)+-}+   transferFunction f w = output (transferFunctionMulti f w)+++{-| Apply a filter network to a signal and keep the output of all nodes.+    Generic function that is wrapped by 'apply'. -}+applyMulti :: (RealField.C t, Trans.C t,+      Module.C a v, Module.C a (list v), Filter list filter) =>+   T filter t a v -> list v -> Sockets (list v)+applyMulti (Prim f) x =+   Sockets (apply f x) Output+applyMulti (Serial fs) x =+   let sq = scanl (\(Sockets y _) -> flip applyMulti y) (Sockets x Output) fs+   in  Sockets (output (last sq)) (Multiplier (tail sq))+applyMulti (Parallel fs) x =+   let socks = map (flip applyMulti x) fs+       y = foldr (Additive.+) zero (map output socks)+   in  Sockets y (Adder socks)+{- the distinction between 'feed' and 'back'+   can be dropped in a more general net structure -}+applyMulti (Feedback feed back) x =+   let sockY@(Sockets y _) = applyMulti feed ((Additive.+) x z)+       sockZ@(Sockets z _) = applyMulti back y+   in  Sockets y (Loop sockY sockZ)+++transferFunctionMulti ::+   (Trans.C t, Module.C a t, Filter list filter) =>+      T filter t a v -> t -> Sockets (Complex.T t)+transferFunctionMulti f w = tfAbsolutize 1 (tfRelative w f)++{-| Compute the transitivity for each part of the filter network.+    We must do this in such a relative manner to be able+    to compute feedback. -}+tfRelative ::+   (Trans.C t, Module.C a t, Filter list filter) =>+      t -> T filter t a v -> Sockets (Complex.T t)+tfRelative w (Prim f) =+   Sockets (FilterBasic.transferFunction f w) Output+tfRelative w (Serial fs) =+   let sq = map (tfRelative w) fs+   in  Sockets (product (map output sq)) (Multiplier sq)+tfRelative w (Parallel fs) =+   let sq = map (tfRelative w) fs+   in  Sockets (sum (map output sq)) (Adder sq)+tfRelative w (Feedback feed back) =+   let sockY = tfRelative w feed+       sockZ = tfRelative w back+       q = output sockY / (1 - output sockZ)+   in  Sockets q (Loop sockY sockZ)+++{-| Make the results from 'tfRelative' absolute. -}+tfAbsolutize :: (Field.C a) => a -> Sockets a -> Sockets a+tfAbsolutize x (Sockets y spec) = Sockets (x*y)+   (case spec of+      (Multiplier socks) ->+         let sq = scanl (\(Sockets z _) -> tfAbsolutize z)+                        (Sockets x Output) socks+         in  Multiplier (tail sq)+      (Adder socks) ->+         let sq = map (tfAbsolutize x) socks+         in  Adder sq+      (Loop feed back) ->+         let sockY = tfAbsolutize (x / (1 - output back)) feed+             sockZ = tfAbsolutize (output sockY) back+             -- it should be  x*y == output sockY+         in  Loop sockY sockZ+      Output -> spec)
+ src/Synthesizer/Filter/Example.hs view
@@ -0,0 +1,243 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.Filter.Example where++import qualified Synthesizer.Filter.OneWay as OneWay+import qualified Synthesizer.Filter.TwoWay as TwoWay+import qualified Synthesizer.Filter.Composition as Composition+import qualified Synthesizer.Filter.Graph as Graph+import qualified Synthesizer.Plain.Interpolation as Interpolation++import Synthesizer.Filter.Basic (apply, )+import Synthesizer.Filter.Composition (T(..))++import qualified Synthesizer.Plain.Oscillator as Osci+import qualified Synthesizer.Basic.Wave       as Wave+import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1+import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR++import qualified Algebra.Module         as Module+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 Data.Maybe (fromMaybe)++import PreludeBase+import NumericPrelude++++{-* Reconstruction of the sound of a plucked guitar string -}++guitarInit :: Field.C a => [a]+guitarInit = map (/128) (+      1 :    1 :    1 :    1 :    1 :    1 :    1 :    1 :+      1 :    2 :    2 :    2 :    2 :    2 :    2 :    2 :+      2 :    2 :    2 :    2 :    2 :    2 :    2 :    2 :+      2 :    2 :    2 :    3 :    3 :    3 :    3 :    3 :+      3 :    3 :    3 :    3 :    3 :    3 :    3 :    3 :+      3 :    3 :    3 :    4 :    4 :    4 :    4 :    4 :+      4 :    4 :    4 :    4 :    4 :    4 :    4 :    4 :+      5 :    5 :    5 :    5 :    5 :    5 :    5 :    5 :+      6 :    6 :    6 :    7 :    7 :    8 :    8 :    9 :+     10 :   11 :   12 :   13 :   14 :   15 :   15 :   16 :+     17 :   17 :   17 :   18 :   18 :   18 :   18 :   18 :+     18 :   18 :   18 :   17 :   17 :   16 :   16 :   15 :+     15 :   14 :   14 :   14 :   13 :   13 :   14 :   14 :+     15 :   16 :   17 :   18 :   19 :   20 :   22 :   23 :+     25 :   27 :   30 :   32 :   35 :   37 :   39 :   41 :+     43 :   45 :   47 :   48 :   49 :   49 :   48 :   46 :+     41 :   34 :   24 :   11 :   -6 :  -26 :  -48 :  -72 :+    -96 : -114 : -128 : -128 : -128 : -128 : -128 : -128 :+   -128 : -125 : -110 :  -93 :  -75 :  -57 :  -41 :  -27 :+    -17 :  -10 :   -6 :   -4 :   -2 :   -2 :   -2 :   -2 :+     -2 :   -3 :   -4 :   -4 :   -5 :   -6 :   -7 :   -8 :+     -9 :  -10 :  -11 :  -12 :  -12 :  -12 :  -13 :  -13 :+    -13 :  -13 :  -13 :  -13 :  -12 :  -12 :  -11 :  -10 :+     -9 :   -9 :   -8 :   -8 :   -7 :   -6 :   -6 :   -5 :+     -5 :   -5 :   -5 :   -4 :   -4 :   -4 :   -4 :   -4 :+     -4 :   -4 :   -4 :   -4 :   -4 :   -5 :   -7 :   -8 :+     -8 :   -9 :  -10 :  -11 :  -12 :  -13 :  -13 :  -14 :+    -14 :  -14 :  -13 :  -10 :   -7 :   -2 :    5 :   15 :+     26 :   37 :   49 :   61 :   73 :   83 :   92 :   99 :+    105 :  109 :  111 :  112 :  110 :  105 :   99 :   90 :+     80 :   71 :   63 :   57 :   52 :   49 :   47 :   47 :+     48 :   49 :   51 :   51 :   52 :   52 :   50 :   48 :+     42 :   34 :   22 :    7 :  -12 :  -32 :  -56 :  -78 :+    -96 : -114 : -127 : -128 : -128 : -128 : -128 : -128 :+   -128 : -118 : -102 :  -83 :  -67 :  -50 :  -37 :  -26 :+    -17 :  -12 :   -8 :   -5 :   -3 :   -3 :   -2 :   -2 :+     -2 :   -3 :   -4 :   -4 :   -6 :   -7 :   -8 :  -10 :+    -11 :  -12 :  -12 :  -13 : [])++guitarCompShort, guitarCompLong ::+   Field.C a => [a] -> Composition.T TwoWay.T Double a a+guitarCompShort past = Feedback (Prim (TwoWay.Past past)) (Parallel [+   Serial [Prim (TwoWay.Delay   1),+           Prim (TwoWay.Mask [0.6519177892575342, 0.2331904728998289])],+   Serial [Prim (TwoWay.Delay 126),+           Prim (TwoWay.Mask [0.08253506238277844,+               0.2369601607320473,   0.18367848836060044,+              -0.06422525077173147, -0.31836517142623727])]])+guitarCompLong past = Feedback (Prim (TwoWay.Past past)) (+   Serial [Prim (TwoWay.Delay 122),+           Prim (TwoWay.Mask [+              -0.23742303494466988,+               0.020278040917954415,+               0.12495333789385828,+               0.16125537461091102,+               0.1993410924766678,+               0.24673057006071691,+               0.25438881375430467,+               0.1424676847770117,+               0.03848071949084291,+              -0.016618282409355676,+              -0.04517323927531556,+              -0.0061713683480988475,+               0.11137126130878339+             ])])++{-| Reconstruct the guitar sound from the sampled initial wave+    and the analysed feedback factors.+    This sounds pretty like the sampled sound. -}+guitarRaw :: (Field.C a, Module.C a a) => [a]+guitarRaw =+   let gi = guitarInit  -- assert monomorphism+       y = TwoWay.future+              (TwoWay.delay (length gi)+                 (apply (guitarCompLong (reverse gi))+                        (TwoWay.Signal [] [])))+   in  y++{-| Reconstruct the guitar sound from the sampled initial wave+    but with simple smoothing on feedback.+    This sounds more statically. -}+guitarRawSimple :: (Field.C a, Module.C a a) => [a]+guitarRawSimple =+   let gi = guitarInit  -- assert monomorphism+       y  = gi ++ drop (length gi)+              (FiltNR.delay 128 (Filt1.lowpass+                 (repeat (Filt1.Parameter (0.4  `asTypeOf` head y))) y))+   in  y++{-| Reconstruct the guitar sound with the analysed feedback factors+    but with an synthetic initial wave.+    The sharpness of the initial wave can be controlled.+    This is used to implement various velocities. -}+guitarRawVelo :: (Real.C a, Trans.C a, Module.C a a) => a -> [a]+guitarRawVelo velo =+   let len  = 128::Int+       wave =+          map (Wave.power01Normed velo)+             (take len (iterate (+ 2 / fromIntegral len) (-1)))+       y = TwoWay.future+              (TwoWay.delay len+                 (apply (guitarCompLong wave)+                        (TwoWay.Signal [] [])))+   in  y+++{-| Resample the reconstructed string sound+    so that notes can be played. -}+guitar :: (RealField.C a, Module.C a a) => a -> [a]+guitar freq =+   let srcFreq = 128 * freq+   in  Interpolation.multiRelativeZeroPadLinear 0+          (repeat (srcFreq `asTypeOf` freq)) guitarRawSimple++++{-* Tests for FilterGraphs -}++type CompositionDouble =+        Composition.T TwoWay.T Double Double Double++{-| a simple lowpass used to create an exponential2 -}+--expo :: (RealField.C a, Module.C a a) => TwoWay.Signal a+expo :: TwoWay.Signal Double+expo =+   let _flt1 = Feedback (Serial [Prim (OneWay.Delay ([0] `asTypeOf` past))])+                       (Serial [Prim (OneWay.Mask+                                        ([0.9] `asTypeOf` past))])+       _flt2 = (Prim (TwoWay.Mask ([0.5] `asTypeOf` past)))+                 :: CompositionDouble+       flt3 = (Feedback (Serial [])+                        (Prim (TwoWay.Delay 1)))+                 :: CompositionDouble+       TwoWay.Signal past future = apply flt3 (TwoWay.Signal [] [1])+   in  TwoWay.Signal past (take 10 future)++type GraphDouble f = Graph.T f Int Double Double Double++simpleGraph :: TwoWay.Signal Double+simpleGraph =+   let out =+          Graph.apply+             (Graph.fromList+                [(0, []),+                 (1, [(0, TwoWay.Delay (-1))]),+                 (2, [(1, TwoWay.Mask [0.95])])] ::+                    GraphDouble TwoWay.T)+             (Graph.signalFromList+                [(0, TwoWay.Signal [] [1])])+   in  fromMaybe (error "requested output of non-existing socket")+                 (Graph.lookupSignal out (2::Int))++expoGraphTwoWay :: [Double]+expoGraphTwoWay =+   let out =+          Graph.apply+             (Graph.fromList+                [(0, [(2, TwoWay.Past [1])]),+                 (1, [(0, TwoWay.Delay 1)]),+                 (2, [(1, TwoWay.Mask [0.95])])] ::+                    GraphDouble TwoWay.T)+             (Graph.signalFromList+                [(0, TwoWay.Signal [] [])])+   in  TwoWay.take 20 $ TwoWay.delay 10+          (fromMaybe (error "requested output of non-existing socket")+             (Graph.lookupSignal out (0::Int)))+++expoGraph :: [Double]+expoGraph =+   let out =+          Graph.apply+             (Graph.fromList+                [(0, [(1, OneWay.Delay [0])]),+                 (1, [(0, OneWay.Mask [0.99])])] ::+                    GraphDouble OneWay.T)+             (Graph.signalFromList+                [(0, [1])])+   in  fromMaybe (error "requested output of non-existing socket")+                 (Graph.lookupSignal out (0::Int))++{-| make recursive flanger with help of the two way interpolation -}+flangedSaw :: Double -> [Double]+flangedSaw sampleRate =+   let {- The flanger's principal filter frequency will vary between+          flangeFreq * 2**flangeRange and flangeFreq / 2**flangeRange -}+       flangeFreq  = 1000+       flangeRange = 2+       sawFreq     = 440+       gain = 0.6+       vol  = 0.5++       {- 'control' contains the feedback times -}+       control  = map (\c -> sampleRate/flangeFreq * 2**(-flangeRange*c))+                      (map sin (iterate (pi/(0.5*sampleRate)+) 0))+       sawPast   = Osci.freqModSaw 0 (repeat (-sawFreq/sampleRate))+       sawFuture = Osci.freqModSaw 0 (repeat ( sawFreq/sampleRate))+       --lowNoise = amplify vol noise+       flt = Feedback+                (Prim (TwoWay.Mask [vol]))+                (Serial [Prim (TwoWay.Mask [gain]),+                         Prim (TwoWay.Past []),+                         Prim (TwoWay.ModFracDelay+                                  Interpolation.linear +                                     (TwoWay.Signal [] control))])+                :: CompositionDouble++   in  TwoWay.future+          (apply flt (TwoWay.Signal sawPast sawFuture))
+ src/Synthesizer/Filter/Fix.hs view
@@ -0,0 +1,38 @@+module Synthesizer.Filter.Fix where++import qualified Synthesizer.Filter.Graph as Graph+++{-|+A 'Graph.T' with numbered nodes is not very comfortable.+Better provide a 'Control.Monad.Fix.fix'-like function+which allows to enter a graph this way:++> fix $ \[v,w,y] ->+> [a·(u + d·w),+>  b·(v + e·y),+>  c· w]++-}++type T filter t a v  =+   [Channel filter t a v] -> [[(Channel filter t a v, filter t a v)]]++type ChannelId = Int++data Channel filter t a v =+   Channel {channelId     :: ChannelId,+            channelInputs :: [(ChannelId, filter t a v)]}+++fix :: T filter t a v -> [Channel filter t a v]+fix f =+   let cs = zipWith (\n inputs ->+               Channel n (map (\(c,filt) -> (channelId c, filt)) inputs))+               [0 ..] (f cs)+   in  cs+++toGraph :: T filter t a v -> Graph.T filter Int t a v+toGraph =+   Graph.fromList . map (\(Channel n inputs) -> (n, inputs)) . fix
+ src/Synthesizer/Filter/Graph.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}+module Synthesizer.Filter.Graph where++import qualified Prelude as P+import PreludeBase+import NumericPrelude++import qualified Synthesizer.Filter.Basic as FilterBasic+import Synthesizer.Filter.Basic (Filter, apply, )+import qualified Data.Map as Map+import Data.Map(Map)+import MathObj.DiscreteMap()  {- Module.C instances for Map -}++import qualified Number.Complex         as Complex+import qualified Algebra.RealField      as RealField+import qualified Algebra.Additive       as Additive+import qualified Algebra.Transcendental as Trans+import qualified Algebra.Module         as Module+import Algebra.Module((*>))+import Orthogonals(Scalar,inverse,add_to_diagonal)+++{-|+A filter network is a graph consisting+of nodes (input and output signals)+and edges (filter processes).+Output signals can be taken from every node,+inputs can be injected in some nodes+which means that the signal at this node is superposed with+the injected signal.+The same can be achieved by duplicating the network,+one duplicate per input,+and superposing the corresponding outputs.+It is also sensible to setup a graph without inputs,+e.g. a recursive filter with some initial conditions+that works independent from any input.++In opposition to electric filter networks+digital filter networks must be directed.++Test-case: leap-frog filters like++>     +-----------[d]-----------++>     v                         |+>(u) -+-> [a] (v) -+-> [b] (w) -+-> [c] (y) -+->+>                  ^                         |+>                  +-----------[e]-----------+++@+v = a·(u + d·w)+w = b·(v + e·y)+y = c· w+@++We model the general network by a list of nodes,+where each node is an adder that holds a list of its inputs.+Each input of a node is an output+of another node that has gone through a processor.+Additionally there may be one input from outside.+In principle a processor could be a simple filter network+as defined by the structure 'Filter'.++The network is an applyable filter+whenever each circle contains a delay.+To compute the transfer function+we have to solve a system of linear equations+which we can construct quite straight forward+from the processors' input lists.++The current design can be abstractly seen+as the system of linear equations:++  y = A*y + u++where A is a matrix containing the edges hosting the filters,+y the vector of output signals,+u the vector of input signals.+In this formulation the number of inputs and outputs must match+but since you are free to ignore some of the inputs and outputs+you can use nodes for pure output, pure input or both of them.++-}++newtype T filter i t a v =+   C (Map i+      [(i,          {- index of the processor whose output goes in here -}+        filter t a v  {- description of the filter -}+        )])+++newtype Signal list i v = Signal (Map i (list v))+++fromList :: (Ord i) => [(i, [(i, filter t a v)])] -> T filter i t a v+fromList = C . Map.fromList++toList :: T filter i t a v -> [(i, [(i, filter t a v)])]+toList (C fg) = Map.toList fg++signalFromList :: (Ord i) => [(i, list v)] -> Signal list i v+signalFromList = Signal . Map.fromList++signalToList :: Signal list i v -> [(i, list v)]+signalToList (Signal x) = Map.toList x++lookupSignal :: (Ord i) => Signal list i v -> i -> Maybe (list v)+lookupSignal (Signal x) = flip Map.lookup x+++{-+  These instance may help to include FilterGraphs+  in even bigger structures.+-}+instance (Ord i, Additive.C (list v), Eq (list v))+            => Additive.C (Signal list i v) where+   zero                      = Signal Additive.zero+   (+) (Signal x) (Signal y) = Signal ((Additive.+) x y)+   (-) (Signal x) (Signal y) = Signal ((Additive.-) x y)+   negate (Signal x)         = Signal (Additive.negate x)++instance (Ord i, Eq a, Additive.C a, Additive.C (list v), Eq (list v),+              Module.C a v, Module.C a (list v))+                 => Module.C a (Signal list i v) where+   s *> (Signal x) = Signal (s *> x)+++{-+   It would be interesting to make FilterGraphs+   an instance of Filter.+   To achieve that we had to make GraphSignals an instance of Module.C+   and the transferFunction would no longer return a factor+   but a function that maps input amplitudes+   of a given frequency to output amplitudes.++instance (Ord i, Show i, Filter list filter) =>+      Filter (Signal list i) (T filter i) where+-}++apply :: (Ord i, Show i, Additive.C t, Trans.C t, RealField.C t,+          Module.C a v, Module.C a (list v),+          Filter list filter) =>+   T filter i t a v -> Signal list i v -> Signal list i v+apply (C fg) (Signal inputs) =+   let getInput  i = Map.findWithDefault Additive.zero i inputs+       getOutput i = Map.findWithDefault+                         (error ("Unknown processor: "++show i)) i outputs+       output i edges =+          foldl (Additive.+) (getInput i) (map (\(j,f) ->+                   FilterBasic.apply f (getOutput j)) edges)+       outputs = Map.mapWithKey output fg+   in  Signal outputs++{-| Compute a matrix that tells how an input frequency+    is mapped to the various output nodes.++   According to the formulation given above+   we have to invert the matrix (I-A).++   Currently this is done by a QR decomposition for each frequency.+   It would be probably faster if we decompose+   the matrix containing polynomial elements.+   Then the inverted matrix would consist of some+   polynomial ratios which can be evaluated for each frequency.+-}+transferFunction ::+   (Ord i, Show i, Trans.C t,+    P.Fractional (Complex.T t), Scalar (Complex.T t),+      Module.C a t, Filter list filter) =>+         T filter i t a v -> t -> [[Complex.T t]]+transferFunction (C fg) w =+   let keys = Map.keys fg+       elts = Map.elems fg+       inputsToMap procs =+          Map.mapWithKey (\_ f -> FilterBasic.transferFunction f w)+                         (Map.fromList procs)+       makeRow procs =+          map (flip (Map.findWithDefault 0) (inputsToMap procs)) keys+       matrix = map makeRow elts+   in  inverse (add_to_diagonal (-1) matrix)
+ src/Synthesizer/Filter/Graphic.hs view
@@ -0,0 +1,7 @@+module Synthesizer.Filter.Graphic where++{-|+  This module should be populated with functions+  that create flowchart graphics from the filter networks+  of the 'Composition' module.+-}
+ src/Synthesizer/Filter/MonadFix.hs view
@@ -0,0 +1,44 @@+module Synthesizer.Filter.MonadFix where++import qualified Synthesizer.Filter.Graph as Graph+import qualified Synthesizer.Filter.Fix   as FFix++import Synthesizer.Filter.Fix (Channel(Channel), ChannelId)++import Control.Monad.Trans.State (StateT, evalStateT, get, modify, )+import Control.Monad.Trans.Writer (Writer, execWriter, tell, )+import Control.Monad.Trans (lift, )+++{-|+If you find 'Filter.Fix.T' still inconvenient,+and if you don't care about portability,+you can also use the following monad with the @mdo@ notation.++> mdo+>   v <- a·(u + d·w)+>   w <- b·(v + e·y)+>   y <- c· w++-}+++type T filter t a v x  =  StateT ChannelId (Writer [Channel filter t a v]) x++makeChannel ::+   [(ChannelId, filter t a v)] ->+   T filter t a v ChannelId+makeChannel inputs =+   do n <- get+      modify succ+      lift $ tell [Channel n inputs]+      return n+++run :: T filter t a v x -> [Channel filter t a v]+run m = execWriter (evalStateT m 0)+++toGraph :: T filter t a v x -> Graph.T filter Int t a v+toGraph =+   Graph.fromList . map (\(Channel n inputs) -> (n, inputs)) . run
+ src/Synthesizer/Filter/OneWay.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+module Synthesizer.Filter.OneWay where++import Synthesizer.Filter.Basic++import qualified Synthesizer.Plain.Interpolation as Interpolation+import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR+import Number.Complex(cis)++import qualified Algebra.Module   as Module+import qualified Algebra.Ring     as Ring+import qualified Algebra.Additive as Additive++import Algebra.Module(linearComb)+import Algebra.Additive(zero)++import PreludeBase+import NumericPrelude++type Signal = []++{-| shift signal in time -}+delay :: (Additive.C v) =>+   Int -> Signal v -> Signal v+delay = FiltNR.delayPad zero++delayOnce :: (Additive.C v) =>+   Signal v -> Signal v+delayOnce = (zero:)+++{-| Unmodulated non-recursive filter -}+nonRecursiveFilter :: Module.C a v =>+      [a] -> [v] -> [v]+nonRecursiveFilter = FiltNR.generic++{-| Modulated non-recursive filter. -}+nonRecursiveFilterMod :: Module.C a v =>+   [[a]] -> [v] -> [v]+nonRecursiveFilterMod ms x =+   zipWith linearComb ms (tail (scanl (flip (:)) [] x))+++{-| Description of a basic filter that can be used in larger networks. -}+data T t a v =+     Mask [a]+        {-^ A static filter described by its mask -}+   | ModMask (Signal [a])+        {-^ A modulated filter described by a list of masks -}+   | FracDelay (Interpolation.T t v) t+        {-^ Delay the signal by a fractional amount of samples.+            This is achieved by interpolation. -}+   | ModFracDelay (Interpolation.T t v) (Signal t)+        {-^ Delay with varying delay times.+            The delay times sequence must monotonically decrease.+            (This includes constant parts!) -}+   | Delay [v]+        {-^ Delay the signal by prepending another one -}++instance Filter [] T where++   apply (Mask         m)     = nonRecursiveFilter m+   apply (ModMask      m)     = nonRecursiveFilterMod m+   apply (FracDelay    ip t)  = Interpolation.multiRelativeZeroPad zero+                                   ip (-t) (repeat 1)+   apply (ModFracDelay ip ts) = Interpolation.multiRelativeZeroPad zero+                                   ip (- head ts) (repeat 1 - FiltNR.differentiate ts)+   apply (Delay        x)     = (x++)++   transferFunction (Mask        m) w = linearComb m (screw (negate w))+   transferFunction (FracDelay _ t) w = cis (negate w * t)+   transferFunction (Delay       x) w = cis (negate w * fromIntegral (length x))+   transferFunction _ _ =+      error "transfer function can't be computed for modulated filters"
+ src/Synthesizer/Filter/TwoWay.hs view
@@ -0,0 +1,247 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+module Synthesizer.Filter.TwoWay where++import Synthesizer.Filter.Basic++import qualified Synthesizer.Plain.Signal as Sig+import qualified Synthesizer.Plain.Interpolation as Ip+import qualified Synthesizer.Plain.Interpolation as Interpolation++import Algebra.Module(linearComb,(*>))++import qualified Algebra.Module    as Module+import qualified Algebra.RealField as RealField+import qualified Algebra.Ring      as Ring+import qualified Algebra.Additive  as Additive++import Number.Complex(cis, )+import Data.Function.HT (nest, )+import qualified Data.List as List++import PreludeBase hiding (take)+import NumericPrelude+++{-| A TwoWay.Signal stores values of the past and the future -}+data Signal v = Signal {past, future :: [v]}+   deriving (Show, Eq)++{-| Take n values starting from time zero.+    If you want clips from elsewhere,+    call 'take' after 'delay'. -}+take :: Int -> Signal v -> [v]+take n (Signal _ x) = List.take n x++zipSignalWith :: (a -> b -> c) -> Signal a -> Signal b -> Signal c+zipSignalWith f (Signal xPast xFuture) (Signal yPast yFuture) =+   (Signal (zipWith f xPast yPast) (zipWith f xFuture yFuture))++{-| Take the value at time zero. -}+origin :: Ring.C a => Signal a -> a+origin (Signal _ (x:_)) = x+origin _ = 0++{-| A signal that consists entirely of ones -}+ones :: Ring.C a => Signal a+ones = Signal (repeat 1) (repeat 1)++{-| shift signal in time,+    keep all values but if required pad with zeros -}+delay :: (Additive.C v) =>+   Int -> Signal v -> Signal v+delay = delayGen delayOnce++delayPad :: v -> Int -> Signal v -> Signal v+delayPad z = delayGen (delayPadOnce z)++{-| shift signal in time,+    zero values at either ends will be flushed -}+delayOpt :: (Eq v, Additive.C v) =>+   Int -> Signal v -> Signal v+delayOpt = delayGen delayOptOnce+++{-| Delay by one sample. -}+delayOnce :: (Additive.C v) =>+   Signal v -> Signal v+--delayOnce (Signal []     []) = ([],[])+delayOnce (Signal []     ys) = Signal [] (zero:ys)+delayOnce (Signal (x:xs) ys) = Signal xs (x:ys)++delayPadOnce :: v -> Signal v -> Signal v+--delayPadOnce _ (Signal []     []) = ([],[])+delayPadOnce z (Signal []     ys) = Signal [] (z:ys)+delayPadOnce _ (Signal (x:xs) ys) = Signal xs (x:ys)++delayOptOnce :: (Eq v, Additive.C v) =>+   Signal v -> Signal v+--delayOptOnce (Signal []     []) = Signal [] []+delayOptOnce (Signal []     ys) = Signal [] (zero:ys)+delayOptOnce (Signal (x:xs) []) = Signal xs (if x==zero then [] else x:[])+delayOptOnce (Signal (x:xs) ys) = Signal xs (x:ys)+++{-| General routine that supports delaying and prefetching+    using a general one-sample delaying routine. -}+delayGen :: (Signal v -> Signal v) ->+               Int -> Signal v -> Signal v+{- Using this optimization applications of recursive filters+   with zero initial conditions represented by an empty list will fail.+   This is because in this case the value of the first item of the future list+   depends on the first item of the input future list,+   whereas normally the first future value depends on no input future value,+   at all.+delayGen _ _ (Signal [] []) = Signal [] []+   cf. the next example -}+delayGen delOnce t =+    if t < 0+    then reverseTwoWay . nest (negate t) delOnce . reverseTwoWay+    else nest t delOnce++reverseTwoWay :: Signal v -> Signal v+reverseTwoWay (Signal x y) = Signal y x+++instance (Additive.C v) => Additive.C (Signal v) where+   zero                                = Signal zero zero+   (+)   (Signal y0 y1) (Signal x0 x1) = Signal (y0 + x0)   (y1 + x1)+   (-)   (Signal y0 y1) (Signal x0 x1) = Signal (y0 - x0)   (y1 - x1)+   negate               (Signal x0 x1) = Signal (negate x0) (negate x1)++instance (Module.C a v) => Module.C a (Signal v) where+   (*>)  s      (Signal x0 x1) = Signal (s *> x0) (s *> x1)+++++{-| for a Signal this means a reversion of the elements -}+flipPair :: (a,b) -> (b,a)+flipPair (x,y) = (y,x)++{- This example simulates what happens if you call+     apply (Feedback (Serial []) (Prim (Delay 1)) []) ([],[1])+   depending on the implementation of delayGen it may work or+   loop infinitely when yFuture is computed.+   It's even before the first element of yFuture is computed.+   Note, that the equivalent+     apply (Feedback (Serial []) (Prim (Delay 1)) [0]) ([],[1])+   works! (i.e. set yPast = [0] -}+testDelayGen :: Signal Double+testDelayGen =+   let yPast = []+       x = Signal [] [1]+       y = Signal yPast yFuture+       Signal _ yFuture = delayOnce (x + y)+       -- Signal _ yFuture = delayOptOnce (add x y)+       -- Signal _ yFuture = delayGen delayOnce 1 (add x y)+   in  Signal yPast (List.take 10 yFuture)++++{-| Unmodulated non-recursive filter -}+nonRecursiveFilter :: Module.C a v =>+      [a] -> Signal v -> Signal v+nonRecursiveFilter m x =+   linearComb m (iterate delayOnce x)++{-| Modulated non-recursive filter.+    The number of values before time 0 (past) or+    the filter mask lengths must be at most finite. -}+nonRecursiveFilterMod :: Module.C a v =>+   Signal [a] -> Signal v -> Signal v+nonRecursiveFilterMod (Signal mpre msuf) x =+   let (pre, suf) = unzip (map (\(Signal a b) -> (a,b)) (iterate delayOnce x))+   in  Signal (zipWith linearComb mpre pre) (zipWith linearComb msuf suf)+++{-| Interpolation allowing negative frequencies,+    but requires storage of all past values. -}+interpolatePaddedZero :: (Ord a, RealField.C a) =>+   b -> Interpolation.T a b+      -> a -> Signal a -> Signal b -> Signal b+interpolatePaddedZero z ip phase fs (Signal xPast xFuture) =+   let (phInt, phFrac) = splitFraction phase+       xPadded = Signal (xPast ++ repeat z) (xFuture ++ repeat z)+   in  interpolateCore ip phFrac fs+          (delayPad z (Ip.offset ip - phInt) xPadded)++interpolatePaddedCyclic :: (Ord a, RealField.C a) =>+   Interpolation.T a b+      -> a -> Signal a -> Signal b -> Signal b+interpolatePaddedCyclic ip phase fs (Signal xPast xFuture) =+   let (phInt, phFrac) = splitFraction phase+       xCyclic = xFuture ++ reverse xPast+   in  interpolateCore ip phFrac fs+          -- mod is for efficiency, only+          (delayPad (error "interpolate: infinite signal needs no zero padding")+                    (mod (Ip.offset ip - phInt) (length xCyclic))+                    (Signal (cycle (reverse xCyclic)) (cycle xCyclic)))++-- note that the extrapolation may miss some of the first and some of the last points+interpolatePaddedExtrapolation :: (Ord a, RealField.C a) =>+   Interpolation.T a b+      -> a -> Signal a -> Signal b -> Signal b+interpolatePaddedExtrapolation ip phase fs x =+   interpolateCore ip (phase - fromIntegral (Ip.offset ip)) fs x++interpolateCore :: (Ord a, Ring.C a) =>+   Interpolation.T a b -> a -> Signal a -> Signal b -> Signal b+interpolateCore ip phase (Signal freqPast freqFuture) x =+   Signal (interpolateHalfWay ip (1-phase) freqPast+             (delayPadOnce (error "interpolateCore: infinite signal needs no zero padding")+                           (reverseTwoWay x)))+          (interpolateHalfWay ip phase freqFuture x)++interpolateHalfWay :: (Ord a, Ring.C a) =>+   Interpolation.T a b -> a -> [a] -> Signal b -> [b]+interpolateHalfWay ip phase freqs (Signal xPast xFuture) =+    if phase >= 1 && Sig.lengthAtLeast (1+Ip.number ip) xFuture+    then interpolateHalfWay ip (phase-1) freqs+            (Signal (head xFuture : xPast) (tail xFuture))+    else if phase < 0 && Sig.lengthAtLeast 1 xPast+         then interpolateHalfWay ip (phase + 1) freqs+                 (Signal (tail xPast) (head xPast : xFuture))+         else Ip.func ip phase xFuture :+              interpolateHalfWay ip (phase + head freqs) (tail freqs)+                 (Signal xPast xFuture)+++{-| Description of a basic filter that can be used in larger networks. -}+data T t a v =+     Mask [a]+        {-^ A static filter described by its mask -}+   | ModMask (Signal [a])+        {-^ A modulated filter described by a list of masks -}+   | FracDelay (Interpolation.T t v) t+        {-^ Delay the signal by a fractional amount of samples.+            This is achieved by interpolation. -}+   | ModFracDelay (Interpolation.T t v) (Signal t)+        {-^ Delay with varying delay times. -}+   | Delay Int+        {-^ Delay the signal by given amount of samples. -}+   | Past [v]+        {-^ Replace the past by the given one.+            This must be present in each recursive filter cycle+            to let the magic work! -}++instance Filter Signal T where++   apply (Mask         m)     = nonRecursiveFilter m+   apply (ModMask      m)     = nonRecursiveFilterMod m+   apply (FracDelay    ip t)  = interpolatePaddedZero zero+                                   ip (-t) ones+   apply (ModFracDelay ip ts) = interpolatePaddedZero zero+                                   ip (- origin ts) (ts - delay (-1) ts + ones)+   apply (Delay        t)     = delay t+   apply (Past         x)     = Signal x . future++   {- This is in principle the same as for one way filters.+      How can one merge them? -}+   transferFunction (Mask        m) w = linearComb m (screw (negate w))+   transferFunction (FracDelay _ t) w = cis (negate w * t)+   transferFunction (Delay       t) w = cis (negate w * fromIntegral t)+   transferFunction (Past        _) _ = 1+   transferFunction _ _ =+      error "transfer function can't be computed for modulated filters"
src/Synthesizer/Frame/Stereo.hs view
@@ -1,21 +1,28 @@-{-# OPTIONS_GHC -fglasgow-exts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-} {- This data type can be used as sample type for stereo signals. -} module Synthesizer.Frame.Stereo (T, left, right, cons, map, ) where -import qualified Synthesizer.Generic.SampledValue as Sample+import qualified Sound.Sox.Frame as Frame +import qualified Synthesizer.Interpolation.Class as Interpol import qualified Algebra.Module   as Module import qualified Algebra.Additive as Additive  import Foreign.Storable (Storable (..), )+import qualified Foreign.Storable.Record as Store +import Control.Applicative (liftA2, )+ import NumericPrelude import PreludeBase hiding (map) import Prelude ()  ++-- cf. Sound.Sox.Frame.Stereo data T a = Cons {left, right :: !a}  @@ -27,26 +34,22 @@ map :: (a -> b) -> T a -> T b map f (Cons l r) = Cons (f l) (f r) +instance Functor T where+   fmap = map -{-# INLINE roundUp #-}-roundUp :: Int -> Int -> Int-roundUp m x = x + mod (-x) m --- cf. StorableInstances+store :: Storable a => Store.Dictionary (T a)+store =+   Store.run $+   liftA2 Cons+      (Store.element left)+      (Store.element right)+ instance (Storable a) => Storable (T a) where-   sizeOf ~(Cons l r) =-      roundUp (alignment r) (sizeOf l) + sizeOf r-   alignment x = alignment (left x)-   peek ptr =-      do l <- peekByteOff ptr 0-         let peekSecond :: Storable b => b -> IO b-             peekSecond ru =-                peekByteOff ptr (roundUp (alignment ru) (sizeOf l))-         r <- peekSecond undefined-         return (Cons l r)-   poke ptr (Cons l r) =-      pokeByteOff ptr 0 l >>-      pokeByteOff ptr (roundUp (alignment r) (sizeOf l)) r+   sizeOf = Store.sizeOf store+   alignment = Store.alignment store+   peek = Store.peek store+   poke = Store.poke store   instance (Additive.C a) => Additive.C (T a) where@@ -63,4 +66,12 @@    {-# INLINE (*>) #-}    s *> (Cons l r)   = Cons (s *> l) (s *> r) -instance (Sample.C a) => Sample.C (T a) -- where+instance Interpol.C a b => Interpol.C a (T b) where+   {-# INLINE scaleAndAccumulate #-}+   scaleAndAccumulate =+      Interpol.makeMac2 Cons left right+++instance Frame.C a => Frame.C (T a) where+   numberOfChannels y = 2 * Frame.numberOfChannels (left y)+   format y = Frame.format (left y)
src/Synthesizer/FusionList/Control.hs view
@@ -1,4 +1,6 @@-{-# OPTIONS_GHC -O2 -fglasgow-exts -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-} {- | Copyright   :  (c) Henning Thielemann 2008 License     :  GPL@@ -26,8 +28,6 @@  -- import Number.Complex (cis,real) -- import qualified Number.Complex as Complex--- import Data.List (zipWith4, tails)--- import NumericPrelude.List (iterateAssoc)  import qualified Prelude as P import PreludeBase@@ -244,9 +244,9 @@ {-# INLINE curveMultiscale #-} curveMultiscale :: (y -> y -> y) -> y -> y -> Sig.T y curveMultiscale op d y0 =-   Sig.cons y0 (Sig.map (op y0) (Sig.iterateAssoc op d))+   Sig.cons y0 (Sig.map (op y0) (Sig.iterateAssociative op d))  {-# INLINE curveMultiscaleNeutral #-} curveMultiscaleNeutral :: (y -> y -> y) -> y -> y -> Sig.T y curveMultiscaleNeutral op d neutral =-   Sig.cons neutral (Sig.iterateAssoc op d)+   Sig.cons neutral (Sig.iterateAssociative op d)
src/Synthesizer/FusionList/Filter/NonRecursive.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright   :  (c) Henning Thielemann 2008 License     :  GPL@@ -11,7 +11,6 @@  import qualified Synthesizer.FusionList.Control as Ctrl import qualified Synthesizer.FusionList.Signal as Sig-import qualified Synthesizer.Generic.SampledValue as Sample  import qualified Algebra.Transcendental as Trans import qualified Algebra.Module         as Module@@ -20,9 +19,9 @@ import qualified Algebra.Ring           as Ring import qualified Algebra.Additive       as Additive -import Algebra.Module( {- linearComb, -} (*>))+import Algebra.Module( {- linearComb, -} (*>), ) -import Synthesizer.Utility (nest)+import Data.Function.HT (nest, )  import PreludeBase import NumericPrelude@@ -66,7 +65,7 @@    in  envelope (leadIn `Sig.append` hold `Sig.append` leadOut)  {-# INLINE fadeInOutStored #-}-fadeInOutStored :: (Field.C a, Sample.C a) =>+fadeInOutStored :: (Field.C a) =>    Int -> Int -> Int -> Sig.T a -> Sig.T a fadeInOutStored tIn tHold tOut xs =    let leadIn  = Sig.take tIn  $ Ctrl.linear (  recip (fromIntegral tIn))  0@@ -97,7 +96,7 @@  {-| Unmodulated non-recursive filter -} {-# INLINE generic #-}-generic :: (Module.C a v, Sample.C a) =>+generic :: (Module.C a v) =>    Sig.T a -> Sig.T v -> Sig.T v generic m x =    let mr = Sig.reverse m
src/Synthesizer/FusionList/Oscillator.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -O2 -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright   :  (c) Henning Thielemann 2006 License     :  GPL@@ -103,7 +103,7 @@ freqModSample ip wave phase freqs =     let len = Sig.length wave     in  Interpolation.multiRelativeCyclicPad-           ip (Phase.toRepresentative $ Phase.multiply len phase)+           ip (fromIntegral len * Phase.toRepresentative phase)            (Sig.map (* fromIntegral len) freqs) wave -}
src/Synthesizer/FusionList/Signal.hs view
@@ -1,9 +1,10 @@-{-# OPTIONS_GHC -O -fglasgow-exts -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fglasgow-exts #-} {- glasgow-exts are for the rules -} module Synthesizer.FusionList.Signal where -import qualified Synthesizer.Generic.Signal as SigG- import qualified Synthesizer.Plain.Signal   as Sig import qualified Synthesizer.Plain.Modifier as Modifier import qualified Data.List as List@@ -20,12 +21,14 @@  import qualified Synthesizer.Format as Format -import Control.Monad.State (State, runState, )+import Control.Monad.Trans.State (runState, ) -import Synthesizer.Utility-   (viewListL, viewListR, mapFst, mapSnd, mapPair, fst3, snd3, thd3)+import Data.Monoid (Monoid, mempty, mappend, ) -import NumericPrelude.Condition (toMaybe)+import qualified Data.List.HT    as ListHT+import Data.Tuple.HT (mapFst, mapSnd, mapPair, fst3, snd3, thd3, )++import Data.Maybe.HT (toMaybe) import NumericPrelude (fromInteger, )  import Text.Show (Show(showsPrec), showParen, showString, )@@ -58,44 +61,9 @@ instance Functor T where    fmap = map ---instance SigG.C T where-   empty = empty-   null = null-   cons = cons-   fromList = fromList-   toList = toList-   repeat = repeat-   cycle = cycle-   replicate = replicate-   iterate = iterate-   iterateAssoc op x = iterate (op x) x -- should be optimized-   unfoldR = generate-   map = map-   mix = mix-   zipWith = zipWith-   scanL = scanL-   viewL = viewL-   viewR = viewR-   foldL = foldL-   length = length-   take = take-   drop = drop-   splitAt = splitAt-   dropMarginRem = dropMarginRem-   takeWhile = takeWhile-   dropWhile = dropWhile-   span = span-   append = append-   concat = concat-   reverse = reverse-{--   mapAccumL = mapAccumL-   mapAccumR = mapAccumR--}-   crochetL = crochetL-+instance Monoid (T y) where+   mempty = empty+   mappend = append   {- * functions based on 'generate' -}@@ -114,7 +82,7 @@  {-# INLINE fromList #-} fromList :: [y] -> T y-fromList = generate viewListL+fromList = generate ListHT.viewL  {-# INLINE toList #-} toList :: T y -> [y]@@ -132,9 +100,9 @@ iterate :: (a -> a) -> a -> T a iterate f = generateInfinite (\x -> (x, f x)) -{-# INLINE iterateAssoc #-}-iterateAssoc :: (a -> a -> a) -> a -> T a-iterateAssoc op x = iterate (op x) x -- should be optimized+{-# INLINE iterateAssociative #-}+iterateAssociative :: (a -> a -> a) -> a -> T a+iterateAssociative op x = iterate (op x) x -- should be optimized  {-# INLINE repeat #-} repeat :: a -> T a@@ -486,7 +454,7 @@   "FusionList.reduceL/generate" forall f g a b.      reduceL g b (generate f a) =         snd-          (recurse (\(a0,b0) ->+          (recourse (\(a0,b0) ->               do (y,a1) <- f a0                  b1 <- g y b0                  Just (a1, b1)) (a,b)) ;@@ -543,11 +511,11 @@  viewL :: T a -> Maybe (a, T a) viewL =-   fmap (mapSnd Cons) . viewListL . decons+   fmap (mapSnd Cons) . ListHT.viewL . decons  viewR :: T a -> Maybe (T a, a) viewR =-   fmap (mapFst Cons) . viewListR . decons+   fmap (mapFst Cons) . ListHT.viewR . decons  extendConstant :: T a -> T a extendConstant xt =@@ -703,6 +671,21 @@          (_,ys) <- viewL ys0          return (f x ys0, (xs,ys))) +zipWithRest ::+   (y0 -> y0 -> y1) ->+   T y0 -> T y0 ->+   (T y1, (Bool, T y0))+zipWithRest f xs ys =+   mapPair (fromList, mapSnd fromList) $+   Sig.zipWithRest f+      (toList xs) (toList ys)++zipWithAppend ::+   (y -> y -> y) ->+   T y -> T y -> T y+zipWithAppend f xs ys =+   uncurry append $ mapSnd snd $ zipWithRest f xs ys+ delayLoop ::       (T y -> T y)             -- ^ processor that shall be run in a feedback loop@@ -726,8 +709,8 @@  -- maybe candidate for Utility -recurse :: (acc -> Maybe acc) -> acc -> acc-recurse f =+recourse :: (acc -> Maybe acc) -> acc -> acc+recourse f =    let aux x = maybe x aux (f x)    in  aux
src/Synthesizer/Generic/Analysis.hs view
@@ -1,8 +1,12 @@-{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-} module Synthesizer.Generic.Analysis where +import qualified Synthesizer.State.Analysis as Ana+ import qualified Synthesizer.Generic.Signal as SigG-import qualified Synthesizer.Generic.SampledValue as Sample+import qualified Synthesizer.Generic.Signal2 as SigG2  -- import qualified Synthesizer.Plain.Control as Ctrl @@ -37,27 +41,27 @@ {- | Volume based on Manhattan norm. -}-volumeMaximum :: (Real.C y, Sample.C y, SigG.C sig) => sig y -> y+volumeMaximum :: (Real.C y, SigG.Read sig y) => sig y -> y volumeMaximum =-   SigG.foldL max zero . rectify---   maximum . rectify+   Ana.volumeMaximum . SigG.toState  {- | Volume based on Energy norm. -}-volumeEuclidean :: (Algebraic.C y, Sample.C y, SigG.C sig) => sig y -> y+volumeEuclidean :: (Algebraic.C y, SigG.Read sig y) => sig y -> y volumeEuclidean =-   Algebraic.sqrt . volumeEuclideanSqr+   Ana.volumeEuclidean . SigG.toState -volumeEuclideanSqr :: (Field.C y, Sample.C y, SigG.C sig) => sig y -> y+volumeEuclideanSqr :: (Field.C y, SigG.Read sig y) => sig y -> y volumeEuclideanSqr =-   average . SigG.map sqr+   Ana.volumeEuclideanSqr . SigG.toState  {- | Volume based on Sum norm. -}-volumeSum :: (Field.C y, Real.C y, Sample.C y, SigG.C sig) => sig y -> y-volumeSum = average . rectify+volumeSum :: (Field.C y, Real.C y, SigG.Read sig y) => sig y -> y+volumeSum =+   Ana.volumeSum . SigG.toState   @@ -65,36 +69,34 @@ Volume based on Manhattan norm. -} volumeVectorMaximum ::-   (NormedMax.C y yv, Ord y, Sample.C y, Sample.C yv, SigG.C sig) =>+   (NormedMax.C y yv, Ord y, SigG.Read sig yv) =>    sig yv -> y volumeVectorMaximum =-   SigG.foldL max zero . SigG.map NormedMax.norm---   NormedMax.norm---   maximum . SigG.map NormedMax.norm+   Ana.volumeVectorMaximum . SigG.toState  {- | Volume based on Energy norm. -} volumeVectorEuclidean ::-   (Algebraic.C y, NormedEuc.C y yv, Sample.C y, Sample.C yv, SigG.C sig) =>+   (Algebraic.C y, NormedEuc.C y yv, SigG.Read sig yv) =>    sig yv -> y volumeVectorEuclidean =-   Algebraic.sqrt . volumeVectorEuclideanSqr+   Ana.volumeVectorEuclidean . SigG.toState  volumeVectorEuclideanSqr ::-   (Field.C y, NormedEuc.Sqr y yv, Sample.C y, Sample.C yv, SigG.C sig) =>+   (Field.C y, NormedEuc.Sqr y yv, SigG.Read sig yv) =>    sig yv -> y volumeVectorEuclideanSqr =-   average . SigG.map NormedEuc.normSqr+   Ana.volumeVectorEuclideanSqr . SigG.toState  {- | Volume based on Sum norm. -} volumeVectorSum ::-   (NormedSum.C y yv, Field.C y, Sample.C y, Sample.C yv, SigG.C sig) =>+   (NormedSum.C y yv, Field.C y, SigG.Read sig yv) =>    sig yv -> y volumeVectorSum =-   average . SigG.map NormedSum.norm+   Ana.volumeVectorSum . SigG.toState   @@ -103,13 +105,9 @@ Compute minimum and maximum value of the stream the efficient way. Input list must be non-empty and finite. -}-bounds :: (Ord y, Sample.C y, SigG.C sig) => sig y -> (y,y)+bounds :: (Ord y, SigG.Read sig y) => sig y -> (y,y) bounds =-   maybe-      (error "Analysis.bounds: List must contain at least one element.")-      (\(x,xs) ->-          SigG.foldL (\(minX,maxX) y -> (min y minX, max y maxX)) (x,x) xs)-   . SigG.viewL+   Ana.bounds . SigG.toState   @@ -221,24 +219,24 @@ -}  {--histogramIntMap :: (RealField.C y, Sample.C y, SigG.C sig) =>+histogramIntMap :: (RealField.C y, SigG.Read sig y) =>    y -> sig y -> (Int, sig Int) histogramIntMap binsPerUnit =    histogramDiscreteIntMap . quantize binsPerUnit -quantize :: (RealField.C y, Sample.C y, SigG.C sig) =>+quantize :: (RealField.C y, SigG.Transform sig y) =>    y -> sig y -> sig Int quantize binsPerUnit = SigG.map (floor . (binsPerUnit*)) -attachOne :: (Sample.C i, SigG.C sig) => sig i -> sig (i,Int)+attachOne :: (Sample.C i) => sig i -> sig (i,Int) attachOne = SigG.map (\i -> (i,one))  meanValues ::-   (RealField.C y, Sample.C y, SigG.C sig) => sig y -> [(Int,y)]+   (RealField.C y, SigG.Read sig y) => sig y -> [(Int,y)] meanValues x = concatMap spread (zip x (tail x))  spread ::-   (RealField.C y, Sample.C y, SigG.C sig) => (y,y) -> [(Int,y)]+   (RealField.C y, SigG.Read sig y) => (y,y) -> [(Int,y)] spread (l0,r0) =    let (l,r) = if l0<=r0 then (l0,r0) else (r0,l0)        (li,lf) = splitFraction l@@ -259,33 +257,27 @@ This is identical to the arithmetic mean. -} directCurrentOffset ::-   (Field.C y, Sample.C y, SigG.C sig) => sig y -> y+   (Field.C y, SigG.Read sig y) => sig y -> y directCurrentOffset = average   scalarProduct ::-   (Ring.C y, Sample.C y, SigG.C sig) => sig y -> sig y -> y+   (Ring.C y, SigG.Read sig y) => sig y -> sig y -> y scalarProduct xs ys =-   SigG.sum (SigG.zipWith (*) xs ys)+   Ana.scalarProduct (SigG.toState xs) (SigG.toState ys)  {- | 'directCurrentOffset' must be non-zero. -}-centroid :: (Field.C y, Sample.C y, SigG.C sig) => sig y -> y-centroid xs =-   scalarProduct (SigG.iterate (one+) zero) xs / SigG.sum xs--{--centroidAlt :: (Field.C y, Sample.C y, SigG.C sig) => sig y -> y-centroidAlt xs =-   SigG.sum (scanr (+) zero (tail xs)) / sum xs--}+centroid :: (Field.C y, SigG.Read sig y) => sig y -> y+centroid =+   Ana.centroid . SigG.toState -average :: (Field.C y, Sample.C y, SigG.C sig) => sig y -> y-average x =-   SigG.sum x / fromIntegral (SigG.length x)+average :: (Field.C y, SigG.Read sig y) => sig y -> y+average =+   Ana.average . SigG.toState -rectify :: (Real.C y, Sample.C y, SigG.C sig) => sig y -> sig y+rectify :: (Real.C y, SigG.Transform sig y) => sig y -> sig y rectify = SigG.map abs  {- |@@ -298,20 +290,20 @@ @(x !! n >= 0) \/= (x !! (n+1) >= 0)@. The result will be one value shorter than the input. -}-zeros :: (Ord y, Ring.C y, Sample.C y, SigG.C sig) =>+zeros :: (Ord y, Ring.C y, SigG2.Transform sig y Bool) =>    sig y -> sig Bool zeros =-   SigG.zapWith (/=) . SigG.map (>=zero)+   SigG.mapAdjacent (/=) . SigG2.map (>=zero)    {- | Detect thresholds with a hysteresis. -}-flipFlopHysteresis :: (Ord y, Sample.C y, SigG.C sig) =>+flipFlopHysteresis :: (Ord y, SigG2.Transform sig y Bool) =>    (y,y) -> Bool -> sig y -> sig Bool flipFlopHysteresis (lower,upper) =-   SigG.scanL+   SigG2.scanL       (\state x ->           if state             then not(x<lower)
src/Synthesizer/Generic/Control.hs view
@@ -1,8 +1,10 @@-{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-} module Synthesizer.Generic.Control where  import qualified Synthesizer.Generic.Signal as SigG-import qualified Synthesizer.Generic.SampledValue as Sample+import qualified Synthesizer.Generic.Signal2 as SigG2  import Synthesizer.Generic.Displacement (raise) @@ -16,10 +18,10 @@ import Algebra.Module((*>))  import Number.Complex (cis,real)--- import qualified Number.Complex as Complex--- import Data.List (zipWith4, tails)--- import NumericPrelude.List (iterateAssoc)+import qualified Number.Complex as Complex +-- import Control.Applicative ((<$>), )+ import qualified Prelude as P import PreludeBase import NumericPrelude@@ -27,61 +29,97 @@  {- * Control curve generation -} -constant :: (Sample.C y, SigG.C sig) => y -> sig y+constant :: (SigG.Write sig y) =>+   SigG.LazySize -> y -> sig y constant = SigG.repeat  -linear :: (Additive.C y, Sample.C y, SigG.C sig) =>-      y   {-^ steepness -}+linear :: (Additive.C y, SigG.Write sig y) =>+      SigG.LazySize+   -> y   {-^ steepness -}    -> y   {-^ initial value -}-   -> sig y {-^ linear progression -}-linear d y0 = SigG.iterate (d+) y0+   -> sig y+          {-^ linear progression -}+linear size d y0 = SigG.iterate size (d+) y0  {- | Minimize rounding errors by reducing number of operations per element to a logarithmuc number. -}-linearMultiscale :: (Additive.C y, Sample.C y, SigG.C sig) =>-      y+linearMultiscale ::+   (Additive.C y, SigG.Write sig y) =>+      SigG.LazySize    -> y+   -> y    -> sig y-linearMultiscale = curveMultiscale (+)+linearMultiscale size =+   curveMultiscale size (+)  {- | Linear curve starting at zero. -}-linearMultiscaleNeutral :: (Additive.C y, Sample.C y, SigG.C sig) =>-      y+linearMultiscaleNeutral :: (Additive.C y, SigG.Write sig y) =>+      SigG.LazySize+   -> y    -> sig y-linearMultiscaleNeutral slope =-   curveMultiscaleNeutral (+) slope zero+linearMultiscaleNeutral size slope =+   curveMultiscaleNeutral size (+) slope zero +{- |+Linear curve of a fixed length.+The final value is not actually reached,+instead we stop one step before.+This way we can concatenate several lines+without duplicate adjacent values.+-}+line :: (Field.C y, SigG.Write sig y) =>+      SigG.LazySize+   -> Int   {-^ length -}+   -> (y,y) {-^ initial and final value -}+   -> sig y+            {-^ linear progression -}+line size n (y0,y1) =+   SigG.take n $ linear size ((y1-y0) / fromIntegral n) y0 -exponential, exponentialMultiscale :: (Trans.C y, Sample.C y, SigG.C sig) =>-      y   {-^ time where the function reaches 1\/e of the initial value -}++exponential, exponentialMultiscale ::+   (Trans.C y, SigG.Write sig y) =>+      SigG.LazySize+   -> y   {-^ time where the function reaches 1\/e of the initial value -}    -> y   {-^ initial value -}-   -> sig y {-^ exponential decay -}-exponential time = SigG.iterate (* exp (- recip time))-exponentialMultiscale time = curveMultiscale (*) (exp (- recip time))+   -> sig y+          {-^ exponential decay -}+exponential size time =+   SigG.iterate size (* exp (- recip time))+exponentialMultiscale size time =+   curveMultiscale size (*) (exp (- recip time)) -exponentialMultiscaleNeutral :: (Trans.C y, Sample.C y, SigG.C sig) =>-      y   {-^ time where the function reaches 1\/e of the initial value -}-   -> sig y {-^ exponential decay -}-exponentialMultiscaleNeutral time =-   curveMultiscaleNeutral (*) (exp (- recip time)) one+exponentialMultiscaleNeutral :: (Trans.C y, SigG.Write sig y) =>+      SigG.LazySize+   -> y   {-^ time where the function reaches 1\/e of the initial value -}+   -> sig y+          {-^ exponential decay -}+exponentialMultiscaleNeutral size time =+   curveMultiscaleNeutral size (*) (exp (- recip time)) one -exponential2, exponential2Multiscale :: (Trans.C y, Sample.C y, SigG.C sig) =>-      y   {-^ half life -}+exponential2, exponential2Multiscale :: (Trans.C y, SigG.Write sig y) =>+      SigG.LazySize+   -> y   {-^ half life -}    -> y   {-^ initial value -}-   -> sig y {-^ exponential decay -}-exponential2 halfLife = SigG.iterate (*  0.5 ** recip halfLife)-exponential2Multiscale halfLife = curveMultiscale (*) (0.5 ** recip halfLife)+   -> sig y+          {-^ exponential decay -}+exponential2 size halfLife =+   SigG.iterate size (*  0.5 ** recip halfLife)+exponential2Multiscale size halfLife =+   curveMultiscale size (*) (0.5 ** recip halfLife) -exponential2MultiscaleNeutral :: (Trans.C y, Sample.C y, SigG.C sig) =>-      y   {-^ half life -}-   -> sig y {-^ exponential decay -}-exponential2MultiscaleNeutral halfLife =-   curveMultiscaleNeutral (*) (0.5 ** recip halfLife) one+exponential2MultiscaleNeutral :: (Trans.C y, SigG.Write sig y) =>+      SigG.LazySize+   -> y   {-^ half life -}+   -> sig y+          {-^ exponential decay -}+exponential2MultiscaleNeutral size halfLife =+   curveMultiscaleNeutral size (*) (0.5 ** recip halfLife) one   @@ -90,32 +128,51 @@     which is straight-forward but requires more explicit signatures.     But since it is needed rarely I setup a separate function. -} vectorExponential ::-   (Trans.C y, Module.C y v, Sample.C v, SigG.C sig) =>-       y  {-^ time where the function reaches 1\/e of the initial value -}+   (Trans.C y, Module.C y v, SigG.Write sig v) =>+      SigG.LazySize+   ->  y  {-^ time where the function reaches 1\/e of the initial value -}    ->  v  {-^ initial value -}-   -> sig v {-^ exponential decay -}-vectorExponential time y0 = SigG.iterate (exp (-1/time) *>) y0+   -> sig v+          {-^ exponential decay -}+vectorExponential size time y0 =+   SigG.iterate size (exp (-1/time) *>) y0  vectorExponential2 ::-   (Trans.C y, Module.C y v, Sample.C v, SigG.C sig) =>-       y  {-^ half life -}+   (Trans.C y, Module.C y v, SigG.Write sig v) =>+      SigG.LazySize+   ->  y  {-^ half life -}    ->  v  {-^ initial value -}-   -> sig v {-^ exponential decay -}-vectorExponential2 halfLife y0 = SigG.iterate (0.5**(1/halfLife) *>) y0+   -> sig v+          {-^ exponential decay -}+vectorExponential2 size halfLife y0 =+   SigG.iterate size (0.5**(1/halfLife) *>) y0   -cosine, cosineMultiscale :: (Trans.C y, Sample.C y, SigG.C sig) =>-       y  {-^ time t0 where  1 is approached -}+cosine, cosineMultiscaleLinear :: (Trans.C y, SigG.Write sig y) =>+      SigG.LazySize+   ->  y  {-^ time t0 where  1 is approached -}    ->  y  {-^ time t1 where -1 is approached -}-   -> sig y {-^ a cosine wave where one half wave is between t0 and t1 -}-cosine = cosineWithSlope $-   \d x -> SigG.map cos (linear d x)+   -> sig y+          {-^ a cosine wave where one half wave is between t0 and t1 -}+cosine size = cosineWithSlope $+   \d x -> SigG.map cos (linear size d x) -cosineMultiscale = cosineWithSlope $-   \d x -> SigG.map real (curveMultiscale (*) (cis d) (cis x))+cosineMultiscaleLinear size = cosineWithSlope $+   \d x -> SigG.map cos (linearMultiscale size d x) +cosineMultiscale ::+   (Trans.C y, SigG.Write sig (Complex.T y),+    SigG2.Transform sig (Complex.T y) y) =>+      SigG.LazySize+   ->  y  {-^ time t0 where  1 is approached -}+   ->  y  {-^ time t1 where -1 is approached -}+   -> sig y+          {-^ a cosine wave where one half wave is between t0 and t1 -}+cosineMultiscale size = cosineWithSlope $+   \d x -> SigG2.map real (curveMultiscale size (*) (cis d) (cis x)) + cosineWithSlope :: (Trans.C y) =>       (y -> y -> signal)    ->  y@@ -126,10 +183,11 @@    in  c inc (-t0*inc)  -cubicHermite :: (Field.C y, Sample.C y, SigG.C sig) =>-   (y, (y,y)) -> (y, (y,y)) -> sig y-cubicHermite node0 node1 =-   SigG.map (cubicFunc node0 node1) (linear 1 0)+cubicHermite :: (Field.C y, SigG.Write sig y) =>+      SigG.LazySize+   -> (y, (y,y)) -> (y, (y,y)) -> sig y+cubicHermite size node0 node1 =+   SigG.map (cubicFunc node0 node1) $ linear size 1 0  {- | 0                                     16@@ -238,33 +296,33 @@ y0 |# ((d,c,y1), xs)  =  ControlPiece c y0 y1 d : xs  -piecewise :: (Trans.C y, RealField.C y, Sample.C y, SigG.C sig) =>-   [ControlPiece y] -> sig y-piecewise xs =+piecewise :: (Trans.C y, RealField.C y, SigG.Write sig y) =>+   SigG.LazySize -> [ControlPiece y] -> sig y+piecewise size xs =    let ts = scanl (\(_,fr) d -> splitFraction (fr+d))                   (0,1) (map pieceDur xs)    in  SigG.concat (zipWith3           (\n t (ControlPiece c yi0 yi1 d) ->-               piecewisePart yi0 yi1 t d n c)+               piecewisePart size yi0 yi1 t d n c)           (map fst (tail ts)) (map (subtract 1 . snd) ts)           xs)  -piecewisePart :: (Trans.C y, Sample.C y, SigG.C sig) =>-   y -> y -> y -> y -> Int -> Control y -> sig y-piecewisePart y0 y1 t0 d n ctrl =+piecewisePart :: (Trans.C y, SigG.Write sig y) =>+   SigG.LazySize -> y -> y -> y -> y -> Int -> Control y -> sig y+piecewisePart size y0 y1 t0 d n ctrl =    SigG.take n       (case ctrl of-         CtrlStep  -> constant y0-         CtrlLin   -> let s = (y1-y0)/d in linearMultiscale s (y0-t0*s)+         CtrlStep  -> constant size y0+         CtrlLin   -> let s = (y1-y0)/d in linearMultiscale size s (y0-t0*s)          CtrlExp s -> let y0' = y0-s; y1' = y1-s; yd = y0'/y1'-                      in  raise s (exponentialMultiscale (d / log yd)+                      in  raise s (exponentialMultiscale size (d / log yd)                                            (y0' * yd**(t0/d)))          CtrlCos   -> SigG.map                           (\y -> (1+y)*(y0/2)+(1-y)*(y1/2))-                          (cosineMultiscale t0 (t0+d))+                          (cosineMultiscaleLinear size t0 (t0+d))          CtrlCubic yd0 yd1 ->-            cubicHermite (t0,(y0,yd0)) (t0+d,(y1,yd1)))+            cubicHermite size (t0,(y0,yd0)) (t0+d,(y1,yd1)))  {-   exp (-1/time) == yd**(-1/d)@@ -282,13 +340,13 @@ {- * Auxiliary functions -}  -curveMultiscale :: (Sample.C y, SigG.C sig) =>-   (y -> y -> y) -> y -> y -> sig y-curveMultiscale op d y0 =-   SigG.cons y0 (SigG.map (op y0) (SigG.iterateAssoc op d))+curveMultiscale :: (SigG.Write sig y) =>+   SigG.LazySize -> (y -> y -> y) -> y -> y -> sig y+curveMultiscale size op d y0 =+   SigG.cons y0 . SigG.map (op y0) $ SigG.iterateAssociative size op d  -curveMultiscaleNeutral :: (Sample.C y, SigG.C sig) =>-   (y -> y -> y) -> y -> y -> sig y-curveMultiscaleNeutral op d neutral =-   SigG.cons neutral (SigG.iterateAssoc op d)+curveMultiscaleNeutral :: (SigG.Write sig y) =>+   SigG.LazySize -> (y -> y -> y) -> y -> y -> sig y+curveMultiscaleNeutral size op d neutral =+   SigG.cons neutral $ SigG.iterateAssociative size op d
+ src/Synthesizer/Generic/Cut.hs view
@@ -0,0 +1,258 @@+{- |+This module allows abstraction of operations+that operate on the time axis+and do also work on signal types without sample values.+The most distinctive instances are certainly+Dirac signals and chunky time values.+-}+module Synthesizer.Generic.Cut where++import qualified Synthesizer.Plain.Signal as Sig+import qualified Synthesizer.State.Signal as SigS+import qualified Synthesizer.FusionList.Signal as SigFL+-- import qualified Synthesizer.Storable.Signal as SigSt+import qualified Data.StorableVector.Lazy as Vector++-- import qualified Algebra.ToInteger as ToInteger+-- import qualified Numeric.NonNegative.Wrapper as NonNegW+import qualified Numeric.NonNegative.Class as NonNeg+import qualified Numeric.NonNegative.Chunky as Chunky++import Foreign.Storable (Storable)++import Data.Function (fix, )+import qualified Data.List as List+import Data.Tuple.HT (mapPair, )+import qualified Data.Monoid as Monoid+import Data.Monoid (Monoid, )++import qualified Prelude as P+import NumericPrelude+import Prelude+   (Bool, Int, String, (++), error,+    pred, (<=), (>=), (<),+    (.), not, (||), (&&), )+++class Read sig where+   null :: sig -> Bool+   length :: sig -> Int++class (Read sig, Monoid sig) => Transform sig where+   {- Monoid functions+   empty :: sig+   cycle :: sig -> sig+   append :: sig -> sig -> sig+   concat :: [sig] -> sig+   -}+   take :: Int -> sig -> sig+   drop :: Int -> sig -> sig+   -- can occur in an inner loop in Interpolation+   dropMarginRem :: Int -> Int -> sig -> (Int, sig)+   splitAt :: Int -> sig -> (sig, sig)+   reverse :: sig -> sig+++-- instance Storable y => Read SigSt.T y where+instance Storable y => Read (Vector.Vector y) where+   {-# INLINE null #-}+   null = Vector.null+   {-# INLINE length #-}+   length = Vector.length++instance Storable y => Transform (Vector.Vector y) where+   {-+   {-# INLINE empty #-}+   empty = Vector.empty+   {-# INLINE cycle #-}+   cycle = Vector.cycle+   {-# INLINE append #-}+   append = Vector.append+   {-# INLINE concat #-}+   concat = Vector.concat+   -}+   {-# INLINE take #-}+   take = Vector.take+   {-# INLINE drop #-}+   drop = Vector.drop+   {-# INLINE splitAt #-}+   splitAt = Vector.splitAt+   {-# INLINE dropMarginRem #-}+   dropMarginRem = Vector.dropMarginRem+   {-# INLINE reverse #-}+   reverse = Vector.reverse+++instance Read ([] y) where+   {-# INLINE null #-}+   null = List.null+   {-# INLINE length #-}+   length = List.length++instance Transform ([] y) where+   {-+   {-# INLINE empty #-}+   empty = []+   {-# INLINE cycle #-}+   cycle = List.cycle+   {-# INLINE append #-}+   append = (List.++)+   {-# INLINE concat #-}+   concat = List.concat+   -}+   {-# INLINE take #-}+   take = List.take+   {-# INLINE drop #-}+   drop = List.drop+   {-# INLINE dropMarginRem #-}+   dropMarginRem = Sig.dropMarginRem+   {-# INLINE splitAt #-}+   splitAt = List.splitAt+   {-# INLINE reverse #-}+   reverse = List.reverse+++instance Read (SigFL.T y) where+   {-# INLINE null #-}+   null = SigFL.null+   {-# INLINE length #-}+   length = SigFL.length++instance Transform (SigFL.T y) where+   {-+   {-# INLINE empty #-}+   empty = SigFL.empty+   {-# INLINE cycle #-}+   cycle = SigFL.cycle+   {-# INLINE append #-}+   append = SigFL.append+   {-# INLINE concat #-}+   concat = SigFL.concat+   -}++   {-# INLINE take #-}+   take = SigFL.take+   {-# INLINE drop #-}+   drop = SigFL.drop+   {-# INLINE dropMarginRem #-}+   dropMarginRem = SigFL.dropMarginRem+   {-# INLINE splitAt #-}+   splitAt = SigFL.splitAt+   {-# INLINE reverse #-}+   reverse = SigFL.reverse+++instance Read (SigS.T y) where+   {-# INLINE null #-}+   null = SigS.null+   {-# INLINE length #-}+   length = SigS.length++instance Transform (SigS.T y) where+   {-+   {-# INLINE empty #-}+   empty = SigS.empty+   {-# INLINE cycle #-}+   cycle = SigS.cycle+   {-# INLINE append #-}+   append = SigS.append+   {-# INLINE concat #-}+   concat = SigS.concat+   -}++   {-# INLINE take #-}+   take = SigS.take+   {-# INLINE drop #-}+   drop = SigS.drop+   {-# INLINE dropMarginRem #-}+   dropMarginRem = SigS.dropMarginRem+   {-# INLINE splitAt #-}+   splitAt n =+      -- This implementation is slow. Better leave it unimplemented?+      mapPair (SigS.fromList, SigS.fromList) .+      List.splitAt n . SigS.toList+   {-# INLINE reverse #-}+   reverse = SigS.reverse+++{-+useful for application of non-negative chunky numbers as gate signals+-}+instance (P.Integral a) => Read (Chunky.T a) where+   {-# INLINE null #-}+   null = List.null . Chunky.toChunks+   {-# INLINE length #-}+   length = sum . List.map (P.fromIntegral . P.toInteger) . Chunky.toChunks+++intToChunky :: (NonNeg.C a) => String -> Int -> Chunky.T a+intToChunky name =+   Chunky.fromNumber .+--   NonNegW.fromNumberMsg ("Generic.Cut."++name) .+   P.fromIntegral .+   (\x ->+      if x<0+        then error ("Generic.Cut.NonNeg.Chunky."++name++": negative argument")+        else x)++instance (P.Integral a, NonNeg.C a) => Transform (Chunky.T a) where+   {-# INLINE take #-}+   take n = P.min (intToChunky "take" n)+   {-# INLINE drop #-}+   drop n x = x NonNeg.-| intToChunky "drop" n+   {-# INLINE dropMarginRem #-}+   dropMarginRem n m x =+      let (z,d,b) =+             Chunky.minMaxDiff+                (intToChunky "dropMargin/n" n)+                (x NonNeg.-| intToChunky "dropMargin/m" m)+      in  (if b then 0 else P.fromIntegral (Chunky.toNumber d),+           x NonNeg.-| z)+   {-# INLINE splitAt #-}+   splitAt n x =+      let (z,d,b) = Chunky.minMaxDiff (intToChunky "splitAt" n) x+      in  (z, if b then d else Chunky.zero)+   {-# INLINE reverse #-}+   reverse = Chunky.fromChunks . P.reverse . Chunky.toChunks+++{-# INLINE empty #-}+empty :: (Monoid sig) => sig+empty = Monoid.mempty++{-# INLINE cycle #-}+cycle :: (Monoid sig) => sig -> sig+cycle x = fix (append x)++{-# INLINE append #-}+append :: (Monoid sig) => sig -> sig -> sig+append = Monoid.mappend++{-# INLINE concat #-}+concat :: (Monoid sig) => [sig] -> sig+concat = Monoid.mconcat+++{- |+Like @lengthAtLeast n xs  =  length xs >= n@,+but is more efficient, because it is more lazy.+-}+{-# INLINE lengthAtLeast #-}+lengthAtLeast :: (Transform sig) =>+   Int -> sig -> Bool+lengthAtLeast n xs =+   n<=0 || not (null (drop (pred n) xs))++{-# INLINE lengthAtMost #-}+lengthAtMost :: (Transform sig) =>+   Int -> sig -> Bool+lengthAtMost n xs =+   n>=0 && null (drop n xs)++{-# INLINE sliceVertical #-}+sliceVertical :: (Transform sig) =>+   Int -> sig -> SigS.T sig+sliceVertical n =+   SigS.map (take n) .+   SigS.takeWhile (not . null) .+   SigS.iterate (drop n)
src/Synthesizer/Generic/Displacement.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} {- | <http://en.wikipedia.org/wiki/Particle_displacement> -}@@ -7,7 +7,6 @@ import qualified Algebra.Additive              as Additive  import qualified Synthesizer.Generic.Signal as SigG-import qualified Synthesizer.Generic.SampledValue as Sample  -- import qualified Prelude as P import PreludeBase@@ -18,7 +17,7 @@  {-| Mix two signals.     In opposition to 'zipWith' the result has the length of the longer signal. -}-mix :: (Additive.C v, Sample.C v, SigG.C sig) =>+mix :: (Additive.C v, SigG.Transform sig v) =>    sig v -> sig v -> sig v mix = SigG.mix @@ -29,15 +28,15 @@ mixMono (x:xs) (y:ys) = x+y : mixMono xs ys -} -{-| Mix an arbitrary number of signals. -}-mixMulti :: (Additive.C v, Sample.C v, SigG.C sig) =>+{-| Mix one or more signals. -}+mixMulti :: (Additive.C v, SigG.Transform sig v) =>    [sig v] -> sig v mixMulti = foldl mix SigG.empty   {-| Add a number to all of the signal values.     This is useful for adjusting the center of a modulation. -}-raise :: (Additive.C v, Sample.C v, SigG.C sig) =>+raise :: (Additive.C v, SigG.Transform sig v) =>    v -> sig v -> sig v raise x = SigG.map ((+) x) @@ -47,6 +46,6 @@ In "Synthesizer.Basic.Distortion" you find a collection of appropriate distortion functions. -}-distort :: (Sample.C c, Sample.C v, SigG.C sig) =>+distort :: (SigG.Read sig c, SigG.Transform sig v) =>    (c -> v -> v) -> sig c -> sig v -> sig v distort = SigG.zipWith
src/Synthesizer/Generic/Filter/Delay.hs view
@@ -1,9 +1,10 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} module Synthesizer.Generic.Filter.Delay where +import qualified Synthesizer.Generic.Filter.NonRecursive as FiltNR import qualified Synthesizer.Generic.Interpolation as Interpolation-import qualified Synthesizer.Generic.SampledValue  as Sample-import qualified Synthesizer.Generic.Signal        as SigG+import qualified Synthesizer.Generic.Signal2 as SigG2+import qualified Synthesizer.Generic.Signal  as SigG  import qualified Algebra.RealField as RealField import qualified Algebra.Additive  as Additive@@ -17,30 +18,39 @@ {- * Shift -}  {-# INLINE static #-}-static :: (Additive.C y, Sample.C y, SigG.C sig) => Int -> sig y -> sig y-static = staticPad zero+static ::+   (Additive.C y, SigG.Write sig y) =>+   Int -> sig y -> sig y+static = FiltNR.delay  {-# INLINE staticPad #-}-staticPad :: (Sample.C y, SigG.C sig) => y -> Int -> sig y -> sig y-staticPad = Interpolation.delayPad+staticPad ::+   (SigG.Write sig y) =>+   y -> Int -> sig y -> sig y+staticPad = FiltNR.delayPad  {-# INLINE staticPos #-}-staticPos :: (Additive.C y, Sample.C y, SigG.C sig) => Int -> sig y -> sig y-staticPos n = SigG.append (SigG.replicate n zero)+staticPos ::+   (Additive.C y, SigG.Write sig y) =>+   Int -> sig y -> sig y+staticPos = FiltNR.delayPos  {-# INLINE staticNeg #-}-staticNeg :: (Sample.C y, SigG.C sig) => Int -> sig y -> sig y-staticNeg = SigG.drop+staticNeg ::+   (SigG.Write sig y) =>+   Int -> sig y -> sig y+staticNeg = FiltNR.delayNeg     {-# INLINE modulatedCore #-} modulatedCore ::-   (RealField.C a, Additive.C v, Sample.C a, Sample.C v, SigG.C sig) =>-   Interpolation.T sig a v -> Int -> sig a -> sig v -> sig v+   (RealField.C t, Additive.C y, SigG.Read sig t, SigG2.Transform sig t y) =>+   Interpolation.T t y -> Int ->+   sig t -> sig y -> sig y modulatedCore ip size =-   SigG.zipWithTails+   SigG2.zipWithTails       (\t -> Interpolation.single ip (fromIntegral size + t))  @@ -53,8 +63,10 @@ -} {-# INLINE modulated #-} modulated ::-   (RealField.C a, Additive.C v, Sample.C a, Sample.C v, SigG.C sig) =>-   Interpolation.T sig a v -> Int -> sig a -> sig v -> sig v+   (RealField.C t, Additive.C y,+    SigG.Read sig t, SigG2.Transform sig t y, SigG.Write sig y) =>+   Interpolation.T t y -> Int ->+   sig t -> sig y -> sig y modulated ip minDev ts xs =    let size = Interpolation.number ip - minDev    in  modulatedCore ip
src/Synthesizer/Generic/Filter/NonRecursive.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright   :  (c) Henning Thielemann 2008 License     :  GPL@@ -10,9 +10,7 @@ module Synthesizer.Generic.Filter.NonRecursive where  import qualified Synthesizer.Generic.Signal as SigG-import qualified Synthesizer.Generic.SampledValue as Sample -import qualified Synthesizer.Generic.Filter.Delay as Delay import qualified Synthesizer.Generic.Control as Ctrl  import qualified Algebra.Transcendental as Trans@@ -22,9 +20,9 @@ import qualified Algebra.Ring           as Ring import qualified Algebra.Additive       as Additive -import Algebra.Module( {- linearComb, -} (*>))+import Algebra.Module( {- linearComb, -} (*>), ) -import Synthesizer.Utility (nest)+import Data.Function.HT (nest, )  import PreludeBase import NumericPrelude@@ -35,25 +33,25 @@  {-# INLINE negate #-} negate ::-   (Additive.C a, Sample.C a, SigG.C sig) =>+   (Additive.C a, SigG.Transform sig a) =>    sig a -> sig a negate = SigG.map Additive.negate  {-# INLINE amplify #-} amplify ::-   (Ring.C a, Sample.C a, SigG.C sig) =>+   (Ring.C a, SigG.Transform sig a) =>    a -> sig a -> sig a amplify v = SigG.map (v*)  {-# INLINE amplifyVector #-} amplifyVector ::-   (Module.C a v, Sample.C v, SigG.C sig) =>+   (Module.C a v, SigG.Transform sig v) =>    a -> sig v -> sig v amplifyVector v = SigG.map (v*>)  {-# INLINE envelope #-} envelope ::-   (Ring.C a, Sample.C a, SigG.C sig) =>+   (Ring.C a, SigG.Transform sig a) =>       sig a  {-^ the envelope -}    -> sig a  {-^ the signal to be enveloped -}    -> sig a@@ -61,7 +59,7 @@  {-# INLINE envelopeVector #-} envelopeVector ::-   (Module.C a v, Sample.C a, Sample.C v, SigG.C sig) =>+   (Module.C a v, SigG.Read sig a, SigG.Transform sig v) =>       sig a  {-^ the envelope -}    -> sig v  {-^ the signal to be enveloped -}    -> sig v@@ -71,13 +69,22 @@  {-# INLINE fadeInOut #-} fadeInOut ::-   (Field.C a, Sample.C a, SigG.C sig) =>+   (Field.C a, SigG.Write sig a) =>    Int -> Int -> Int -> sig a -> sig a fadeInOut tIn tHold tOut xs =    let slopeIn  =                  recip (fromIntegral tIn)        slopeOut = Additive.negate (recip (fromIntegral tOut))-       leadIn  = SigG.take tIn  $ Ctrl.linear slopeIn  0-       leadOut = SigG.take tOut $ Ctrl.linear slopeOut 1+       {-+       Since we use the size only for the internal envelope+       no laziness effect can be observed outside the function.+       We could also create the envelope as State.Signal.+       But I assume that concatenating chunks of an envelope+       is more efficient than concatenating generator loops.+       However, our intermediate envelope is still observable,+       because we have to use SigG.Write class.+       -}+       leadIn  = SigG.take tIn  $ Ctrl.linear SigG.defaultLazySize slopeIn  0+       leadOut = SigG.take tOut $ Ctrl.linear SigG.defaultLazySize slopeOut 1        (partIn, partHoldOut) = SigG.splitAt tIn xs        (partHold, partOut)   = SigG.splitAt tHold partHoldOut    in  envelope leadIn partIn `SigG.append`@@ -87,15 +94,67 @@  {- * Smoothing -} +{-# INLINE delay #-}+delay :: (Additive.C y, SigG.Write sig y) =>+   Int -> sig y -> sig y+delay =+   delayPad zero +{-# INLINE delayPad #-}+delayPad :: (SigG.Write sig y) =>+   y -> Int -> sig y -> sig y+delayPad z n =+   if n<0+     then SigG.drop (Additive.negate n)+     else SigG.append (SigG.replicate SigG.defaultLazySize n z)++{-# INLINE delayPos #-}+delayPos :: (Additive.C y, SigG.Write sig y) =>+   Int -> sig y -> sig y+delayPos n =+   SigG.append (SigG.replicate SigG.defaultLazySize n zero)++{-# INLINE delayNeg #-}+delayNeg :: (SigG.Transform sig y) =>+   Int -> sig y -> sig y+delayNeg = SigG.drop++++{-# INLINE delayLazySize #-}+delayLazySize :: (Additive.C y, SigG.Write sig y) =>+   SigG.LazySize -> Int -> sig y -> sig y+delayLazySize size =+   delayPadLazySize size zero++{- |+The pad value @y@ must be defined,+otherwise the chunk size of the padding can be observed.+-}+{-# INLINE delayPadLazySize #-}+delayPadLazySize :: (SigG.Write sig y) =>+   SigG.LazySize -> y -> Int -> sig y -> sig y+delayPadLazySize size z n =+   if n<0+     then SigG.drop (Additive.negate n)+     else SigG.append (SigG.replicate size n z)++{-# INLINE delayPosLazySize #-}+delayPosLazySize :: (Additive.C y, SigG.Write sig y) =>+   SigG.LazySize -> Int -> sig y -> sig y+delayPosLazySize size n =+   SigG.append (SigG.replicate size n zero)+++ {-| Unmodulated non-recursive filter -} {-# INLINE generic #-} generic ::-   (Module.C a v, Sample.C a, Sample.C v, SigG.C sig) =>+   (Module.C a v, SigG.Transform sig a, SigG.Write sig v) =>    sig a -> sig v -> sig v generic m x =    let mr = SigG.reverse m-       xp = Delay.staticPos (pred (SigG.length m)) x+       xp = delayPos (pred (SigG.length m)) x    in  SigG.mapTails (SigG.linearComb mr) xp  {-@@ -130,7 +189,7 @@ -} {-# INLINE binomial #-} binomial ::-   (Trans.C a, RealField.C a, Module.C a v, Sample.C v, SigG.C sig) =>+   (Trans.C a, RealField.C a, Module.C a v, SigG.Transform sig v) =>    a -> a -> sig v -> sig v binomial ratio freq =    let width = ceiling (2 * ratioFreqToVariance ratio freq ^ 2)@@ -163,8 +222,8 @@  {-# INLINE binomial1 #-} binomial1 ::-   (Additive.C v, Sample.C v, SigG.C sig) => sig v -> sig v-binomial1 = SigG.zapWith (+)+   (Additive.C v, SigG.Transform sig v) => sig v -> sig v+binomial1 = SigG.mapAdjacent (+)   @@ -176,7 +235,7 @@ -} {-# INLINE sums #-} sums ::-   (Additive.C v, Sample.C v, SigG.C sig) =>+   (Additive.C v, SigG.Transform sig v) =>    Int -> sig v -> sig v sums n = SigG.mapTails (SigG.sum . SigG.take n) @@ -260,9 +319,9 @@ -} {-# INLINE differentiate #-} differentiate ::-   (Additive.C v, Sample.C v, SigG.C sig) =>+   (Additive.C v, SigG.Transform sig v) =>    sig v -> sig v-differentiate x = SigG.zapWith subtract x+differentiate x = SigG.mapAdjacent subtract x  {- | Central difference quotient.@@ -277,13 +336,20 @@  ToDo: Vector variant -}+{-+This implementation is a bit cumbersome,+but it fits both StorableVector and State.Signal+(since it avoids recomputation).+-} {-# INLINE differentiateCenter #-} differentiateCenter ::-   (Field.C v, Sample.C v, SigG.C sig) =>+   (Field.C v, SigG.Transform sig v) =>    sig v -> sig v differentiateCenter =-   SigG.zapWith (\(x0,_) (_,x1) -> (x1 - x0) * (1/2)) .-   SigG.zapWith (,)+   SigG.drop 2 .+   SigG.crochetL+      (\x0 (x1,x2) -> Just ((x2-x0)/2, (x0,x1)))+      (zero,zero)  {- | Second derivative.@@ -292,6 +358,6 @@ -} {-# INLINE differentiate2 #-} differentiate2 ::-   (Additive.C v, Sample.C v, SigG.C sig) =>+   (Additive.C v, SigG.Transform sig v) =>    sig v -> sig v differentiate2 = differentiate . differentiate
+ src/Synthesizer/Generic/Filter/Recursive/Comb.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++Comb filters, useful for emphasis of tones with harmonics+and for repeated echos.+-}+module Synthesizer.Generic.Filter.Recursive.Comb where++import qualified Synthesizer.Generic.Filter.NonRecursive as Filt+import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1++import qualified Synthesizer.Generic.Signal as SigG++import qualified Algebra.Module                as Module+-- import qualified Algebra.Field                 as Field+import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import qualified Prelude as P+import PreludeBase+import NumericPrelude+++{- |+The most simple version of the Karplus-Strong algorithm+which is suitable to simulate a plucked string.+It is similar to the 'runProc' function.+-}+{-# INLINE karplusStrong #-}+karplusStrong ::+   (Ring.C t, Module.C t y, SigG.Write sig y) =>+   Filt1.Parameter t -> sig y -> sig y+karplusStrong c wave =+   SigG.delayLoop (SigG.modifyStatic Filt1.lowpassModifier c) wave+++{- |+Infinitely many equi-delayed exponentially decaying echos.+The echos are clipped to the input length.+We think it is easier (and simpler to do efficiently)+to pad the input with zeros or whatever+instead of cutting the result according to the input length.+-}+{-# INLINE run #-}+run :: (Module.C t y, SigG.Write sig y) =>+   Int -> t -> sig y -> sig y+run time gain =+   runProc time (Filt.amplifyVector gain)++{- |+Echos of different delays.+Chunk size must be smaller than all of the delay times.+-}+{-# INLINE runMulti #-}+runMulti :: (Ring.C t, Module.C t y, SigG.Write sig y) =>+   [Int] -> t -> sig y -> sig y+runMulti times gain x =+    let y = foldl+               (SigG.zipWith (+)) x+               (map (flip Filt.delay (Filt.amplifyVector gain y)) times)+--               (map (flip Delay.staticPos (gain *> y)) times)+    in  y++{- | Echos can be piped through an arbitrary signal processor. -}+{-# INLINE runProc #-}+runProc :: (Additive.C y, SigG.Write sig y) =>+   Int -> (sig y -> sig y) -> sig y -> sig y+runProc = SigG.delayLoopOverlap
src/Synthesizer/Generic/Filter/Recursive/Integration.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright   :  (c) Henning Thielemann 2008 License     :  GPL@@ -11,8 +11,7 @@ -} module Synthesizer.Generic.Filter.Recursive.Integration where -import qualified Synthesizer.Generic.Signal       as SigG-import qualified Synthesizer.Generic.SampledValue as Sample+import qualified Synthesizer.Generic.Signal as SigG  -- import qualified Algebra.Field                 as Field -- import qualified Algebra.Ring                  as Ring@@ -29,7 +28,7 @@ It maintains the length of the signal. -} {-# INLINE run #-}-run :: (Additive.C v, Sample.C v, SigG.C sig) =>+run :: (Additive.C v, SigG.Transform sig v) =>    sig v -> sig v run =    SigG.crochetL (\x acc -> let y = x+acc in Just (y,y)) zero@@ -41,7 +40,7 @@ The signal become one element longer. -} {-# INLINE runInit #-}-runInit :: (Additive.C v, Sample.C v, SigG.C sig) =>+runInit :: (Additive.C v, SigG.Transform sig v) =>    v -> sig v -> sig v runInit = SigG.scanL (+)
src/Synthesizer/Generic/Filter/Recursive/MovingAverage.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright   :  (c) Henning Thielemann 2008 License     :  GPL@@ -14,13 +14,15 @@     ) where  import qualified Synthesizer.Generic.Signal  as SigG-import qualified Synthesizer.Generic.SampledValue as Sample+import qualified Synthesizer.Generic.Signal2 as SigG2  import qualified Synthesizer.Generic.Filter.Recursive.Integration as Integration import qualified Synthesizer.Generic.Filter.Delay as Delay -import Synthesizer.Utility (nest, )+import qualified Synthesizer.State.Signal as SigS +import Data.Function.HT (nest, )+ import qualified Algebra.Module                as Module import qualified Algebra.RealField             as RealField @@ -45,14 +47,14 @@ @ -} {-# INLINE sumsStaticInt #-}-sumsStaticInt :: (Additive.C v, Sample.C v, SigG.C sig) =>+sumsStaticInt :: (Additive.C v, SigG.Write sig v) =>    Int -> sig v -> sig v sumsStaticInt n xs =    Integration.run (sub xs (Delay.staticPos n xs))   {-# INLINE sub #-}-sub :: (Additive.C v, Sample.C v, SigG.C sig) =>+sub :: (Additive.C v, SigG.Transform sig v) =>    sig v -> sig v -> sig v sub xs ys =    SigG.mix xs (SigG.map Additive.negate ys)@@ -73,7 +75,7 @@  {-# INLINE sumFromToFrac #-} sumFromToFrac ::-   (RealField.C a, Module.C a v, Sample.C v, SigG.C sig) =>+   (RealField.C a, Module.C a v, SigG.Transform sig v) =>    a -> a -> sig v -> v sumFromToFrac from to xs =    let (fromInt, fromFrac) = splitFraction from@@ -96,7 +98,7 @@  {-# INLINE index #-} index ::-   (SigG.C sig, Sample.C y) =>+   (SigG.Transform sig y) =>    y -> Int -> sig y -> y index deflt n =    maybe deflt fst . SigG.viewL . SigG.drop n@@ -104,12 +106,11 @@  {-# INLINE addNext #-} addNext ::-   (Additive.C v, Sample.C a, SigG.C sig) =>+   (Additive.C v, SigG.Read sig a) =>    (a -> v) -> (v -> sig a -> v) -> v -> sig a -> v-addNext f next s xs =-   maybe s-      (\(y,ys) -> next (s + f y) ys)-      (SigG.viewL xs)+addNext f next s =+   SigG.switchL s+      (\y ys -> next (s + f y) ys)   {- |@@ -117,21 +118,30 @@ -} {-# INLINE sumDiffsModulated #-} sumDiffsModulated ::-   (RealField.C a, Module.C a v, Sample.C a, Sample.C v, SigG.C sig) =>+   (RealField.C a, Module.C a v, SigG2.Transform sig a v) =>    a -> sig a -> sig v -> sig v sumDiffsModulated d ds =    maybe (error "MovingAverage: signal must be non-empty because we prepended a zero before") fst .    SigG.viewR .    -- prevent negative d's since 'drop' cannot restore past values-   SigG.zipWithTails (uncurry sumFromToFrac)-       (SigG.zip (SigG.cons (d+1) ds) (SigG.map (1+) ds)) .+   zipRangesWithTails sumFromToFrac+      (SigG.cons (d+1) ds) (SigG.map (1+) ds) .    SigG.cons zero  {--   SigG.zipWithTails (uncurry sumFromToFrac)-      (SigG.zip (SigG.cons d (SigG.map (subtract 1) ds)) ds)+   zipRangesWithTails sumFromToFrac+      (SigG.cons d (SigG.map (subtract 1) ds)) ds -} +zipRangesWithTails ::+   (SigG2.Transform sig a v) =>+   (a -> a -> sig v -> v) -> sig a -> sig a -> sig v -> sig v+zipRangesWithTails f tls tus xs =+   SigG2.zipWithState+      (\(tl,suffix) tu -> f tl tu suffix)+      (SigS.zip (SigG.toState tls) (SigG.tails xs))+      tus+ {- {-# INLINE sumsModulated #-} sumsModulated :: (RealField.C a, Module.C a v) =>@@ -149,7 +159,7 @@ -} {-# INLINE sumsModulatedHalf #-} sumsModulatedHalf ::-   (RealField.C a, Module.C a v, Sample.C a, Sample.C v, SigG.C sig) =>+   (RealField.C a, Module.C a v, SigG2.Transform sig a v, SigG.Write sig v) =>    Int -> sig a -> sig v -> sig v sumsModulatedHalf maxDInt ds xs =    let maxD  = fromIntegral maxDInt@@ -161,9 +171,8 @@  {-# INLINE modulatedFrac #-} modulatedFrac ::-   (RealField.C a, Module.C a v, Sample.C a, Sample.C v, SigG.C sig) =>+   (RealField.C a, Module.C a v, SigG2.Transform sig a v, SigG.Write sig v) =>    Int -> sig a -> sig v -> sig v modulatedFrac maxDInt ds xs =    SigG.zipWith (\d y -> recip (2*d) *> y) ds $    sumsModulatedHalf maxDInt ds xs-
src/Synthesizer/Generic/Interpolation.hs view
@@ -1,66 +1,58 @@-{-# OPTIONS -fno-implicit-prelude #-}-{- |-ToDo:-use AffineSpace instead of Module for the particular interpolation types,-since affine combinations assert reconstruction of constant functions.-They are more natural for interpolation of internal control parameters.-However, how can cubic interpolation expressed by affine combinations-without divisions?--}-module Synthesizer.Generic.Interpolation where+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.Generic.Interpolation (+   T, func, offset, number,+   zeroPad, constantPad, cyclicPad, extrapolationPad,+   single,+   multiRelative,+   multiRelativeZeroPad, multiRelativeConstantPad,+   multiRelativeCyclicPad, multiRelativeExtrapolationPad,+   multiRelativeZeroPadConstant, multiRelativeZeroPadLinear,+   multiRelativeZeroPadCubic,+   ) where -import qualified Synthesizer.Generic.Control      as Ctrl-import qualified Synthesizer.Generic.SampledValue as Sample-import qualified Synthesizer.Generic.Signal       as SigG+import qualified Synthesizer.Interpolation as Interpolation+import Synthesizer.Interpolation (T, offset, number, )+import Synthesizer.Interpolation.Module (constant, linear, cubic, ) +import qualified Synthesizer.Generic.Signal  as SigG+import qualified Synthesizer.Generic.Signal2 as SigG2+import qualified Synthesizer.Generic.Filter.NonRecursive as FiltNR+ import qualified Algebra.Module    as Module import qualified Algebra.RealField as RealField-import qualified Algebra.Field     as Field-import qualified Algebra.Ring      as Ring+-- import qualified Algebra.Field     as Field+-- import qualified Algebra.Ring      as Ring import qualified Algebra.Additive  as Additive -import Algebra.Additive(zero)-import Algebra.Module((*>))-import Data.Maybe (fromMaybe)--import Control.Monad.State (StateT(StateT), evalStateT, ap, )-import Control.Applicative (Applicative(pure, (<*>)), (<$>), liftA2, )-import Synthesizer.ApplicativeUtility (liftA4, )-import Synthesizer.Utility (affineComb, )+import Algebra.Additive(zero, )+import Data.Maybe (fromMaybe, )  import PreludeBase import NumericPrelude  -{- | interpolation as needed for resampling -}-data T sig t y =-  Cons {-    number :: Int,  -- interpolation requires a total number of 'number'-    offset :: Int,  -- interpolation requires 'offset' values before the current-    func   :: t -> sig y -> y-  }-- {-* Interpolation with various padding methods -}  {-# INLINE zeroPad #-}-zeroPad :: (RealField.C t, Sample.C y, SigG.C sig) =>-   (T sig t y -> t -> sig y -> a) ->-   y -> T sig t y -> t -> sig y -> a+zeroPad :: (RealField.C t, SigG.Write sig y) =>+   (T t y -> t -> sig y -> a) ->+   y -> T t y -> t -> sig y -> a zeroPad interpolate z ip phase x =    let (phInt, phFrac) = splitFraction phase    in  interpolate ip phFrac-          (delayPad z (offset ip - phInt) (SigG.append x (SigG.repeat z)))+          (FiltNR.delayPad z (offset ip - phInt)+              (SigG.append x (SigG.repeat SigG.defaultLazySize z)))  {-# INLINE constantPad #-}-constantPad :: (RealField.C t, Sample.C y, SigG.C sig) =>-   (T sig t y -> t -> sig y -> a) ->-   T sig t y -> t -> sig y -> a+constantPad :: (RealField.C t, SigG.Write sig y) =>+   (T t y -> t -> sig y -> a) ->+   T t y -> t -> sig y -> a constantPad interpolate ip phase x =    let (phInt, phFrac) = splitFraction phase        xPad =           do (xFirst,_) <- SigG.viewL x-             return (delayPad xFirst (offset ip - phInt) (SigG.extendConstant x))+             return (FiltNR.delayPad xFirst+                (offset ip - phInt) (SigG.extendConstant SigG.defaultLazySize x))    in  interpolate ip phFrac           (fromMaybe SigG.empty xPad) @@ -69,9 +61,9 @@ Only for finite input signals. -} {-# INLINE cyclicPad #-}-cyclicPad :: (RealField.C t, Sample.C y, SigG.C sig) =>-   (T sig t y -> t -> sig y -> a) ->-   T sig t y -> t -> sig y -> a+cyclicPad :: (RealField.C t, SigG.Transform sig y) =>+   (T t y -> t -> sig y -> a) ->+   T t y -> t -> sig y -> a cyclicPad interpolate ip phase x =    let (phInt, phFrac) = splitFraction phase    in  interpolate ip phFrac@@ -81,9 +73,9 @@ The extrapolation may miss some of the first and some of the last points -} {-# INLINE extrapolationPad #-}-extrapolationPad :: (RealField.C t, Sample.C y, SigG.C sig) =>-   (T sig t y -> t -> sig y -> a) ->-   T sig t y -> t -> sig y -> a+extrapolationPad :: (RealField.C t, SigG.Transform sig y) =>+   (T t y -> t -> sig y -> a) ->+   T t y -> t -> sig y -> a extrapolationPad interpolate ip phase =    interpolate ip (phase - fromIntegral (offset ip)) {-@@ -94,17 +86,22 @@  {-* Interpolation of multiple values with various padding methods -} +func :: (SigG.Read sig y) =>+   T t y -> t -> sig y -> y+func ip phase =+   Interpolation.func ip phase . SigG.toState+ {-# INLINE skip #-}-skip :: (RealField.C t, Sample.C y, SigG.C sig) =>-   T sig t y -> (t, sig y) -> (t, sig y)+skip :: (RealField.C t, SigG.Transform sig y) =>+   T t y -> (t, sig y) -> (t, sig y) skip ip (phase0, x0) =    let (n, frac) = splitFraction phase0        (m, x1) = SigG.dropMarginRem (number ip) n x0    in  (fromIntegral m + frac, x1)  {-# INLINE single #-}-single :: (RealField.C t, Sample.C y, SigG.C sig) =>-   T sig t y -> t -> sig y -> y+single :: (RealField.C t, SigG.Transform sig y) =>+   T t y -> t -> sig y -> y single ip phase0 x0 =    uncurry (func ip) $ skip ip (phase0, x0) --   curry (uncurry (func ip) . skip ip)@@ -118,10 +115,10 @@ {- | All values of frequency control must be non-negative. -} {-# INLINE multiRelative #-} multiRelative ::-   (RealField.C t, Sample.C t, Sample.C y, SigG.C sig) =>-   T sig t y -> t -> sig y -> sig t -> sig y+   (RealField.C t, SigG2.Transform sig t y) =>+   T t y -> t -> sig y -> sig t -> sig y multiRelative ip phase0 x0 =-   SigG.crochetL+   SigG2.crochetL       (\freq pos ->           let (phase,x) = skip ip pos           in  Just (func ip phase x, (phase+freq,x)))@@ -130,22 +127,22 @@  {-# INLINE multiRelativeZeroPad #-} multiRelativeZeroPad ::-   (RealField.C t, Sample.C t, Sample.C y, SigG.C sig) =>-   y -> T sig t y -> t -> sig t -> sig y -> sig y+   (RealField.C t, SigG2.Transform sig t y, SigG.Write sig y) =>+   y -> T t y -> t -> sig t -> sig y -> sig y multiRelativeZeroPad z ip phase fs x =    zeroPad multiRelative z ip phase x fs  {-# INLINE multiRelativeConstantPad #-} multiRelativeConstantPad ::-   (RealField.C t, Sample.C t, Sample.C y, SigG.C sig) =>-   T sig t y -> t -> sig t -> sig y -> sig y+   (RealField.C t, SigG2.Transform sig t y, SigG.Write sig y) =>+   T t y -> t -> sig t -> sig y -> sig y multiRelativeConstantPad ip phase fs x =    constantPad multiRelative ip phase x fs  {-# INLINE multiRelativeCyclicPad #-} multiRelativeCyclicPad ::-   (RealField.C t, Sample.C t, Sample.C y, SigG.C sig) =>-   T sig t y -> t -> sig t -> sig y -> sig y+   (RealField.C t, SigG2.Transform sig t y) =>+   T t y -> t -> sig t -> sig y -> sig y multiRelativeCyclicPad ip phase fs x =    cyclicPad multiRelative ip phase x fs @@ -154,8 +151,8 @@ -} {-# INLINE multiRelativeExtrapolationPad #-} multiRelativeExtrapolationPad ::-   (RealField.C t, Sample.C t, Sample.C y, SigG.C sig) =>-   T sig t y -> t -> sig t -> sig y -> sig y+   (RealField.C t, SigG2.Transform sig t y) =>+   T t y -> t -> sig t -> sig y -> sig y multiRelativeExtrapolationPad ip phase fs x =    extrapolationPad multiRelative ip phase x fs {-@@ -167,182 +164,21 @@  {-# INLINE multiRelativeZeroPadConstant #-} multiRelativeZeroPadConstant ::-   (RealField.C t, Additive.C y, Sample.C t, Sample.C y, SigG.C sig) =>+   (RealField.C t, Additive.C y, SigG2.Transform sig t y, SigG.Write sig y) =>    t -> sig t -> sig y -> sig y-multiRelativeZeroPadConstant = multiRelativeZeroPad zero constant+multiRelativeZeroPadConstant =+   multiRelativeZeroPad zero constant  {-# INLINE multiRelativeZeroPadLinear #-} multiRelativeZeroPadLinear ::-   (RealField.C t, Module.C t y, Sample.C t, Sample.C y, SigG.C sig) =>+   (RealField.C t, Module.C t y, SigG2.Transform sig t y, SigG.Write sig y) =>    t -> sig t -> sig y -> sig y-multiRelativeZeroPadLinear = multiRelativeZeroPad zero linear+multiRelativeZeroPadLinear =+   multiRelativeZeroPad zero linear  {-# INLINE multiRelativeZeroPadCubic #-} multiRelativeZeroPadCubic ::-   (RealField.C t, Module.C t y, Sample.C t, Sample.C y, SigG.C sig) =>+   (RealField.C t, Module.C t y, SigG2.Transform sig t y, SigG.Write sig y) =>    t -> sig t -> sig y -> sig y-multiRelativeZeroPadCubic = multiRelativeZeroPad zero cubic---{-* Different kinds of interpolation -}--{-** Hard-wired interpolations -}--data PrefixReader sig a =-   PrefixReader Int (StateT sig Maybe a)--instance Functor (PrefixReader sig) where-   fmap f (PrefixReader count parser) =-      PrefixReader count (fmap f parser)--instance Applicative (PrefixReader sig) where-   pure = PrefixReader 0 . return-   (PrefixReader count0 parser0) <*> (PrefixReader count1 parser1) =-       PrefixReader (count0+count1) (parser0 `ap` parser1)--{-# INLINE getNode #-}-getNode :: (Sample.C y, SigG.C sig) =>-   PrefixReader (sig y) y-getNode = PrefixReader 1 (StateT SigG.viewL)--{-# INLINE fromPrefixReader #-}-fromPrefixReader :: (Sample.C y, SigG.C sig) =>-   String -> Int -> PrefixReader (sig y) (t -> y) -> T sig t y-fromPrefixReader name off (PrefixReader count parser) =-   Cons count off-      (\t xs ->-          maybe-             (error (name ++ " interpolation: not enough nodes"))-             ($t)-             (evalStateT parser xs))--{-| Consider the signal to be piecewise constant. -}-{-# INLINE constant #-}-constant :: (Sample.C y, SigG.C sig) => T sig t y-constant =-   fromPrefixReader "constant" 0 (const <$> getNode)--{-| Consider the signal to be piecewise linear. -}-{-# INLINE linear #-}-linear :: (Module.C t y, Sample.C y, SigG.C sig) => T sig t y-linear =-   fromPrefixReader "linear" 0-      (liftA2-          (\x0 x1 phase -> affineComb phase (x0,x1))-          getNode getNode)--{-| Consider the signal to be piecewise cubic,-    with smooth connections at the nodes.-    It uses a cubic curve which has node values-    x0 at 0 and x1 at 1 and derivatives-    (x1-xm1)/2 and (x2-x0)/2, respectively.-    You can see how it works-    if you evaluate the expression for t=0 and t=1-    as well as the derivative at these points. -}-{-# INLINE cubic #-}-cubic :: (Field.C t, Module.C t y, Sample.C y, SigG.C sig) => T sig t y-cubic =-   fromPrefixReader "cubic" 1-      (liftA4-         (\xm1 x0 x1 x2 t ->-            let lipm12 = affineComb t (xm1,x2)-                lip01  = affineComb t (x0, x1)-                three  = 3 `asTypeOf` t-            in  lip01 + (t*(t-1)/2) *>-                           (lipm12 + (x0+x1) - three *> lip01))-         getNode getNode getNode getNode)--{-# INLINE cubicAlt #-}-cubicAlt :: (Field.C t, Module.C t y, Sample.C y, SigG.C sig) => T sig t y-cubicAlt =-   fromPrefixReader "cubicAlt" 1-      (liftA4-         (\xm1 x0 x1 x2 t ->-          let half = 1/2 `asTypeOf` t-          in  cubicHalf    t  x0 (half *> (x1-xm1)) +-              cubicHalf (1-t) x1 (half *> (x0-x2)))-         getNode getNode getNode getNode)---{- \t -> cubicHalf t x x' has a double zero at 1 and-   at 0 it has value x and steepness x' -}-{-# INLINE cubicHalf #-}-cubicHalf :: (Module.C t y) => t -> y -> y -> y-cubicHalf t x x' =-   (t-1)^2 *> ((1+2*t)*>x + t*>x')----{-** Interpolation based on piecewise defined functions -}--{-# INLINE piecewise #-}-piecewise :: (Module.C t y, Sample.C t, Sample.C y, SigG.C sig) =>-   Int -> [t -> t] -> T sig t y-piecewise center ps =-   Cons (length ps) (center-1)-      (\t -> linearComb (SigG.reverse (SigG.fromList (map ($t) ps))))--{-# INLINE piecewiseConstant #-}-piecewiseConstant ::-   (Module.C t y, Sample.C t, Sample.C y, SigG.C sig) => T sig t y-piecewiseConstant =-   piecewise 1 [const 1]--{-# INLINE piecewiseLinear #-}-piecewiseLinear ::-   (Module.C t y, Sample.C t, Sample.C y, SigG.C sig) => T sig t y-piecewiseLinear =-   piecewise 1 [id, (1-)]--{-# INLINE piecewiseCubic #-}-piecewiseCubic ::-   (Field.C t, Module.C t y, Sample.C t, Sample.C y, SigG.C sig) => T sig t y-piecewiseCubic =-   piecewise 2 $-      Ctrl.cubicFunc (0,(0,0))    (1,(0,1/2)) :-      Ctrl.cubicFunc (0,(0,1/2))  (1,(1,0)) :-      Ctrl.cubicFunc (0,(1,0))    (1,(0,-1/2)) :-      Ctrl.cubicFunc (0,(0,-1/2)) (1,(0,0)) :-      []--{--GNUPlot.plotList [] $ take 100 $ interpolate (Zero 0) piecewiseCubic (-2.3 :: Double) (repeat 0.1) [2,1,2::Double]--}---{-** Interpolation based on arbitrary functions -}--{- | with this wrapper you can use the collection of interpolating functions from Donadio's DSP library -}-{-# INLINE function #-}-function :: (Module.C t y, Sample.C t, Sample.C y, SigG.C sig) =>-      (Int,Int)   {- ^ @(left extent, right extent)@, e.g. @(1,1)@ for linear hat -}-   -> (t -> t)-   -> T sig t y-function (left,right) f =-   let len = left+right-   in  Cons len left-          (\t -> linearComb $ SigG.reverse $-               SigG.map-                  (\x -> f (t + fromIntegral x))-                  (SigG.take len (SigG.iterate succ (-left))))-{--GNUPlot.plotList [] $ take 300 $ interpolate (Zero 0) (function (1,1) (\x -> exp (-6*x*x))) (-2.3 :: Double) (repeat 0.03) [2,1,2::Double]--}----- cf. Module.linearComb-{-# INLINE linearComb #-}-linearComb ::-   (SigG.C sig, Sample.C t, Sample.C y, Module.C t y) =>-   sig t -> sig y -> y-linearComb ts ys =-   SigG.sum $ SigG.zipWith (*>) ts ys----{-* Helper functions -}--{-# INLINE delayPad #-}-delayPad :: (Sample.C y, SigG.C sig) => y -> Int -> sig y -> sig y-delayPad z n =-   if n<0 then SigG.drop (negate n) else SigG.append (SigG.replicate n z)+multiRelativeZeroPadCubic =+   multiRelativeZeroPad zero cubic
src/Synthesizer/Generic/Noise.hs view
@@ -1,10 +1,14 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE FlexibleContexts #-} {- | Noise and random processes. -} module Synthesizer.Generic.Noise where -import qualified Synthesizer.Generic.Signal as SigG-import qualified Synthesizer.Generic.SampledValue as Sample+import qualified Synthesizer.State.Noise as Noise +import qualified Synthesizer.Generic.Signal  as SigG+import qualified Synthesizer.Generic.Signal2 as SigG2+import qualified Synthesizer.State.Signal      as SigS+ import qualified Algebra.Real                  as Real import qualified Algebra.Ring                  as Ring @@ -21,15 +25,16 @@ That is, variance is 1\/3. -} white ::-   (Ring.C y, Random y, Sample.C y, SigG.C sig) =>-   sig y-white = whiteGen (mkStdGen 12354)+   (Ring.C y, Random y, SigG.Write sig y) =>+   SigG.LazySize -> sig y+white size =+   SigG.fromState size $ Noise.white  whiteGen ::-   (Ring.C y, Random y, RandomGen g, Sample.C y, SigG.C sig) =>-   g -> sig y-whiteGen =-   SigG.unfoldR (Just . randomR (-1,1))+   (Ring.C y, Random y, RandomGen g, SigG.Write sig y) =>+   SigG.LazySize -> g -> sig y+whiteGen size =+   SigG.fromState size . Noise.whiteGen   {- |@@ -37,18 +42,14 @@ by a quadratic B-spline distribution. -} whiteQuadraticBSplineGen ::-   (Ring.C y, Random y, RandomGen g, Sample.C y, SigG.C sig) =>-   g -> sig y-whiteQuadraticBSplineGen g =-   let (g0,gr) = Rnd.split g-       (g1,g2) = Rnd.split gr-   in  whiteGen g0 `SigG.mix`-       whiteGen g1 `SigG.mix`-       whiteGen g2+   (Ring.C y, Random y, RandomGen g, SigG.Write sig y) =>+   SigG.LazySize -> g -> sig y+whiteQuadraticBSplineGen size =+   SigG.fromState size . Noise.whiteQuadraticBSplineGen   randomPeeks ::-   (Real.C y, Random y, Sample.C y, SigG.C sig) =>+   (Real.C y, Random y, SigG2.Transform sig y Bool) =>       sig y    {- ^ momentary densities, @p@ means that there is about one peak                       in the time range of @1\/p@ samples -}    -> sig Bool {- ^ Every occurence of 'True' represents a peak. -}@@ -56,9 +57,9 @@    randomPeeksGen (mkStdGen 876)  randomPeeksGen ::-   (Real.C y, Random y, RandomGen g, Sample.C y, SigG.C sig) =>+   (Real.C y, Random y, RandomGen g, SigG2.Transform sig y Bool) =>       g    -> sig y    -> sig Bool randomPeeksGen =-   SigG.zipWith (<) . SigG.unfoldR (Just . randomR (0,1))+   SigG2.zipWithState (<) . SigS.unfoldR (Just . randomR (0,1))
src/Synthesizer/Generic/Oscillator.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright   :  (c) Henning Thielemann 2006 License     :  GPL@@ -15,15 +15,20 @@ -} module Synthesizer.Generic.Oscillator where --- import qualified Synthesizer.Plain.ToneModulation as ToneMod+import qualified Synthesizer.State.Oscillator as OsciS+import qualified Synthesizer.Causal.Oscillator as OsciC+import qualified Synthesizer.Causal.Process as Causal+ import qualified Synthesizer.Basic.Wave       as Wave import qualified Synthesizer.Basic.Phase      as Phase -import qualified Synthesizer.Generic.Interpolation as Interpolation+import qualified Synthesizer.Causal.Interpolation as Interpolation -import qualified Synthesizer.Generic.Signal as SigG-import qualified Synthesizer.Generic.SampledValue as Sample+import qualified Synthesizer.Generic.Signal  as SigG+import qualified Synthesizer.Generic.Signal2 as SigG2 +import Control.Arrow ((>>>), )+ {- import qualified Algebra.RealTranscendental    as RealTrans import qualified Algebra.Module                as Module@@ -48,167 +53,110 @@  {- * Oscillators with arbitrary but constant waveforms -} -freqToPhase :: (RealField.C a, Sample.C a, SigG.C sig) =>-    Phase.T a -> sig a -> sig (Phase.T a)-freqToPhase phase freq =-    SigG.scanL (flip Phase.increment) phase freq-- {- | oscillator with constant frequency -}-static :: (RealField.C a, Sample.C a, Sample.C b, SigG.C sig) =>+static :: (RealField.C a, SigG.Write sig b) =>+   SigG.LazySize ->    Wave.T a b -> (Phase.T a -> a -> sig b)-static wave phase freq =-    SigG.map (Wave.apply wave) (SigG.iterate (Phase.increment freq) phase)+static size wave phase freq =+   SigG.fromState size (OsciS.static wave phase freq)  {- | oscillator with modulated frequency -}-freqMod :: (RealField.C a, Sample.C a, Sample.C b, SigG.C sig) =>+freqMod :: (RealField.C a, SigG2.Transform sig a b) =>    Wave.T a b -> Phase.T a -> sig a -> sig b-freqMod wave phase freqs =-    SigG.map (Wave.apply wave) (freqToPhase phase freqs)+freqMod wave phase =+   Causal.applyGeneric (OsciC.freqMod wave phase)  {- | oscillator with modulated phase -}-phaseMod :: (RealField.C a, Sample.C a, Sample.C b, SigG.C sig) =>+phaseMod :: (RealField.C a, SigG2.Transform sig a b) =>    Wave.T a b -> a -> sig a -> sig b-phaseMod wave = shapeMod (Wave.phaseOffset wave) zero+phaseMod wave =+   shapeMod (Wave.phaseOffset wave) zero  {- | oscillator with modulated shape -}-shapeMod :: (RealField.C a, Sample.C a, Sample.C b, Sample.C c, SigG.C sig) =>+shapeMod :: (RealField.C a, SigG2.Transform sig c b) =>    (c -> Wave.T a b) -> Phase.T a -> a -> sig c -> sig b-shapeMod wave phase freq parameters =-    SigG.zipWith (Wave.apply . wave) parameters (SigG.iterate (Phase.increment freq) phase)+shapeMod wave phase freq =+   Causal.applyGeneric (OsciC.shapeMod wave phase freq)  {- | oscillator with both phase and frequency modulation -}-phaseFreqMod :: (RealField.C a, Sample.C a, Sample.C b, SigG.C sig) =>+phaseFreqMod :: (RealField.C a, SigG2.Transform sig a b) =>    Wave.T a b -> sig a -> sig a -> sig b-phaseFreqMod wave = shapeFreqMod (Wave.phaseOffset wave) zero+phaseFreqMod wave =+   shapeFreqMod (Wave.phaseOffset wave) zero  {- | oscillator with both shape and frequency modulation -}-shapeFreqMod :: (RealField.C a, Sample.C a, Sample.C b, Sample.C c, SigG.C sig) =>+shapeFreqMod ::+   (RealField.C a, SigG.Read sig c, SigG2.Transform sig a b) =>    (c -> Wave.T a b) -> Phase.T a -> sig c -> sig a -> sig b-shapeFreqMod wave phase parameters freqs =-    SigG.zipWith (Wave.apply . wave) parameters (freqToPhase phase freqs)+shapeFreqMod wave phase parameters =+   Causal.applyGeneric+      (Causal.feedGenericFst parameters >>>+       OsciC.shapeFreqMod wave phase)   {- | oscillator with a sampled waveform with constant frequency-     This is essentially an interpolation with cyclic padding. -}-staticSample :: (RealField.C a, Sample.C a, Sample.C b, SigG.C sig) =>-   Interpolation.T sig a b -> [b] -> Phase.T a -> a -> sig b-staticSample ip wave phase freq =-    freqModSample ip wave phase (SigG.repeat freq)+This is essentially an interpolation with cyclic padding.+-}+staticSample :: (RealField.C a, SigG.Read wave b, SigG.Write sig b) =>+   SigG.LazySize ->+   Interpolation.T a b -> wave b -> Phase.T a -> a -> sig b+staticSample size ip wave phase freq =+   let len = fromIntegral $ SigG.length wave+   in  SigG.fromState size $+       Interpolation.relativeCyclicPad+          ip (len * Phase.toRepresentative phase)+          (SigG.toState wave)+       `Causal.applyConst`+       (freq * len)  {- | oscillator with a sampled waveform with modulated frequency-     Should behave homogenously for different types of interpolation. -}-freqModSample :: (RealField.C a, Sample.C a, Sample.C b, SigG.C sig) =>-   Interpolation.T sig a b -> [b] -> Phase.T a -> sig a -> sig b+Should behave homogenously for different types of interpolation.+-}+freqModSample :: (RealField.C a, SigG.Read wave b, SigG2.Transform sig a b) =>+   Interpolation.T a b -> wave b -> Phase.T a -> sig a -> sig b freqModSample ip wave phase freqs =-    let len = length wave-    in  Interpolation.multiRelativeCyclicPad-           ip (Phase.toRepresentative $ Phase.multiply len phase)-           (SigG.map (* fromIntegral len) freqs)-           (SigG.fromList wave)+   let len = fromIntegral $ SigG.length wave+   in  Interpolation.relativeCyclicPad+          ip (len * Phase.toRepresentative phase)+          (SigG.toState wave)+       `Causal.applyGeneric`+       SigG.map (* len) freqs -{--{- |-Shape control is a list of relative changes,-each of which must be non-negative in order to allow lazy processing.-'1' advances by one wave.-Frequency control can be negative.-If you want to use sampled waveforms as well-then use 'Wave.sample' in the list of waveforms.-With sampled waves this function is identical to HunkTranspose in Assampler. -Example: interpolate different versions-of 'Wave.oddCosine' and 'Wave.oddTriangle'.--You could also chop a tone into single waves-and use the waves as input for this function-but you certainly want to use-'Wave.sampledTone' or 'shapeFreqModFromSampledTone' instead,-because in the wave information for 'shapeFreqModSample'-shape and phase are strictly separated.--}-shapeFreqModSample :: (RealField.C c, RealField.C b, Sample.C a, SigG.C sig) =>-    Interpolation.T c (b -> a) -> [b -> a] -> c -> b -> sig c -> sig b -> sig a-shapeFreqModSample ip waves shape0 phase shapes freqs =-    SigG.zipWith ($)-       (Interpolation.multiRelativeConstantPad ip shape0 shapes waves)-       (freqToPhase phase freqs) {--GNUPlot.plotList [] $ take 500 $ shapeFreqModSample Interpolation.cubic (SigG.map Wave.truncOddCosine [0..3]) (0.1::Double) (0::Double) (repeat 0.005) (repeat 0.02)--}--{- |-Time stretching and frequency modulation of a pure tone.--We consider a tone as the result of a shape modulated oscillator,-and virtually reconstruct the waveform function-(a function of time and phase) by interpolation and resample it.-This way we can alter frequency and time progress of the tone independently.--This function is identical to using 'shapeFreqMod'-with a wave function constructed by 'Wave.sampledTone'-but it consumes the sampled source tone lazily-and thus allows only relative shape control with non-negative control steps.--The function is similar to 'shapeFreqModSample' but respects-that in a sampled tone, phase and shape control advance synchronously.-Actually we could re-use 'shapeFreqModSample' with modified phase values.-But we would have to cope with negative shape control jumps,-and waves would be padded locally cyclically.-The latter one is not wanted-since we want padding according to the adjacencies in the source tone.--Although the shape difference values must be non-negative-I hesitate to give them the type @Number.NonNegative.T t@-because then you cannot call this function with other types-of non-negative numbers like 'Number.NonNegativeChunky.T'.--The prototype tone signal is reproduced if-@freqs == repeat (1\/period)@ and @shapes == repeat 1@.--}-shapeFreqModFromSampledTone :: (RealField.C t, Sample.C a, SigG.C sig) =>-    Interpolation.T t y ->-    Interpolation.T t y ->-    t -> sig y -> t -> t -> sig t -> sig t -> sig y-shapeFreqModFromSampledTone-      ipLeap ipStep period sampledTone-      shape0 phase shapes freqs =-   SigG.map-      (uncurry (ToneMod.interpolateCell ipLeap ipStep))-      (ToneMod.oscillatorCells-          ipLeap ipStep period sampledTone-          (shape0, shapes) (phase, freqs))-{--GNUPlot.plotList [] $ take 1000 $ shapeFreqModFromSampledTone Interpolation.linear Interpolation.linear (1/0.07::Double) (staticSine (0::Double) 0.07) 0 0 (repeat 0.1) (repeat 0.01)-GNUPlot.plotList [] $ take 1000 $ shapeFreqModFromSampledTone Interpolation.linear Interpolation.linear (1/0.07::Double) (staticSine (0::Double) 0.07) 0 0 (repeat 0.1) (SigG.iterate (*(1-2e-3)) 0.01)-GNUPlot.plotList [] $ take 101 $ shapeFreqModFromSampledTone Interpolation.linear Interpolation.linear (1/0.07::Double) (SigG.iterate (1+) (0::Double)) 0 0 (repeat 1) (repeat 0.7)--}+Shape+phase modulating oscillators can be found in Causal.Oscillator. -} - {- * Oscillators with specific waveforms -}  {- | sine oscillator with static frequency -}-staticSine :: (Trans.C a, RealField.C a, Sample.C a, SigG.C sig) =>+staticSine :: (Trans.C a, RealField.C a, SigG.Write sig a) =>+   SigG.LazySize ->    Phase.T a -> a -> sig a-staticSine = static Wave.sine+staticSine size =+   static size Wave.sine  {- | sine oscillator with modulated frequency -}-freqModSine :: (Trans.C a, RealField.C a, Sample.C a, SigG.C sig) =>+freqModSine :: (Trans.C a, RealField.C a, SigG.Transform sig a) =>    Phase.T a -> sig a -> sig a-freqModSine = freqMod Wave.sine+freqModSine phase =+   Causal.applyGenericSameType (OsciC.freqMod Wave.sine phase)  {- | sine oscillator with modulated phase, useful for FM synthesis -}-phaseModSine :: (Trans.C a, RealField.C a, Sample.C a, SigG.C sig) =>+phaseModSine :: (Trans.C a, RealField.C a, SigG.Transform sig a) =>    a -> sig a -> sig a-phaseModSine = phaseMod Wave.sine+phaseModSine freq =+   Causal.applyGenericSameType (OsciC.phaseMod Wave.sine freq)  {- | saw tooth oscillator with modulated frequency -}-staticSaw :: (RealField.C a, Sample.C a, SigG.C sig) =>+staticSaw :: (RealField.C a, SigG.Write sig a) =>+   SigG.LazySize ->    Phase.T a -> a -> sig a-staticSaw = static Wave.saw+staticSaw size =+   static size Wave.saw  {- | saw tooth oscillator with modulated frequency -}-freqModSaw :: (RealField.C a, Sample.C a, SigG.C sig) =>+freqModSaw :: (RealField.C a, SigG.Transform sig a) =>    Phase.T a -> sig a -> sig a-freqModSaw = freqMod Wave.saw+freqModSaw phase =+   Causal.applyGenericSameType (OsciC.freqMod Wave.saw phase)
− src/Synthesizer/Generic/SampledValue.hs 
@@ -1,20 +0,0 @@-module Synthesizer.Generic.SampledValue where--import Foreign.Storable (Storable)-import StorableInstance ()--import qualified Number.Complex as Complex-import qualified Number.Ratio   as Ratio-import qualified Algebra.PrincipalIdealDomain as PID---class Storable a => C a -- where--instance C Bool -- where-instance C Int -- where-instance C Float -- where-instance C Double -- where-instance (C a, C b) => C (a,b) -- where-instance (C a, C b, C c) => C (a,b,c) -- where-instance (C a) => C (Complex.T a) -- where-instance (C a, PID.C a) => C (Ratio.T a) -- where
src/Synthesizer/Generic/Signal.hs view
@@ -1,171 +1,495 @@-{- OPTIONS_GHC -fglasgow-exts -}-{--Unfortunately we have to use the SampledValue constraint also for lists,-which means that we can only use Storable values for signals.-Maybe we can improve this situation using associated types.+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{- |+Type classes that give a uniform interface to+storable signals, stateful signals, lists, fusable lists.+Some of the signal types require constraints on the element type.+Storable signals require Storable elements.+Thus we need multiparameter type classes.+In this module we collect functions+where the element type is not altered by the function. -}-module Synthesizer.Generic.Signal where+module Synthesizer.Generic.Signal+   (module Synthesizer.Generic.Signal,+    Cut.null,+    Cut.length,+    Cut.empty,+    Cut.cycle,+    Cut.append,+    Cut.concat,+    Cut.take,+    Cut.drop,+    Cut.dropMarginRem,+    Cut.splitAt,+    Cut.reverse,+    Cut.lengthAtLeast,+    Cut.lengthAtMost,+    Cut.sliceVertical,+   ) where -import qualified Algebra.Module   as Module-import qualified Algebra.Additive as Additive+import Synthesizer.Generic.Cut (append, )+import qualified Synthesizer.Generic.Cut as Cut -import qualified Synthesizer.Generic.SampledValue as Sample+import qualified Synthesizer.Plain.Signal as Sig+import qualified Synthesizer.State.Signal as SigS+import qualified Synthesizer.FusionList.Signal as SigFL+import qualified Synthesizer.Storable.Signal as SigSt+import qualified Data.StorableVector.Lazy as Vector  import qualified Synthesizer.Plain.Modifier as Modifier -import Control.Monad.State (State, runState, )+import qualified Algebra.Module   as Module+import qualified Algebra.Additive as Additive +import Foreign.Storable (Storable)++import Control.Monad.Trans.State (runState, runStateT, )++import Data.Function (fix, )+import qualified Data.List.HT as ListHT import qualified Data.List as List+import Data.Tuple.HT (mapPair, mapFst, ) -import Synthesizer.Utility (fst3, snd3, thd3) import Prelude-   (Bool, Int, Maybe(Just), maybe,-    fst, snd, flip, uncurry, (.), not, )+   (Bool, Int, Maybe(Just), maybe, snd,+    flip, uncurry, (.), ($), id,+    fmap, return, )  -class C sig where-   empty :: (Sample.C y) => sig y-   null :: (Sample.C y) => sig y -> Bool-   cons :: (Sample.C y) => y -> sig y -> sig y-   fromList :: (Sample.C y) => [y] -> sig y-   toList :: (Sample.C y) => sig y -> [y]-   repeat :: (Sample.C y) => y -> sig y-   cycle :: (Sample.C y) => sig y -> sig y-   replicate :: (Sample.C y) => Int -> y -> sig y-   iterate :: (Sample.C y) => (y -> y) -> y -> sig y-   iterateAssoc :: (Sample.C y) => (y -> y -> y) -> y -> sig y-   unfoldR :: (Sample.C b) => (a -> Maybe (b,a)) -> a -> sig b-   map :: (Sample.C a, Sample.C b) => (a -> b) -> (sig a -> sig b)-   mix :: (Sample.C y, Additive.C y) => sig y -> sig y -> sig y-   zipWith :: (Sample.C a, Sample.C b, Sample.C c) =>-      (a -> b -> c) -> (sig a -> sig b -> sig c)-{--   zipWithTails :: (Sample.C a, Sample.C b, Sample.C c) =>-      (a -> T b -> c) -> T a -> T b -> T c+class Cut.Read (sig y) => Read sig y where+   toList :: sig y -> [y]+   toState :: sig y -> SigS.T y+--   toState :: StateT (sig y) Maybe y+   foldL :: (s -> y -> s) -> s -> sig y -> s+-- better move to Transform class?+   viewL :: sig y -> Maybe (y, sig y)+   viewR :: sig y -> Maybe (sig y, y)++class (Read sig y, Cut.Transform (sig y)) => Transform sig y where+   {- |+   This function belongs logically to the Write class,+   but since an empty signal contains no data,+   the maximum package size is irrelevant.+   This makes e.g. the definition of mixMulti more general.+   -}+   cons :: y -> sig y -> sig y+   takeWhile :: (y -> Bool) -> sig y -> sig y+   dropWhile :: (y -> Bool) -> sig y -> sig y+   span :: (y -> Bool) -> sig y -> (sig y, sig y)+   -- functions from Transform2 that are oftenly used with only one type variable+   map :: (y -> y) -> (sig y -> sig y)+   scanL :: (y -> y -> y) -> y -> sig y -> sig y+   crochetL :: (y -> s -> Maybe (y, s)) -> s -> sig y -> sig y+   zipWithAppend :: (y -> y -> y) -> sig y -> sig y -> sig y+++{- |+This type is used for specification of the maximum size of strict packets.+Packets can be smaller, can have different sizes in one signal.+In some kinds of streams, like lists and stateful generators,+the packet size is always 1.+The packet size is not just a burden caused by efficiency,+but we need control over packet size in applications with feedback. -}-   scanL :: (Sample.C a, Sample.C b) =>-      (a -> b -> a) -> a -> sig b -> sig a-   foldL :: (Sample.C b) => (a -> b -> a) -> a -> sig b -> a-   viewL :: (Sample.C a) => sig a -> Maybe (a, sig a)-   viewR :: (Sample.C a) => sig a -> Maybe (sig a, a)-   length :: (Sample.C y) => sig y -> Int-   take :: (Sample.C y) => Int -> sig y -> sig y-   drop :: (Sample.C y) => Int -> sig y -> sig y-   dropMarginRem :: (Sample.C y) => Int -> Int -> sig y -> (Int, sig y)-   splitAt :: (Sample.C y) => Int -> sig y -> (sig y, sig y)-   takeWhile :: (Sample.C y) => (y -> Bool) -> sig y -> sig y-   dropWhile :: (Sample.C y) => (y -> Bool) -> sig y -> sig y-   span :: (Sample.C y) => (y -> Bool) -> sig y -> (sig y, sig y)-   append :: (Sample.C y) => sig y -> sig y -> sig y-   concat :: (Sample.C y) => [sig y] -> sig y-   reverse :: (Sample.C y) => sig y -> sig y-{--   mapAccumL :: (Sample.C x, Sample.C y) =>-      (acc -> x -> (acc, y)) -> acc -> sig x -> (acc, sig y)-   mapAccumR :: (Sample.C x, Sample.C y) =>-      (acc -> x -> (acc, y)) -> acc -> sig x -> (acc, sig y)+newtype LazySize = LazySize Int++{- |+This can be used for internal signals+that have no observable effect on laziness.+E.g. when you construct a list+by @repeat defaultLazySize zero@+we assume that 'zero' is defined for all Additive types. -}-   crochetL :: (Sample.C x, Sample.C y) =>-      (x -> acc -> Maybe (y, acc)) -> acc -> sig x -> sig y+defaultLazySize :: LazySize+defaultLazySize =+   let (Vector.ChunkSize size) = Vector.defaultChunkSize+   in  LazySize size +{- |+We could provide the 'LazySize' by a Reader monad,+but we don't do that because we expect that the choice of the lazy size+is more local than say the choice of the sample rate.+E.g. there is no need to have the same laziness coarseness+for multiple signal processors.+-}+class Transform sig y => Write sig y where+   fromList :: LazySize -> [y] -> sig y+--   fromState :: LazySize -> SigS.T y -> sig y+--   fromState :: LazySize -> StateT s Maybe y -> s -> sig y+   repeat :: LazySize -> y -> sig y+   replicate :: LazySize -> Int -> y -> sig y+   iterate :: LazySize -> (y -> y) -> y -> sig y+   iterateAssociative :: LazySize -> (y -> y -> y) -> y -> sig y+   unfoldR :: LazySize -> (s -> Maybe (y,s)) -> s -> sig y -{-# INLINE sum #-}-sum :: (Additive.C a, Sample.C a, C sig) => sig a -> a-sum = foldL (Additive.+) Additive.zero -{--{-# INLINE tails #-}-tails :: (Sample.C y, C sig) => sig y -> [sig y]-tails =-   List.unfoldr (fmap (\x -> (x, fmap snd (viewL x)))) . Just--}+-- instance Storable y => Read SigSt.T y where+instance Storable y => Read Vector.Vector y where+   {-# INLINE toList #-}+   toList = Vector.unpack+   {-# INLINE toState #-}+   toState = SigS.fromStorableSignal+   {-# INLINE viewL #-}+   viewL = Vector.viewL+   {-# INLINE viewR #-}+   viewR = Vector.viewR+   {-# INLINE foldL #-}+   foldL = Vector.foldl -{-# INLINE zapWith #-}-zapWith :: (Sample.C a, Sample.C b, C sig) =>-   (a -> a -> b) -> sig a -> sig b-zapWith f xs0 =-   let xs1 = maybe empty snd (viewL xs0)-   in  zipWith f xs0 xs1+instance Storable y => Transform Vector.Vector y where+   {-# INLINE cons #-}+   cons = Vector.cons+   {-# INLINE takeWhile #-}+   takeWhile = Vector.takeWhile+   {-# INLINE dropWhile #-}+   dropWhile = Vector.dropWhile+   {-# INLINE span #-}+   span = Vector.span -{-# INLINE zip #-}-zip :: (Sample.C a, Sample.C b, C sig) =>-   sig a -> sig b -> sig (a,b)-zip = zipWith (,)+   {-# INLINE map #-}+   map = Vector.map+   {-# INLINE scanL #-}+   scanL = Vector.scanl+   {-# INLINE crochetL #-}+   crochetL = Vector.crochetL+   {-# INLINE zipWithAppend #-}+   zipWithAppend = SigSt.zipWithAppend  -{-# INLINE unzip #-}-unzip :: (Sample.C a, Sample.C b, C sig) =>-   sig (a,b) -> (sig a, sig b)-unzip xs =-   (map fst xs, map snd xs) -{-# INLINE unzip3 #-}-unzip3 :: (Sample.C a, Sample.C b, Sample.C c, C sig) =>-   sig (a,b,c) -> (sig a, sig b, sig c)-unzip3 xs =-   (map fst3 xs, map snd3 xs, map thd3 xs)+withStorableContext ::+   (Vector.ChunkSize -> a) -> (LazySize -> a)+withStorableContext f =+   \(LazySize size) -> f (Vector.ChunkSize size) +instance Storable y => Write Vector.Vector y where+   {-# INLINE fromList #-}+   fromList = withStorableContext $ \size -> Vector.pack size+   {-# INLINE repeat #-}+   repeat = withStorableContext $ \size -> Vector.repeat size+   {-# INLINE replicate #-}+   replicate = withStorableContext $ \size -> Vector.replicate size+   {-# INLINE iterate #-}+   iterate = withStorableContext $ \size -> Vector.iterate size+   {-# INLINE unfoldR #-}+   unfoldR = withStorableContext $ \size -> Vector.unfoldr size+   {-# INLINE iterateAssociative #-}+   iterateAssociative = withStorableContext $ \size op x -> Vector.iterate size (op x) x -- should be optimized +++instance Read [] y where+   {-# INLINE toList #-}+   toList = id+   {-# INLINE toState #-}+   toState = SigS.fromList+   {-# INLINE viewL #-}+   viewL = ListHT.viewL+   {-# INLINE viewR #-}+   viewR = ListHT.viewR+   {-# INLINE foldL #-}+   foldL = List.foldl++instance Transform [] y where+   {-# INLINE cons #-}+   cons = (:)+   {-# INLINE takeWhile #-}+   takeWhile = List.takeWhile+   {-# INLINE dropWhile #-}+   dropWhile = List.dropWhile+   {-# INLINE span #-}+   span = List.span++   {-# INLINE map #-}+   map = List.map+   {-# INLINE scanL #-}+   scanL = List.scanl+   {-# INLINE crochetL #-}+   crochetL = Sig.crochetL+   {-# INLINE zipWithAppend #-}+   zipWithAppend = Sig.zipWithAppend+++instance Write [] y where+   {-# INLINE fromList #-}+   fromList _ = id+   {-# INLINE repeat #-}+   repeat _ = List.repeat+   {-# INLINE replicate #-}+   replicate _ = List.replicate+   {-# INLINE iterate #-}+   iterate _ = List.iterate+   {-# INLINE unfoldR #-}+   unfoldR _ = List.unfoldr+   {-# INLINE iterateAssociative #-}+   iterateAssociative _ = ListHT.iterateAssociative++++instance Read SigFL.T y where+   {-# INLINE toList #-}+   toList = SigFL.toList+   {-# INLINE toState #-}+   toState = SigS.fromList . SigFL.toList+   {-# INLINE viewL #-}+   viewL = SigFL.viewL+   {-# INLINE viewR #-}+   viewR = SigFL.viewR+   {-# INLINE foldL #-}+   foldL = SigFL.foldL++instance Transform SigFL.T y where+   {-# INLINE cons #-}+   cons = SigFL.cons+   {-# INLINE takeWhile #-}+   takeWhile = SigFL.takeWhile+   {-# INLINE dropWhile #-}+   dropWhile = SigFL.dropWhile+   {-# INLINE span #-}+   span = SigFL.span++   {-# INLINE map #-}+   map = SigFL.map+   {-# INLINE scanL #-}+   scanL = SigFL.scanL+   {-# INLINE crochetL #-}+   crochetL = SigFL.crochetL+   {-# INLINE zipWithAppend #-}+   zipWithAppend = SigFL.zipWithAppend+++instance Write SigFL.T y where+   {-# INLINE fromList #-}+   fromList _ = SigFL.fromList+   {-# INLINE repeat #-}+   repeat _ = SigFL.repeat+   {-# INLINE replicate #-}+   replicate _ = SigFL.replicate+   {-# INLINE iterate #-}+   iterate _ = SigFL.iterate+   {-# INLINE unfoldR #-}+   unfoldR _ = SigFL.unfoldR+   {-# INLINE iterateAssociative #-}+   iterateAssociative _ = SigFL.iterateAssociative++++instance Read SigS.T y where+   {-# INLINE toList #-}+   toList = SigS.toList+   {-# INLINE toState #-}+   toState = id+   {-# INLINE viewL #-}+   viewL = SigS.viewL+   {-# INLINE viewR #-}+   viewR =+      -- This implementation is slow. Better leave it unimplemented?+      fmap (mapFst SigS.fromList) .+      ListHT.viewR . SigS.toList+   {-# INLINE foldL #-}+   foldL = SigS.foldL++instance Transform SigS.T y where+   {-# INLINE cons #-}+   cons = SigS.cons+   {-# INLINE takeWhile #-}+   takeWhile = SigS.takeWhile+   {-# INLINE dropWhile #-}+   dropWhile = SigS.dropWhile+   {-# INLINE span #-}+   span p =+      -- This implementation is slow. Better leave it unimplemented?+      mapPair (SigS.fromList, SigS.fromList) .+      List.span p . SigS.toList++   {-# INLINE map #-}+   map = SigS.map+   {-# INLINE scanL #-}+   scanL = SigS.scanL+   {-# INLINE crochetL #-}+   crochetL = SigS.crochetL+   {-# INLINE zipWithAppend #-}+   zipWithAppend = SigS.zipWithAppend+++instance Write SigS.T y where+   {-# INLINE fromList #-}+   fromList _ = SigS.fromList+   {-# INLINE repeat #-}+   repeat _ = SigS.repeat+   {-# INLINE replicate #-}+   replicate _ = SigS.replicate+   {-# INLINE iterate #-}+   iterate _ = SigS.iterate+   {-# INLINE unfoldR #-}+   unfoldR _ = SigS.unfoldR+   {-# INLINE iterateAssociative #-}+   iterateAssociative _ = SigS.iterateAssociative++++{-# INLINE switchL #-}+switchL :: (Read sig y) =>+   a -> (y -> sig y -> a) -> sig y -> a+switchL nothing just =+   maybe nothing (uncurry just) . viewL++{-# INLINE mix #-}+mix :: (Additive.C y, Transform sig y) =>+   sig y -> sig y -> sig y+mix = zipWithAppend (Additive.+)++{-# INLINE zipWith #-}+zipWith :: (Read sig a, Transform sig b) =>+   (a -> b -> b) -> (sig a -> sig b -> sig b)+zipWith h a =+   crochetL+      (\x0 a0 ->+          do (y0,a1) <- viewL a0+             Just (h y0 x0, a1))+      a+++{-# INLINE delay #-}+delay :: (Write sig y) =>+   LazySize -> y -> Int -> sig y -> sig y+delay size z n =+   append (replicate size n z)++{-# INLINE delayLoop #-}+delayLoop ::+   (Transform sig y) =>+      (sig y -> sig y)+            -- ^ processor that shall be run in a feedback loop+   -> sig y -- ^ prefix of the output, its length determines the delay+   -> sig y+delayLoop proc prefix =+   fix (append prefix . proc)+++{-# INLINE delayLoopOverlap #-}+delayLoopOverlap ::+   (Additive.C y, Write sig y) =>+      Int+   -> (sig y -> sig y)+            {- ^ Processor that shall be run in a feedback loop.+                 It's absolutely necessary that this function preserves the chunk structure+                 and that it does not look a chunk ahead.+                 That's guaranteed for processes that do not look ahead at all,+                 like 'Vector.map', 'Vector.crochetL' and+                 all of type @Causal.Process@. -}+   -> sig y -- ^ input+   -> sig y -- ^ output has the same length as the input+delayLoopOverlap time proc xs =+   fix (zipWith (Additive.+) xs .+        delay defaultLazySize Additive.zero time . proc)++++{-# INLINE sum #-}+sum :: (Additive.C a, Read sig a) => sig a -> a+sum = foldL (Additive.+) Additive.zero++{-# INLINE tails #-}+tails :: (Transform sig y) => sig y -> SigS.T (sig y)+tails =+   SigS.unfoldR (fmap (\x -> (x, fmap snd (viewL x)))) . Just++{-# INLINE mapAdjacent #-}+mapAdjacent :: (Read sig a, Transform sig a) =>+   (a -> a -> a) -> sig a -> sig a+mapAdjacent f xs0 =+   let xs1 = maybe xs0 snd (viewL xs0)+   in  zipWith f xs0 xs1+ {-# INLINE modifyStatic #-}-modifyStatic :: (Sample.C a, Sample.C b, C sig) =>-   Modifier.Simple s ctrl a b -> ctrl -> sig a -> sig b-modifyStatic (Modifier.Simple state proc) control x =-   crochetL (\a acc -> Just (runState (proc control a) acc)) state x+modifyStatic :: (Transform sig a) =>+   Modifier.Simple s ctrl a a -> ctrl -> sig a -> sig a+modifyStatic (Modifier.Simple state proc) control =+   crochetL (\a acc -> Just (runState (proc control a) acc)) state  {-| Here the control may vary over the time. -} {-# INLINE modifyModulated #-}-modifyModulated :: (Sample.C a, Sample.C b, Sample.C ctrl, C sig) =>-   Modifier.Simple s ctrl a b -> sig ctrl -> sig a -> sig b+modifyModulated :: (Transform sig a, Read sig ctrl) =>+   Modifier.Simple s ctrl a a -> sig ctrl -> sig a -> sig a+modifyModulated (Modifier.Simple state proc) control =+   crochetL+      (\x (acc0,cs0) ->+         do (c,cs1) <- viewL cs0+            let (y,acc1) = runState (proc c x) acc0+            return (y,(acc1,cs1)))+      (state,control)+{- modifyModulated (Modifier.Simple state proc) control x =    crochetL       (\ca acc -> Just (runState (uncurry proc ca) acc))       state (zip control x)-+-}  -- cf. Module.linearComb {-# INLINE linearComb #-} linearComb ::-   (Module.C t y, Sample.C t, Sample.C y, C sig) =>+   (Module.C t y, Read sig t, Read sig y) =>    sig t -> sig y -> y linearComb ts ys =-   sum (zipWith (Module.*>) ts ys)+   SigS.sum (SigS.zipWith (Module.*>) (toState ts) (toState ys))  -{-# INLINE sliceVert #-}-sliceVert :: (Sample.C y, C sig) =>-   Int -> sig y -> [sig y]-sliceVert n =-   List.map (take n) . List.takeWhile (not . null) . List.iterate (drop n)-+fromState :: (Write sig y) =>+   LazySize -> SigS.T y -> sig y+fromState size (SigS.Cons f x) =+   unfoldR size (runStateT f) x  {-# INLINE extendConstant #-}-extendConstant :: (Sample.C y, C sig) =>-   sig y -> sig y-extendConstant xt =-   maybe empty-      (append xt . repeat . snd)+extendConstant :: (Write sig y) =>+   LazySize -> sig y -> sig y+extendConstant size xt =+   maybe+      xt+      (append xt . repeat size . snd)       (viewR xt)   -- comonadic 'bind' -- only non-empty suffixes are processed {-# INLINE mapTails #-}-mapTails :: (Sample.C a, Sample.C b, C sig) =>-   (sig a -> b) -> sig a -> sig b-mapTails f =-   unfoldR (\xs ->+mapTails :: (Transform sig a) =>+   (sig a -> a) -> sig a -> sig a+mapTails f x =+   crochetL (\_ xs0 ->+      do (_,xs1) <- viewL xs0+         Just (f xs0, xs1))+      x x+{-+Implementation with unfoldR is more natural,+but it could not preserve the chunk structure of the input signal.+Thus we prefer crochetL, although we do not consume single elements of the input signal.+-}+mapTailsAlt ::+   (Read sig a, Write sig b) =>+   LazySize -> (sig a -> b) -> sig a -> sig b+mapTailsAlt size f =+   unfoldR size (\xs ->       do (_,ys) <- viewL xs          Just (f xs, ys)) --- only non-empty suffixes are processed+{- |+Only non-empty suffixes are processed.+More oftenly we might need++> zipWithTails :: (Read sig b, Transform2 sig a) =>+>    (b -> sig a -> a) -> sig b -> sig a -> sig a++this would preserve the chunk structure of @sig a@,+but it is a bit more hassle to implement that.+-} {-# INLINE zipWithTails #-}-zipWithTails :: (Sample.C a, Sample.C b, Sample.C c, C sig) =>-   (a -> sig b -> c) -> sig a -> sig b -> sig c+zipWithTails :: (Read sig b, Transform sig a) =>+   (a -> sig b -> a) -> sig a -> sig b -> sig a zipWithTails f =    flip (crochetL (\x ys0 ->       do (_,ys) <- viewL ys0          Just (f x ys0, ys)))-  {- instance (Additive.C y, Sample.C y, C sig) => Additive.C (sig y) where
+ src/Synthesizer/Generic/Signal2.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{- |+Type class for several signal storage types+that allows alter element types.+There is some overlap between the two @Transform@ classes.+This was done in order to save us+from ubiquitous @Transform sig y y@ constraints.+-}+module Synthesizer.Generic.Signal2 where++import Synthesizer.Generic.Signal (Read, viewL, sum, )+import qualified Synthesizer.Generic.Signal as SigG++import qualified Algebra.Module   as Module+-- import qualified Algebra.Additive as Additive++import qualified Synthesizer.State.Signal as SigS+import qualified Synthesizer.Plain.Signal as Sig+-- import qualified Synthesizer.Storable.Signal as SigSt+import qualified Data.StorableVector.Lazy as Vector++import qualified Synthesizer.Plain.Modifier as Modifier++import Foreign.Storable (Storable)++import Control.Monad.Trans.State (runState, )++import qualified Data.List as List++import Data.Tuple.HT (fst3, snd3, thd3, )+import Prelude+   (Bool, Int, Maybe(Just), maybe, fst, snd,+    flip,+    return, )+++class (SigG.Transform sig y0, SigG.Transform sig y1) =>+          Transform sig y0 y1 where+   map :: (y0 -> y1) -> (sig y0 -> sig y1)+   scanL :: (y1 -> y0 -> y1) -> y1 -> sig y0 -> sig y1+   crochetL :: (y0 -> s -> Maybe (y1, s)) -> s -> sig y0 -> sig y1+++instance (Storable y0, Storable y1) => Transform Vector.Vector y0 y1 where+   {-# INLINE map #-}+   map = Vector.map+   {-# INLINE scanL #-}+   scanL = Vector.scanl+   {-# INLINE crochetL #-}+   crochetL = Vector.crochetL+++instance Transform [] y0 y1 where+   {-# INLINE map #-}+   map = List.map+   {-# INLINE scanL #-}+   scanL = List.scanl+   {-# INLINE crochetL #-}+   crochetL = Sig.crochetL+++instance Transform SigS.T y0 y1 where+   {-# INLINE map #-}+   map = SigS.map+   {-# INLINE scanL #-}+   scanL = SigS.scanL+   {-# INLINE crochetL #-}+   crochetL = SigS.crochetL++++{-# INLINE zipWith #-}+zipWith :: (Read sig a, Transform sig b c) =>+   (a -> b -> c) -> (sig a -> sig b -> sig c)+zipWith h a =+   crochetL+      (\x0 a0 ->+          do (y0,a1) <- viewL a0+             Just (h y0 x0, a1))+      a++{-# INLINE mapAdjacent #-}+mapAdjacent :: (Read sig a, Transform sig a b) =>+   (a -> a -> b) -> sig a -> sig b+mapAdjacent f xs0 =+   let xs1 = maybe xs0 snd (viewL xs0)+   in  zipWith f xs0 xs1+++{-# INLINE zip #-}+zip :: (Read sig a, Transform sig b (a,b)) =>+   sig a -> sig b -> sig (a,b)+zip = zipWith (,)+++{-# INLINE unzip #-}+unzip :: (Transform sig (a,b) a, Transform sig (a,b) b) =>+   sig (a,b) -> (sig a, sig b)+unzip xs =+   (map fst xs, map snd xs)++{-# INLINE unzip3 #-}+unzip3 :: (Transform sig (a,b,c) a, Transform sig (a,b,c) b, Transform sig (a,b,c) c) =>+   sig (a,b,c) -> (sig a, sig b, sig c)+unzip3 xs =+   (map fst3 xs, map snd3 xs, map thd3 xs)++++{-# INLINE modifyStatic #-}+modifyStatic :: (Transform sig a b) =>+   Modifier.Simple s ctrl a b -> ctrl -> sig a -> sig b+modifyStatic (Modifier.Simple state proc) control =+   crochetL (\a acc -> Just (runState (proc control a) acc)) state++{-| Here the control may vary over the time. -}+{-# INLINE modifyModulated #-}+modifyModulated :: (Transform sig a b, Read sig ctrl) =>+   Modifier.Simple s ctrl a b -> sig ctrl -> sig a -> sig b+modifyModulated (Modifier.Simple state proc) control =+   crochetL+      (\x (acc0,cs0) ->+         do (c,cs1) <- viewL cs0+            let (y,acc1) = runState (proc c x) acc0+            return (y,(acc1,cs1)))+      (state,control)++linearComb ::+   (Module.C t y, Read sig t, Transform sig y y) =>+   sig t -> sig y -> y+linearComb ts ys =+   sum (zipWith (Module.*>) ts ys)++mapTails :: (Transform sig a b) =>+   (sig a -> b) -> sig a -> sig b+mapTails f x =+   crochetL (\_ xs0 ->+      do (_,xs1) <- viewL xs0+         Just (f xs0, xs1))+      x x++{-# INLINE zipWithTails #-}+zipWithTails :: (Read sig b, Transform sig a c) =>+   (a -> sig b -> c) -> sig a -> sig b -> sig c+zipWithTails f =+   flip (crochetL (\x ys0 ->+      do (_,ys) <- viewL ys0+         Just (f x ys0, ys)))++{-# INLINE zipWith2Tails #-}+zipWith2Tails :: (Read sig b, Read sig c, Transform sig a d) =>+   (a -> sig b -> sig c -> d) -> sig a -> sig b -> sig c -> sig d+zipWith2Tails f as bs cs =+   crochetL (\x (ys0,zs0) ->+      do (_,ys1) <- viewL ys0+         (_,zs1) <- viewL zs0+         Just (f x ys0 zs0, (ys1,zs1)))+      (bs,cs) as++zipWithState :: (Transform sig b c) =>+   (a -> b -> c) -> SigS.T a -> sig b -> sig c+zipWithState f =+   crochetL (\b as0 ->+      do (a,as1) <- SigS.viewL as0+         Just (f a b, as1))
+ src/Synthesizer/Generic/Tutorial.hs view
@@ -0,0 +1,231 @@+{-# LANGUAGE FlexibleContexts #-}+{- |+In this module we demonstrate techniques for getting sound in real-time.+Getting real-time performance is mostly an issue of the right signal data structure.+However, there is no one-size-fits-all data structure.+For choosing the right one, you need to understand how various data structures work,+what are their strengths and what are their weaknesses.+-}+module Synthesizer.Generic.Tutorial+{-# DEPRECATED "do not import that module, it is only intended for demonstration" #-}+ where++import qualified Synthesizer.Plain.Tutorial as Tutorial -- needed for Haddock++import qualified Sound.Sox.Play as Play+import qualified Sound.Sox.Option.Format as SoxOpt+import qualified Synthesizer.Basic.Binary as BinSmp+import qualified Synthesizer.Storable.Signal as SigSt+import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.Generic.Signal2 as SigG2+import qualified Synthesizer.State.Signal as Sig+import qualified Synthesizer.Causal.Process as Causal+import Control.Arrow ((&&&), (^<<), (<<^), (<<<), )++import qualified Synthesizer.Generic.Oscillator as Osci+import qualified Synthesizer.Generic.Filter.NonRecursive as Filt+import qualified Synthesizer.Plain.Filter.Recursive as FiltRec+import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter+import qualified Synthesizer.Basic.Wave as Wave++import qualified Synthesizer.State.Control as CtrlS+import qualified Synthesizer.State.Oscillator as OsciS++import System.Exit (ExitCode, )+import NumericPrelude+import PreludeBase+import Prelude ()+++{- |+First, we define a play routine for lazy storable vectors.+Storable lazy vectors are lazy lists of low-level arrays.+They are both efficient in time and memory consumption,+but the blocks disallow feedback by small delays.+Elements of a storable vector must be of type class Storable.+This means that elements must have fixed size+and advanced data types like functions cannot be used.+-}+play :: SigSt.T Double -> IO ExitCode+play =+   Play.simple SigSt.hPut SoxOpt.none 44100 .+   SigSt.map BinSmp.int16FromDouble++{- |+Here is a simple oscillator generated as lazy storable vector.+An oscillator is a signal generator,+that is it produces a signal+without consuming other signals that correspond in time.+Signal generators have the maximal block size as parameter.+This is the lower limit of possible feedback delays.+-}+oscillator :: IO ExitCode+oscillator =+   play (Osci.static SigG.defaultLazySize Wave.sine zero (0.01::Double))++{- |+We rewrite the filter example 'Tutorial.filterSaw'+in terms of type classes for more signal types.+The constraints become quite large+because we must assert, that a particular sample type+can be used in the addressed signal type.+-}+filterSawSig ::+   (SigG.Write sig Double,+    SigG2.Transform sig (UniFilter.Result Double) Double,+    SigG2.Transform sig Double (UniFilter.Result Double),+    SigG2.Transform sig Double (UniFilter.Parameter Double)) =>+   sig Double+filterSawSig =+   SigG2.map UniFilter.lowpass $ SigG2.modifyModulated UniFilter.modifier (SigG2.map (\f -> UniFilter.parameter $ FiltRec.Pole 10 (0.04+0.02*f)) $ Osci.static SigG.defaultLazySize Wave.sine zero (0.00001::Double)) $ Osci.static SigG.defaultLazySize Wave.saw zero (0.002::Double)++{- |+Here we instantiate 'filterSawSig' for storable vectors and play it.+This means that all operations convert a storable vector into another storable vector.+While every single operation probably is as efficient as possible,+the composition of all those processes could be more efficient.+So keep on reading.+-}+filterSaw :: IO ExitCode+filterSaw =+   play filterSawSig+++{- |+The next signal type we want to consider is the stateful signal generator.+It is not a common data structure, where the sample values are materialized.+Instead it is a description of how to generate sample values iteratively.+This is almost identical to the @Data.Stream@ module from the @stream-fusion@ package.+With respect to laziness and restrictions of the sample type (namely none),+this signal representation is equivalent to lists.+You can convert one into the other in a lossless way.+That is, function as sample type is possible.+Combination of such signal generators is easily possible+and does not require temporary storage,+because this signal representation needs no sample value storage at all.+However at the end of such processes, the signal must be materialized.+Here we write the result into a lazy storable vector and play that.+What the compiler actually does is to create a single loop,+that generates the storable vector to be played in one go.+-}+playState :: Sig.T Double -> IO ExitCode+playState =+   Play.simple SigSt.hPut SoxOpt.none 44100 .+   SigG.fromState SigG.defaultLazySize .+   Sig.map BinSmp.int16FromDouble++{- |+We demonstrate the stateful signal generator using the known 'filterSaw' example.+Actually we can reuse the code from above,+because the signal generator is also an instance of the generic signal class.+-}+filterSawState :: IO ExitCode+filterSawState =+   playState filterSawSig+++{- |+Merging subsequent signal processes based on signal generators+into an efficient large signal processor is easy.+Not storing intermediate results is however a problem in another situation:+Sometimes you want to share one signal between several processes.+-}+filterPingStateProc :: Sig.T Double -> Sig.T Double+filterPingStateProc env =+   Filt.envelope env $ Sig.map UniFilter.lowpass $ Sig.modifyModulated UniFilter.modifier (Sig.map (\f -> UniFilter.parameter $ FiltRec.Pole 10 (0.03*f)) $ env) $ OsciS.static Wave.saw zero (0.002::Double)++{- |+In the following example we generate an exponential curve+which shall be used both as envelope+and as resonance frequency control of a resonant lowpass.+Actually, recomputing an exponential curve is not an issue,+since it only needs one multiplication per sample.+But it is simple enough to demonstrate the problem and its solutions.+The expression @let env = exponential2 50000 1@ fools the reader of the program,+since the @env@ that is shared, is only the signal generator,+that is, the description of how to compute the exponential curve successively.+That is wherever a signal process reads @env@, it is computed again.+-}+filterPingState :: IO ExitCode+filterPingState =+   playState $+   filterPingStateProc $+   CtrlS.exponential2 50000 1++{- |+You can achieve sharing by a very simple way.+You can write the result of the signal generator in a list ('Sig.toList')+and use this list as source for a new generator ('Sig.fromList').+'Sig.fromList' provides a signal generator that generates new sample values+by delivering the next sample from the list.++In a real world implementation you would move+the @Sig.fromList . Sig.toList@ to 'filterPingStateProc',+since the caller cannot know, that this function uses the signal twice,+and the implementor of 'filterPingStateProc' cannot know,+how expensive the computation of @env@ is.++You can use any other signal type for sharing, e.g. storable vectors,+but whatever type you choose, you also get its disadvantages.+Namely, storable vectors only work for storable samples+and lists are generally slow,+and they also cannot be optimized away,+since this only works, when no sharing is required.++Whenever a signal is shared as input between several signal processes,+the actual materialized data is that+between the slowest and the fastest reading process.+This is due to lazy evaluation and garbage collection.+If the different readers read with different speed,+then you will certainly need a temporary sample storage.+-}+filterPingShare :: IO ExitCode+filterPingShare =+   playState $+   filterPingStateProc $+   Sig.fromList $ Sig.toList $ CtrlS.exponential2 50000 1++{- |+It is however not uncommon that all readers read with the same speed.+In this case we would in principle only need to share the input signal per sample.+This way we would not need a data structure+for storing a sub-sequence of samples temporarily.+But how to do that practically?++The solution is not to think in terms of signals and signal processors,+e.g. @Sig.T a@ and @Sig.T a -> Sig.T b -> Sig.T c@, respectively,+but in terms of signal processors, that are guaranteed to run in sync.+That is we must assert that signal processors+process the samples in chronological order and emit one sample per input sample.+We call such processes \"causal\" processes.+For example @Causal.T (a,b) c@ represents the function @Sig.T (a,b) -> Sig.T c@+but it also carries the guarantee,+that for each input of type @(a,b)@+one sample of type @c@ is emitted or the output terminates.+Internally it is the Kleisli arrow of the @StateT Maybe@ monad.++Another important application of the Causal arrow is feedback.+Using causal processes guarantees, that a process cannot read ahead,+such that it runs into future data, which does still not exist due to recursion.++Programming with arrows needs a bit experience or Haskell extensions.+Haskell extensions are either an @Arrow@ syntax preprocessor+or the preprocessor that is built into GHC.+However, for computing with physical dimensions+you can no longer use the original @Arrow@ class+and thus you cannot use the arrow syntax.+So here is an example of how to program 'filterPingShare'+using @Arrow@ combinators.+-}+filterPingCausal :: IO ExitCode+filterPingCausal =+   playState $+   let proc =+          uncurry (*) ^<<+          ((UniFilter.lowpass ^<<+            UniFilter.causal <<<+            Causal.feedSnd (OsciS.static Wave.saw zero (0.002::Double)) <<^+            (\f -> UniFilter.parameter $ FiltRec.Pole 10 (0.03*f)))+           &&&+           Causal.id)+   in  Causal.apply proc $ CtrlS.exponential2 50000 1
+ src/Synthesizer/Generic/Wave.hs view
@@ -0,0 +1,48 @@+module Synthesizer.Generic.Wave where++import qualified Synthesizer.State.ToneModulation as ToneMod+import qualified Synthesizer.Basic.Wave as Wave++import qualified Synthesizer.Generic.Signal as SigG++import qualified Synthesizer.Interpolation as Interpolation++import qualified Algebra.RealField             as RealField++-- import Data.Tuple.HT (swap, )++import NumericPrelude+import PreludeBase+import Prelude ()+++sample ::+   (RealField.C a, SigG.Transform sig v) =>+   Interpolation.T a v -> sig v -> Wave.T a v+sample ip wave =+   let len = SigG.length wave+       cycleWave = SigG.cycle wave+   in  Wave.fromFunction $ \ phase ->+           let (n,q) = RealField.splitFraction (phase * fromIntegral len)+           in  Interpolation.func ip q $+               SigG.toState $+               SigG.drop n cycleWave+++{- |+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 a, SigG.Transform sig v) =>+   Interpolation.T a v ->+   Interpolation.T a v ->+   a -> sig v -> a -> Wave.T a v+sampledTone ipLeap ipStep period tone shape = Wave.Cons $ \phase ->+--   uncurry (ToneMod.interpolateCell ipStep ipLeap . swap) $+   uncurry (ToneMod.interpolateCell ipLeap ipStep) $+   ToneMod.sampledToneCell+      (ToneMod.makePrototype (Interpolation.margin ipLeap) (Interpolation.margin ipStep) period tone)+      shape phase+
− src/Synthesizer/Inference/DesignStudy/Applicative.hs 
@@ -1,42 +0,0 @@-{- |-  A design study about how to design signal processors-  that adapt to a common sample rate.-  I simplified "Synthesizer.Inference.DesignStudy.Arrow" to this module-  which uses only Applicative functors.--}-module Synthesizer.Inference.DesignStudy.Applicative where--import Data.List (intersect)-import Control.Applicative (Applicative(..), liftA3, )--data Rates = Rates [Int] | Any deriving Show--- it is a Reader monad with context processing-data Processor a = P Rates (Rates -> a)--intersectRates :: Rates -> Rates -> Rates-intersectRates Any y = y-intersectRates x Any = x-intersectRates (Rates xs) (Rates ys) = Rates $ intersect xs ys--instance Functor Processor where-   fmap f (P r f0) = P r (f . f0)--instance Applicative Processor where-   pure x = P Any (const x)-   (P r0 f0) <*> (P r1 f1)  =-      P (intersectRates r0 r1) (\r -> f0 r (f1 r))--runProcessor :: Processor a -> a-runProcessor (P r f) = f r---- test processors-processor1, processor2, processor3 :: Processor Rates-processor1 = P (Rates [44100, 48000]) id-processor2 = P Any                    id-processor3 = P (Rates [48000])        id--process :: Processor (Rates, Rates, Rates)-process = liftA3 (,,) processor1 processor2 processor3--test :: (Rates, Rates, Rates)-test = runProcessor process
− src/Synthesizer/Inference/DesignStudy/Arrow.hs 
@@ -1,45 +0,0 @@-module Synthesizer.Inference.DesignStudy.Arrow where--{--  A hint from Haskell cafe about how to design signal processors-  that adapt to a common sample rate.--}--{--Date: Fri, 12 Nov 2004 02:59:31 +0900-From: Koji Nakahara <yu-@div.club.ne.jp>-To: haskell-cafe@haskell.org--}--import Control.Arrow-import Data.List (intersect)-data Rates = Rates [Int] | Any deriving Show-data Processor b c = P Rates (Rates -> b -> c)---- test Stream-type Stream = String--intersectRates :: Rates -> Rates -> Rates-intersectRates Any y = y-intersectRates x Any = x-intersectRates (Rates xs) (Rates ys) = Rates $ intersect xs ys--instance Arrow Processor where-  arr f = P Any (const f)-  (P r0 f0) >>> (P r1 f1) =-     P (intersectRates r0 r1) (\r -> f1 r . f0 r)-  first (P r0 f) = P r0 (\r (x, s) -> (f r x, s))--runProcessor :: Processor b c -> b -> c-runProcessor (P r f) s = f r s---- test processors-process, processor1, processor2, processor3 :: Processor String String-processor1 = P (Rates [44100, 48000]) (\r -> ( ++ show r))-processor2 = P Any                    (\r -> ( ++ show r))-processor3 = P (Rates [48000])        (\r -> ( ++ show r))--process = processor1 >>> processor2 >>> processor3--test :: String-test = runProcessor process "bla"
− src/Synthesizer/Inference/DesignStudy/Monad.hs 
@@ -1,44 +0,0 @@-{- |-  A design study about how to design signal processors-  that adapt to a common sample rate.-  I tried to simplify "Synthesizer.Inference.DesignStudy.Arrow" to this module which uses only Monads.-  However the module is now very weird and does not really represent,-  what I intended to do.--}-module Synthesizer.Inference.DesignStudy.Monad where--import Control.Monad.Writer (Writer, execWriter, tell)-import Data.List (intersect)--data Rates = Rates [Int] | Any deriving Show--- it is a combination of Reader and Writer monad with context processing-data Processor a = P Rates (Rates -> Writer Stream a)---- test Stream-type Stream = String--intersectRates :: Rates -> Rates -> Rates-intersectRates Any y = y-intersectRates x Any = x-intersectRates (Rates xs) (Rates ys) = Rates $ intersect xs ys--instance Monad Processor where-   return x = P Any (\_ -> return x)-   -- maybe we should turn this into an Applicative instance-   (P r0 f0) >> (P r1 f1)  =-       P (intersectRates r0 r1) (\r -> f0 r >> f1 r)-   (P _ _) >>= _ = error "Is it possible to implement that?"--runProcessor :: Processor a -> Stream-runProcessor (P r f) = execWriter (f r)---- test processors-process, processor1, processor2, processor3 :: Processor ()-processor1 = P (Rates [44100, 48000]) (tell . show)-processor2 = P Any                    (tell . show)-processor3 = P (Rates [47000])        (tell . show)--process = processor1 >> processor2 >> processor3--test :: Stream-test = runProcessor process
− src/Synthesizer/Inference/Func/Cut.hs 
@@ -1,276 +0,0 @@-{-# OPTIONS -fno-implicit-prelude #-}-{- |-Copyright   :  (c) Henning Thielemann 2006, 2008-License     :  GPL--Maintainer  :  synthesizer@henning-thielemann.de-Stability   :  provisional-Portability :  requires multi-parameter type classes--}-module Synthesizer.Inference.Func.Cut (-   {- * dissection -}-   -- splitAt,-   -- take,-   -- drop,-   takeUntilPause,-   -- unzip,-   -- unzip3,--   {- * glueing -}-   concat,-   concatVolume,-   append,-   zip,-   -- zip3,-   arrange,-   arrangeVolume,-  ) where--import qualified Synthesizer.Physical.Signal      as SigP-import qualified Synthesizer.Physical.Cut         as CutP-import qualified Synthesizer.Inference.Func.Signal as SigF--import qualified Synthesizer.SampleRateContext.Signal as SigC-import qualified Synthesizer.SampleRateContext.Rate as Rate-import qualified Synthesizer.SampleRateContext.Cut as CutC--import qualified Data.EventList.Relative.TimeBody as EventList-import qualified Numeric.NonNegative.Class as NonNeg--import qualified Algebra.NormedSpace.Maximum as NormedMax-import qualified Algebra.OccasionallyScalar  as OccScalar-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.Ring                as Ring---- import qualified Data.List as List---- import Control.Monad.Fix(mfix)--import PreludeBase hiding (zip, zip3, concat, )--- import NumericPrelude-import Prelude (RealFrac)--{--{- * dissection -}--splitAt :: (RealField.C a, Field.C q, OccScalar.C a q) =>-   q -> SigI.T a q v -> Process.T q (SigI.T a q v, SigI.T a q v)-splitAt t0 x@(Cons sr amp ss) =-   do t <- SigI.toTimeScalar x (Expr.constant t0)-      let (ss0,ss1) = List.splitAt (round t) ss-      return (Cons sr amp ss0, Cons sr amp ss1)--take :: (RealField.C a, Field.C q, OccScalar.C a q) =>-   q -> SigI.T a q v -> SigI.Process a q v-take t = fmap fst . splitAt t--drop :: (RealField.C a, Field.C q, OccScalar.C a q) =>-   q -> SigI.T a q v -> SigI.Process a q v-drop t = fmap snd . splitAt t--}--takeUntilPause :: (RealField.C t, Ring.C t', OccScalar.C t t',-                   Field.C y', NormedMax.C y yv, OccScalar.C y y') =>-   y' -> t' -> SigF.T t t' y y' yv -> SigF.T t t' y y' yv-takeUntilPause y' t' x =-   SigF.cons $ \infered@(isr,iamp) ->-      let x' = SigF.eval x infered-          xp = SigP.replaceParameters isr iamp x'-          zp = CutP.takeUntilPause y' t' xp-      in  SigP.replaceParameters-             (SigP.sampleRate x') (SigP.amplitude x') zp---{--How can we assert sharing of the input signal-with the output signals?--unzip ::-       SigF.T t t' y y' (yv0, yv1)-   -> (SigF.T t t' y y' yv0, SigF.T t t' y y' yv1)-unzip x =-   (SigF.cons $ \inferedY@(isrY,iampY) -> ,-    SigF.cons $ \inferedZ@(isrZ,iampZ) -> )---unzip3 ::-       SigF.T t t' y y' (yv0, yv1, yv2)-   -> (SigF.T t t' y y' yv0, SigF.T t t' y y' yv1, SigF.T t t' y y' yv2)-unzip3 = return . CutC.unzip3--}---{- * glueing -}--{- |-  Similar to @foldr1 append@ but more efficient and accurate,-  because it reduces the number of amplifications.-  Does not work for infinite lists,-  because in this case a maximum amplitude cannot be computed.--}-concat ::-   (Eq t', Real.C y', Field.C y', Module.C y yv, OccScalar.C y y') =>-      [SigF.T t t' y y' yv]-   ->  SigF.T t t' y y' yv-concat xs =-   SigF.cons $ \(isr,iamp) ->-      let xs' = zipWith (\x amp -> SigF.eval x (isr, amp)) xs amps-          amps = map SigF.guessAmplitude xs'-          xps = zipWith SigF.contextFixAmplitude amps xs'-          sampleRate = SigF.mergeSampleRates xs'-      in  SigF.fromContextCheckAmplitude sampleRate iamp-             (CutC.concat (Rate.fromNumber isr) xps)--{- |-  Like 'concat' but it expects a fixed output amplitude.-  This way it can also handle infinitely many inputs-  if one input or the output has a fixed sample rate.--  'concatVolume' is one reason for the complicated handling-  of sampling rates by lists of @Maybe@s.--  The problem of finding an apropriate sampling rate is that-  we must have an order of processing parallel signal processors-  which guarantees termination if termination is possible.-  Say @mix (concat infinitelist0) (concat infinitelist1)@.-  Either infinite list can have signal with fixed sample rate or not.-  There is no way to determine this a priori.-  The only safe way is to process them in parallel.-  That's why we must have a @[Maybe t']@ instead of @Maybe t'@.-  Also @[t']@ is not enough,-  because e.g. a concatenation of infinitely many sounds-  with undetermined sampling rate-  would have an empty list representing the sampling rate,-  but computing the empty list needs infinite time.--}-concatVolume ::-   (Eq t', Real.C y', Field.C y', Module.C y yv, OccScalar.C y y') =>-      [SigF.T t t' y y' yv]-   ->  SigF.T t t' y y' yv-concatVolume xs =-   SigF.cons $ \(isr,iamp) ->-      let xs' = zipWith (\x amp -> SigF.eval x (isr, amp)) xs amps-          amps = map SigF.guessAmplitude xs'-          xps = zipWith SigF.contextFixAmplitude amps xs'-          sampleRate = SigF.mergeSampleRates xs'-      in  SigF.fromContextFreeAmplitude sampleRate-             (CutC.concatVolume iamp (Rate.fromNumber isr) xps)---merge :: (Eq t', Real.C y', Field.C y', OccScalar.C y y',-          Module.C y v0, Module.C y v1) =>-      (Rate.T t t' -> SigC.T y y' v0 -> SigC.T y y' v1 -> SigC.T y y' v2)-   -> SigF.T t t' y y' v0-   -> SigF.T t t' y y' v1-   -> SigF.T t t' y y' v2-merge f x y =-   SigF.cons $ \(isr,iamp) ->-      let x' = SigF.eval x (isr, ampX)-          y' = SigF.eval y (isr, ampY)-          ampX = SigF.guessAmplitude x'-          ampY = SigF.guessAmplitude y'-          xp = SigF.contextFixAmplitude ampX x'-          yp = SigF.contextFixAmplitude ampY y'-          sampleRate = SigF.mergeSampleRate x' y'-      in  SigF.fromContextCheckAmplitude sampleRate iamp-             (f (Rate.fromNumber isr) xp yp)---append :: (Eq t', Real.C y', Field.C y', OccScalar.C y y',-         Module.C y yv) =>-      SigF.T t t' y y' yv-   -> SigF.T t t' y y' yv-   -> SigF.T t t' y y' yv-append = merge CutC.append---zip :: (Eq t', Real.C y', Field.C y', OccScalar.C y y',-        Module.C y v0, Module.C y v1) =>-      SigF.T t t' y y' v0-   -> SigF.T t t' y y' v1-   -> SigF.T t t' y y' (v0,v1)-zip = merge CutC.zip--{--zip3 :: (Real.C q, Field.C q, Ord q, OccScalar.C a q,-         Module.C a v0, Module.C a v1, Module.C a v2)-   => SigI.T a q v0-   -> SigI.T a q v1-   -> SigI.T a q v2-   -> SigI.Process a q (v0, v1, v2)-zip3 x0 x1 x2 =-   mfix (\z ->-      do sampleRate <- Process.equalValues-            [SigP.sampleRate x0, SigP.sampleRate x1, SigP.sampleRate x2]-         amplitude  <- Process.fromExpr-            (Expr.maximum [amplitudeExpr x0, amplitudeExpr x1, amplitudeExpr x2])-         samp0 <- SigI.vectorSamples (toAmplitudeScalar z) x0-         samp1 <- SigI.vectorSamples (toAmplitudeScalar z) x1-         samp2 <- SigI.vectorSamples (toAmplitudeScalar z) x2-         SigI.returnCons sampleRate amplitude-            (List.zip3 samp0 samp1 samp2))--}----scheduleToContext ::-      t'-   -> EventList.T time (SigF.T t t' y y' yv)-   -> (SigF.Parameter t',-       EventList.T time (SigC.T y y' yv))-scheduleToContext isr sched =-   let xps =-          EventList.mapBody-             (\x ->-                 let y = SigF.eval x (isr, amp)-                     amp = SigF.guessAmplitude y-                     z = SigF.contextFixAmplitude amp y-                 in  (y,z)) sched-       schedp = EventList.mapBody snd xps-       sampleRate = SigF.mergeSampleRates (map fst (EventList.getBodies xps))-   in  (sampleRate, schedp)---{- |-  Given a list of signals with time stamps,-  mix them into one signal as they occur in time.-  Ideally for composing music.-  Infinite schedules are not supported,-  because no maximum amplitude can be computed.--}-arrange ::-   (RealFrac t, NonNeg.C t, Eq t', Ring.C t, Ring.C t', OccScalar.C t t',-    Ord y', Field.C y', OccScalar.C y y',-    Module.C y yv) =>-      t'-   -> EventList.T t (SigF.T t t' y y' yv)-          {-^ A list of pairs: (relative start time, signal part),-              The start time is relative-              to the start time of the previous event. -}-   -> SigF.T t t' y y' yv-          {-^ The mixed signal. -}-arrange unit sched =-   SigF.cons $ \(isr,iamp) ->-      let (sampleRate, schedp) = scheduleToContext isr sched-      in  SigF.fromContextCheckAmplitude sampleRate iamp-             (CutC.arrange unit (Rate.fromNumber isr) schedp)--arrangeVolume ::-   (RealFrac t, NonNeg.C t, Eq t', Ring.C t, Ring.C t', OccScalar.C t t',-    Field.C y', OccScalar.C y y',-    Module.C y yv) =>-      t'-   -> EventList.T t (SigF.T t t' y y' yv)-          {-^ A list of pairs: (relative start time, signal part),-              The start time is relative-              to the start time of the previous event. -}-   -> SigF.T t t' y y' yv-          {-^ The mixed signal. -}-arrangeVolume unit sched =-   SigF.cons $ \(isr,iamp) ->-      let (sampleRate, schedp) = scheduleToContext isr sched-      in  SigF.fromContextFreeAmplitude sampleRate-             (CutC.arrangeVolume iamp unit (Rate.fromNumber isr) schedp)
− src/Synthesizer/Inference/Func/Signal.hs 
@@ -1,297 +0,0 @@-{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}-{- |--Copyright   :  (c) Henning Thielemann 2006, 2008-License     :  GPL--Maintainer  :  synthesizer@henning-thielemann.de-Stability   :  provisional-Portability :  requires multi-parameter type classes---}-module Synthesizer.Inference.Func.Signal where--import qualified Synthesizer.Physical.Signal as SigP-import qualified Synthesizer.SampleRateContext.Signal as SigC---- import qualified Algebra.OccasionallyScalar as OccScalar--- import qualified Algebra.Module         as Module--- import qualified Algebra.Field          as Field--- import qualified Algebra.Ring           as Ring---- import Algebra.OccasionallyScalar (toScalar)--import Control.Monad.Fix (fix)-import Data.Maybe (catMaybes, isJust)-import Data.List  (transpose)-import NumericPrelude.List (shearTranspose)---- import NumericPrelude-import PreludeBase as P--{- |-Each process must work the following way:-If the signal processor has a fixed sample rate or amplitude-either implied by its parameters or its inputs-then this parameter should be set as @Just@-in the corresponding fields of @SigP.T@.-These fields must be computed-independently from the function argument of type @(t',y')@.-This function argument is the pair of eventually used signal parameters-sample rate and amplitude.-If you set signal parameters to @Just@ with a value,-then you can expect that the corresponding pair member has the same value.--}-newtype T t t' y y' yv =-   Cons {eval :: (t',y') -> Evaluated t t' y y' yv}--type Evaluated t t' y y' yv = SigP.T t (Parameter t') y (Parameter y') yv-{- |-Since all 'Just' values must contain the same value,-we could also use the data structure '(Peano, a)'-just like in the @unique-logic@ package.--}-newtype Parameter a = Parameter {parameterDesc :: [Maybe a]}--liftParam2 ::-   ([Maybe a] -> [Maybe b] -> [Maybe c]) ->-   Parameter a -> Parameter b -> Parameter c-liftParam2 f (Parameter x) (Parameter y) = Parameter (f x y)--cons :: ((t',y') -> SigP.T t (Parameter t') y (Parameter y') yv) -> T t t' y y' yv-cons = Cons---contextFixAmplitude ::-      y'-   -> Evaluated t t' y y' yv-   -> SigC.T y y' yv-contextFixAmplitude amp =-   SigC.replaceAmplitude amp . SigP.content--fromContextFreeAmplitude ::-      Parameter t'-   -> SigC.T y y' yv-   -> Evaluated t t' y y' yv-fromContextFreeAmplitude sr (SigC.Cons _amp ss) =-   SigP.cons sr anyParameter ss--fromContextCheckAmplitude :: (Eq y') =>-      Parameter t'-   -> y'-   -> SigC.T y y' yv-   -> Evaluated t t' y y' yv-fromContextCheckAmplitude sr iamp (SigC.Cons amp ss) =-   SigP.cons sr (justParameter amp)-      (if iamp==amp then ss else error "fromContextCheckAmplitude: amplitudes differ")---anyParameter :: Parameter q-anyParameter = Parameter []--justParameter :: q -> Parameter q-justParameter x = Parameter [Just x]--inSampleRate :: (t',y') -> t'-inSampleRate = fst--inAmplitude :: (t',y') -> y'-inAmplitude = snd----{--vectorSamples :: (Eq t', Module.C y yv) =>-   (y' -> y) -> T t t' y y' yv -> (t' -> [yv])-vectorSamples toAmpScalar sig =-   \inferedSampleRate ->-      let x'   = eval sig (inferedSampleRate, amp')-          amp' = guessParameter-                    "vectorSamples: input amplitude"-                    (SigP.amplitude x')-          amp = toAmpScalar amp' `SigP.asTypeOfAmplitude` x'-      in  amp *> SigP.samples x'--scalarSamples :: (Eq t', Ring.C y) =>-   (y' -> y) -> T t t' y y' y -> (t' -> [y])-scalarSamples toAmpScalar sig =-   \inferedSampleRate ->-      let x'  = sig (inferParameter inferedSampleRate (SigP.sampleRate x'),-                     amp')-          amp' = fromMaybe (error "scalarSamples: undetermined input amplitude")-                           (SigP.amplitude x')-          amp = toAmpScalar amp' `SigP.asTypeOfAmplitude` x'-      in  map (amp*) (SigP.samples x')----inferParameter :: Eq q => q -> Maybe q -> q-inferParameter infered =-   maybe infered-      (\x -> if x == infered-               then x-               else error ("inferParameter:" ++-                           " requested value and infered one differ"))--}--equalParameter :: Eq q => String -> Maybe q -> Maybe q -> Maybe q-equalParameter name x y =-   case (x,y) of-      (Nothing,_) -> y-      (_,Nothing) -> x-      (Just xv, Just yv) ->-         if xv == yv-           then Just xv-           else error ("equalParameter: " ++ name ++ " differ")--equalSampleRate :: Eq t' => Maybe t' -> Maybe t' -> Maybe t'-equalSampleRate = equalParameter "sample rate"---zipJut :: (a -> a -> a) -> [a] -> [a] -> [a]-zipJut f =-   let aux (x:xs) (y:ys) = f x y : aux xs ys-       aux []     ys     = ys-       aux xs     []     = xs-   in  aux--{-|-  Merge the @Just@s of two lists.-  It does not check for validity of the data.--}-mergeParameter :: Parameter q -> Parameter q -> Parameter q-mergeParameter =-   liftParam2 (zipJut (\x y -> if isJust x then x else y))--mergeSampleRate ::-   Evaluated t t' y0 y0' yv0 -> Evaluated t t' y1 y1' yv1 -> Parameter t'-mergeSampleRate x y =-   mergeParameter (SigP.sampleRate x) (SigP.sampleRate y)---mergeParameterEq :: Eq q => String -> Parameter q -> Parameter q -> Parameter q-mergeParameterEq name =-   liftParam2 (zipJut (equalParameter name))--mergeSampleRateEq :: Eq t' => Parameter t' -> Parameter t' -> Parameter t'-mergeSampleRateEq = mergeParameterEq "sample rate"---- cf. Examples.merge-merge :: [a] -> [a] -> [a]-merge (x:xs) ys = x : merge ys xs-merge []     ys = ys--propMerge :: Eq a => [a] -> [a] -> Bool-propMerge xs ys  =  merge xs ys == concat (transpose [xs,ys])--mergeParameter' :: Parameter t' -> Parameter t' -> Parameter t'-mergeParameter' = liftParam2 merge--checkParameter :: Eq q => String -> q -> Maybe q -> q-checkParameter name x =-   maybe x (\y -> if x == y-                    then x-                    else error ("checkParameter: deviation from common " ++ name))--checkSampleRate :: Eq t' => t' -> Maybe t' -> t'-checkSampleRate = checkParameter "sample rate"--checkAmplitude :: Eq y' => y' -> Maybe y' -> y'-checkAmplitude = checkParameter "amplitude"---{-|-  This routine is prepared for infinite lists.-  In order to handle them we employ a Cantor diagonalization scheme.-  It does not check for validity of the data-  (i.e. equal @Just@ values)-  but it does only keep some @Just@s,-  and thus allows for a quick search of a guess of a parameter value.--}-mergeParameters :: [Parameter q] -> Parameter q-mergeParameters =-   Parameter . map (head . (++[Nothing]) . filter isJust)-      . shearTranspose . map parameterDesc--mergeSampleRates :: [Evaluated t t' y y' yv] -> Parameter t'-mergeSampleRates =-   mergeParameters . map SigP.sampleRate--mergeParametersEq :: Eq q => String -> [Parameter q] -> Parameter q-mergeParametersEq name =-   Parameter . map (foldl (equalParameter name) Nothing)-      . shearTranspose . map parameterDesc--mergeSampleRatesEq :: Eq t' => [Parameter t'] -> Parameter t'-mergeSampleRatesEq = mergeParametersEq "sample rate"--{- |-This is a simple working version of 'mergeParameters',-which does not need @Eq@ constraint.-However, flattening a three-dimensional list-does handle different dimensions differently,-that is slower than the others.--}-mergeParameters' :: [Parameter q] -> Parameter q-mergeParameters' =-   Parameter . concat . shearTranspose . map parameterDesc---{--equalParameters :: Eq q => String -> [Parameter q] -> Parameter q-equalParameters name xs =-   let cxs = catMaybes xs-   in  if and (zipWith (==) cxs (tail cxs))-         then listToMaybe cxs-         else error ("equalParameters: " ++ name ++ " differ")--equalSampleRates :: Eq t' => [Maybe t'] -> Maybe t'-equalSampleRates = equalParameters "sample rates"--}--guessParameter :: String -> Parameter q -> q-guessParameter context =-   head . (++ error (context ++ " undetermined")) . catMaybes . parameterDesc--guessSampleRate :: Evaluated t t' y y' yv -> t'-guessSampleRate = guessParameter "sample rate" . SigP.sampleRate--guessAmplitude :: Evaluated t t' y y' yv -> y'-guessAmplitude = guessParameter "amplitude" . SigP.amplitude----{- |-  A complex signal graph can be built without ever mentioning a sampling rate.-  However when it comes to playing or writing a file,-  we must determine the sampling rate eventually.-  This function simply passes a signal through-  while forcing it to the given sampling rate.--}-fixSampleRate :: (Eq t') =>-      t'                {-^ sample rate -}-   -> T t t' y y' yv    {-^ passed through signal -}-   -> T t t' y y' yv-fixSampleRate forcedSampleRate input =-   Cons $ \infered ->-      let inputSig = eval input infered-      in  SigP.cons-             (justParameter forcedSampleRate)-             (SigP.amplitude inputSig)-             (if inSampleRate infered == forcedSampleRate-                then SigP.samples inputSig-                else error "fixSampleRate: sampleRates differ")---- ***** Is this one correct? Has the usage of 'infered' a cycle?-{- | Create a loop (feedback) from one node to another one.-     That is, compute the fix point of a process iteration. -}-loop :: (Eq t') =>-      (T t t' y y' yv -> T t t' y y' yv)-                        {-^ process chain that shall be looped -}-   ->  T t t' y y' yv-loop f =-   fix (\x -> f (Cons $ \infered ->-          SigP.cons anyParameter anyParameter-                    (SigP.samples (eval x infered))))---- example: loop (\y -> x + delay y)
+ src/Synthesizer/Inference/Overview.hs view
@@ -0,0 +1,129 @@+{- |+There are still several alternatives+of how to handle the sample rates+(that can be equipped with physical dimensions).++(1) Stick to simple lists as data and+    pass additional information directly to the functions.+    E.g. mixing several signals is easy+    since only one sample rate is given+    which applies to all signals.+    But it leads to the problem+    that subsequent function calls must receive the same value.+    This cannot be guaranteed and is thus a source of error.+    E.g. the mistake+       @play (44100*hertz) (osciSine (22050*hertz) (440*hertz))@+    can't be detected.+    In this approach the signal data structure is very simple,+    the values may be passed to multiple functions,+    the combinations are simply done by function application,+    a supervisor is not necessary,+    consistency checks can hardly be performed.+    This approach is certainly the most basic one,+    on which others, more safer ones, can sit on top.+    It is implemented in "Synthesizer.Plain.Signal" with numbers without units.++(2) Equip signals with sample rate and amplitude.+    Processors without input need the sample rate as explicit parameter.+    If there is more than one signal as input,+    then there must be additional checks.+    The error in+    @+       mix (osciSine (22050*hertz) (440*hertz))+           (osciSine (44100*hertz) (330*hertz))+    @+    can be detected at runtime.+    However the sample rate has to be specified for both input signals,+    although it is obvious, that both signals have to share the sample rate.+    In this approach the data structure is more complex,+    the values may be passed to multiple functions+    but consistency checks can be performed+    and a supervisor is still not necessary.+    This strategy is implemented in the "Synthesizer.Physical.Signal" modules.++(3) We still like to hide the sample rate where possible.+    All processors should work as good as possible at each rate.+    Here we provide the sample rate to each processor.+    The result of a processor is not just a list of samples+    but it is a function, which computes the list of samples+    depending on the sample rate.+    Sample rate is fixed not until it comes to the rendering of a sound,+    e.g. for playing or writing of a file.+       @play (44100*hertz) (osciSine (440*hertz))@+    Returning a function instead of computed data+    has the disadvantage that multiply used data cannot be shared.+    For these situations we need a @share@ function.+    Combinator functions similar to @($)@ are used+    to plug sample rate dependent output from one processor+    into plain signal parameters.+    With this approach, the type signature tells+    which signals share the sample rate.+    Infinitely many signals can be handled.+    Types for time and volume can be chosen quite freely.+    Supervision is not necessary.+    This strategy is implemented in the "Synthesizer.Inference.Reader.Signal" modules,+    where we hide the sample rate in a "Control.Monad.Trans.Reader".+    There is also "Synthesizer.SampleRateContext.Signal"+    which exposes the sample rate.+    It is more convenient to implement and to call,+    but I think it is more unsafe,+    because you can mix sample rates from different sources accidentally.+    The same is available for numbers with dimension terms in types.+    See "Synthesizer.Dimensional.Process".+    /In most cases this will be the method of choice!/+    Maybe I'm going to wrap this in a Reader monad\/applicative functor.+    It also requires that Haddock supports comments in parameters of type constructors.++(4) I have tried more sophisticated approaches+    in order to handle not only the sample rates but also the amplitudes.+    However I feel that I wanted more than I actually needed.+    I do no longer maintain these approaches but explain them for completeness.+    The most convenient solution for handling sample rates and amplitudes+    is certainly an inference system like Haskell's type system.+    If some input and output signals of a processor+    must have the same sampling rate,+    then the concrete rate must only be known for one of these signals.+    If no participating signal has a fixed rate, this is an error.+    The dependencies of sampling rates become very large by this system.+    The direction can be from inputs to outputs and vice versa,+    not to mention loops.+    This approach needs a lot of management,+    e.g. a supervisor which runs the network,+    but it is very convenient and safe.+    However, sometimes you have to fiddle with monads.+    Unfortunately it is restricted to finitely many monads+    and the types for time and volume are restricted.+    Thus this concept does not scale to physical units expressed in types.+    This strategy is implemented in the modules under "Synthesizer.Inference.Monad.Signal".++(5) We tried to work-around the restrictions+    using a function based approach.+    Since the parameters are functions,+    sharing cannot take place.+    There is no way to spread sample rate from one consumer to another one.+    E.g. If there is+    @+       let y = f x;+           z = g x+    @+    and it is known that @f@ and @g@ maintain the sample rate,+    and the sample rate of @z@ is known - how to infer the sample rate of @y@?+    This approach was dropped quickly and+    exists for historical reasons in "Synthesizer.Inference.Func.Signal".++(6) There is a very cool approach,+    which implements the equation solver of the monadic approach+    by lazy evaluation and Peano numbers.+    This poses no restriction on types+    and works for infinitely many equations as well.+    The drawbacks are difficult application+    (you cannot simply apply a function to a signal,+    but you must compose functions in an arrow like way),+    and slow solution of the equation system+    (quadratic time although in principle+    only run-time around linear time is necessary,+    it's similar to topological sort).+    However it's as slow as the explicit solver using monads in "Synthesizer.Inference.Monad.Signal".+    This strategy is tested in the modules under "Synthesizer.Inference.Fix".+-}+module Synthesizer.Inference.Overview where
− src/Synthesizer/Inference/Reader/Control.hs 
@@ -1,167 +0,0 @@-{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}-{- |-Copyright   :  (c) Henning Thielemann 2007-License     :  GPL--Maintainer  :  synthesizer@henning-thielemann.de-Stability   :  provisional-Portability :  requires multi-parameter type classes---Control curves which can be used-as envelopes, for controlling filter parameters and so on.--}-module Synthesizer.Inference.Reader.Control-   ({- * Primitives -}-    constant, constantVector, linear, line, exponential, exponential2,-    {- * Piecewise -}-    piecewise, piecewiseVolume, Control(..), ControlPiece(..),-    (-|#), ( #|-), (=|#), ( #|=), (|#), ( #|),  -- spaces before # for Haddock-    {- * Preparation -}-    mapLinear, mapExponential, )-   where---import Synthesizer.Plain.Control-   (Control(..), ControlPiece(..), (-|#), ( #|-), (=|#), ( #|=), (|#), ( #|))--import qualified Synthesizer.SampleRateContext.Control as CtrlC--{--if we import that, then GHC-6.4.1 will no longer complain,-that Synthesizer.Plain.Control is unnecessarily imported-import qualified Synthesizer.Plain.Control as Ctrl--}--import qualified Synthesizer.Inference.Reader.Signal as SigR-import qualified Synthesizer.Inference.Reader.Process as Proc--import qualified Algebra.OccasionallyScalar as OccScalar-import qualified Algebra.Module             as Module-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.Ring               as Ring---- import NumericPrelude--- import PreludeBase as P---constant :: (Field.C y', Real.C y', OccScalar.C y y') =>-      y' {-^ value -}-   -> Proc.T t t' (SigR.T y y' y)-constant y =-   SigR.lift (CtrlC.constant y)--{- |-The amplitude must be positive!-This is not checked.--}-constantVector :: -- (Field.C y', Real.C y', OccScalar.C y y') =>-      y' {-^ amplitude -}-   -> yv {-^ value -}-   -> Proc.T t t' (SigR.T y y' yv)-constantVector y yv =-   SigR.lift (CtrlC.constantVector y yv)--{- 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', OccScalar.C y y') =>--}--{- |-Caution: This control curve can contain samples-with an absolute value greater than 1.--Linear curves starting with zero are impossible.-Maybe you prefer using 'line'.--}-linear ::-   (Field.C q, Field.C q',-    Real.C q', OccScalar.C q q') =>-      q' {-^ slope of the curve -}-   -> q' {-^ initial value -}-   -> Proc.T q q' (SigR.T q q' q)-linear slope y0 =-   SigR.lift (CtrlC.linear slope y0)--{- |-Generates a finite ramp.--}-line ::-   (RealField.C q, Field.C q',-    Real.C q', OccScalar.C q q') =>-      q'      {-^ duration of the ramp -}-   -> (q',q') {-^ initial and final value -}-   -> Proc.T q q' (SigR.T q q' q)-line dur (y0,y1) =-   SigR.lift (CtrlC.line dur (y0,y1))--exponential :: (Trans.C q, Field.C q', Real.C q', OccScalar.C q q') =>-      q' {-^ time where the function reaches 1\/e of the initial value -}-   -> q' {-^ initial value -}-   -> Proc.T q q' (SigR.T q q' q)-exponential time y0 =-   SigR.lift (CtrlC.exponential time y0)--{--  take 1000 $ show (run (fixSampleRate 100 (exponential 0.1 1)) :: SigDouble)--}--exponential2 :: (Trans.C q, Field.C q', Real.C q', OccScalar.C q q') =>-      q' {-^ half life, time where the function reaches 1\/2 of the initial value -}-   -> q' {-^ initial value -}-   -> Proc.T q q' (SigR.T q q' q)-exponential2 time y0 =-   SigR.lift (CtrlC.exponential2 time y0)----{- |-Since this function looks for the maximum node value,-and since the signal parameter inference phase must be completed before signal processing,-infinite descriptions cannot be used here.--}-piecewise :: (Trans.C q, RealField.C q,-              Real.C q', Field.C q', OccScalar.C q q') =>-      [ControlPiece q']-   -> Proc.T q q' (SigR.T q q' q)-piecewise cs =-   SigR.lift (CtrlC.piecewise cs)--piecewiseVolume ::-   (Trans.C q, RealField.C q,-    Real.C q', Field.C q', OccScalar.C q q') =>-      [ControlPiece q']-   -> q'-   -> Proc.T q q' (SigR.T q q' q)-piecewiseVolume cs amplitude =-   SigR.lift (CtrlC.piecewiseVolume cs amplitude)---{- |-Map a control curve without amplitude unit-by a linear (affine) function with a unit.--}-mapLinear :: (Ring.C y, Field.C y', Real.C y', OccScalar.C y y') =>-      y'  {- ^ range: one is mapped to @center+range@ -}-   -> y'  {- ^ center: zero is mapped to @center@ -}-   -> Proc.T t t'-       (SigR.T y y' y-     -> SigR.T y y' y)-mapLinear range center =-   SigR.lift (CtrlC.mapLinear range center)--{- |-Map a control curve without amplitude unit-exponentially to one with a unit.--}-mapExponential :: (Field.C y', Trans.C y, Module.C y y') =>-      y   {- ^ range: one is mapped to @center*range@, must be positive -}-   -> y'  {- ^ center: zero is mapped to @center@ -}-   -> Proc.T t t'-       (SigR.T y y  y-     -> SigR.T y y' y)-mapExponential range center =-   SigR.lift (CtrlC.mapExponential range center)
− src/Synthesizer/Inference/Reader/Cut.hs 
@@ -1,194 +0,0 @@-{-# OPTIONS -fno-implicit-prelude #-}-{- |-Copyright   :  (c) Henning Thielemann 2006-License     :  GPL--Maintainer  :  synthesizer@henning-thielemann.de-Stability   :  provisional-Portability :  requires multi-parameter type classes--}-module Synthesizer.Inference.Reader.Cut (-   {- * dissection -}-   splitAt,-   take,-   drop,-   takeUntilPause,-   unzip,-   unzip3,--   {- * glueing -}-   concat,   concatVolume,-   append,   appendVolume,-   zip,      zipVolume,-   zip3,     zip3Volume,-   arrange,  arrangeVolume,-  ) where--import qualified Synthesizer.SampleRateContext.Cut as CutC--import qualified Synthesizer.Inference.Reader.Signal as SigR-import qualified Synthesizer.Inference.Reader.Process as Proc--import qualified Data.EventList.Relative.TimeBody as EventList-import qualified Numeric.NonNegative.Class as NonNeg--import qualified Algebra.NormedSpace.Maximum as NormedMax-import qualified Algebra.OccasionallyScalar  as OccScalar-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.Ring                as Ring---- import qualified Data.List as List--import PreludeBase ((.), Ord)--- import NumericPrelude-import Prelude (RealFrac)---{- * dissection -}--splitAt :: (RealField.C t, Field.C t', OccScalar.C t t') =>-   t' -> Proc.T t t' (SigR.T y y' yv -> (SigR.T y y' yv, SigR.T y y' yv))-splitAt t = SigR.lift (CutC.splitAt t)--take :: (RealField.C t, Field.C t', OccScalar.C t t') =>-   t' -> Proc.T t t' (SigR.T y y' yv -> SigR.T y y' yv)-take t = SigR.lift (CutC.take t)--drop :: (RealField.C t, Field.C t', OccScalar.C t t') =>-   t' -> Proc.T t t' (SigR.T y y' yv -> SigR.T y y' yv)-drop t = SigR.lift (CutC.drop t)--takeUntilPause ::-  (RealField.C t, Ring.C t', OccScalar.C t t',-   Field.C y', NormedMax.C y yv, OccScalar.C y y') =>-   y' -> t' -> Proc.T t t' (SigR.T y y' yv -> SigR.T y y' yv)-takeUntilPause y' t' = SigR.lift (CutC.takeUntilPause y' t')---unzip ::-   Proc.T t t'-      (SigR.T y y' (yv0, yv1) ->-         (SigR.T y y' yv0, SigR.T y y' yv1))-unzip = SigR.lift CutC.unzip--unzip3 ::-   Proc.T t t'-      (SigR.T y y' (yv0, yv1, yv2) ->-         (SigR.T y y' yv0, SigR.T y y' yv1, SigR.T y y' yv2))-unzip3 = SigR.lift CutC.unzip3---{- * glueing -}--{- |-Similar to @foldr1 append@ but more efficient and accurate,-because it reduces the number of amplifications.-Does not work for infinite lists,-because no maximum amplitude can be computed.--}-concat ::-   (Real.C y, Ord y', Field.C y', OccScalar.C y y',-    Module.C y yv) =>-   Proc.T t t' ([SigR.T y y' yv] -> SigR.T y y' yv)-concat = SigR.lift CutC.concat--{- |-Give the output volume explicitly.-Does also work for infinite lists.--}-concatVolume ::-   (Field.C y', OccScalar.C y y',-    Module.C y yv) =>-   y' -> Proc.T t t' ([SigR.T y y' yv] -> SigR.T y y' yv)-concatVolume = SigR.lift . CutC.concatVolume---append ::-   (Real.C y, Ord y', Field.C y', OccScalar.C y y',-    Module.C y yv) =>-   Proc.T t t' (SigR.T y y' yv -> SigR.T y y' yv -> SigR.T y y' yv)-append = SigR.lift CutC.append--appendVolume ::-   (Field.C y', OccScalar.C y y',-    Module.C y yv) =>-   y' ->-   Proc.T t t' (SigR.T y y' yv -> SigR.T y y' yv -> SigR.T y y' yv)-appendVolume = SigR.lift . CutC.appendVolume---zip ::-   (Real.C y, Ord y', Field.C y', OccScalar.C y y',-    Module.C y yv0, Module.C y yv1) =>-   Proc.T t t' (SigR.T y y' yv0 -> SigR.T y y' yv1 -> SigR.T y y' (yv0,yv1))-zip = SigR.lift CutC.zip--zipVolume ::-   (Field.C y', OccScalar.C y y',-    Module.C y yv0, Module.C y yv1) =>-   y' ->-   Proc.T t t' (SigR.T y y' yv0 -> SigR.T y y' yv1 -> SigR.T y y' (yv0,yv1))-zipVolume = SigR.lift . CutC.zipVolume---zip3 ::-   (Real.C y, Ord y', Field.C y', OccScalar.C y y',-    Module.C y yv0, Module.C y yv1, Module.C y yv2) =>-   Proc.T t t' (SigR.T y y' yv0 -> SigR.T y y' yv1 -> SigR.T y y' yv2 ->-                 SigR.T y y' (yv0,yv1,yv2))-zip3 = SigR.lift CutC.zip3--zip3Volume ::-   (Field.C y', OccScalar.C y y',-    Module.C y yv0, Module.C y yv1, Module.C y yv2) =>-   y' ->-   Proc.T t t' (SigR.T y y' yv0 -> SigR.T y y' yv1 -> SigR.T y y' yv2 ->-                 SigR.T y y' (yv0,yv1,yv2))-zip3Volume = SigR.lift . CutC.zip3Volume---{- |-Uses maximum input volume as output volume.--}-arrange ::-   (Ring.C t', OccScalar.C t t',-    RealFrac t, NonNeg.C t,-    Ord y', Field.C y', OccScalar.C y y',-    Module.C y yv) =>-      t'  {-^ Unit of the time values in the time ordered list. -}-   -> Proc.T t t'-        (EventList.T t (SigR.T y y' yv)-             {-  A list of pairs: (relative start time, signal part),-                 The start time is relative-                 to the start time of the previous event. -}-         -> SigR.T y y' yv-             {-  The mixed signal. -} )-arrange = SigR.lift . CutC.arrange---{- |-Given a list of signals with time stamps,-mix them into one signal as they occur in time.-Ideally for composing music.-Infinite schedules are not supported.-Does not work for infinite lists,-because no maximum amplitude can be computed.--}-arrangeVolume ::-   (Ring.C t', OccScalar.C t t',-    RealFrac t, NonNeg.C t,-    Field.C y', OccScalar.C y y',-    Module.C y yv) =>-      y'  {-^ Output volume. -}-   -> t'  {-^ Unit of the time values in the time ordered list. -}-   -> Proc.T t t'-        (EventList.T t (SigR.T y y' yv)-             {-  A list of pairs: (relative start time, signal part),-                 The start time is relative-                 to the start time of the previous event. -}-         -> SigR.T y y' yv-             {-  The mixed signal. -} )-arrangeVolume amp = SigR.lift . CutC.arrangeVolume amp
− src/Synthesizer/Inference/Reader/Filter.hs 
@@ -1,340 +0,0 @@-{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}-{- |-Copyright   :  (c) Henning Thielemann 2007-License     :  GPL--Maintainer  :  synthesizer@henning-thielemann.de-Stability   :  provisional-Portability :  requires multi-parameter type classes--}-module Synthesizer.Inference.Reader.Filter (-   {- * Non-recursive -}--   {- ** Amplification -}-   amplify,-   negate,-   envelope,-   {- ** Filter operators from calculus -}-   differentiate,--{--   {- ** Smooth -}-   mean,--   {- ** Delay -}-   delay,-   phaseModulation,-   phaser,-   phaserStereo,---   {- * Recursive -}--   {- ** Without resonance -}-   firstOrderLowpass,-   firstOrderHighpass,-   butterworthLowpass,-   butterworthHighpass,-   chebyshevALowpass,-   chebyshevAHighpass,-   chebyshevBLowpass,-   chebyshevBHighpass,-   {- ** With resonance -}-   universal,-   moogLowpass,-   {- ** Allpass -}-   allpassCascade,--}-   {- ** Reverb -}-   comb,--   {- ** Filter operators from calculus -}-   integrate,-) where---import qualified Synthesizer.SampleRateContext.Filter as FiltC--import qualified Synthesizer.Inference.Reader.Signal as SigR-import qualified Synthesizer.Inference.Reader.Process as Proc--{--import Synthesizer.Inference.Reader.Signal-   (toTimeScalar, toFrequencyScalar)--import qualified Synthesizer.Physical.Signal as SigP-import qualified Synthesizer.Plain.Displacement as Syn-import qualified Synthesizer.Plain.Interpolation as Interpolation-import qualified Synthesizer.Plain.Filter.Delay.Block as Delay-import qualified Synthesizer.Plain.Filter.NonRecursive as Filt-import qualified Synthesizer.Inference.Monad.Signal.Displacement as SynI-import qualified Synthesizer.Inference.Monad.Signal.Cut         as CutI--}--import qualified Algebra.OccasionallyScalar as OccScalar--- 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.Ring           as Ring-import qualified Algebra.Additive       as Additive-import qualified Algebra.Module         as Module--- import qualified Algebra.VectorSpace    as VectorSpace--{--import Synthesizer.Utility(clip)--import Control.Monad(liftM2)--import NumericPrelude hiding (negate)-import PreludeBase as P--}---{- | The amplification factor must be positive. -}-amplify :: (Field.C y') =>-      y'-   -> Proc.T t t'-        (SigR.T y y' yv-      -> SigR.T y y' yv)-amplify volume = SigR.lift (FiltC.amplify volume)--negate :: (Additive.C yv) =>-   Proc.T t t'-       (SigR.T y y' yv-     -> SigR.T y y' yv)-negate = SigR.lift FiltC.negate---envelope :: (Module.C y yv, Field.C y') =>-   Proc.T t t' (-      SigR.T y y' y   {-  the envelope -}-   -> SigR.T y y' yv  {-  the signal to be enveloped -}-   -> SigR.T y y' yv)-envelope = SigR.lift FiltC.envelope---differentiate :: (Additive.C v, Field.C q') =>-   Proc.T q q' (-        SigR.T q q' v-     -> SigR.T q q' v)-differentiate = SigR.lift FiltC.differentiate---{--{- | needs a good handling of boundaries, yet -}-mean :: (Additive.C yv, Field.C y', RealField.C a,-         Module.C a v, OccScalar.C a q) =>-      q            {- ^ time length of the window -}-   -> SigR.T y y' yv-   -> Proc.T t t' (SigR.T y y' yv)-mean time x =-   do t <- toTimeScalar x (Expr.constant time)-      let tInt  = round ((t-1)/2)-      let width = tInt*2+1-      returnModified []-         ((SigP.asTypeOfAmplitude (recip (fromIntegral width)) x *> ) .-          Filt.sums width . FiltNR.delay tInt) x---delay :: (Additive.C yv, Field.C y', RealField.C a, OccScalar.C a q) =>-      q-   -> SigR.T y y' yv-   -> Proc.T t t' (SigR.T y y' yv)-delay time x =-   do t <- toTimeScalar x (Expr.constant time)-      returnModified [] (FiltNR.delay (round t)) x---phaseModulation ::-         (Additive.C yv, Field.C y', RealField.C a, OccScalar.C a q) =>-      Interpolation.T a v-   -> q   {- ^ minDelay, minimal delay, may be negative -}-   -> q   {- ^ maxDelay, maximal delay, it must be @minDelay <= maxDelay@-               and the modulation must always be-               in the range [minDelay,maxDelay]. -}-   -> SigI.T a q a-          {- ^ delay control, positive numbers mean delay,-               negative numbers mean prefetch -}-   -> SigR.T y y' yv-   -> Proc.T t t' (SigR.T y y' yv)-phaseModulation ip minDelay maxDelay delays x =-   do t0 <- toTimeScalar x (Expr.constant minDelay)-      t1 <- toTimeScalar x (Expr.constant maxDelay)-      let tInt0 = floor   t0-      let tInt1 = ceiling t1-      let tInt0Neg = Additive.negate tInt0-      ds <- SigI.scalarSamples (toTimeScalar delays) delays-      returnModified [SigP.sampleRate delays]-         (FiltNR.delay tInt0 .-             Delay.modulated ip (tInt1-tInt0+1)-               (FiltNR.delay tInt0Neg-                  (Syn.raise (fromIntegral tInt0Neg)-                     (map (clip t0 t1) ds)))) x---{- | symmetric phaser -}-phaser :: (Additive.C yv, Field.C y', RealField.C a,-           Module.C a v, OccScalar.C a q) =>-      Interpolation.T a v-   -> q   {- ^ maxDelay, must be positive -}-   -> SigI.T a q a-          {- ^ delay control -}-   -> SigR.T y y' yv-   -> Proc.T t t' (SigR.T y y' yv)-phaser ip maxDelay delays x =-   amplify (asTypeOf 0.5 maxDelay) =<<-      uncurry SynI.mix =<< phaserCore ip maxDelay delays x--phaserStereo :: (Additive.C yv, Field.C y', Real.C q, RealField.C a,-                 Module.C a v, OccScalar.C a q) =>-      Interpolation.T a v-   -> q   {- ^ maxDelay, must be positive -}-   -> SigI.T a q a-          {- ^ delay control -}-   -> SigR.T y y' yv-   -> SigI.Process a q (v,v)-phaserStereo ip maxDelay delays x =-   uncurry CutI.zip =<< phaserCore ip maxDelay delays x--phaserCore :: (Additive.C yv, Field.C y', RealField.C a,-               Module.C a v, OccScalar.C a q) =>-      Interpolation.T a v-   -> q   {- ^ maxDelay, must be positive -}-   -> SigI.T a q a-          {- ^ delay control -}-   -> SigR.T y y' yv-   -> Process.T q (SigR.T y y' yv, SigR.T y y' yv)-phaserCore ip maxDelay delays x =-   do let minDelay = Additive.negate maxDelay-      negDelays <- Inference.Signal.Filter.negate delays-      liftM2 (,)-         (phaseModulation ip minDelay maxDelay delays x)-         (phaseModulation ip minDelay maxDelay negDelays x)----firstOrderLowpass, firstOrderHighpass ::-   (Trans.C a, Trans.C q, Module.C a v, OccScalar.C a q) =>-      SigI.T a q a {- ^ Control signal for the cut-off frequency. -}-   -> SigR.T y y' yv {- ^ Input signal -}-   -> Proc.T t t' (SigR.T y y' yv)-firstOrderLowpass  = firstOrderGen Syn.lowpass1stOrder-firstOrderHighpass = firstOrderGen Syn.highpass1stOrder--firstOrderGen :: (Trans.C a, Trans.C q, Module.C a v, OccScalar.C a q) =>-      ([a] -> [v] -> [v])-   -> SigI.T a q a-   -> SigR.T y y' yv-   -> Proc.T t t' (SigR.T y y' yv)-firstOrderGen filt freq x =-   do freqs <- SigI.scalarSamples (toFrequencyScalar x) freq-      returnModified [SigP.sampleRate freq]-         (filt (map Syn.lowpass1stOrderParam freqs)) x---butterworthLowpass, butterworthHighpass,-   chebyshevALowpass, chebyshevAHighpass,-   chebyshevBLowpass, chebyshevBHighpass ::-      (Field.C y', Trans.C a, VectorSpace.C a v, OccScalar.C a q) =>-      Int          {- ^ Order of the filter, must be even,-                        the higher the order, the sharper is the separation of frequencies. -}-   -> a            {- ^ The attenuation at the cut-off frequency.-                        Should be between 0 and 1. -}-   -> SigI.T a q a {- ^ Control signal for the cut-off frequency. -}-   -> SigR.T y y' yv {- ^ Input signal -}-   -> Proc.T t t' (SigR.T y y' yv)--butterworthLowpass  = higherOrderNoResoGen Syn.butterworthLowpass-butterworthHighpass = higherOrderNoResoGen Syn.butterworthHighpass-chebyshevALowpass   = higherOrderNoResoGen Syn.chebyshevALowpass-chebyshevAHighpass  = higherOrderNoResoGen Syn.chebyshevAHighpass-chebyshevBLowpass   = higherOrderNoResoGen Syn.chebyshevBLowpass-chebyshevBHighpass  = higherOrderNoResoGen Syn.chebyshevBHighpass--higherOrderNoResoGen ::-   (Field.C y', Ring.C a, OccScalar.C a q) =>-      (Int -> a -> [a] -> [v] -> [v])-   -> Int-   -> a-   -> SigI.T a q a-   -> SigR.T y y' yv-   -> Proc.T t t' (SigR.T y y' yv)-higherOrderNoResoGen filt order ratio freq x =-   do freqs <- SigI.scalarSamples (toFrequencyScalar x) freq-      returnModified [SigP.sampleRate freq]-         (filt order ratio freqs) x----universal :: (Trans.C a, Module.C a v, Field.C y', OccScalar.C a q) =>-      SigI.T a q a {- ^ signal for resonance,-                        i.e. factor of amplification at the resonance frequency-                        relatively to the transition band. -}-   -> SigI.T a q a {- ^ signal for cut off and band center frequency -}-   -> SigR.T y y' yv {- ^ input signal -}-   -> SigI.Process a q (v,v,v) {- ^ highpass, bandpass, lowpass filter -}-universal reso freq x =-   do resos <- SigI.scalarSamples (Process.exprToScalar) reso-      freqs <- SigI.scalarSamples (toFrequencyScalar x) freq-      let params =-             map UniFilter.parameter-                 (zipWith Syn.Pole resos freqs)-      returnModified [SigP.sampleRate reso, SigP.sampleRate freq]-         (UniFilter.run params) x--moogLowpass :: (Trans.C a, Module.C a v, Field.C y', OccScalar.C a q) =>-      Int-   -> SigI.T a q a {- ^ signal for resonance,-                        i.e. factor of amplification at the resonance frequency-                        relatively to the transition band. -}-   -> SigI.T a q a {- ^ signal for cut off and band center frequency -}-   -> SigR.T y y' yv-   -> Proc.T t t' (SigR.T y y' yv)-moogLowpass order reso freq x =-   do resos <- SigI.scalarSamples (Process.exprToScalar) reso-      freqs <- SigI.scalarSamples (toFrequencyScalar x) freq-      let params =-             map (Moog.parameter order)-                 (zipWith Syn.Pole resos freqs)-      returnModified [SigP.sampleRate reso, SigP.sampleRate freq]-         (Moog.lowpass order params) x--allpassCascade :: (Trans.C a, Module.C a v, Field.C y', OccScalar.C a q) =>-      Int          {- ^ order, number of filters in the cascade -}-   -> a            {- ^ the phase shift to be achieved for the given frequency -}-   -> SigI.T a q a {- ^ lowest comb frequency -}-   -> SigR.T y y' yv-   -> Proc.T t t' (SigR.T y y' yv)-allpassCascade order phase freq x =-   do freqs <- SigI.scalarSamples (toFrequencyScalar x) freq-      let params = map (Syn.allpassCascadeParam order phase) freqs-      returnModified [SigP.sampleRate freq]-         (Syn.allpassCascade order params) x--}----{- | Infinitely many equi-delayed exponentially decaying echos. -}-comb :: (RealField.C t, Ring.C t', OccScalar.C t t', Module.C y yv) =>-   t' -> y -> Proc.T t t' (SigR.T y y' yv -> SigR.T y y' yv)-comb time gain = SigR.lift (FiltC.comb time gain)---integrate :: (Additive.C v, Field.C q') =>-   Proc.T q q'-       (SigR.T q q' v-     -> SigR.T q q' v)-integrate = SigR.lift FiltC.integrate---{--returnModified :: (Eq q) =>-   [Process.Value q] -> ([v] -> [w]) -> SigR.T y y' yv -> SigI.Process a q w-returnModified sampleRates proc x =-   do let sampleRate = SigP.sampleRate x-      mapM_ (Process.equalValue sampleRate) sampleRates-      SigI.returnCons-         sampleRate (SigP.amplitude x)-         (proc (SigP.samples x))--}
− src/Synthesizer/Inference/Reader/Noise.hs 
@@ -1,62 +0,0 @@-{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}-{- |-Copyright   :  (c) Henning Thielemann 2006-License     :  GPL--Maintainer  :  synthesizer@henning-thielemann.de-Stability   :  provisional-Portability :  requires multi-parameter type classes---}-module Synthesizer.Inference.Reader.Noise-  (white,-   whiteGen,-   randomPeeks) where---import qualified Synthesizer.SampleRateContext.Noise as NoiseC--import qualified Synthesizer.Inference.Reader.Signal as SigR-import qualified Synthesizer.Inference.Reader.Process as Proc--import qualified Algebra.OccasionallyScalar as OccScalar-import qualified Algebra.Algebraic          as Algebraic-import qualified Algebra.Field              as Field-import qualified Algebra.Ring               as Ring--import System.Random (Random, RandomGen)---- import NumericPrelude-import PreludeBase as P----white :: (Ring.C yv, Random yv, Algebraic.C q') =>-      q'  {-^ width of the frequency band -}-   -> q'  {-^ volume caused by the given frequency band -}-   -> Proc.T t q' (SigR.T y q' yv)-          {-^ noise -}-white bandWidth volume = SigR.lift $ NoiseC.white bandWidth volume--whiteGen :: (Ring.C yv, Random yv, RandomGen g, Algebraic.C q') =>-      g   {-^ random generator, can be used to choose a seed -}-   -> q'  {-^ width of the frequency band -}-   -> q'  {-^ volume caused by the given frequency band -}-   -> Proc.T t q' (SigR.T y q' yv)-          {-^ noise -}-whiteGen gen bandWidth volume = SigR.lift (NoiseC.whiteGen gen bandWidth volume)--{--The Field.C q constraint could be lifted to Ring.C-if we would use direct division instead of toFrequencyScalar.--}-randomPeeks ::-   (Field.C q, Random q, Ord q,-    Field.C q', OccScalar.C q q') =>-   Proc.T q q'-      (   SigR.T q q' q  {-   momentary densities (frequency),-                              @p@ means that there is about one peak-                              in the time range of @1\/p@. -}-       -> [Bool])-                         {-   Every occurence of 'True' represents a peak. -}-randomPeeks = SigR.lift NoiseC.randomPeeks
− src/Synthesizer/Inference/Reader/Oscillator.hs 
@@ -1,79 +0,0 @@-{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}-{- |-Copyright   :  (c) Henning Thielemann 2006, 2008-License     :  GPL--Maintainer  :  synthesizer@henning-thielemann.de-Stability   :  provisional-Portability :  requires multi-parameter type classes---}-module Synthesizer.Inference.Reader.Oscillator (-   {- * Oscillators with constant waveforms -}-   static,-   freqMod,-   phaseMod,-   phaseFreqMod,-) where--import qualified Synthesizer.SampleRateContext.Oscillator as OsciC---- import qualified Synthesizer.Plain.Oscillator as Osci-import qualified Synthesizer.Basic.Wave       as Wave--import qualified Synthesizer.Inference.Reader.Signal as SigR-import qualified Synthesizer.Inference.Reader.Process as Proc--import qualified Algebra.OccasionallyScalar as OccScalar-import qualified Algebra.RealField          as RealField-import qualified Algebra.Field              as Field---- import NumericPrelude--- import PreludeBase as P---{- * Oscillators with constant waveforms -}--{- | oscillator with a functional waveform with constant frequency -}-static :: (RealField.C t, Field.C t', OccScalar.C t t') =>-      Wave.T t yv  {- ^ waveform -}-   -> y'           {- ^ amplitude -}-   -> t            {- ^ start phase from the range [0,1] -}-   -> t'           {- ^ frequency -}-   -> Proc.T t t' (SigR.T y y' yv)-static wave amplitude phase freq =-   SigR.lift (OsciC.static wave amplitude phase freq)--{- | oscillator with a functional waveform with modulated frequency -}-freqMod :: (RealField.C t, Field.C t', OccScalar.C t t') =>-      Wave.T t yv  {- ^ waveform -}-   -> y'           {- ^ amplitude -}-   -> t            {- ^ start phase from the range [0,1] -}-   -> Proc.T t t' (-          SigR.T t t' t  {-   frequency control -}-       -> SigR.T y y' yv)-freqMod wave amplitude phase =-   SigR.lift (OsciC.freqMod wave amplitude phase)--{- | oscillator with modulated phase -}-phaseMod :: (RealField.C t, Field.C t', OccScalar.C t t') =>-      Wave.T t yv  {- ^ waveform -}-   -> y'           {- ^ amplitude -}-   -> t'           {- ^ frequency control -}-   -> Proc.T t t' (-          SigR.T t t  t  {-   phase modulation, phases must have no unit and-                              are from range [0,1] -}-       -> SigR.T y y' yv)-phaseMod wave amplitude freq =-   SigR.lift (OsciC.phaseMod wave amplitude freq)--{- | oscillator with a functional waveform with modulated phase and frequency -}-phaseFreqMod :: (RealField.C t, Field.C t', OccScalar.C t t') =>-      Wave.T t yv  {- ^ waveform -}-   -> y'           {- ^ amplitude -}-   -> Proc.T t t' (-          SigR.T t t  t  {-   phase control -}-       -> SigR.T t t' t  {-   frequency control -}-       -> SigR.T y y' yv)-phaseFreqMod wave amplitude =-   SigR.lift (OsciC.phaseFreqMod wave amplitude)
− src/Synthesizer/Inference/Reader/Play.hs 
@@ -1,21 +0,0 @@-module Synthesizer.Inference.Reader.Play where--import qualified BinarySample as BinSmp--import qualified Synthesizer.Inference.Reader.Signal  as SigR-import qualified Synthesizer.Inference.Reader.Process as ProcR-import qualified Synthesizer.Physical.Play           as PlayP--import qualified Algebra.OccasionallyScalar as OccScalar-import qualified Algebra.VectorSpace        as VectorSpace-import qualified Algebra.RealField          as RealField-import qualified Algebra.Field              as Field---auto :: (RealField.C t, BinSmp.C yv,-         Field.C t', OccScalar.C t t',-         Field.C y', OccScalar.C y y',-         VectorSpace.C y yv) =>-   t' -> y' -> t' -> ProcR.T t t' (SigR.T y y' yv) -> IO ()-auto freqUnit amp sampleRate proc =-   PlayP.auto freqUnit amp (SigR.run sampleRate proc)
− src/Synthesizer/Inference/Reader/Process.hs 
@@ -1,110 +0,0 @@-{- |--Copyright   :  (c) Henning Thielemann 2007-License     :  GPL--Maintainer  :  synthesizer@henning-thielemann.de-Stability   :  provisional-Portability :  requires multi-parameter type classes (OccasionallyScalar)----Light-weight sample parameter inference which will fit most needs.-We only do \"poor man's inference\", only for sample rates.-The sample rate will be provided in a Reader monad.-We almost do not need monad functionality-but only "Control.Applicative" functionality.--In contrast to the run-time inference approach,-we have the static guarantee that the sample rate is fixed-before passing a signal to the outside world.--}-module Synthesizer.Inference.Reader.Process (-      T(..),-      run, share,-      injectParam, extractParam, convertTimeParam,-      loop, pure,-      ($:), ($::), ($^), ($#),-      (.:), (.^),-      liftP, liftP2, liftP3, liftP4,-   ) where--import Control.Monad.Fix (MonadFix(mfix), )-import Synthesizer.ApplicativeUtility-import qualified Control.Applicative as App-import Control.Applicative (Applicative)--{--import NumericPrelude-import PreludeBase as P--}---{- |-This wraps a function which computes a sample rate dependent result.-Sample rate tells how many values per unit are stored-for representation of a signal.--}-newtype T t t' a = Cons {process :: t' -> a}---instance Functor (T t t') where-   fmap f x = Cons (f . process x)--instance Applicative (T t t') where-   pure  = pure-   (<*>) = apply--instance Monad (T t t') where-   return = pure-   (>>=)  = share--instance MonadFix (T t t') where-   mfix = loop . injectParam----run ::-   t' -> T t t' a -> (t', a)-run sr (Cons p) = (sr, p sr)---{- |-Re-use a result several times without recomputing.-With a simple @let@ you can re-use a result-but it must be recomputed due to the dependency on the sample rate.--}-share ::-      T t t' a        {-^ process that provides a result -}-   -> (a -> T t t' b) {-^ function that can re-use that result as much as it wants -}-   -> T t t' b-share p f = Cons $ \sr ->-   process (f (process p sr)) sr----{- |-This corresponds to 'Control.Applicative.pure'--}-pure :: a -> T t t' a-pure x = Cons $ const x--apply :: T t t' (a -> b) -> T t t' a -> T t t' b-apply f proc = Cons $ \sr ->-   process f sr (process proc sr)--extractParam :: T t t' (a -> b) -> (a -> T t t' b)-extractParam = ($#)--injectParam :: (a -> T t t' b) -> T t t' (a -> b)-injectParam f = Cons $ \sr x ->-   process (f x) sr--{- |-The first argument will be a function like 'InferenceReader.Signal.toTimeScalar'.-If you use this function instead of 'InferenceReader.Signal.toTimeScalar' directly,-the type @t@ can be automatically infered.--}-convertTimeParam :: (t' -> t' -> t) -> t' -> (t -> a) -> T t t' a-convertTimeParam convert t' f = Cons $ \sr ->-   f (convert sr t')
− src/Synthesizer/Inference/Reader/Signal.hs 
@@ -1,136 +0,0 @@-{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}-{- |--Copyright   :  (c) Henning Thielemann 2007-License     :  GPL--Maintainer  :  synthesizer@henning-thielemann.de-Stability   :  provisional-Portability :  requires multi-parameter type classes (OccasionallyScalar)--}-module Synthesizer.Inference.Reader.Signal (-    T(..),-    run,-    addSampleRate,-    apply,-    lift,-    returnCons,--    toTimeScalar,-    toFrequencyScalar,-    toAmplitudeScalar,-    toGradientScalar,--    scalarSamples,-    vectorSamples,--    ($-),-    constant,-   ) where--import Synthesizer.Inference.Reader.Process (($:))-import qualified Synthesizer.Inference.Reader.Process as Proc--import qualified Synthesizer.SampleRateContext.Rate   as Rate-import qualified Synthesizer.SampleRateContext.Signal as SigC-import qualified Synthesizer.Physical.Signal as SigP--import Synthesizer.SampleRateContext.Signal (T(Cons, samples, amplitude))--import qualified Algebra.OccasionallyScalar as OccScalar-import qualified Algebra.Module         as Module-import qualified Algebra.Field          as Field-import qualified Algebra.Ring           as Ring--import Algebra.OccasionallyScalar (toScalar)--import NumericPrelude-import PreludeBase as P----run ::-   t' -> Proc.T t t' (T y y' yv) -> SigP.T t t' y y' yv-run sr proc =-   uncurry addSampleRate (Proc.run sr proc)--{--run ::-   Rate.T t t' -> Proc.T t t' (T y y' yv) -> SigP.T t t' y y' yv-run sr proc =-   uncurry addSampleRate (Proc.run (Rate.toNumber sr) proc)--}--addSampleRate ::-   t' -> T y y' yv -> SigP.T t t' y y' yv-addSampleRate = SigP.addPlainSampleRate--apply ::-   (Proc.T t t' (T y0 y0' y0v -> T y1 y1' y1v))-    -> SigP.T t t' y0 y0' y0v-    -> SigP.T t t' y1 y1' y1v-apply proc (SigP.Cons sr sig) =-   let (sr', f) = Proc.run (Rate.toNumber sr) proc-   in  addSampleRate sr' (f sig)---lift :: (Rate.T t t' -> a) -> Proc.T t t' a-lift f = Proc.Cons $ f . Rate.fromNumber---returnCons ::-   y' -> [yv] -> Proc.T t t' (T y y' yv)-returnCons amp sig = Proc.pure (Cons amp sig)--{--sampleRateExpr :: SigP.T t (Value t') y (Value y') yv -> Expr t'-sampleRateExpr x = Expr.fromValue (SigP.sampleRate x)--amplitudeExpr :: SigP.T t (Value t') y (Value y') yv -> Expr y'-amplitudeExpr x = Expr.fromValue (SigP.amplitude x)--}--toTimeScalar :: (Ring.C t', OccScalar.C t t') =>-   t' -> t' -> t-toTimeScalar sampleRate t = toScalar (t * sampleRate)--toFrequencyScalar :: (Field.C t', OccScalar.C t t') =>-   t' -> t' -> t-toFrequencyScalar sampleRate f = toScalar (f / sampleRate)--toAmplitudeScalar :: (Field.C y', OccScalar.C y y') =>-   T y y' yv -> y' -> y-toAmplitudeScalar sig y =-   toScalar (y / amplitude sig)--toGradientScalar :: (Field.C q', OccScalar.C q q') =>-   q' -> q' -> q' -> q-toGradientScalar amp sampleRate steepness =-   toFrequencyScalar sampleRate (steepness / amp)---scalarSamples :: (Ring.C y) =>-   (y' -> y) -> T y y' y -> [y]-scalarSamples toAmpScalar sig =-   let y = toAmpScalar (amplitude sig)-   in  map (y*) (samples sig)--vectorSamples :: (Module.C y yv) =>-   (y' -> y) -> T y y' yv -> [yv]-vectorSamples toAmpScalar sig =-   let y = toAmpScalar (amplitude sig)-   in  y *> samples sig---{- |-Take a scalar argument where a process expects a signal.--}-($-) :: Ring.C yv =>-    Proc.T t t' (T y y' yv -> a) -> y' -> Proc.T t t' a-($-) f x = f $: Proc.pure (constant x)--{--Should be in Control module.--}-constant :: Ring.C yv => y' -> T y y' yv-constant x = Cons x (repeat 1)
+ src/Synthesizer/Interpolation.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.Interpolation where++import qualified Synthesizer.State.Signal  as Sig++import Control.Monad.Trans.State (StateT(StateT), evalStateT, )+import Control.Monad.Trans.Writer (Writer, writer, runWriter, )+import Data.Monoid (Sum(Sum), )+import Control.Applicative (Applicative(pure, (<*>)), (<$>), liftA2, )++import PreludeBase+import NumericPrelude+++++{- | interpolation as needed for resampling -}+data T t y =+  Cons {+    margin :: !Margin,+    func   :: !(t -> Sig.T y -> y)+  }++data Margin =+    Margin {+       marginNumber :: !Int,+          -- ^ interpolation requires a total number of 'number'+       marginOffset :: !Int+          -- ^ interpolation requires 'offset' values before the current+    }+   deriving (Show, Eq)++cons :: Int -> Int -> (t -> Sig.T y -> y) -> T t y+cons num off =+   Cons (Margin num off)++number :: T t y -> Int+number = marginNumber . margin++offset :: T t y -> Int+offset = marginOffset . margin++++{-* Different kinds of interpolation -}++{-** Hard-wired interpolations -}++{-+Applicative composition of two applicative functors,+namely @Writer@ and @StateT Maybe@.+We could also use (.:) from TypeCompose.+-}+newtype PrefixReader y a =+   PrefixReader (Writer (Sum Int) (StateT (Sig.T y) Maybe a))++instance Functor (PrefixReader y) where+   {-# INLINE fmap #-}+   fmap f (PrefixReader m) =+      PrefixReader (fmap (fmap f) m)++instance Applicative (PrefixReader y) where+   {-# INLINE pure #-}+   {-# INLINE (<*>) #-}+   pure = PrefixReader . pure . pure+   (PrefixReader f) <*> (PrefixReader x) =+       PrefixReader (liftA2 (<*>) f x)+++{-# INLINE getNode #-}+getNode :: PrefixReader y y+getNode =+   PrefixReader $ writer (StateT Sig.viewL, Sum 1)++{-# INLINE fromPrefixReader #-}+fromPrefixReader :: String -> Int -> PrefixReader y (t -> y) -> T t y+fromPrefixReader name off (PrefixReader pr) =+   let (parser, Sum count) = runWriter pr+   in  cons count off+          (\t xs ->+              maybe+                 (error (name ++ " interpolation: not enough nodes"))+                 ($t)+                 (evalStateT parser xs))++{-| Consider the signal to be piecewise constant. -}+{-# INLINE constant #-}+constant :: T t y+constant =+   fromPrefixReader "constant" 0 (const <$> getNode)
+ src/Synthesizer/Interpolation/Class.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{- |+See NumericPrelude.AffineSpace for design discussion.+-}+module Synthesizer.Interpolation.Class where++import qualified Synthesizer.State.Signal as Sig++import qualified Algebra.Module as Module+import qualified Algebra.PrincipalIdealDomain as PID+import qualified Algebra.Ring as Ring+import qualified Algebra.Additive as Additive++import qualified Number.Ratio as Ratio+import qualified Number.Complex as Complex++import Control.Applicative (Applicative(pure, (<*>)), )+import Data.Tuple.HT (mapPair, mapSnd, fst3, snd3, thd3, )++import NumericPrelude hiding (zero, )+import PreludeBase+import Prelude ()++{- |+Given that @scale zero v == Additive.zero@+this type class is equivalent to Module in the following way:++> scaleAndAccumulate (a,x) =+>    let ax = a *> x+>    in  (ax, (ax+))++(see implementation of 'scaleAndAccumulateModule')+and++> x+y = scaleAccumulate one y $ scale one x+> zero = scale zero x+> s*>x = scale s x++But this redundancy is only because of a lack of the type system+or lack of my imagination how to solve it better.+Use this type class for all kinds of interpolation,+that is where addition and scaling alone make no sense.++I intended to name this class AffineSpace,+because all interpolations should be affine combinations.+This property is equivalent to interpolations that preserve constant functions.+However, I cannot easily assert this property+and I'm not entirely sure+that all reasonable interpolations are actually affine.++Early versions had a @zero@ method,+but this is against the idea of interpolation.+For implementing @zero@ we needed a @Maybe@ wrapper+for interpolation of @StorableVector@s.+Btw. having @zero@ instead of @scale@ is also inefficient,+since every sum must include a zero summand,+which works well only when the optimizer+simplifies addition with a constant.++We use only one class method+that contains actually two methods:+@scale@ and @scaleAccumulate@.+We expect that instances are always defined on record types+lifting interpolations from scalars to records.+This should be done using 'makeMac' and friends+or the 'MAC' type and the 'Applicative' interface+for records with many elements.+-}+class Ring.C a => C a v where+   scaleAndAccumulate :: (a,v) -> (v, v -> v)+++instance C Float Float where+   {-# INLINE scaleAndAccumulate #-}+   scaleAndAccumulate = scaleAndAccumulateRing++instance C Double Double where+   {-# INLINE scaleAndAccumulate #-}+   scaleAndAccumulate = scaleAndAccumulateRing++instance (C a v) => C a (Complex.T v) where+   {-# INLINE scaleAndAccumulate #-}+   scaleAndAccumulate =+      makeMac2 (Complex.+:) Complex.real Complex.imag++instance (PID.C a) => C (Ratio.T a) (Ratio.T a) where+   {-# INLINE scaleAndAccumulate #-}+   scaleAndAccumulate = scaleAndAccumulateRing++instance (C a v, C a w) => C a (v, w) where+   {-# INLINE scaleAndAccumulate #-}+   scaleAndAccumulate = makeMac2 (,) fst snd++instance (C a v, C a w, C a u) => C a (v, w, u) where+   {-# INLINE scaleAndAccumulate #-}+   scaleAndAccumulate = makeMac3 (,,) fst3 snd3 thd3++++infixl 6 +.*++{-# INLINE scale #-}+scale :: C a v => (a,v) -> v+scale = fst . scaleAndAccumulate++{-# INLINE scaleAccumulate #-}+scaleAccumulate :: C a v => (a,v) -> v -> v+scaleAccumulate = snd . scaleAndAccumulate++{- |+Infix variant of 'scaleAccumulate'.+-}+{-# INLINE (+.*) #-}+(+.*) :: C a v => v -> (a,v) -> v+(+.*) = flip scaleAccumulate+++combine2 :: C a v => a -> (v, v) -> v+combine2 a (x,y) =+   scaleAccumulate (one-a, x) $+   scale (a, y)++combineMany :: C a v => (a, Sig.T a) -> (v, Sig.T v) -> v+combineMany (a,as) (v,vs) =+   Sig.foldL (flip scaleAccumulate) (scale (a,v)) $+   Sig.zip as vs+++-- * convenience functions for defining scaleAndAccumulate++{-# INLINE scaleAndAccumulateRing #-}+scaleAndAccumulateRing ::+   Ring.C a =>+   (a,a) -> (a, a -> a)+scaleAndAccumulateRing (a,x) =+   let ax = a * x+   in  (ax, (ax+))++{-# INLINE scaleAndAccumulateModule #-}+scaleAndAccumulateModule ::+   Module.C a v =>+   (a,v) -> (v, v -> v)+scaleAndAccumulateModule (a,x) =+   let ax = a *> x+   in  (ax, (ax+))+++{- |+A special reader monad.+-}+newtype MAC a v x = MAC {runMac :: (a,v) -> (x, v -> x)}++{-# INLINE element #-}+element ::+   (C a x) =>+   (v -> x) -> MAC a v x+element f =+   MAC $ \(a,x) ->+      mapSnd (.f) $ scaleAndAccumulate (a, f x)++instance Functor (MAC a v) where+   {-# INLINE fmap #-}+   fmap f (MAC x) =+      MAC $ mapPair (f, (f .)) . x++instance Applicative (MAC a v) where+   {-# INLINE pure #-}+   {-# INLINE (<*>) #-}+   pure x = MAC $ const (x, const x)+   MAC f <*> MAC x =+      MAC $ \av ->+         let (xav,add) = x av+             (g,fadd)  = f av+         in  (g xav, \y -> fadd y (add y))++{-# INLINE makeMac #-}+makeMac ::+   (C a x) =>+   (x -> v) ->+   (v -> x) ->+   (a,v) -> (v, v -> v)+makeMac cons x =+   runMac $ pure cons <*> element x++{-# INLINE makeMac2 #-}+makeMac2 ::+   (C a x, C a y) =>+   (x -> y -> v) ->+   (v -> x) -> (v -> y) ->+   (a,v) -> (v, v -> v)+makeMac2 cons x y =+   runMac $ pure cons <*> element x <*> element y++{-# INLINE makeMac3 #-}+makeMac3 ::+   (C a x, C a y, C a z) =>+   (x -> y -> z -> v) ->+   (v -> x) -> (v -> y) -> (v -> z) ->+   (a,v) -> (v, v -> v)+makeMac3 cons x y z =+   runMac $ pure cons <*> element x <*> element y <*> element z
+ src/Synthesizer/Interpolation/Custom.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+Special interpolations defined in terms of our custom Interpolation class.+-}+module Synthesizer.Interpolation.Custom (+   T,+   constant,+   linear,+   cubic,+   piecewise,+   piecewiseConstant,+   piecewiseLinear,+   piecewiseCubic,+   function,+   ) where++import qualified Synthesizer.State.Signal  as Sig+import qualified Synthesizer.Plain.Control as Ctrl+import qualified Synthesizer.Interpolation.Class as Interpol++import Synthesizer.Interpolation (+   T, cons, getNode, fromPrefixReader,+   constant,+   )++import qualified Algebra.Field     as Field+import qualified Algebra.Ring      as Ring+import qualified Algebra.Additive  as Additive++import Synthesizer.Interpolation.Class ((+.*), )++import Control.Applicative (liftA2, )+import Synthesizer.ApplicativeUtility (liftA4, )++import PreludeBase+import NumericPrelude++++{-| Consider the signal to be piecewise linear. -}+{-# INLINE linear #-}+linear :: (Interpol.C t y) => T t y+linear =+   fromPrefixReader "linear" 0+      (liftA2+          (\x0 x1 phase -> Interpol.combine2 phase (x0,x1))+          getNode getNode)++{-|+Consider the signal to be piecewise cubic,+with smooth connections at the nodes.+It uses a cubic curve which has node values+x0 at 0 and x1 at 1 and derivatives+(x1-xm1)/2 and (x2-x0)/2, respectively.+You can see how it works+if you evaluate the expression for t=0 and t=1+as well as the derivative at these points.+-}+{-# INLINE cubic #-}+cubic :: (Field.C t, Interpol.C t y) => T t y+cubic =+   fromPrefixReader "cubicAlt" 1 $ liftA4+      (\xm1 x0 x1 x2 t ->+       let (am1, a0, a1) = cubicHalf    t+           ( b2, b1, b0) = cubicHalf (1-t)+       in  Interpol.scale (am1,xm1)+             +.* (a0+b0,x0)+             +.* (a1+b1,x1)+             +.* (b2,x2))+      getNode getNode getNode getNode++{- |+See 'cubicHalfModule'.+-}+{-# INLINE cubicHalf #-}+cubicHalf :: (Field.C t) => t -> (t,t,t)+cubicHalf t =+   let c = (t-1)^2+       ct2 = c*t/2+   in  (-ct2, c*(1+2*t), ct2)+++{-** Interpolation based on piecewise defined functions -}++{- |+List of functions must be non-empty.+-}+{-# INLINE piecewise #-}+piecewise :: (Interpol.C t y) =>+   Int -> [t -> t] -> T t y+piecewise center ps =+   cons (length ps) (center-1) $+   \t ->+      combineMany+         "Interpolation.element: list of functions empty"+         "Interpolation.element: list of samples empty" $+            Sig.map ($t) $ Sig.fromList $ reverse ps++{-# INLINE piecewiseConstant #-}+piecewiseConstant :: (Interpol.C t y) => T t y+piecewiseConstant =+   piecewise 1 [const 1]++{-# INLINE piecewiseLinear #-}+piecewiseLinear :: (Interpol.C t y) => T t y+piecewiseLinear =+   piecewise 1 [id, (1-)]++{-# INLINE piecewiseCubic #-}+piecewiseCubic :: (Field.C t, Interpol.C t y) => T t y+piecewiseCubic =+   piecewise 2 $+      Ctrl.cubicFunc (0,(0,0))    (1,(0,1/2)) :+      Ctrl.cubicFunc (0,(0,1/2))  (1,(1,0)) :+      Ctrl.cubicFunc (0,(1,0))    (1,(0,-1/2)) :+      Ctrl.cubicFunc (0,(0,-1/2)) (1,(0,0)) :+      []++{-+GNUPlot.plotList [] $ take 100 $ interpolate (Zero 0) piecewiseCubic (-2.3 :: Double) (repeat 0.1) [2,1,2::Double]+-}+++{-** Interpolation based on arbitrary functions -}++{- | with this wrapper you can use the collection of interpolating functions from Donadio's DSP library -}+{-# INLINE function #-}+function :: (Interpol.C t y) =>+      (Int,Int)   {- ^ @(left extent, right extent)@, e.g. @(1,1)@ for linear hat -}+   -> (t -> t)+   -> T t y+function (left,right) f =+   let len = left+right+       ps  = Sig.take len $ Sig.iterate pred (pred right)+       -- ps = Sig.reverse $ Sig.take len $ Sig.iterate succ (-left)+   in  cons len left $+       \t ->+          combineMany+             "Interpolation.function: empty function domain"+             "Interpolation.function: list of samples empty" $+             Sig.map (\x -> f (t + fromIntegral x)) ps+{-+GNUPlot.plotList [] $ take 300 $ interpolate (Zero 0) (function (1,1) (\x -> exp (-6*x*x))) (-2.3 :: Double) (repeat 0.03) [2,1,2::Double]+-}++combineMany ::+   (Interpol.C a v) =>+   String -> String ->+   Sig.T a -> Sig.T v -> v+combineMany msgCoefficients msgSamples ct xt =+   Sig.switchL (error msgCoefficients)+      (\c cs ->+         Sig.switchL (error msgSamples)+            (curry (Interpol.combineMany (c,cs)))+            xt)+      ct
+ src/Synthesizer/Interpolation/Module.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+Special interpolations defined in terms of Module operations.+-}+module Synthesizer.Interpolation.Module (+   T,+   constant,+   linear,+   cubic,+   cubicAlt,+   piecewise,+   piecewiseConstant,+   piecewiseLinear,+   piecewiseCubic,+   function,+   ) where++import qualified Synthesizer.State.Signal  as Sig+import qualified Synthesizer.Plain.Control as Ctrl++import Synthesizer.Interpolation (+   T, cons, getNode, fromPrefixReader,+   constant,+   )++import qualified Algebra.Module    as Module+-- import qualified Algebra.RealField as RealField+import qualified Algebra.Field     as Field+import qualified Algebra.Ring      as Ring+import qualified Algebra.Additive  as Additive++import Algebra.Module((*>))++import Control.Applicative (liftA2, )+import Synthesizer.ApplicativeUtility (liftA4, )+import Synthesizer.Utility (affineComb, )++import PreludeBase+import NumericPrelude+++{-| Consider the signal to be piecewise linear. -}+{-# INLINE linear #-}+linear :: (Module.C t y) => T t y+linear =+   fromPrefixReader "linear" 0+      (liftA2+          (\x0 x1 phase -> affineComb phase (x0,x1))+          getNode getNode)++{- |+Consider the signal to be piecewise cubic,+with smooth connections at the nodes.+It uses a cubic curve which has node values+x0 at 0 and x1 at 1 and derivatives+(x1-xm1)/2 and (x2-x0)/2, respectively.+You can see how it works+if you evaluate the expression for t=0 and t=1+as well as the derivative at these points.+-}+{-# INLINE cubic #-}+cubic :: (Field.C t, Module.C t y) => T t y+cubic =+   fromPrefixReader "cubic" 1+      (liftA4+         (\xm1 x0 x1 x2 t ->+            let lipm12 = affineComb t (xm1,x2)+                lip01  = affineComb t (x0, x1)+                three  = 3 `asTypeOf` t+            in  lip01 + (t*(t-1)/2) *>+                           (lipm12 + (x0+x1) - three *> lip01))+         getNode getNode getNode getNode)++{- |+The interpolators for module operations+do not simply compute a straight linear combination of some vectors.+Instead they add then scale, then add again, and so on.+This is efficient whenever scaling and addition is cheap.+In this case they might save multiplications.+I can't say much about numeric cancellations, however.+-}+{-# INLINE cubicAlt #-}+cubicAlt :: (Field.C t, Module.C t y) => T t y+cubicAlt =+   fromPrefixReader "cubicAlt" 1+      (liftA4+         (\xm1 x0 x1 x2 t ->+          let half = 1/2 `asTypeOf` t+          in  cubicHalf    t  x0 (half *> (x1-xm1)) ++              cubicHalf (1-t) x1 (half *> (x0-x2)))+         getNode getNode getNode getNode)+++{- |+@\t -> cubicHalf t x x'@ has a double zero at 1 and+at 0 it has value x and slope x'.+-}+{-# INLINE cubicHalf #-}+cubicHalf :: (Module.C t y) => t -> y -> y -> y+cubicHalf t x x' =+   (t-1)^2 *> ((1+2*t)*>x + t*>x')++++{-** Interpolation based on piecewise defined functions -}++{-# INLINE piecewise #-}+piecewise :: (Module.C t y) =>+   Int -> [t -> t] -> T t y+piecewise center ps =+   cons (length ps) (center-1)+      (\t -> Sig.linearComb (Sig.fromList (map ($t) (reverse ps))))++{-# INLINE piecewiseConstant #-}+piecewiseConstant :: (Module.C t y) => T t y+piecewiseConstant =+   piecewise 1 [const 1]++{-# INLINE piecewiseLinear #-}+piecewiseLinear :: (Module.C t y) => T t y+piecewiseLinear =+   piecewise 1 [id, (1-)]++{-# INLINE piecewiseCubic #-}+piecewiseCubic :: (Field.C t, Module.C t y) => T t y+piecewiseCubic =+   piecewise 2 $+      Ctrl.cubicFunc (0,(0,0))    (1,(0,1/2)) :+      Ctrl.cubicFunc (0,(0,1/2))  (1,(1,0)) :+      Ctrl.cubicFunc (0,(1,0))    (1,(0,-1/2)) :+      Ctrl.cubicFunc (0,(0,-1/2)) (1,(0,0)) :+      []++{-+GNUPlot.plotList [] $ take 100 $ interpolate (Zero 0) piecewiseCubic (-2.3 :: Double) (repeat 0.1) [2,1,2::Double]+-}+++{-** Interpolation based on arbitrary functions -}++{- | with this wrapper you can use the collection of interpolating functions from Donadio's DSP library -}+{-# INLINE function #-}+function :: (Module.C t y) =>+      (Int,Int)   {- ^ @(left extent, right extent)@, e.g. @(1,1)@ for linear hat -}+   -> (t -> t)+   -> T t y+function (left,right) f =+   let len = left+right+       ps  = Sig.take len $ Sig.iterate pred (pred right)+       -- ps = Sig.reverse $ Sig.take len $ Sig.iterate succ (-left)+   in  cons len left+          (\t -> Sig.linearComb $+                   Sig.map (\x -> f (t + fromIntegral x)) ps)+{-+GNUPlot.plotList [] $ take 300 $ interpolate (Zero 0) (function (1,1) (\x -> exp (-6*x*x))) (-2.3 :: Double) (repeat 0.03) [2,1,2::Double]+-}
+ src/Synthesizer/Overview.hs view
@@ -0,0 +1,178 @@+{- |+This module gives an overview of the library.++The library is a collection of modules for synthesizing and processing audio signals.+It allows generation of effects, instruments and+even music using the Haskore package.+It can write raw audio data to files,+convert them to common audio formats or+play them using external commands from the Sox package.+If used properly, it can run in real-time.++A signal is modeled by a sequence of sample values.+E.g. @[Double]@ represents a mono signal,+@[(Double, Double)]@ stores a stereo signal.+Since a list is lazy, it can be infinitely long,+and it also supports feedback.+(The drawback is, that its implementation is very slow.+You have to use other signal presentations of this library for real-time processing.)+We are using the NumericPrelude type class hierarchy+which is cleaner than the one of Haskell 98+and provides us with a type class for vector spaces and other structures.+This allows us to formulate many algorithms for mono, stereo and multi-channel signals at once.+The drawback is that the vector space type class has multiple type parameters.+This type extension is available in GHC and Hugs and maybe other compilers.+It may hurt you, because type inference fails sometimes,+resulting in strange type errors.+(To be precise: GHC suggests type constraints intended for fixing the problem,+but if you copy them to your program, they won't fix the problem,+because the constraint refers to local variables+that you have no access to at the signature.+In this case you have to use 'asTypeOf' or similar self-written helpers.)++There must also be information about how fast sample values are emitted.+This is specified by the sample rate.+44100 Hz means that 44100 sample values are emitted per second.+This information must be stored along with the sample values.+This is where things become complicated.++In the very basic modules in the "Synthesizer.Plain.Signal" directory,+there is no notion of sample rate.+You have to base all computations on the number of samples.+This is unintuitive and disallows easy adaption to different audio devices+(CD, DAT, ...).+But it is very simple and can be re-used in the higher level modules.++Let's continue with the sample rate issue.+Sounds of different sources may differ in their sampling rate+(and also with respect to its amplitude and the unit of the values).+Sampled sounds have 44100 Hz on a compact disk,+48000 Hz or 32000 Hz on DAT recorders.+We want to respect different sampling rates and volumes,+we want to let signals in different formats coexist nicely,+and we want to let the user choose when to do which conversion+(called /resampling/)+in order to bring them together.++In fact this view generalizes the concept of note, control, and audio rates,+which is found in some software synthesizers,+like CSound and SuperCollider.+If signals of different rate are fed to a signal processor+in such a software synthesizer,+all signals are converted to the highest rate among the inputs.+Then the processor runs at this rate.+The conversion is usually done by \"constant\" interpolation,+in order to minimize recomputation of internal parameters.+However the handling of different signal rates must be built into every processor,+and may even reduce the computation speed.+Consider an exponential envelope which is computed at control rate+and an amplifier which applies this envelope to an audio signal.+The amplifier has to upsample the exponential envelope before applying it to the signal.+But the generation of the exponential is very simple,+one multiplication per sample,+and the amplifier is very simple, too,+again only one multiplication per sample.+So, is there a need for trouble of the resampling?+Does it really accelerates computation?+Many other envelope generators like straight lines, sines, oscillators,+are comparably simple.+However there are some processors like filters,+which need some recomputation when a control parameter changes.++Our approach is this one:+We try to avoid resampling and compute all signals at the same rate,+if no speed loss must be expected.+If a speed loss is to be expected,+we can interpolate the internal parameters of the processor explicitly.+This way we can also specify an interpolation method.+Alternatively we can move the interpolation into the processor+but let the user specify an interpolation method.+(Currently it can be used only manually for the low-level routines in "Synthesizer.Plain.Signal"+and for the high level modules there is "Synthesizer.Dimensional.ControlledProcess".)++Additional to the treatment of sampling rates,+we also want to separate amplitude information from the signal.+The separated amplitude serves two purposes:++(1) The amplitude can be equipped with a physical unit,+    whereas this information is omitted for the samples.+    Since I can hardly imagine that it is sensible to mix samples+    with different physical units,+    it would be only wasted time to always check+    if all physical values of a sequence have the same unit.++(2) The amplitude can be a floating point number,+    but the samples can be fixed point numbers.+    This is interesting for hardware digital signal processors+    or other low-level applications.+    With this method we can separate the overall dynamics from the samples.+++Let's elaborate on the physical units now.+With them we can work with values from the real world immediately+and we have additional safety by unit checks.+I have not fixed the physical dimensions for the signal processors,+e.g. an oscillator can well generate a signal+over the length dimension mapping to forces.+This is useful for interim results in physically motivated signal generation+but it can be useful on its own for non-audio signal processing.+The processors only check whether the dimensions match,+e.g. an oscillator generating a time-to-voltage signal+must have a frequency in Hertz+and a length-to-force oscillator must have @1/meter@ as frequency.++Of course I prefer static safety.+E.g. I want to avoid+to accidentally call a function with conflicting parameters.+However, I see no way for both applying the unit checks statically+and let check physical quantities that are provided by an application user via I\/O.+Since there seems to be no one solution for all problems,+we have two distinct ones:++(1) Store units in a data structure and check them dynamically.+    This is imported from NumericPrelude's "Number.Physical".+    Units can be fetched from the user.+    The API of signal processing functions is generic enough+    to cover both values without units and values with units.+    Debugging of unit errors is cumbersome.++(2) Store physical dimensions in types+    either using Buckwalter's dimensional package+    or using NumericPrelude's "Number.DimensionTerm".+    Here we use the latter one.+    This is the most useful if user interaction is not needed.+    If data is fetched from an audio file+    the dimensions are statically fixed.++* The various signal storage types are described in "Synthesizer.Storage".++* The various attributes, that can be attached to plain signal storages+  are described in "Synthesizer.Dimensional.Overview".++* Various abstractions are described in "Synthesizer.Dimensional.Abstraction.Overview".++* For historical reasons there is a survey on various approaches+  of sample rate abstraction in "Synthesizer.Inference.Overview".++* Some introductory examples are described+  in "Synthesizer.Tutorial".+++Packages based on this one:++* @dafx@ package:+  The module "Presentation" contains functions+  for demonstrating synthesizer functions in GHCi+  and "DAFx" contains some examples based on them.+  Just hit @make dafx@ in a shell in order to compile the modules+  and enter the interactive GHC with all modules loaded.++* An interface to the music composition library Haskore+  together with various examples+  can be found in the @haskore-synthesizer@ package.++* @synthesizer-alsa@ allows to receive MIDI events via ALSA+  and convert them to control signals.+  This way you can do interactive signal processing via MIDI input devices.+-}+module Synthesizer.Overview where
src/Synthesizer/Physical/Control.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} {-| Control curve generation -}
src/Synthesizer/Physical/Cut.hs view
@@ -28,9 +28,7 @@ import qualified Algebra.Real               as Real import qualified Algebra.Ring               as Ring --- import qualified Data.List as List--import Synthesizer.Utility (mapSnd)+import Data.Tuple.HT (mapSnd, )  import PreludeBase (Eq, Ord, Bool, uncurry, (.), (==), flip, fst, error) -- import NumericPrelude
src/Synthesizer/Physical/File.hs view
@@ -1,8 +1,8 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} module Synthesizer.Physical.File where -import qualified Sox.File-import qualified BinarySample as BinSmp+import qualified Synthesizer.Plain.File as File+import qualified Synthesizer.Basic.Binary as BinSmp  import qualified Synthesizer.Physical.Signal as SigP @@ -18,10 +18,11 @@   -write :: (RealField.C t, BinSmp.C yv,-          Field.C t', OccScalar.C t t',-          Field.C y', OccScalar.C y y',-          VectorSpace.C y yv) =>+writeToInt16 ::+   (RealField.C t, BinSmp.C yv,+    Field.C t', OccScalar.C t t',+    Field.C y', OccScalar.C y y',+    VectorSpace.C y yv) =>    t' -> y' -> FilePath -> SigP.T t t' y y' yv -> IO ExitCode-write freqUnit amp name sig =-   uncurry (Sox.File.write name) (SigP.pureData freqUnit amp sig)+writeToInt16 freqUnit amp name sig =+   uncurry (File.writeToInt16 name) (SigP.pureData freqUnit amp sig)
src/Synthesizer/Physical/Filter.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} module Synthesizer.Physical.Filter where  import qualified Synthesizer.SampleRateContext.Filter as FiltC
src/Synthesizer/Physical/Noise.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} module Synthesizer.Physical.Noise where  import qualified Synthesizer.SampleRateContext.Noise as NoiseC
src/Synthesizer/Physical/Oscillator.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright   :  (c) Henning Thielemann 2006, 2008 License     :  GPL
src/Synthesizer/Physical/Play.hs view
@@ -1,8 +1,8 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} module Synthesizer.Physical.Play where -import qualified Sox.Play-import qualified BinarySample as BinSmp+import qualified Synthesizer.Plain.Play as Play+import qualified Synthesizer.Basic.Binary as BinSmp  import qualified Synthesizer.Physical.Signal as SigP @@ -11,15 +11,18 @@ import qualified Algebra.RealField          as RealField import qualified Algebra.Field              as Field +import System.Exit(ExitCode)+ -- import NumericPrelude import PreludeBase   -auto :: (RealField.C t, BinSmp.C yv,-         Field.C t', OccScalar.C t t',-         Field.C y', OccScalar.C y y',-         VectorSpace.C y yv) =>-   t' -> y' -> SigP.T t t' y y' yv -> IO ()-auto freqUnit amp sig =-   uncurry Sox.Play.auto (SigP.pureData freqUnit amp sig)+toInt16 ::+   (RealField.C t, BinSmp.C yv,+    Field.C t', OccScalar.C t t',+    Field.C y', OccScalar.C y y',+    VectorSpace.C y yv) =>+   t' -> y' -> SigP.T t t' y y' yv -> IO ExitCode+toInt16 freqUnit amp sig =+   uncurry Play.toInt16 (SigP.pureData freqUnit amp sig)
src/Synthesizer/Physical/Signal.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} {-| Copyright   :  (c) Henning Thielemann 2006, 2008 License     :  GPL@@ -37,7 +37,8 @@ import Algebra.OccasionallyScalar(toScalar) import Algebra.Module((*>)) -import Synthesizer.Utility (mapSnd, common, )+import Data.Tuple.HT (mapSnd, )+import Synthesizer.Utility (common, )  import PreludeBase import NumericPrelude
src/Synthesizer/Plain/Analysis.hs view
@@ -1,4 +1,6 @@-{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-} module Synthesizer.Plain.Analysis where  import qualified Synthesizer.Plain.Signal as Sig@@ -252,11 +254,15 @@ -} centroid :: Field.C y => Sig.T y -> y centroid xs =-   scalarProduct (iterate (one+) zero) xs / sum xs+   firstMoment xs / sum xs  centroidAlt :: Field.C y => Sig.T y -> y centroidAlt xs =    sum (scanr (+) zero (tail xs)) / sum xs++firstMoment :: Ring.C y => Sig.T y -> y+firstMoment =+   scalarProduct (iterate (one+) zero)   average :: Field.C y => Sig.T y -> y
+ src/Synthesizer/Plain/Builder.hs view
@@ -0,0 +1,57 @@+module Synthesizer.Plain.Builder (+   T, Put, put, run,+   signalToBinary, signalToBinaryMono, signalToBinaryStereo,+   ) where++import qualified Synthesizer.Basic.Binary as BinSmp++import Data.Monoid (Monoid, mempty, mappend, mconcat, Endo(Endo), appEndo, )++import qualified Algebra.ToInteger as ToInteger+import qualified Algebra.RealField as RealField++import qualified Prelude as P98++import PreludeBase+import NumericPrelude++++newtype T a = Cons {decons :: Endo [a]}++type Put a = a -> T a+++instance Monoid (T a) where+   mempty = Cons mempty+   mappend x y = Cons $ decons x `mappend` decons y++put :: Put a+put = Cons . Endo . (:)++run :: T a -> [a]+run = flip appEndo [] . decons+++{-# INLINE signalToBinary #-}+signalToBinary ::+   (BinSmp.C v, ToInteger.C int, Bounded int) =>+   [v] -> [int]+signalToBinary =+   run . mconcat . map (BinSmp.outputFromCanonical put)++{-# INLINE signalToBinaryMono #-}+signalToBinaryMono ::+   (RealField.C a, ToInteger.C int, Bounded int) =>+   [a] -> [int]+signalToBinaryMono =+   map (BinSmp.fromCanonicalWith round)++{-# INLINE signalToBinaryStereo #-}+signalToBinaryStereo ::+   (RealField.C a, ToInteger.C int, Bounded int) =>+   [(a,a)] -> [int]+signalToBinaryStereo =+   concatMap (\(l,r) ->+      [BinSmp.fromCanonicalWith round l,+       BinSmp.fromCanonicalWith round r])
src/Synthesizer/Plain/Control.hs view
@@ -1,4 +1,6 @@-{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-} module Synthesizer.Plain.Control where  import Synthesizer.Plain.Displacement (raise)@@ -16,8 +18,8 @@  import Number.Complex (cis,real) -- import qualified Number.Complex as Complex-import Data.List (zipWith4, tails)-import NumericPrelude.List (iterateAssoc)+import Data.List (zipWith4, tails, )+import Data.List.HT (iterateAssociative, )  import qualified Prelude as P import PreludeBase@@ -90,7 +92,22 @@ linearSubdivision = subdivide (\x0 x1 -> (x0+x1)/2)  +{- |+Linear curve of a fixed length.+The final value is not actually reached,+instead we stop one step before.+This way we can concatenate several lines+without duplicate adjacent values.+-}+line :: Field.C y =>+      Int     {-^ length -}+   -> (y,y)   {-^ initial and final value -}+   -> Sig.T y {-^ linear progression -}+line n (y0,y1) =+   take n $ linear ((y1-y0) / fromIntegral n) y0 ++ exponential, exponentialMultiscale, exponentialStable :: Trans.C y =>       y   {-^ time where the function reaches 1\/e of the initial value -}    -> y   {-^ initial value -}@@ -468,9 +485,9 @@  curveMultiscale :: (y -> y -> y) -> y -> y -> Sig.T y curveMultiscale op d y0 =-   y0 : map (op y0) (iterateAssoc op d)+   y0 : map (op y0) (iterateAssociative op d)   curveMultiscaleNeutral :: (y -> y -> y) -> y -> y -> Sig.T y curveMultiscaleNeutral op d neutral =-   neutral : iterateAssoc op d+   neutral : iterateAssociative op d
src/Synthesizer/Plain/Cut.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright   :  (c) Henning Thielemann 2006 License     :  GPL@@ -30,8 +30,6 @@  import qualified Number.NonNegative as NonNeg -import NumericPrelude.List (zipWithMatch)- import PreludeBase import NumericPrelude @@ -59,10 +57,14 @@   +-- Better use zipWithMatch from NumericPrelude? selectBool :: (Sig.T a, Sig.T a) -> Sig.T Bool -> Sig.T a selectBool =+   uncurry (zipWith3 (\xf xt c -> if c then xt else xf))+{-    zipWithMatch (\(xf,xt) c -> if c then xt else xf) .    uncurry (zipWithMatch (,))+-}   select :: Ix i => Array i (Sig.T a) -> Sig.T i -> Sig.T a
src/Synthesizer/Plain/Displacement.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} {- | <http://en.wikipedia.org/wiki/Particle_displacement> -}
src/Synthesizer/Plain/Effect.hs view
@@ -13,9 +13,8 @@ import Synthesizer.Plain.Control(exponential2) import Synthesizer.Plain.Instrument import Synthesizer.Plain.Effect.Glass(glass)-import qualified Sox-import qualified Sox.File-import Filter.Example(guitarRaw, flangedSaw)+import qualified Synthesizer.Plain.File as File+import Synthesizer.Filter.Example(guitarRaw, flangedSaw) --import Interpolation(interpolate,interpolateConstant) --import System.Random import System.Exit(ExitCode)@@ -24,10 +23,9 @@ main :: IO ExitCode main =    let rate = 44100-   in  do {- Sox.File.writeMono "test" rate+   in  do {- File.writeMono "test" rate                 (take (round (3*rate)) (soundD rate)) -}-          Sox.File.renderMono "test" rate soundE-          rawSystem "sox" (Sox.sampleRateOption rate ++ ["test.sw", "test.aiff"])+          File.renderMonoToInt16 "test.aiff" rate soundE           rawSystem "play" ["test.aiff"]  @@ -55,7 +53,7 @@                         (choir sampleRate (baseFreq*3/2))        filterFreqs = map (3000/sampleRate*)                          (map sin (iterate (pi/(6*sampleRate)+) 0))-   in  Butter.lowpass 8 (0.3::Double) filterFreqs (chord::[Double])+   in  Butter.lowpassPole 8 (repeat (0.3::Double)) filterFreqs (chord::[Double])  soundA sampleRate =    choir sampleRate cFreq@@ -65,16 +63,16 @@  sound8 sampleRate =    let filterFreqs = exponential2 (-0.5*sampleRate) (100/sampleRate)-   --  Cheby.lowpassB-   --  Cheby.highpassB-   --  Cheby.lowpassA-   --  Cheby.highpassA-   in  Cheby.lowpassB 8 (0.3::Double) filterFreqs (Noise.white::[Double])+   --  Cheby.lowpassBPole+   --  Cheby.highpassBPole+   --  Cheby.lowpassAPole+   --  Cheby.highpassAPole+   in  Cheby.lowpassBPole 8 (repeat (0.3::Double)) filterFreqs (Noise.white::[Double])  sound7 sampleRate =    let filterFreqs = exponential2 (-0.5*sampleRate) (100/sampleRate)    --  butterworthHighpass-   in  Butter.lowpass 8 (0.3::Double) filterFreqs (Noise.white::[Double])+   in  Butter.lowpassPole 8 (repeat (0.3::Double)) filterFreqs (Noise.white::[Double])  -- a moog filter which randomly changes the resonance frequency sound6 sampleRate =
src/Synthesizer/Plain/Effect/Fly.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} module Synthesizer.Plain.Effect.Fly where  import qualified Synthesizer.Plain.Oscillator as Osci@@ -6,7 +6,7 @@ import qualified Synthesizer.Plain.Interpolation as Interpolation import qualified Synthesizer.Plain.Miscellaneous as Syn -import Sox.File+import qualified Synthesizer.Plain.File as File import System.Exit(ExitCode)  import System.Random@@ -23,8 +23,8 @@  main :: IO ExitCode main =-   Sox.File.writeStereo "Fly" sampleRate-              (take (round (10*sampleRate)) fly)+   File.writeStereoToInt16 "Fly" sampleRate+      (take (round (10*sampleRate)) fly)  sampleRate :: Double sampleRate = 44100
src/Synthesizer/Plain/Effect/Glass.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} module Synthesizer.Plain.Effect.Glass where  import qualified Data.EventList.Relative.TimeBody as EventList
+ src/Synthesizer/Plain/File.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.Plain.File where++import qualified Sound.Sox.Convert as Convert+import qualified Sound.Sox.Frame as Frame+import qualified Sound.Sox.Frame.Stereo as Stereo+import qualified Sound.Sox.Option.Format as SoxOpt+import qualified Sound.Sox.Write as Write+import qualified Sound.Sox.Read as Read+import qualified Sound.Sox.Signal.List as SoxList++import qualified Synthesizer.Plain.IO as FileL+import qualified Synthesizer.Plain.Builder as Builder++import qualified Data.ByteString.Lazy as B+import qualified Data.Binary.Get as Get+import qualified Synthesizer.Basic.Binary as BinSmp+import Foreign.Storable (Storable, )+import Data.Int (Int16, )++import System.Cmd (rawSystem, )+import System.Exit (ExitCode, )+import Control.Monad (liftM2, )+import Data.Monoid (mconcat, )++import qualified Algebra.ToInteger          as ToInteger+import qualified Algebra.RealField          as RealField+import qualified Algebra.Field              as Field++import qualified System.FilePath as FilePath++import PreludeBase+import NumericPrelude++++{- |+See 'write'.+-}+render ::+   (Storable int, Frame.C int, ToInteger.C int, Bounded int,+    RealField.C a, BinSmp.C v) =>+   Builder.Put int -> FilePath -> a -> (a -> [v]) -> IO ExitCode+render put fileName sampleRate renderer =+   write put fileName sampleRate (renderer sampleRate)++renderToInt16 :: (RealField.C a, BinSmp.C v) =>+   FilePath -> a -> (a -> [v]) -> IO ExitCode+renderToInt16 fileName sampleRate renderer =+   writeToInt16 fileName sampleRate (renderer sampleRate)++renderMonoToInt16 :: (RealField.C a) =>+   FilePath -> a -> (a -> [a]) -> IO ExitCode+renderMonoToInt16 fileName sampleRate renderer =+   writeMonoToInt16 fileName sampleRate (renderer sampleRate)++renderStereoToInt16 :: (RealField.C a) =>+   FilePath -> a -> (a -> [(a,a)]) -> IO ExitCode+renderStereoToInt16 fileName sampleRate renderer =+   writeStereoToInt16 fileName sampleRate (renderer sampleRate)+++{- |+The output format is determined by SoX by the file name extension.+The sample precision is determined by the provided 'Builder.Put' function.++Example:++> import qualified Synthesizer.Plain.Builder as Builder+>+> write (Builder.put :: Builder.Put Int16) "test.aiff" 44100 sound+-}+write ::+   (Storable int, Frame.C int, ToInteger.C int, Bounded int,+    RealField.C a, BinSmp.C v) =>+   Builder.Put int -> FilePath -> a -> [v] -> IO ExitCode+write put fileName sampleRate signal =+   writeRaw+      (SoxOpt.numberOfChannels (BinSmp.numberOfSignalChannels signal))+      fileName+      sampleRate+      (Builder.run . mconcat . map (BinSmp.outputFromCanonical put) $+       signal)++writeToInt16 :: (RealField.C a, BinSmp.C v) =>+   FilePath -> a -> [v] -> IO ExitCode+writeToInt16 =+   write (Builder.put :: Builder.Put Int16)++writeMonoToInt16 :: (RealField.C a) =>+   FilePath -> a -> [a] -> IO ExitCode+writeMonoToInt16 fileName sampleRate signal =+   writeRaw SoxOpt.none fileName sampleRate+      (map BinSmp.int16FromCanonical signal)++writeStereoToInt16 :: (RealField.C a) =>+   FilePath -> a -> [(a,a)] -> IO ExitCode+writeStereoToInt16 fileName sampleRate signal =+   writeRaw SoxOpt.none fileName sampleRate+      (map (fmap BinSmp.int16FromCanonical . uncurry Stereo.cons) signal)++writeRaw :: (RealField.C a, Frame.C v, Storable v) =>+   SoxOpt.T -> FilePath -> a -> [v] -> IO ExitCode+writeRaw opts fileName sampleRate signal =+   Write.extended SoxList.put opts SoxOpt.none fileName (round sampleRate) signal++{- |+You hardly need this routine+since you can use a filename with @.mp3@ or @.ogg@+extension for 'writeRaw'+and SoX will do the corresponding compression for you.+-}+writeRawCompressed :: (RealField.C a, Frame.C v, Storable v) =>+   SoxOpt.T -> FilePath -> a -> [v] -> IO ExitCode+writeRawCompressed opts fileName sampleRate signal =+   do writeRaw opts fileName sampleRate signal+      compress fileName+++{-# DEPRECATED rawToAIFF "If you want to generate AIFF, then just write to files with .aiff filename extension. If you want to convert files to AIFF, use Sound.Sox.Convert." #-}+rawToAIFF :: (RealField.C a) =>+   FilePath -> SoxOpt.T -> a -> Int -> IO ExitCode+rawToAIFF fileName soxOptions sampleRate numChannels =+   let fileNameRaw  = fileName ++ ".sw"+       fileNameAIFF = fileName ++ ".aiff"+   in  Convert.simple+          (mconcat $+           soxOptions :+           SoxOpt.sampleRate (round sampleRate) :+           SoxOpt.numberOfChannels numChannels :+           [])+          fileNameRaw+          SoxOpt.none fileNameAIFF++compress :: FilePath -> IO ExitCode+compress fileName =+   do rawSystem "oggenc" ["--quality", "5", fileName]+      rawSystem "lame"+         ["-h", fileName, FilePath.replaceExtension fileName "mp3"]+++{-# DEPRECATED readAIFFMono "Use readMonoFromInt16 instead" #-}+{-+This implementation doesn't work properly.+It seems like readFile is run+after all system calls to Sox are performed.+Aren't the calls serialized?++readAIFFMono :: (RealField.C a, Floating a) => FilePath -> IO [a]+readAIFFMono file =+   do putStrLn ("sox "++file++" /tmp/sample.sw")+      system ("sox "++file++" /tmp/sample.sw")+      str <- readFile "/tmp/sample.sw"+      return (binaryToSignalMono str)+-}+readAIFFMono :: (Field.C a) => FilePath -> IO [a]+readAIFFMono file =+   do --putStrLn ("sox "++file++" "++tmp)+      let tmp = FilePath.replaceExtension file "sw"+      Convert.simple SoxOpt.none file SoxOpt.none tmp+      fmap (map BinSmp.int16ToCanonical) (FileL.readInt16StreamStrict tmp)+++{- |+I suspect we cannot handle file closing properly.+-}+readMonoFromInt16 :: (Field.C a) => FilePath -> IO [a]+readMonoFromInt16 fileName =+   Read.open SoxOpt.none fileName >>=+   Read.withHandle1 (fmap (Get.runGet getInt16List) . B.hGetContents) >>=+   return . map BinSmp.int16ToCanonical++getInt16List :: Get.Get [Int16]+getInt16List =+   do b <- Get.isEmpty+      if b+        then return []+        else liftM2 (:) (fmap fromIntegral Get.getWord16host) getInt16List
src/Synthesizer/Plain/Filter/Delay.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} module Synthesizer.Plain.Filter.Delay where  import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR
src/Synthesizer/Plain/Filter/Delay/Block.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} {- | Fast delay based on block lists. Blocks are arrays. They are part of Haskell 98.
src/Synthesizer/Plain/Filter/Delay/List.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} module Synthesizer.Plain.Filter.Delay.List where  import qualified Synthesizer.Plain.Interpolation as Interpolation
src/Synthesizer/Plain/Filter/Delay/ST.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} {- | An implementation of a Delay using a classical circular buffer running in the State Thread monad.
src/Synthesizer/Plain/Filter/LinearPredictive.hs view
@@ -5,7 +5,7 @@ import qualified Algebra.Additive as Additive import Synthesizer.Plain.Analysis (scalarProduct) -import NumericPrelude.List (takeMatch, dropMatch, )+import qualified Data.List.Match as ListMatch import qualified Data.List as List  import NumericPrelude@@ -20,8 +20,8 @@ approxCoefficients :: Field.C a =>    a -> [a] -> [a] -> [(a,[a])] approxCoefficients k mask0 xs =-   let infixes = map (takeMatch mask0) (List.tails xs)-       targets = dropMatch mask0 xs+   let infixes = map (ListMatch.take mask0) (List.tails xs)+       targets = ListMatch.drop mask0 xs    in  scanl           (\(_,mask) (infx,target) ->               let residue = target - scalarProduct mask infx
src/Synthesizer/Plain/Filter/NonRecursive.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright   :  (c) Henning Thielemann 2006 License     :  GPL@@ -21,11 +21,11 @@  import Algebra.Module(linearComb, (*>)) -import Synthesizer.Utility (nest, )-import Data.List (tails)+import Data.Function.HT (nest, )+import Data.List (tails, ) --- import Control.Monad.State (StateT)--- import Control.Monad.Writer (WriterT)+-- import Control.Monad.Trans.State (StateT)+-- import Control.Monad.Trans.Writer (WriterT)  import PreludeBase import NumericPrelude
src/Synthesizer/Plain/Filter/Recursive.hs view
@@ -1,4 +1,6 @@-{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-} {- | Copyright   :  (c) Henning Thielemann 2008 License     :  GPL
src/Synthesizer/Plain/Filter/Recursive/Allpass.hs view
@@ -1,4 +1,6 @@-{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-} {- | Copyright   :  (c) Henning Thielemann 2008 License     :  GPL@@ -11,6 +13,8 @@  import qualified Synthesizer.Plain.Signal   as Sig import qualified Synthesizer.Plain.Modifier as Modifier+import qualified Synthesizer.Causal.Process as Causal+import qualified Synthesizer.Interpolation.Class as Interpol  import qualified Algebra.Module                as Module import qualified Algebra.RealTranscendental    as RealTrans@@ -23,9 +27,10 @@  import Number.Complex ((+:)) import qualified Number.Complex as Complex-import Synthesizer.Utility (nest, mapSnd, )+import Data.Tuple.HT (mapSnd, )+import Data.Function.HT (nest, ) -import Control.Monad.State (State(..), evalState, )+import Control.Monad.Trans.State (State, state, runState, evalState, )  import qualified Prelude as P import PreludeBase@@ -33,10 +38,21 @@   -newtype Parameter a = Parameter a  {- ^ Feedback factor. -}+newtype Parameter a =+   Parameter {getParameter :: a}  {- ^ Feedback factor. -}    deriving Show  +instance Interpol.C a v => Interpol.C a (Parameter v) where+   {-# INLINE scaleAndAccumulate #-}+   scaleAndAccumulate = Interpol.makeMac Parameter getParameter+++{-+Shall the phase parameter be of type Phase?+I think no, because for the allpass cascade we divide by the order+and then there is a difference between phase pi and 3*pi.+-} {-# INLINE parameter #-} parameter :: Trans.C a =>      Int  {- ^ The number of equally designed 1st order allpasses. -}@@ -50,16 +66,20 @@         k = (cos phi - cos omega) / (1 - cos (phi - omega))     in  Parameter k +{-# INLINE flangerPhase #-}+flangerPhase :: Trans.C a => a+flangerPhase = -2*pi+ {-# INLINE flangerParameter #-} flangerParameter :: Trans.C a => Int -> a -> Parameter a flangerParameter order frequency =-    parameter order (-2*pi) frequency+   parameter order flangerPhase frequency  {-# INLINE firstOrderStep #-} firstOrderStep :: (Ring.C a, Module.C a v) =>    Parameter a -> v -> State (v,v) v firstOrderStep (Parameter k) u0 =-   State (\(u1,y1) -> let y0 = u1 + k *> (u0-y1) in (y0,(u0,y0)))+   state (\(u1,y1) -> let y0 = u1 + k *> (u0-y1) in (y0,(u0,y0)))  {-# INLINE firstOrderModifier #-} firstOrderModifier :: (Ring.C a, Module.C a v) =>@@ -67,6 +87,12 @@ firstOrderModifier =    Modifier.Simple (zero,zero) firstOrderStep +{-# INLINE firstOrderCausal #-}+firstOrderCausal :: (Ring.C a, Module.C a v) =>+   Causal.T (Parameter a, v) v+firstOrderCausal =+   Causal.fromSimpleModifier firstOrderModifier+ {-# INLINE firstOrder #-} firstOrder :: (Ring.C a, Module.C a v) =>    Sig.T (Parameter a) -> Sig.T v -> Sig.T v@@ -95,7 +121,7 @@ cascadeStepStack :: (Ring.C a, Module.C a v) =>    Parameter a -> v -> State [v] v cascadeStepStack k x =-   State $+   state $       mapSnd fromPairs .       runState (cascadeStepStackPairs k x) .       toPairs@@ -118,7 +144,7 @@  cascadeStep = cascadeStepRec -cascadeStepRec (Parameter k) x = State $ \s ->+cascadeStepRec (Parameter k) x = state $ \s ->     let crawl _ [] = error "Allpass.crawl needs at least one element in the list"         crawl u0 (_:[]) = u0:[]         crawl u0 (u1:y1:us) =@@ -127,7 +153,7 @@         news = crawl x s     in  (last news, news) -cascadeStepRecAlt k x = State $ \s ->+cascadeStepRecAlt k x = state $ \s ->     let crawl _ [] = error "Allpass.crawl needs at least one element in the list"         crawl u0 (u1:u1s) = mapSnd (u0:) $            case u1s of@@ -141,6 +167,20 @@    Int -> Modifier.Simple [v] (Parameter a) v v cascadeModifier order =    Modifier.Simple (replicate (succ order) zero) cascadeStep++{-# INLINE cascadeCausal #-}+{-# INLINE cascadeCausalStacked #-}+{-# INLINE cascadeCausalModifier #-}+cascadeCausal, cascadeCausalStacked, cascadeCausalModifier ::+   (Ring.C a, Module.C a v) =>+   Int -> Causal.T (Parameter a, v) v+cascadeCausal = cascadeCausalModifier++cascadeCausalStacked order =+   Causal.replicateControlled order firstOrderCausal++cascadeCausalModifier order =+   Causal.fromSimpleModifier (cascadeModifier order)   {-# INLINE cascade #-}
src/Synthesizer/Plain/Filter/Recursive/AllpassPoly.hs view
@@ -1,4 +1,6 @@-{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-} {- | Copyright   :  (c) Henning Thielemann 2008 License     :  GPL
src/Synthesizer/Plain/Filter/Recursive/Butterworth.hs view
@@ -1,4 +1,6 @@-{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-} {- | Copyright   :  (c) Henning Thielemann 2008 License     :  GPL@@ -11,11 +13,14 @@ -} module Synthesizer.Plain.Filter.Recursive.Butterworth where -import Synthesizer.Plain.Filter.Recursive (Passband(Lowpass,Highpass))+import Synthesizer.Plain.Filter.Recursive (Passband(Lowpass,Highpass), Pole(Pole))+import qualified Synthesizer.Plain.Filter.Recursive.SecondOrderCascade as Cascade import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2 -- import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder  as Filt1 import qualified Synthesizer.Plain.Signal   as Sig--- import qualified Synthesizer.Plain.Modifier as Modifier+import qualified Synthesizer.Plain.Modifier as Modifier+import qualified Synthesizer.Causal.Process as Causal+import Control.Arrow ((>>>), )  import qualified Algebra.Module                as Module import qualified Algebra.Transcendental        as Trans@@ -23,7 +28,8 @@ import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive --- import Control.Monad.State (State(..), evalState)+import qualified Data.StorableVector as SV+import Foreign.Storable (Storable)  import qualified Prelude as P import PreludeBase@@ -31,9 +37,12 @@   -sineListSlow, sineListFast :: (Trans.C a) => a -> [a]-sineListSlow x = map sin (map (x*) (iterate (2+) 1))+sineList, sineListSlow, sineListFast :: (Trans.C a) => a -> [a]+sineList = sineListFast +sineListSlow x =+   map sin $ map (x*) $ iterate (2+) 1+ sineListFast x =    let sinx  = sin x        cos2x = 2 - 4*sinx*sinx@@ -42,11 +51,23 @@                   zipWith (\y1 y0 -> cos2x * y0 - y1) sines (tail sines)    in  tail sines -parameterInstable, parameter :: (Trans.C a) =>+makeSines :: (Trans.C a) =>+   Int -> [a]+makeSines order =+   take (checkedHalf "makeSines" order) (sineList (pi / fromIntegral (2*order)))++partialRatio :: (Trans.C a) =>+   Int -> a -> a+partialRatio order ratio =+   (1/ratio^2-1) ** (-1 / fromIntegral (2*order))++++partialParameterInstable, partialParameter :: (Trans.C a) =>    a -> a -> a -> Filt2.Parameter a  {- must handle infinite values when 'freq' approaches 0.5 -}-parameterInstable ratio sinw freq =+partialParameterInstable ratio freq sinw =    let wc    = ratio * tan (pi*freq)        sinw2 = 2 * wc * sinw        wc2   = wc * wc@@ -56,30 +77,116 @@           (2*(1-wc2)/denom) ((-wc2+sinw2-1)/denom)  -- using ratio disallows simplification by trigonometric Pythagoras' theorem-parameter ratio sinw freq =-   let phi     = pi*freq-       sinsin  = sin (2*phi) * sinw-       sinphi2 = (sin phi)^2-       ratsin  = 1 + (ratio^2-1) * sinphi2-       denom   = ratsin + ratio*sinsin-       c0      = ratio^2 * sinphi2 / denom-   in  Filt2.Parameter c0 (2*c0) c0-          (2*(1-(ratio^2+1)*sinphi2)/denom) ((ratio*sinsin-ratsin)/denom)+partialParameter ratio freq =+   let phi      = pi*freq+       rsin2phi = ratio * sin (2*phi)+       cosphi2  = cos phi ^ 2+       c0d      = (ratio * sin phi) ^ 2+       d1d      = (cosphi2 - c0d) * 2+       ratsin   = cosphi2 + c0d+   in  \sinw ->+          let rsinsin = rsin2phi * sinw+              denom   = rsinsin + ratsin+              d2d     = rsinsin - ratsin+              c0      = c0d / denom+              d1      = d1d / denom+              d2      = d2d / denom+          in  Filt2.Parameter c0 (2*c0) c0 d1 d2 -run :: (Trans.C a, Module.C a v) =>-   Passband -> Int -> a -> Sig.T a -> Sig.T v -> Sig.T v-run kind order ratio freqs =-   let orderFloat = fromIntegral (2*order)-       sines = take (div order 2) (sineListFast (pi/orderFloat))-       -- the filter amplifies frequency 0 with factor 1-       -- and frequency 'freq' with factor 'ratio'-       wcoef = (1/ratio^2-1)**(-1/orderFloat)-       makePartialFilter s =-          Filt2.run (map (Filt2.adjustPassband kind . parameter wcoef s) freqs)-   in  foldl (.) id (map makePartialFilter sines) +-- * use second order filter parameters for control++type Parameter a = Cascade.Parameter a++{-# INLINE parameter #-}+parameter ::+   (Trans.C a, Storable a) =>+   Passband -> Int -> Pole a -> Parameter a+parameter kind order =+   -- I hope that the 'let' is floated out of a 'map'+   let sinesVec = SV.pack (makeSines order)+   in  \ (Pole ratio freq) ->+           Cascade.Parameter $+           SV.map (\sinw ->+              Filt2.adjustPassband kind+                 (flip (partialParameter (partialRatio order ratio)) sinw) freq) $+           sinesVec++{-# INLINE modifier #-}+modifier ::+   (Ring.C a, Module.C a v, Storable a, Storable v) =>+   Int ->+   Modifier.Simple (Cascade.Status v) (Parameter a) v v+modifier =+   Cascade.modifier++{-# INLINE causal #-}+causal :: (Ring.C a, Module.C a v, Storable a, Storable v) =>+   Int ->+   Causal.T (Parameter a, v) v+causal order =+   Cascade.causal (checkedHalf "causal" order)+++{-# INLINE checkedHalf #-}+checkedHalf :: String -> Int -> Int+checkedHalf funcName order =+   let (order2,r) = divMod order 2+   in  if r==0+         then order2+         else error $ "Butterworth."++funcName++": order must be even"++{-+lowpassCausal, highpassCausal :: (Trans.C a, Module.C a v) =>+   Int -> Causal.T (Parameter a, v) v+lowpassCausal  = causal Lowpass+highpassCausal = causal Highpass+ lowpass, highpass :: (Trans.C a, Module.C a v) =>-   Int -> a -> Sig.T a -> Sig.T v -> Sig.T v-lowpass = run Lowpass-highpass order ratio freqs =-   run Highpass order ratio (map (0.5-) freqs)+   Int -> Sig.T (Parameter a) -> Sig.T v -> Sig.T v+lowpass  = run Lowpass+highpass = run Highpass+-}+++-- * directly use frequency as control parameter++{- |+When called as @runPole kind order ratio freqs@,+the filter amplifies frequency 0 with factor 1+and frequency @freq@ with factor @ratio@.++It uses the frequency and ratio information directly+and thus cannot benefit from efficient parameter interpolation+(asynchronous run of a ControlledProcess.+-}+runPole :: (Trans.C a, Module.C a v) =>+   Passband -> Int -> Sig.T a -> Sig.T a -> Sig.T v -> Sig.T v+runPole kind order ratios freqs =+   let makePartialFilter s =+          Filt2.run (zipWith (\ratio ->+             Filt2.adjustPassband kind $ \freq ->+                partialParameter (partialRatio order ratio) freq s) ratios freqs)+   in  foldl (.) id (map makePartialFilter (makeSines order))++causalPole :: (Trans.C a, Module.C a v) =>+   Passband -> Int -> Causal.T (Pole a, v) v+causalPole kind order =+   let {-# INLINE makePartialFilter #-}+       makePartialFilter s =+          Causal.first (Causal.map (\(Pole ratio freq) ->+             Filt2.adjustPassband kind+                (flip (partialParameter (partialRatio order ratio)) s) freq)) >>>+          Filt2.causal+   in  Causal.chainControlled $ map makePartialFilter $ makeSines order+++lowpassCausalPole, highpassCausalPole :: (Trans.C a, Module.C a v) =>+   Int -> Causal.T (Pole a, v) v+lowpassCausalPole  = causalPole Lowpass+highpassCausalPole = causalPole Highpass++lowpassPole, highpassPole :: (Trans.C a, Module.C a v) =>+   Int -> Sig.T a -> Sig.T a -> Sig.T v -> Sig.T v+lowpassPole  = runPole Lowpass+highpassPole = runPole Highpass
src/Synthesizer/Plain/Filter/Recursive/Chebyshev.hs view
@@ -1,4 +1,6 @@-{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-} {- | Copyright   :  (c) Henning Thielemann 2008 License     :  GPL@@ -11,13 +13,16 @@ -} module Synthesizer.Plain.Filter.Recursive.Chebyshev where -import Synthesizer.Plain.Filter.Recursive (Passband(Lowpass,Highpass))+import Synthesizer.Plain.Filter.Recursive (Passband(Lowpass,Highpass), Pole(Pole, poleResonance))+import qualified Synthesizer.Plain.Filter.Recursive.SecondOrderCascade as Cascade import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2 -- import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder  as Filt1 import qualified Synthesizer.Plain.Signal   as Sig -- import qualified Synthesizer.Plain.Modifier as Modifier+import qualified Synthesizer.Causal.Process as Causal+import Control.Arrow ((>>>), (^>>), (&&&), ) -import qualified Algebra.VectorSpace           as VectorSpace+-- import qualified Algebra.VectorSpace           as VectorSpace import qualified Algebra.Module                as Module import qualified Algebra.Transcendental        as Trans import qualified Algebra.Field                 as Field@@ -26,94 +31,355 @@  import Algebra.Module((*>)) -import Number.Complex ((+:),real,imag)+import Number.Complex (real, imag, cis, ) import qualified Number.Complex as Complex --- import Control.Monad.State (State(..), evalState)+-- import Control.Monad.Trans.State (State(..), evalState) +import qualified Data.StorableVector as SV+import Foreign.Storable (Storable)+ import qualified Prelude as P import PreludeBase import NumericPrelude --- compute the partial filter of the second order from the pole information++++circleList, circleListSlow, circleListFast :: (Trans.C a) => a -> [Complex.T a]+circleList = circleListSlow++circleListSlow x =+   map cis $ map (x*) $ iterate (2+) 1++circleListFast x =+   let z1 = cis x+       z2 = z1^2+   in  iterate (z2*) z1+++makeCirclePoints :: (Trans.C a) => Int -> [Complex.T a]+makeCirclePoints order =+   take order (circleList (pi / (4 * fromIntegral order)))++-- | compute the partial filter of the second order from the pole information {- It's worth to think it over whether this routine could be used for the Butterworth filter. But whereas this function is specialized to the zeros of the denominator polynomial for the Butterworth filter the quadratic factors of the polynomial can be determined more efficiently than the zeros. -}-parameterA, parameterB :: (Trans.C a) =>-   a -> Complex.T a -> a -> Filt2.Parameter a-parameterA vol z freq =-   let re      = real z-       im      = imag z+partialParameterA, partialParameterB :: (Trans.C a) =>+   Int -> a -> a -> Complex.T a -> Filt2.Parameter a+{-+partialParameterA order ratio freq =+   let {- if ratio == (sqrt 2) then the product of the normalization factors is+          2^(1-2*order) -}+--       bn = asinh (ratio/sqrt(1-ratio^2)) / fromIntegral (2*order)+       bn = (log(1+ratio) - log(1-ratio^2)/2) / fromIntegral (2*order)+       coshbn = cosh bn+       sinhbn = sinh bn+        phi     = pi*freq        sinphi  = sin phi        cosphi  = cos phi-       cpims   = cosphi + im*sinphi-       cmims   = cosphi - im*sinphi-       resin2  = (re*sinphi)^2-       denom   = - cmims^2 - resin2-       c0      = vol * sinphi^2 / denom-   in  Filt2.Parameter-          c0 (2*c0) c0-          (-2*(cpims*cmims - resin2)/denom) ((cpims^2 + resin2)/denom)+       sinphi2 = sinphi^2 -runA :: (Trans.C a, Module.C a v) =>-   Passband -> Int -> a -> Sig.T a -> Sig.T v -> Sig.T v-runA kind order ratio freqs =-   let orderFloat = fromIntegral (2*order)-       bn = asinh (ratio/sqrt(1-ratio^2)) / orderFloat-       pikn  = take order (map (pi/(2*orderFloat)*) (iterate (2+) 1))-       zeros = map (\angle -> cos angle * cosh bn +: (- sin angle * sinh bn)) pikn-       {- if ratio == (sqrt 2) then the product of the normalization factors is+   in  \c ->+          let re      =   real c * coshbn; re2 = re^2+              im      = - imag c * sinhbn; im2 = im^2+              cpims   = cosphi + im*sinphi+              cmims   = cosphi - im*sinphi+              resin2  = re2*sinphi2+              denom   = - cmims^2 - resin2+              vol     = sqrt ((1-re2-im2)^2 + 4*im2)+              c0      = vol * sinphi2 / denom+          in  Filt2.Parameter+                 c0 (2*c0) c0+                 (-2*(cpims*cmims - resin2)/denom) ((cpims^2 + resin2)/denom)+-}++partialParameterA order ratio freq =+   let {- if ratio == (sqrt 2) then the product of the normalization factors is           2^(1-2*order) -}-       makePartialFilter z =-          Filt2.run-             (map (Filt2.adjustPassband kind .-                   parameterA (sqrt-                      ((1-real z^2-imag z^2)^2 + 4*imag z^2)) z)-                  freqs)-   in  foldl (.) (ratio *>) (map makePartialFilter zeros)+--       bn = asinh (ratio/sqrt(1-ratio^2)) / fromIntegral (2*order)+       bn = (log(1+ratio) - log(1-ratio^2)/2) / fromIntegral (2*order)+       coshbn = cosh bn+       sinhbn = sinh bn+--       cosh2bn = (cosh(2*bn)-1)/2 = sinhbn2+       coshbn2 = coshbn^2+       sinhbn2 = sinhbn^2 +       phi     = pi*freq+       sinphi  = sin phi+       cosphi  = cos phi+       sinphi2 = sinphi^2 -parameterB a0 z freq =-   let re      = real z-       im      = imag z+       sinhbnsinphi   = sinhbn*sinphi+--       sinhbn2sinphi2 = sinhbn2*sinphi2+       coshbn2sinphi2 = coshbn2*sinphi2++   in  \c ->+          let re      = real c+              im      = imag c+              imss    = im * sinhbnsinphi+              cpims   = cosphi - imss+              cmims   = cosphi + imss+              resin2  = re^2 * coshbn2sinphi2+              denom   = - cmims^2 - resin2+              c0      = (im^2 + sinhbn2)*sinphi2 / denom+          in  Filt2.Parameter+                 c0 (2*c0) c0+                 (-2*(cpims*cmims - resin2)/denom) ((cpims^2 + resin2)/denom)++{-+partialParameterA order ratio freq =+   let {- if ratio == (sqrt 2) then the product of the normalization factors is+          2^(1-2*order) -}+       bn = asinh (ratio/sqrt(1-ratio^2)) / fromIntegral (2*order)+       sinhbnd = 2 * sinh bn+       cosh2bn = (cosh(2*bn)-1)/2++       phi       = pi*freq+       sinphi    = sin phi+       cosphi    = cos phi+       sinphi2   = sinphi^2+--       cosphi2   = cosphi^2+       sincosphi = sinphi*cosphi++   in  \c ->+          let imd     = - imag c * sinhbnd+              re2pim2 = cosh2bn + real c ^ 2+              ri2sp2  = (re2pim2-1)*sinphi2+              cpims2  = 1 + ri2sp2 + imd*sincosphi+              cmims2  = 1 + ri2sp2 - imd*sincosphi+              cpmims  = 1 - (re2pim2+1)*sinphi2+              denom   = - cmims2+              vol     = sqrt (ri2sp2^2 + (imd*sinphi2)^2)+              c0      = vol / denom+          in  Filt2.Parameter+                 c0 (2*c0) c0+                 (-2*cpmims/denom) (cpims2/denom)+-}++{-+partialParameterA order ratio freq =+   let {- if ratio == (sqrt 2) then the product of the normalization factors is+          2^(1-2*order) -}+       bn = asinh (ratio/sqrt(1-ratio^2)) / fromIntegral (2*order)+       coshbn = cosh bn+       sinhbn = sinh bn++       phi       = pi*freq+       sinphi    = sin phi+       cosphi    = cos phi+       sinphi2   = sinphi^2+--       cosphi2   = cosphi^2+       sincosphi = sinphi*cosphi++   in  \c ->+          let re      =   real c * coshbn; re2 = re^2+              im      = - imag c * sinhbn; im2 = im^2+              re2pim2 = re2+im2+              cpims2  = 1 + (re2pim2-1)*sinphi2 + 2*im*sincosphi+              cmims2  = 1 + (re2pim2-1)*sinphi2 - 2*im*sincosphi+              cpmims  = 1 - (re2pim2+1)*sinphi2+              denom   = - cmims2+              vol     = sqrt ((re2pim2-1)^2 + 4*im2)+              c0      = vol * sinphi2 / denom+          in  Filt2.Parameter+                 c0 (2*c0) c0+                 (-2*cpmims/denom) (cpims2/denom)+-}++{-+partialParameterB order ratio freq =+   let -- bn = asinh (sqrt(1-ratio^2)/ratio) / fromIntegral (2*order)+       bn = (log(1+sqrt(1-ratio^2)) - log ratio) / fromIntegral (2*order)+       coshbn  = cosh bn+       sinhbn  = sinh bn+       coshbn2 = coshbn^2+        phi     = pi*freq        sinphi  = sin phi        cosphi  = cos phi-       spimc   = sinphi + im*cosphi-       smimc   = sinphi - im*cosphi-       recos2  = (re*cosphi)^2-       denom   = smimc^2 + recos2-       c0      = (sinphi^2 + a0^2*cosphi^2) / denom-       c1      = (sinphi^2 - a0^2*cosphi^2) / denom-   in  Filt2.Parameter-          c0 (2*c1) c0-          (-2*(spimc*smimc - recos2)/denom) (-(spimc^2 + recos2)/denom)+       sinphi2 = sinphi^2+       cosphi2 = cosphi^2 -runB :: (Trans.C a, Module.C a v) =>-   Passband -> Int -> a -> Sig.T a -> Sig.T v -> Sig.T v-runB kind order ratio freqs =-   let orderFloat = fromIntegral (2*order)-       bn = (asinh (sqrt(1-ratio^2)/ratio)) / orderFloat-       pikn  = take order (map (pi/(2*orderFloat)*) (iterate (2+) 1))-       zeros = map (\angle -> (cos angle * cosh bn +: (- sin angle * sinh bn))) pikn-       a0s   = map cos pikn-       makePartialFilter a0 z =+   in  \c ->+          let re      =   real c * coshbn+              im      = - imag c * sinhbn+              spimc   = sinphi + im*cosphi+              smimc   = sinphi - im*cosphi+              recos2  = re^2 * cosphi2+              denom   = smimc^2 + recos2+              a02cosphi2 = real c ^ 2 * cosphi2+              c0      = (sinphi2 + a02cosphi2) / denom+              c1      = (sinphi2 - a02cosphi2) / denom+          in  Filt2.Parameter+                 c0 (2*c1) c0+                 (-2*(spimc*smimc - recos2)/denom) (-(spimc^2 + recos2)/denom)+-}++partialParameterB order ratio freq =+   let -- bn = asinh (sqrt(1-ratio^2)/ratio) / fromIntegral (2*order)+       bn = (log(1+sqrt(1-ratio^2)) - log ratio) / fromIntegral (2*order)+       coshbn  = cosh bn+       sinhbn  = sinh bn+       coshbn2 = coshbn^2++       phi     = pi*freq+       sinphi  = sin phi+       cosphi  = cos phi+       sinphi2 = sinphi^2+       cosphi2 = cosphi^2++       sinhbncosphi = sinhbn*cosphi++   in  \c ->+          let a02cosphi2 = real c ^ 2 * cosphi2+              imsc    = imag c * sinhbncosphi+              spimc   = sinphi - imsc+              smimc   = sinphi + imsc+              recos2  = a02cosphi2 * coshbn2+              denom   = smimc^2 + recos2+              c0      = (sinphi2 + a02cosphi2) / denom+              c1      = (sinphi2 - a02cosphi2) / denom+          in  Filt2.Parameter+                 c0 (2*c1) c0+                 (-2*(spimc*smimc - recos2)/denom) (-(spimc^2 + recos2)/denom)+++-- * use second order filter parameters for control++type ParameterA a = (a, Cascade.Parameter a)++{-# INLINE parameterA #-}+parameterA ::+   (Trans.C a, Storable a) =>+   Passband -> Int -> Pole a -> ParameterA a+parameterA kind order =+   -- I hope that the 'let' is floated out of a 'map'+   let circleVec = SV.pack (makeCirclePoints order)+   in  \ (Pole ratio freq) ->+          (ratio,+           Cascade.Parameter $+           SV.map (\c ->+              Filt2.adjustPassband kind+                 (flip (partialParameterA order ratio) c) freq) $+           circleVec)+++type ParameterB a = Cascade.Parameter a++{-# INLINE parameterB #-}+parameterB ::+   (Trans.C a, Storable a) =>+   Passband -> Int -> Pole a -> ParameterB a+parameterB kind order =+   -- I hope that the 'let' is floated out of a 'map'+   let circleVec = SV.pack (makeCirclePoints order)+   in  \ (Pole ratio freq) ->+           Cascade.Parameter $+           SV.map (\c ->+              Filt2.adjustPassband kind+                 (flip (partialParameterB order ratio) c) freq) $+           circleVec++{-+{-# INLINE modifierB #-}+modifierB ::+   (Ring.C a, Module.C a v, Storable a, Storable v) =>+   Int ->+   Modifier.Simple (Cascade.Status v) (Cascade.Parameter a) v v+modifierB =+   Cascade.modifierB+-}++{-# INLINE causalA #-}+causalA :: (Ring.C a, Module.C a v, Storable a, Storable v) =>+   Int ->+   Causal.T (ParameterA a, v) v+causalA order =+   Causal.map (snd.fst) &&& Causal.map (\((ratio,_), y) -> ratio *> y)+    >>> Cascade.causal order++{-# INLINE causalB #-}+causalB :: (Ring.C a, Module.C a v, Storable a, Storable v) =>+   Int ->+   Causal.T (ParameterB a, v) v+causalB =+   Cascade.causal+++++-- * directly use frequency as control parameter++runAPole, runBPole :: (Trans.C a, Module.C a v) =>+   Passband -> Int -> Sig.T a -> Sig.T a -> Sig.T v -> Sig.T v+runAPole kind order ratios freqs =+   let makePartialFilter c =           Filt2.run-             (map (Filt2.adjustPassband kind .-                   parameterB a0 z) freqs)-   in  foldl (.) id (zipWith makePartialFilter a0s zeros)+             (zipWith+                 (\ratio -> Filt2.adjustPassband kind $+                  \freq -> partialParameterA order ratio freq c)+                 ratios freqs)+   in  foldl (.) (zipWith (*>) ratios)+          (map makePartialFilter (makeCirclePoints order)) -lowpassA, highpassA, lowpassB, highpassB ::-   (Trans.C a, VectorSpace.C a v) =>-   Int -> a -> Sig.T a -> Sig.T v -> Sig.T v-lowpassA = runA Lowpass-highpassA order ratio freqs =-   runA Highpass order ratio (map (0.5-) freqs)+runBPole kind order ratios freqs =+   let makePartialFilter c =+          Filt2.run+             (zipWith+                 (\ratio -> Filt2.adjustPassband kind $+                  \freq -> partialParameterB order ratio freq c)+                 ratios freqs)+   in  foldl (.) id (map makePartialFilter (makeCirclePoints order)) -lowpassB = runB Lowpass-highpassB order ratio freqs =-   runB Highpass order ratio (map (0.5-) freqs)++causalAPole, causalBPole :: (Trans.C a, Module.C a v) =>+   Passband -> Int -> Causal.T (Pole a, v) v+causalAPole kind order =+   let {-# INLINE makePartialFilter #-}+       makePartialFilter c =+          Causal.first (Causal.map (\(Pole ratio freq) ->+             Filt2.adjustPassband kind+             (flip (partialParameterA order ratio) c) freq)) >>>+          Filt2.causal+   in  (\(p, y) -> (p, poleResonance p *> y)) ^>>+       (Causal.chainControlled $+        map makePartialFilter $+        makeCirclePoints order)++causalBPole kind order =+   let {-# INLINE makePartialFilter #-}+       makePartialFilter c =+          Causal.first (Causal.map (\(Pole ratio freq) ->+             Filt2.adjustPassband kind+             (flip (partialParameterB order ratio) c) freq)) >>>+          Filt2.causal+   in  Causal.chainControlled $+       map makePartialFilter $+       makeCirclePoints order+++lowpassACausalPole, highpassACausalPole,+ lowpassBCausalPole, highpassBCausalPole ::+   (Trans.C a, Module.C a v) =>+   Int -> Causal.T (Pole a, v) v+lowpassACausalPole  = causalAPole Lowpass+highpassACausalPole = causalAPole Highpass++lowpassBCausalPole  = causalBPole Lowpass+highpassBCausalPole = causalBPole Highpass+++lowpassAPole, highpassAPole, lowpassBPole, highpassBPole ::+   (Trans.C a, Module.C a v) =>+   Int -> Sig.T a -> Sig.T a -> Sig.T v -> Sig.T v+lowpassAPole  = runAPole Lowpass+highpassAPole = runAPole Highpass++lowpassBPole  = runBPole Lowpass+highpassBPole = runBPole Highpass
src/Synthesizer/Plain/Filter/Recursive/Comb.hs view
@@ -1,4 +1,6 @@-{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-} {- | Copyright   :  (c) Henning Thielemann 2008 License     :  GPL
src/Synthesizer/Plain/Filter/Recursive/FirstOrder.hs view
@@ -1,4 +1,6 @@-{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-} {- | Copyright   :  (c) Henning Thielemann 2008 License     :  GPL@@ -13,27 +15,35 @@  import qualified Synthesizer.Plain.Signal   as Sig import qualified Synthesizer.Plain.Modifier as Modifier+import qualified Synthesizer.Causal.Process as Causal+import qualified Synthesizer.Interpolation.Class as Interpol  import qualified Algebra.Module                as Module import qualified Algebra.Transcendental        as Trans -- import qualified Algebra.Field                 as Field import qualified Algebra.Ring                  as Ring--- import qualified Algebra.Additive              as Additive+import qualified Algebra.Additive              as Additive  import Algebra.Module((*>))  -- import qualified Number.Complex as Complex -import Control.Monad.State (State(..), )+import Control.Monad.Trans.State (State, state, )  import PreludeBase import NumericPrelude   -newtype Parameter a = Parameter a+newtype Parameter a = Parameter {getParameter :: a}    deriving Show ++instance Interpol.C a v => Interpol.C a (Parameter v) where+   {-# INLINE scaleAndAccumulate #-}+   scaleAndAccumulate = Interpol.makeMac Parameter getParameter++ {-| Convert cut-off frequency to feedback factor. -} {-# INLINE parameter #-} parameter :: Trans.C a => a -> Parameter a@@ -44,7 +54,7 @@ lowpassStep :: (Ring.C a, Module.C a v) =>    Parameter a -> v -> State v v lowpassStep (Parameter c) x =-   State (\s -> let y = x + c *> (s-x) in (y,y))+   state (\s -> let y = x + c *> (s-x) in (y,y))  {-# INLINE lowpassModifierInit #-} lowpassModifierInit :: (Ring.C a, Module.C a v) =>@@ -58,6 +68,14 @@ lowpassModifier =    Sig.modifierInitialize lowpassModifierInit zero +{-# INLINE lowpassCausal #-}+lowpassCausal ::+   (Ring.C a, Module.C a v) =>+   Causal.T (Parameter a, v) v+lowpassCausal =+   Causal.fromSimpleModifier lowpassModifier++ {-# INLINE lowpassInit #-} lowpassInit :: (Ring.C a, Module.C a v) =>    v -> Sig.T (Parameter a) -> Sig.T v -> Sig.T v@@ -103,3 +121,30 @@ highpass :: (Ring.C a, Module.C a v) =>    Sig.T (Parameter a) -> Sig.T v -> Sig.T v highpass = highpassInit zero++++data Result a =+        Result {highpass_, lowpass_ :: !a}++instance Additive.C v => Additive.C (Result v) where+   {-# INLINE zero #-}+   {-# INLINE (+) #-}+   {-# INLINE (-) #-}+   {-# INLINE negate #-}+   zero = Result zero zero+   (+) (Result xhp xlp) (Result yhp ylp) = Result (xhp + yhp) (xlp + ylp)+   (-) (Result xhp xlp) (Result yhp ylp) = Result (xhp - yhp) (xlp - ylp)+   negate               (Result xhp xlp) = Result (negate xhp) (negate xlp)+++instance Module.C a v => Module.C a (Result v) where+   {-# INLINE (*>) #-}+   s *> (Result hp lp) = Result (s *> hp) (s *> lp)+++{-# INLINE step #-}+step :: (Ring.C a, Module.C a v) =>+   Parameter a -> v -> State v (Result v)+step c x =+   fmap (\lp -> Result (x-lp) lp) (lowpassStep c x)
+ src/Synthesizer/Plain/Filter/Recursive/FirstOrderComplex.hs view
@@ -0,0 +1,238 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++First order lowpass and highpass with complex valued feedback.+The complex feedback allows resonance.+-}+module Synthesizer.Plain.Filter.Recursive.FirstOrderComplex (+   Parameter,+   parameter,+   parameterFromPeakWidth,+   parameterFromPeakToDCRatio,+   step,+   modifierInit,+   modifier,+   causal,+   runInit,+   run,+   ) where++import Synthesizer.Plain.Filter.Recursive (Pole(..))+import qualified Synthesizer.Plain.Signal   as Sig+import qualified Synthesizer.Plain.Modifier as Modifier+import qualified Synthesizer.Causal.Process as Causal++import qualified Synthesizer.Interpolation.Class as Interpol++import qualified Number.Complex as Complex+import Number.Complex ((+:))++import qualified Algebra.Module                as Module+import qualified Algebra.Transcendental        as Trans+import qualified Algebra.Algebraic             as Algebraic+import qualified Algebra.Field                 as Field+import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import Algebra.Module((*>))++import Control.Monad.Trans.State (State, state, )++import qualified Prelude as P+import PreludeBase+import NumericPrelude+++data Parameter a =+        Parameter {c, amp :: !(Complex.T a)}+++instance Interpol.C a v => Interpol.C a (Parameter v) where+   {-# INLINE scaleAndAccumulate #-}+   scaleAndAccumulate = Interpol.makeMac2 Parameter c amp++++{-+y0 = u0 + k * cis w * y1++transfer function:+   1/(1 - k * cis w * z)++frequency 0 amplified by @recip (1 - k * cis w)@.+resonance frequency amplified by 1+k+k^2+..., which equals @recip (1-k)@.+resonance frequency + half sample rate is amplified by @recip (1+k)@.+-}+++{-|+The internal parameters are computed such that:++* At the resonance frequency+  the filter amplifies by the factor @resonance@+  with no phase shift.++* At resonance frequency plus half sample rate+  the filter amplifies by facter @recip $ 2 - recip resonance@+  with no phase shift,+  but you cannot observe this immediately,+  because it is outside the Nyquist band.+-}+{-# INLINE parameter #-}+parameter :: Trans.C a => Pole a -> Parameter a+parameter (Pole resonance frequency) =+    let cisw   = Complex.cis (2*pi*frequency)+        k      = 1 - recip resonance+        kcisw  = Complex.scale k cisw+    in  Parameter kcisw one+++{-+Let resonance be the ratio+of the resonance amplification+to the amplification at another frequency, encoded by z.++resonance = abs(1 - k * cis w * z) / (1 - k)++Solution: Substitute @cis w * z@ by @cis a@+and proceed as in parameterFromPeakToDCRatio.+-}+{-|+The internal parameters are computed such that:++* At the resonance frequency+  the filter amplifies by the factor @resonance@+  with no phase shift.++* At resonance frequency plus and minus band width+  the filter amplifies by facter 1 with a non-zero phase shift.+-}+{-# INLINE parameterFromPeakWidth #-}+parameterFromPeakWidth :: Trans.C a => a -> Pole a -> Parameter a+parameterFromPeakWidth width (Pole resonance frequency) =+    let cisw   = Complex.cis (2*pi*frequency)+        k      = solveRatio resonance (cos (2*pi*width))+        kcisw  = Complex.scale k cisw+        amp_   = Complex.fromReal ((1-k)*resonance)+    in  Parameter kcisw amp_++{-|+The internal parameters are computed such that:++* At the resonance frequency+  the filter amplifies by the factor @resonance@+  with a non-zero phase shift.++* The filter amplifies the direct current (frequency zero) by factor 1+  with no phase shift.++* The real component is a lowpass,+  the imaginary component is a highpass.+  You can interpolate between them using other complex projections.+-}+{-+If we want to interpret the resonance+as ratio of the peak height to direct current amplification,+we get:++resonance = abs ((1 - k * cis w) / (1-k))+resonance^2 * (1-k)^2+   = (1 - k * cis w) * (1 - k * cis (-w))+   = 1 + k^2 - 2*k*cos w+0 = 1-resonance^2 + 2 * (resonance^2 - cos w) * k + (1-resonance^2) * k^2+0 = 1 + 2 * (resonance^2 - cos w) / (1-resonance^2) * k + k^2+-}+{-# INLINE parameterFromPeakToDCRatio #-}+parameterFromPeakToDCRatio :: Trans.C a => Pole a -> Parameter a+parameterFromPeakToDCRatio (Pole resonance frequency) =+    let cisw   = Complex.cis (2*pi*frequency)+        k      = solveRatio resonance (Complex.real cisw)+        kcisw  = Complex.scale k cisw+        amp_   = one - kcisw+    in  Parameter kcisw amp_++solveRatio :: (Algebraic.C a) =>+    a -> a -> a+solveRatio resonance cosine =+    let r2 = resonance^2+        p  = (r2 - cosine) / (r2 - 1)+        {- no cancelation for p close to 1,+           that is, big resonance or cosine close to 1 -}+    in  recip $ p + sqrt (p^2 - 1)++{-+solveRatioAnalytic :: (Algebraic.C a) =>+    a -> a -> a+solveRatioAnalytic resonance cosine =+    let r2 = resonance^2+        p  = (r2 - cosine) / (r2 - 1)+    in  p - sqrt (p^2 - 1)+-}+++{- |+We use complex numbers as result types,+since the particular filter type is determined by the parameter generator.+-}+type Result = Complex.T+++{-| Universal filter: Computes high pass, band pass, low pass in one go -}+{-# INLINE step #-}+step :: (Module.C a v) =>+   Parameter a -> v -> State (Complex.T v) (Result v)+step p u =+   state $ \s ->+      let y = scale (amp p) u + mul (c p) s+      in  (y, y)+--      in (Result (Complex.imag y) (Complex.real y), y)++scale :: (Module.C a v) =>+   Complex.T a -> v -> Complex.T v+scale s x =+   Complex.real s *> x  +:  Complex.imag s *> x++mul :: (Module.C a v) =>+   Complex.T a -> Complex.T v -> Complex.T v+mul x y =+   (Complex.real x *> Complex.real y - Complex.imag x *> Complex.imag y)+   +:+   (Complex.real x *> Complex.imag y + Complex.imag x *> Complex.real y)+++{-# INLINE modifierInit #-}+modifierInit :: (Ring.C a, Module.C a v) =>+   Modifier.Initialized (Complex.T v) (Complex.T v) (Parameter a) v (Result v)+modifierInit =+   Modifier.Initialized id step++{-# INLINE modifier #-}+modifier :: (Ring.C a, Module.C a v) =>+   Modifier.Simple (Complex.T v) (Parameter a) v (Result v)+modifier = Sig.modifierInitialize modifierInit zero++{-# INLINE causal #-}+causal ::+   (Ring.C a, Module.C a v) =>+   Causal.T (Parameter a, v) (Result v)+causal =+   Causal.fromSimpleModifier modifier+++{-# INLINE runInit #-}+runInit :: (Ring.C a, Module.C a v) =>+   Complex.T v -> Sig.T (Parameter a) -> Sig.T v -> Sig.T (Result v)+runInit = Sig.modifyModulatedInit modifierInit++{-# INLINE run #-}+run :: (Ring.C a, Module.C a v) =>+   Sig.T (Parameter a) -> Sig.T v -> Sig.T (Result v)+run = runInit zero
src/Synthesizer/Plain/Filter/Recursive/Integration.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright   :  (c) Henning Thielemann 2008 License     :  GPL
src/Synthesizer/Plain/Filter/Recursive/Moog.hs view
@@ -1,4 +1,6 @@-{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-} {- | Copyright   :  (c) Henning Thielemann 2008 License     :  GPL@@ -16,7 +18,10 @@ import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1 import qualified Synthesizer.Plain.Signal   as Sig import qualified Synthesizer.Plain.Modifier as Modifier+import qualified Synthesizer.Causal.Process as Causal +import qualified Synthesizer.Interpolation.Class as Interpol+ import qualified Algebra.Module                as Module import qualified Algebra.Transcendental        as Trans import qualified Algebra.Field                 as Field@@ -25,9 +30,10 @@  import Algebra.Module((*>)) -import Synthesizer.Utility (nest)+import Data.Function.HT (nest, ) -import Control.Monad.State (State(..), evalState, gets)+import Control.Monad.Trans.State (State, state, evalState, gets)+import Control.Arrow ((&&&), (>>^), (^>>), )  import qualified Prelude as P import PreludeBase@@ -42,6 +48,12 @@            {- ^ Feedback of each of the lowpasses of 1st order -} }   deriving Show ++instance Interpol.C a v => Interpol.C a (Parameter v) where+   {-# INLINE scaleAndAccumulate #-}+   scaleAndAccumulate = Interpol.makeMac2 Parameter feedback lowpassParam++ parameter :: Trans.C a => Int -> Pole a -> Parameter a parameter order (Pole resonance frequency) =     let beta  = frequency * 2 * pi@@ -65,7 +77,7 @@  lowpassStepRev :: (Ring.C a, Module.C a v) =>    Parameter a -> v -> State [v] v-lowpassStepRev (Parameter f k) x = State (\s ->+lowpassStepRev (Parameter f k) x = state (\s ->     let news =            tail (scanl               (evalState . Filt1.lowpassStep k)@@ -80,6 +92,26 @@    Modifier.Simple (replicate order zero) lowpassStepStack  +{-# INLINE lowpassCausal #-}+{-# INLINE lowpassCausalStacked #-}+{-# INLINE lowpassCausalModifier #-}+lowpassCausal, lowpassCausalStacked, lowpassCausalModifier ::+   (Ring.C a, Module.C a v) =>+   Int -> Causal.T (Parameter a, v) v+lowpassCausal = lowpassCausalStacked++lowpassCausalStacked order =+   Causal.map fst &&&+   Causal.feedbackControlled+      ((\(((Parameter f k),x),y0) -> (k, x - f *> y0)) ^>>+       Causal.replicateControlled order Filt1.lowpassCausal)+      (snd ^>> Causal.consInit zero)+    >>^ (\((Parameter f _k),y1) -> (1+f) *> y1)++lowpassCausalModifier order =+   Causal.fromSimpleModifier (lowpassModifier order)++ lowpass, lowpassState, lowpassRecursive ::    (Ring.C a, Module.C a v) =>    Int -> Sig.T (Parameter a) -> Sig.T v -> Sig.T v@@ -98,9 +130,3 @@        z = zipWith subtract (envelopeVector f (zero:y)) x        y = nest order (Filt1.lowpass k) z    in  zipWith (*>) (map (1+) f) y--lowpassTest :: [Double]-lowpassTest =-   lowpass 10-      (repeat (parameter 10 (Pole 10 (0.05::Double))))-      (1:repeat 0)
src/Synthesizer/Plain/Filter/Recursive/MovingAverage.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright   :  (c) Henning Thielemann 2008 License     :  GPL
src/Synthesizer/Plain/Filter/Recursive/SecondOrder.hs view
@@ -1,4 +1,6 @@-{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-} {- | Copyright   :  (c) Henning Thielemann 2008 License     :  GPL@@ -15,13 +17,18 @@  import Synthesizer.Plain.Filter.Recursive (Passband(Lowpass,Highpass)) import qualified Synthesizer.Plain.Signal   as Sig--- import qualified Synthesizer.Plain.Modifier as Modifier+import qualified Synthesizer.Plain.Modifier as Modifier -- import qualified Synthesizer.Plain.Control as Ctrl +import qualified Synthesizer.Interpolation.Class as Interpol+import Synthesizer.ApplicativeUtility (liftA4, liftA5, )++import qualified Synthesizer.Causal.Process as Causal+ -- import qualified Algebra.VectorSpace           as VectorSpace import qualified Algebra.Module                as Module -- import qualified Algebra.Transcendental        as Trans--- import qualified Algebra.Field                 as Field+import qualified Algebra.Field                 as Field import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive @@ -29,8 +36,11 @@  import Data.List (zipWith6) -import Control.Monad.State (State(..), )+import Control.Monad.Trans.State (State, state, ) +import Foreign.Storable (Storable(..))+import qualified Foreign.Storable.Record as Store+ import qualified Prelude as P import PreludeBase import NumericPrelude@@ -41,45 +51,132 @@    Parameter {c0, c1, c2, d1, d2 :: !a}        deriving Show -{- | Given the filter parameters of a lowpass filter,-     turn them into highpass parameters, if requested filter type is Highpass -}+data Status a =+   Status {u1, u2, y1, y2 :: !a}+       deriving Show++zeroStatus :: Additive.C a => Status a+zeroStatus =+   Status+      {u1 = zero, u2 = zero,+       y1 = zero, y2 = zero}+++instance Interpol.C a v => Interpol.C a (Parameter v) where+   {-# INLINE scaleAndAccumulate #-}+   scaleAndAccumulate =+      Interpol.runMac $+         liftA5 Parameter+            (Interpol.element c0)+            (Interpol.element c1)+            (Interpol.element c2)+            (Interpol.element d1)+            (Interpol.element d2)++++instance Storable a => Storable (Parameter a) where+   sizeOf    = Store.sizeOf storeParameter+   alignment = Store.alignment storeParameter+   peek      = Store.peek storeParameter+   poke      = Store.poke storeParameter++storeParameter ::+   Storable a => Store.Dictionary (Parameter a)+storeParameter =+   Store.run $+   liftA5 Parameter+      (Store.element c0)+      (Store.element c1)+      (Store.element c2)+      (Store.element d1)+      (Store.element d2)+++instance Storable a => Storable (Status a) where+   sizeOf    = Store.sizeOf storeStatus+   alignment = Store.alignment storeStatus+   peek      = Store.peek storeStatus+   poke      = Store.poke storeStatus++storeStatus ::+   Storable a => Store.Dictionary (Status a)+storeStatus =+   Store.run $+   liftA4 Status+      (Store.element u1)+      (Store.element u2)+      (Store.element y1)+      (Store.element y2)+++{- |+Given a function which computes the filter parameters of a lowpass filter+for a given frequency,+turn that into a function which generates highpass parameters,+if requested filter type is Highpass.+-} {-# INLINE adjustPassband #-}-adjustPassband :: (Ring.C a) =>-   Passband -> Parameter a -> Parameter a-adjustPassband kind p =+adjustPassband :: (Field.C a) =>+   Passband -> (a -> Parameter a) -> (a -> Parameter a)+adjustPassband kind comp f =    case kind of-      Lowpass  -> p-      Highpass -> Parameter (c0 p) (- c1 p) (c2 p) (- d1 p) (d2 p)+      Lowpass  -> comp f+      Highpass ->+         let p = comp (0.5-f)+         in  Parameter (c0 p) (- c1 p) (c2 p) (- d1 p) (d2 p)  {-# INLINE step #-} step :: (Ring.C a, Module.C a v) =>-   Parameter a -> v -> State ((v,v),(v,v)) v-step c u0 = State $ \((u1,u2),(y1,y2)) ->+   Parameter a -> v -> State (Status v) v+step c u0 = state $ \s ->    let y0 =-          c0 c *> u0 +-          c1 c *> u1 + d1 c *> y1 +-          c2 c *> u2 + d2 c *> y2-   in  (y0, ((u0,u1),(y0,y1)))+          c0 c *> u0   ++          c1 c *> u1 s + d1 c *> y1 s ++          c2 c *> u2 s + d2 c *> y2 s+   in  (y0, Status+               {u1 = u0, u2 = u1 s,+                y1 = y0, y2 = y1 s})  +{-# INLINE modifierInit #-}+modifierInit :: (Ring.C a, Module.C a v) =>+   Modifier.Initialized (Status v) (Status v) (Parameter a) v v+modifierInit =+   Modifier.Initialized id step++{-# INLINE modifier #-}+modifier :: (Ring.C a, Module.C a v) =>+   Modifier.Simple (Status v) (Parameter a) v v+modifier =+   Sig.modifierInitialize modifierInit zeroStatus++{-# INLINE causal #-}+causal :: (Ring.C a, Module.C a v) =>+   Causal.T (Parameter a, v) v+causal =+   Causal.fromSimpleModifier modifier++ {-# INLINE runInit #-} runInit :: (Ring.C a, Module.C a v) =>-   ((v,v),(v,v)) -> Sig.T (Parameter a) -> Sig.T v -> Sig.T v-runInit ((u0init,u1init),(y0init,y1init)) control input =+   Status v -> Sig.T (Parameter a) -> Sig.T v -> Sig.T v+runInit sInit control input =    let u0s = input-       u1s = u0init:u0s-       u2s = u1init:u1s-       y1s = y0init:y0s-       y2s = y1init:y1s+       u1s = u1 sInit : u0s+       u2s = u2 sInit : u1s+       y1s = y1 sInit : y0s+       y2s = y2 sInit : y1s        y0s = zipWith6-          (\c u0 u1 u2 y1 y2 ->-              c0 c *> u0 +-              c1 c *> u1 + d1 c *> y1 +-              c2 c *> u2 + d2 c *> y2)+          (\c u0_ u1_ u2_ y1_ y2_ ->+              c0 c *> u0_ ++              c1 c *> u1_ + d1 c *> y1_ ++              c2 c *> u2_ + d2 c *> y2_)           control u0s u1s u2s y1s y2s    in  y0s  {-# INLINE run #-} run :: (Ring.C a, Module.C a v) =>    Sig.T (Parameter a) -> Sig.T v -> Sig.T v-run = runInit zero+run =+   runInit zeroStatus
+ src/Synthesizer/Plain/Filter/Recursive/SecondOrderCascade.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++All recursive filters with real coefficients+can be decomposed into first order and second order filters with real coefficients.+This follows from the Fundamental theorem of algebra.++This implements a cascade of second order filters+using StorableVectors for state and filter parameters.+-}+module Synthesizer.Plain.Filter.Recursive.SecondOrderCascade where++import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2+-- import Synthesizer.Plain.Filter.Recursive (Passband(Lowpass,Highpass))+import qualified Synthesizer.Plain.Signal   as Sig+import qualified Synthesizer.Plain.Modifier as Modifier+-- import qualified Synthesizer.Plain.Control as Ctrl+import qualified Synthesizer.Interpolation.Class as Interpol++import qualified Synthesizer.Causal.Process as Causal++-- import qualified Algebra.VectorSpace           as VectorSpace+import qualified Algebra.Module                as Module+-- import qualified Algebra.Transcendental        as Trans+-- import qualified Algebra.Field                 as Field+import qualified Algebra.Ring                  as Ring+-- import qualified Algebra.Additive              as Additive++-- import Algebra.Module((*>))++import Control.Monad.Trans.State (State, )++import qualified Data.StorableVector as SV+import Foreign.Storable (Storable(..))++import qualified Prelude as P+import PreludeBase+import NumericPrelude+++{-+Maybe there is no need to make the parameter vector+a StorableVector or an Array.+We could also make Paramter a State.Signal,+which reads from a StorableVector or Array buffer.+This way we would not need to create many StorableVectors+when interpolating filter parameters.+-}+newtype Parameter a =+   Parameter (SV.Vector (Filt2.Parameter a))++{-+If Causal.Process would support ST operations,+then we could use a writeable storable vector for the status.+This would save us many allocations.+-}+type Status a =+   SV.Vector (Filt2.Status a)+++{-# INLINE checkSizes #-}+checkSizes :: String -> SV.Vector a -> SV.Vector b -> c -> c+checkSizes opName x y act =+   if SV.length x == SV.length y+     then act+     else error $ opName ++ ": incompatible sizes of cascades of second order filters"++{-# INLINE withSizeCheck #-}+withSizeCheck ::+   String ->+   (SV.Vector a -> SV.Vector b -> c) ->+   (SV.Vector a -> SV.Vector b -> c)+withSizeCheck opName f x y =+   checkSizes opName x y (f x y)+++instance (Interpol.C a v, Storable v) => Interpol.C a (Parameter v) where+   {-# INLINE scaleAndAccumulate #-}+   scaleAndAccumulate (a, Parameter x) =+      (Parameter $ SV.map (curry Interpol.scale a) x,+       \ (Parameter y) ->+          Parameter $ withSizeCheck "mac"+             (SV.zipWith (curry Interpol.scaleAccumulate a)) x y)+++{-# INLINE step #-}+step ::+   (Ring.C a, Module.C a v, Storable a, Storable v) =>+   Parameter a -> v -> State (Status v) v+step (Parameter p) =+   Modifier.stackStatesStorableVaryL Filt2.step p++{-# INLINE modifierInit #-}+modifierInit ::+   (Ring.C a, Module.C a v, Storable a, Storable v) =>+   Modifier.Initialized (Status v) (Status v) (Parameter a) v v+modifierInit =+   Modifier.Initialized id step+++{-# INLINE modifier #-}+modifier ::+   (Ring.C a, Module.C a v, Storable a, Storable v) =>+   Int ->+   Modifier.Simple (Status v) (Parameter a) v v+modifier order =+   Sig.modifierInitialize modifierInit+      (SV.replicate order Filt2.zeroStatus)++{-# INLINE causal #-}+causal :: (Ring.C a, Module.C a v, Storable a, Storable v) =>+   Int ->+   Causal.T (Parameter a, v) v+causal order =+   Causal.fromSimpleModifier (modifier order)+
src/Synthesizer/Plain/Filter/Recursive/Test.hs view
@@ -1,12 +1,21 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} module Synthesizer.Plain.Filter.Recursive.Test where  import qualified Synthesizer.Plain.Oscillator as Osci import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2 import qualified Synthesizer.Plain.Filter.Recursive.Butterworth as Butter import qualified Synthesizer.Plain.Filter.Recursive.Chebyshev   as Cheby-import Number.Complex((+:))+import qualified Synthesizer.Plain.Filter.Recursive.Moog        as Moog+import qualified Synthesizer.Plain.Filter.Recursive.Universal   as Uni+import qualified Synthesizer.Plain.Filter.Recursive.FirstOrderComplex as C1+import qualified Synthesizer.Basic.Wave as Wave +import Synthesizer.Plain.Filter.Recursive (Pole(..))++import Number.Complex ((+:), real, imag, )+import qualified Number.Complex as Complex++import qualified Algebra.Transcendental      as Trans import qualified Algebra.Ring                as Ring  import PreludeBase@@ -22,7 +31,6 @@ chirp :: Double -> [Double] chirp len = Osci.freqModSine 0 (iterate (+0.5/len) 0) - filter2ndOrderTest :: [Double] filter2ndOrderTest =    take 10@@ -33,37 +41,115 @@  butterworthLowpassTest0 :: [Double] butterworthLowpassTest0 =-   take 30 (Butter.lowpass 2 0.2 (repeat (0.1::Double)) (repeat 1))+   take 30 (Butter.lowpassPole 2 (repeat 0.2) (repeat (0.1::Double)) (repeat 1))  butterworthLowpassTest1 :: Double butterworthLowpassTest1 =    maximum (take 300 (drop 500-         (Butter.lowpass 6 0.1 (repeat (0.05::Double))+         (Butter.lowpassPole 6 (repeat 0.1) (repeat (0.05::Double))                (map sin (iterate (+2*pi*0.05) 0)))))  butterworthLowpassTest2 :: [Double] butterworthLowpassTest2 =    let len = 1*sampleRate-   in  take (round len) (Butter.lowpass 20 0.1 (repeat (0.1::Double)) (chirp len))+   in  take (round len) (Butter.lowpassPole 20 (repeat 0.3) (repeat (0.2::Double)) (chirp len)) +chebyParameterA, chebyParameterB :: (Trans.C a) =>+   a -> Complex.T a -> a -> Filt2.Parameter a+chebyParameterA vol z freq =+   let re      = real z+       im      = imag z+       phi     = pi*freq+       sinphi  = sin phi+       cosphi  = cos phi+       cpims   = cosphi + im*sinphi+       cmims   = cosphi - im*sinphi+       resin2  = (re*sinphi)^2+       denom   = - cmims^2 - resin2+       c0      = vol * sinphi^2 / denom+   in  Filt2.Parameter+          c0 (2*c0) c0+          (-2*(cpims*cmims - resin2)/denom) ((cpims^2 + resin2)/denom) +chebyParameterB a0 z freq =+   let re      = real z+       im      = imag z+       phi     = pi*freq+       sinphi  = sin phi+       cosphi  = cos phi+       spimc   = sinphi + im*cosphi+       smimc   = sinphi - im*cosphi+       recos2  = (re*cosphi)^2+       denom   = smimc^2 + recos2+       c0      = (sinphi^2 + a0^2*cosphi^2) / denom+       c1      = (sinphi^2 - a0^2*cosphi^2) / denom+   in  Filt2.Parameter+          c0 (2*c1) c0+          (-2*(spimc*smimc - recos2)/denom) (-(spimc^2 + recos2)/denom)++-- cf. makeZero chebyshevALowpassTest0 :: Filt2.Parameter Double chebyshevALowpassTest0 =-   let beta = (asinh 1) / 4-   in  Cheby.parameterA 1 (12/13 * cosh beta +: (-5/13 * sinh beta)) 0.1+   let beta = asinh 1 / 4+   in  chebyParameterA 1 (12/13 * cosh beta +: (-5/13 * sinh beta)) 0.1  chebyshevBLowpassTest0 :: Filt2.Parameter Double chebyshevBLowpassTest0 =-   let beta = (asinh 1) / 4-   in  Cheby.parameterB (12/13) (12/13 * cosh beta +: (-5/13 * sinh beta)) 0.1+   let beta = asinh 1 / 4+   in  chebyParameterB (12/13) (12/13 * cosh beta +: (-5/13 * sinh beta)) 0.1  chebyshevLowpassTest1 :: [Double] chebyshevLowpassTest1 =    let len = 1*sampleRate    in  take (round len) (Filt2.run (repeat chebyshevALowpassTest0) (chirp len)) -chebyshevLowpassTest2 :: [Double]-chebyshevLowpassTest2 =+chebyshevALowpassTest2 :: [Double]+chebyshevALowpassTest2 =    let len = 1*sampleRate-   in  take (round len) (Cheby.lowpassA 10 0.25 (repeat (0.1::Double)) (chirp len))+   in  take (round len) $+       Cheby.lowpassAPole 10 (repeat 0.25) (repeat (0.3::Double)) (chirp len) +chebyshevBLowpassTest2 :: [Double]+chebyshevBLowpassTest2 =+   let len = 1*sampleRate+   in  take (round len) $+       Cheby.lowpassBPole 10 (repeat 0.25) (repeat (0.1::Double)) (chirp len)++++moogLowpassTest :: [Double]+moogLowpassTest =+   Moog.lowpass 10+      (repeat (Moog.parameter 10 (Pole 10 (0.05::Double))))+      (1:repeat 0)++universalTest :: [Uni.Result Double]+universalTest =+   let len = 1*sampleRate+   in  take (round len) $+       Uni.run+          (repeat (Uni.parameter (Pole 5 (0.1::Double))))+          (chirp len)+++complexRealTest :: [Complex.T Double]+complexRealTest =+   let len = 1*sampleRate+   in  take (round len) $+       C1.run+          (repeat (C1.parameterFromPeakWidth 0.025 (Pole 5 (0.1::Double))))+          (chirp len)++chirpComplex :: Double -> [Complex.T Double]+chirpComplex len =+   Osci.freqMod Wave.helix 0 (iterate (+0.5/len) 0)++complexTest :: [Complex.T Double]+complexTest =+   let len = 1*sampleRate+   in  take (round len) $+       map+          (\x -> Complex.real x + Complex.quarterLeft (Complex.imag x)) $+       C1.run+          (repeat (C1.parameterFromPeakWidth 0.025 (Pole 5 (0.1::Double))))+          (chirpComplex len)
src/Synthesizer/Plain/Filter/Recursive/Universal.hs view
@@ -1,4 +1,6 @@-{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-} {- | Copyright   :  (c) Henning Thielemann 2008 License     :  GPL@@ -8,16 +10,21 @@ Portability :  requires multi-parameter type classes  State variable filter.-One filter that generates lowpass, bandpass, highpass at once.--ToDo: band limit filter as sum of input and band pass+One filter that generates lowpass, bandpass, highpass, bandlimit at once. -} module Synthesizer.Plain.Filter.Recursive.Universal where  import Synthesizer.Plain.Filter.Recursive (Pole(..)) import qualified Synthesizer.Plain.Signal   as Sig import qualified Synthesizer.Plain.Modifier as Modifier+import qualified Synthesizer.Causal.Process as Causal +import qualified Synthesizer.Interpolation.Class as Interpol+import Synthesizer.ApplicativeUtility (liftA4, liftA6, )++import Foreign.Storable (Storable(..))+import qualified Foreign.Storable.Record as Store+ import qualified Algebra.Module                as Module import qualified Algebra.Transcendental        as Trans import qualified Algebra.Field                 as Field@@ -26,7 +33,7 @@  import Algebra.Module((*>)) -import Control.Monad.State (State(..), )+import Control.Monad.Trans.State (State, state, )  import qualified Prelude as P import PreludeBase@@ -34,28 +41,97 @@   data Parameter a =-        Parameter {k1, k2, ampIn, ampI1, ampI2 :: !a}+        Parameter {k1, k2, ampIn, ampI1, ampI2, ampLimit :: !a} ++instance Interpol.C a v => Interpol.C a (Parameter v) where+   {-# INLINE scaleAndAccumulate #-}+   scaleAndAccumulate =+      Interpol.runMac $ liftA6 Parameter+         (Interpol.element k1)+         (Interpol.element k2)+         (Interpol.element ampIn)+         (Interpol.element ampI1)+         (Interpol.element ampI2)+         (Interpol.element ampLimit)++instance Storable a => Storable (Parameter a) where+   sizeOf    = Store.sizeOf storeParameter+   alignment = Store.alignment storeParameter+   peek      = Store.peek storeParameter+   poke      = Store.poke storeParameter++storeParameter ::+   Storable a => Store.Dictionary (Parameter a)+storeParameter =+   Store.run $+   liftA6 Parameter+      (Store.element k1)+      (Store.element k2)+      (Store.element ampIn)+      (Store.element ampI1)+      (Store.element ampI2)+      (Store.element ampLimit)++ data Result a =-        Result {highpass, bandpass, lowpass :: !a}+        Result {highpass, bandpass, lowpass, bandlimit :: !a}  instance Additive.C v => Additive.C (Result v) where    {-# INLINE zero #-}    {-# INLINE (+) #-}    {-# INLINE (-) #-}    {-# INLINE negate #-}-   zero = Result zero zero zero-   (+) (Result xhp xbp xlp) (Result yhp ybp ylp) = Result (xhp + yhp) (xbp + ybp) (xlp + ylp)-   (-) (Result xhp xbp xlp) (Result yhp ybp ylp) = Result (xhp - yhp) (xbp - ybp) (xlp - ylp)-   negate                   (Result xhp xbp xlp) = Result (negate xhp) (negate xbp) (negate xlp)-+   zero = Result zero zero zero zero+   (+) (Result xhp xbp xlp xbl) (Result yhp ybp ylp ybl) =+      Result (xhp + yhp) (xbp + ybp) (xlp + ylp) (xbl + ybl)+   (-) (Result xhp xbp xlp xbl) (Result yhp ybp ylp ybl) =+      Result (xhp - yhp) (xbp - ybp) (xlp - ylp) (xbl - ybl)+   negate                   (Result xhp xbp xlp xbl) =+      Result (negate xhp) (negate xbp) (negate xlp) (negate xbl)  instance Module.C a v => Module.C a (Result v) where    {-# INLINE (*>) #-}-   s *> (Result hp bp lp) = Result (s *> hp) (s *> bp) (s *> lp)+   s *> (Result hp bp lp bl) =+      Result (s *> hp) (s *> bp) (s *> lp) (s *> bl) +instance Storable a => Storable (Result a) where+   sizeOf    = Store.sizeOf storeResult+   alignment = Store.alignment storeResult+   peek      = Store.peek storeResult+   poke      = Store.poke storeResult -{-| Universal filter: Computes high pass, band pass, low pass in one go -}+storeResult ::+   Storable a => Store.Dictionary (Result a)+storeResult =+   Store.run $+   liftA4 Result+      (Store.element highpass)+      (Store.element bandpass)+      (Store.element lowpass)+      (Store.element bandlimit)++++{-|+The computation of the internal parameters is a bit complicated,+but it fulfills the following properties:++* At the resonance frequency the band pass has 180 degree phase shift.+  This is also approximately the frequency+  where the filter has maximum output.+  Even more important, this is the frequency where the band limit filter works.++* At the resonance frequency highpass, lowpass, and bandpass+  amplify by the factor @resonance@.++* The lowpass amplifies the frequency zero by factor 1.++* The highpass amplifies the highest representable (Nyquist) frequency by the factor 1.++* The bandlimit amplifies both frequency zero and Nyquist frequency+  by factor one and cancels the resonance frequency.+-} {-# INLINE parameter #-} parameter :: Trans.C a => Pole a -> Parameter a parameter (Pole resonance frequency) =@@ -72,17 +148,18 @@         volBP  = sqrt (volHP*volLP)     in  Parameter            (pk1*volHP/volBP)  (pk2*volHP/volLP)-           volHP  (volBP/volHP)  (volLP/volBP)+           volHP  (volBP/volHP)  (volLP/volBP)  (recip resonance) +{-| Universal filter: Computes high pass, band pass, low pass in one go -} {-# INLINE step #-} step :: (Ring.C a, Module.C a v) =>    Parameter a -> v -> State (v,v) (Result v) step p u =-   State $ \(i1,i2) ->+   state $ \(i1,i2) ->       let newsum = ampIn p *> u + k1 p *> i1 - k2 p *> i2           newi1  = i1 - ampI1 p *> newsum           newi2  = i2 - ampI2 p *> newi1-          out    = Result newsum newi1 newi2+          out    = Result newsum newi1 newi2 (u + ampLimit p *> newi1)       in  (out, (newi1, newi2))  {-# INLINE modifierInit #-}@@ -95,6 +172,14 @@ modifier :: (Ring.C a, Module.C a v) =>    Modifier.Simple (v,v) (Parameter a) v (Result v) modifier = Sig.modifierInitialize modifierInit (zero, zero)++{-# INLINE causal #-}+causal ::+   (Ring.C a, Module.C a v) =>+   Causal.T (Parameter a, v) (Result v)+causal =+   Causal.fromSimpleModifier modifier+  {-# INLINE runInit #-} runInit :: (Ring.C a, Module.C a v) =>
+ src/Synthesizer/Plain/IO.hs view
@@ -0,0 +1,142 @@+{- |+This is old code, handling Int16 using two characters.+-}+module Synthesizer.Plain.IO+   {-# DEPRECATED "Use Sound.Sox.Signal.List instead." #-}+   (+    writeInt16Stream, readInt16StreamStrict,+    writeLEInt16Stream, readLEInt16Stream,+    putInt16Stream, putInt16StreamChunky,+    -- historical functions+    intToTwoLEChars, twoLECharsToInt,+   ) where++import Foreign (Int16, Ptr, alloca, sizeOf, poke, peek)+import System.IO+          (openBinaryFile, IOMode(WriteMode,ReadMode), hClose,+           Handle, hPutBuf, hGetBuf)+import Control.Exception (bracket, )+import Control.Monad (liftM, )++import Data.Monoid (Monoid, mconcat, )++import qualified Data.ByteString.Lazy as B+import qualified Data.Binary.Builder as Builder++import qualified Algebra.Ring      as Ring++import Data.Char (ord, )++import qualified Prelude as P98++import PreludeBase+import NumericPrelude++++-- | little endian (Intel)+{-# INLINE leCharsToInt16 #-}+leCharsToInt16 :: Char -> Char -> Int16+leCharsToInt16 hi lo =+   P98.fromIntegral $ ord lo + 256 * ord hi++twoLECharsToInt :: Char -> Char -> Int+twoLECharsToInt hi lo =+   let unsigned = ord lo + 256 * ord hi+   in  mod (unsigned + 32768) 65536 - 32768+++-- | little endian (Intel)+{-# INLINE int16ToLEChars #-}+int16ToLEChars :: Int16 -> [Char]+int16ToLEChars x =+   let (hi,lo) = divMod (P98.fromIntegral x) 256+   in  [toEnum lo, toEnum (mod hi 256)]++intToTwoLEChars :: Int -> [Char]+intToTwoLEChars x =+   let (hi,lo) = divMod x 256+   in  [toEnum lo, toEnum (mod hi 256)]++++{-# INLINE binaryToIntsMono16 #-}+binaryToIntsMono16 :: [Char] -> [Int16]+binaryToIntsMono16 sig =+   case sig of+      (lo:hi:xs) ->+         leCharsToInt16 hi lo : binaryToIntsMono16 xs+      (_:[]) ->+         error "binaryToIntsMono16: 16 bit sample files must have even length"+      [] -> []+++{- |+Write a little endian 16 bit integer stream+via String data and 'writeFile'.+-}+writeLEInt16Stream :: FilePath -> [Int16] -> IO ()+writeLEInt16Stream fileName =+   writeFile fileName . concatMap int16ToLEChars++{- |+Uses endianess of the machine, like Sox does.+-}+writeInt16Stream :: FilePath -> [Int16] -> IO ()+writeInt16Stream fileName stream =+   bracket (openBinaryFile fileName WriteMode) hClose+      (flip putInt16Stream stream)++putInt16StreamChunky :: Handle -> [Int16] -> IO ()+putInt16StreamChunky h =+   B.hPut h . Builder.toLazyByteString .+   mconcat . map (Builder.putWord16host . P98.fromIntegral)++putInt16Stream :: Handle -> [Int16] -> IO ()+putInt16Stream h stream =+   alloca $+      \p -> mapM_ (putInt16 h p) stream++putInt16 :: Handle -> Ptr Int16 -> Int16 -> IO ()+putInt16 h p n =+   poke p n >> hPutBuf h p (sizeOf n)+++{- |+The end of the list is undefined,+if the file has odd length.+It would be better if it throws an exception.+-}+readLEInt16Stream :: FilePath -> IO [Int16]+readLEInt16Stream fileName =+   fmap binaryToIntsMono16 (readFile fileName)++{- |+The end of the list is undefined,+if the file has odd length.+It would be better if it throws an exception.+-}+readInt16StreamStrict :: FilePath -> IO [Int16]+readInt16StreamStrict fileName =+   bracket (openBinaryFile fileName ReadMode) hClose+      getInt16StreamStrict++getInt16StreamStrict :: Handle -> IO [Int16]+getInt16StreamStrict h =+   alloca $+      \p -> fmap (map P98.fromIntegral)+                 (unfoldM (getInt16 h p))++-- candidate for Utility+unfoldM :: Monad m => m (Maybe a) -> m [a]+unfoldM act =+   let listM = maybe (return []) (\x -> liftM (x:) listM) =<< act+   in  listM++getInt16 :: Handle -> Ptr Int16 -> IO (Maybe Int16)+getInt16 h p =+   do cnt <- hGetBuf h p (sizeOf (undefined::Int16))+      case cnt of+        0 -> return Nothing+        2 -> fmap Just (peek p)+        _ -> return (error "getInt16: only one byte found")
src/Synthesizer/Plain/Instrument.hs view
@@ -1,4 +1,6 @@-{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-} module Synthesizer.Plain.Instrument where  import Synthesizer.Plain.Displacement (mixMulti, )
src/Synthesizer/Plain/Interpolation.hs view
@@ -1,46 +1,47 @@-{-# OPTIONS -fno-implicit-prelude #-}-{- |-ToDo:-use AffineSpace instead of Module for the particular interpolation types,-since affine combinations assert reconstruction of constant functions.-They are more natural for interpolation of internal control parameters.-However, how can cubic interpolation expressed by affine combinations-without divisions?--}-module Synthesizer.Plain.Interpolation where+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.Plain.Interpolation (+   T, func, offset, number,+   zeroPad, constantPad, cyclicPad, extrapolationPad,+   single,+   multiRelative,+   multiRelativeZeroPad, multiRelativeConstantPad,+   multiRelativeCyclicPad, multiRelativeExtrapolationPad,+   multiRelativeZeroPadConstant, multiRelativeZeroPadLinear,+   multiRelativeZeroPadCubic, -import qualified Synthesizer.Plain.Control as Ctrl+   constant, linear, cubic,+   piecewise, function,++   Interpolation.Margin, Interpolation.margin,++   singleRec, -- for testing+   ) where++import qualified Synthesizer.Interpolation as Interpolation+import Synthesizer.Interpolation (T, offset, number, )+import Synthesizer.Interpolation.Module+          (constant, linear, cubic, piecewise, function, )++import qualified Synthesizer.State.Signal       as SigS+ import qualified Synthesizer.Plain.Signal  as Sig import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR  import qualified Algebra.Module    as Module import qualified Algebra.RealField as RealField-import qualified Algebra.Field     as Field import qualified Algebra.Ring      as Ring import qualified Algebra.Additive  as Additive  import Algebra.Additive(zero)-import Algebra.Module((*>)) import Data.Maybe (fromMaybe)-import Synthesizer.Utility (viewListL, viewListR, affineComb, )-import Synthesizer.ApplicativeUtility (liftA4, )+import qualified Data.List.HT as ListHT -import Control.Monad.State (StateT(StateT), evalStateT, replicateM_, ap, guard, )-import Control.Applicative (Applicative(pure, (<*>)), (<$>), liftA2, )+import Control.Monad (guard, )  import PreludeBase import NumericPrelude  -{- | interpolation as needed for resampling -}-data T t y =-  Cons {-    number :: Int,  -- interpolation requires a total number of 'number'-    offset :: Int,  -- interpolation requires 'offset' values before the current-    func   :: t -> Sig.T y -> y-  }-- {-* Interpolation with various padding methods -}  zeroPad :: (RealField.C t) =>@@ -57,8 +58,8 @@ constantPad interpolate ip phase x =    let (phInt, phFrac) = splitFraction phase        xPad =-          do (xFirst,_) <- viewListL x-             (xBody,xLast) <- viewListR x+          do (xFirst,_) <- ListHT.viewL x+             (xBody,xLast) <- ListHT.viewR x              return (FiltNR.delayPad xFirst (offset ip - phInt) (xBody ++ repeat xLast))    in  interpolate ip phFrac           (fromMaybe [] xPad)@@ -91,6 +92,11 @@  {-* Interpolation of multiple values with various padding methods -} +func ::+   T t y -> t -> Sig.T y -> y+func ip phase =+   Interpolation.func ip phase . SigS.fromList+ skip :: (RealField.C t) =>    T t y -> (t, Sig.T y) -> (t, Sig.T y) skip ip (phase0, x0) =@@ -115,8 +121,8 @@    maybe       (func ip phase x)       (singleRec ip (phase - 1))-      (do (_,xs) <- viewListL x-          guard (phase >= 1 && minLength (number ip) xs)+      (do (_,xs) <- ListHT.viewL x+          guard (phase >= 1 && Sig.lengthAtLeast (number ip) xs)           return xs)  @@ -172,142 +178,3 @@ multiRelativeZeroPadCubic ::    (RealField.C t, Module.C t y) => t -> Sig.T t -> Sig.T y -> Sig.T y multiRelativeZeroPadCubic = multiRelativeZeroPad zero cubic---{-* Different kinds of interpolation -}--{-** Hard-wired interpolations -}--data PrefixReader y a =-   PrefixReader Int (StateT (Sig.T y) Maybe a)--instance Functor (PrefixReader y) where-   fmap f (PrefixReader count parser) =-      PrefixReader count (fmap f parser)---- this is a MonadWriter with Sum monoid-instance Applicative (PrefixReader y) where-   pure = PrefixReader 0 . return-   (PrefixReader count0 parser0) <*> (PrefixReader count1 parser1) =-       PrefixReader (count0+count1) (parser0 `ap` parser1)--getNode :: PrefixReader y y-getNode = PrefixReader 1 (StateT viewListL)--fromPrefixReader :: String -> Int -> PrefixReader y (t -> y) -> T t y-fromPrefixReader name off (PrefixReader count parser) =-   Cons count off-      (\t xs ->-          maybe-             (error (name ++ " interpolation: not enough nodes"))-             ($t)-             (evalStateT parser xs))--{-| Consider the signal to be piecewise constant. -}-constant :: T t y-constant =-   fromPrefixReader "constant" 0 (const <$> getNode)--{-| Consider the signal to be piecewise linear. -}-linear :: (Module.C t y) => T t y-linear =-   fromPrefixReader "linear" 0-      (liftA2-          (\x0 x1 phase -> affineComb phase (x0,x1))-          getNode getNode)--{-| Consider the signal to be piecewise cubic,-    with smooth connections at the nodes.-    It uses a cubic curve which has node values-    x0 at 0 and x1 at 1 and derivatives-    (x1-xm1)/2 and (x2-x0)/2, respectively.-    You can see how it works-    if you evaluate the expression for t=0 and t=1-    as well as the derivative at these points. -}-cubic :: (Field.C t, Module.C t y) => T t y-cubic =-   fromPrefixReader "cubic" 1-      (liftA4-         (\xm1 x0 x1 x2 t ->-            let lipm12 = affineComb t (xm1,x2)-                lip01  = affineComb t (x0, x1)-                three  = 3 `asTypeOf` t-            in  lip01 + (t*(t-1)/2) *>-                           (lipm12 + (x0+x1) - three *> lip01))-         getNode getNode getNode getNode)--cubicAlt :: (Field.C t, Module.C t y) => T t y-cubicAlt =-   fromPrefixReader "cubicAlt" 1-      (liftA4-         (\xm1 x0 x1 x2 t ->-          let half = 1/2 `asTypeOf` t-          in  cubicHalf    t  x0 (half *> (x1-xm1)) +-              cubicHalf (1-t) x1 (half *> (x0-x2)))-         getNode getNode getNode getNode)---{- \t -> cubicHalf t x x' has a double zero at 1 and-   at 0 it has value x and steepness x' -}-cubicHalf :: (Module.C t y) => t -> y -> y -> y-cubicHalf t x x' =-   (t-1)^2 *> ((1+2*t)*>x + t*>x')----{-** Interpolation based on piecewise defined functions -}--piecewise :: (Module.C t y) =>-   Int -> [t -> t] -> T t y-piecewise center ps =-   Cons (length ps) (center-1)-      (\t -> Module.linearComb (reverse (map ($t) ps)))--piecewiseConstant :: (Module.C t y) => T t y-piecewiseConstant =-   piecewise 1 [const 1]--piecewiseLinear :: (Module.C t y) => T t y-piecewiseLinear =-   piecewise 1 [id, (1-)]--piecewiseCubic :: (Field.C t, Module.C t y) => T t y-piecewiseCubic =-   piecewise 2 $-      Ctrl.cubicFunc (0,(0,0))    (1,(0,1/2)) :-      Ctrl.cubicFunc (0,(0,1/2))  (1,(1,0)) :-      Ctrl.cubicFunc (0,(1,0))    (1,(0,-1/2)) :-      Ctrl.cubicFunc (0,(0,-1/2)) (1,(0,0)) :-      []--{--GNUPlot.plotList [] $ take 100 $ interpolate (Zero 0) piecewiseCubic (-2.3 :: Double) (repeat 0.1) [2,1,2::Double]--}---{-** Interpolation based on arbitrary functions -}--{- | with this wrapper you can use the collection of interpolating functions from Donadio's DSP library -}-function :: (Module.C t y) =>-      (Int,Int)   {- ^ @(left extent, right extent)@, e.g. @(1,1)@ for linear hat -}-   -> (t -> t)-   -> T t y-function (left,right) f =-   let len = left+right-   in  Cons len left-          (\t -> Module.linearComb (reverse-              (map (\x -> f (t + fromIntegral x)) (take len [(-left)..]))))-{--GNUPlot.plotList [] $ take 300 $ interpolate (Zero 0) (function (1,1) (\x -> exp (-6*x*x))) (-2.3 :: Double) (repeat 0.03) [2,1,2::Double]--}----{-* Helper functions -}---{-| Test if a list has at least @n@ elements-    make sure that @n@ is non-negative -}-minLength :: Int -> Sig.T y -> Bool-minLength n xs =-   maybe False (const True) (evalStateT (replicateM_ n (StateT viewListL)) xs)
src/Synthesizer/Plain/LorenzAttractor.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} module Synthesizer.Plain.LorenzAttractor where  import qualified Algebra.Module as Module
src/Synthesizer/Plain/Miscellaneous.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} module Synthesizer.Plain.Miscellaneous where  import qualified Algebra.NormedSpace.Euclidean as Euc
src/Synthesizer/Plain/Modifier.hs view
@@ -1,10 +1,22 @@ {- | Support for stateful modifiers like controlled filters.+This is similar to "Synthesizer.Causal.Process"+but we cannot replace the Modifier structure by the Causal structure+because the Modifier structure exhibits the state+which allows stacking of modifiers+using an efficient storage for the stacked state.+More precisely, because Modifiers exhibits the type of the state,+we can ensure that the state type of several modifiers is equal+and thus the individual states can be stored in an array or a StorableVector. -} module Synthesizer.Plain.Modifier where -import Control.Monad.State (State(..), zipWithM, evalState)+import Control.Monad.Trans.State (State, state, runState, evalState, )+import Control.Monad (zipWithM, ) +import qualified Data.StorableVector as SV+import Foreign.Storable (Storable(..))+ import qualified Data.List as List  import Prelude hiding (init)@@ -55,14 +67,14 @@  staticInit ::    Initialized s init ctrl a b -> init -> ctrl -> T a -> T b-staticInit modif state =-   static (initialize modif state)+staticInit modif state_ =+   static (initialize modif state_)  {-| Here the control may vary over the time. -} modulatedInit ::    Initialized s init ctrl a b -> init -> T ctrl -> T a -> T b-modulatedInit modif state =-   modulated (initialize modif state)+modulatedInit modif state_ =+   modulated (initialize modif state_)   @@ -73,8 +85,50 @@ -} stackStatesR :: (a -> State s a) -> (a -> State [s] a) stackStatesR m =-   State . List.mapAccumR (runState . m)+   state . List.mapAccumR (runState . m)  stackStatesL :: (a -> State s a) -> (a -> State [s] a) stackStatesL m =-   State . List.mapAccumL (runState . m)+   state . List.mapAccumL (runState . m)+++{-# INLINE stackStatesStorableR #-}+stackStatesStorableR :: (Storable s) =>+   (a -> State s a) -> (a -> State (SV.Vector s) a)+stackStatesStorableR m =+   state . SV.mapAccumR (runState . m)++{-# INLINE stackStatesStorableL #-}+stackStatesStorableL :: (Storable s) =>+   (a -> State s a) -> (a -> State (SV.Vector s) a)+stackStatesStorableL m =+   state . SV.mapAccumL (runState . m)+++{-+{-# INLINE stackStatesStorableVaryR #-}+stackStatesStorableVaryR :: (Storable s, Storable c) =>+   (c -> a -> State s a) -> (SV.Vector c -> a -> State (SV.Vector s) a)+stackStatesStorableVaryR m cv a =+   State . SV.mapAccumL (runState . m)+-}++{-# INLINE stackStatesStorableVaryL #-}+stackStatesStorableVaryL :: (Storable s, Storable c) =>+   (c -> a -> State s a) -> (SV.Vector c -> a -> State (SV.Vector s) a)+stackStatesStorableVaryL m cv a = state $ \sv ->+   -- emulate SV.zipWith with minimal use of Storable functionality+   let (svFinal, mcsa) =+          SV.unfoldrN (SV.length sv)+             (\(cv0,sv0,a0) ->+                  do (c,cv1) <- SV.viewL cv0+                     (s,sv1) <- SV.viewL sv0+                     let (a1,sNew) = runState (m c a0) s+                     return (sNew,(cv1,sv1,a1)))+             (cv,sv,a)+   in  (case mcsa of+           Just (_, _, aFinal) -> aFinal+           _ -> error $ "Modifier: control vector too short - "+                   ++ "status size " ++ show (SV.length sv) ++ " vs. "+                   ++ "control size " ++ show (SV.length cv),+        svFinal)
src/Synthesizer/Plain/Noise.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} {- | Noise and random processes. -} module Synthesizer.Plain.Noise where @@ -9,7 +9,7 @@  import System.Random (Random, RandomGen, randomRs, mkStdGen, ) -import NumericPrelude.List (sliceVert)+import Data.List.HT (sliceVertical, )  import qualified Prelude as P import PreludeBase@@ -35,7 +35,7 @@ whiteQuadraticBSplineGen :: (Ring.C y, Random y, RandomGen g) =>    g -> Sig.T y whiteQuadraticBSplineGen =-   map sum . sliceVert 3 . randomRs (-1,1)+   map sum . sliceVertical 3 . randomRs (-1,1)   randomPeeks :: (Real.C y, Random y) =>
src/Synthesizer/Plain/Oscillator.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright   :  (c) Henning Thielemann 2006 License     :  GPL@@ -21,7 +21,7 @@ import qualified Synthesizer.Plain.Interpolation as Interpolation import qualified Synthesizer.Plain.Signal as Sig -import Synthesizer.Plain.ToneModulation (freqToPhase, )+import Synthesizer.Plain.ToneModulation (freqsToPhases, )  {- import qualified Algebra.RealTranscendental    as RealTrans@@ -38,6 +38,8 @@  -- import qualified Number.NonNegative       as NonNeg +import Data.Tuple.HT (mapFst, mapSnd, )+ import NumericPrelude  -- import qualified Prelude as P@@ -59,7 +61,7 @@ freqMod :: (RealField.C a) => Wave.T a b -> Phase a -> Sig.T a -> Sig.T b freqMod wave phase freqs =     map (Wave.apply wave)-        (freqToPhase (Phase.fromRepresentative phase) freqs)+        (freqsToPhases (Phase.fromRepresentative phase) freqs)  {- | oscillator with modulated phase -} phaseMod :: (RealField.C a) => Wave.T a b -> a -> Sig.T (Phase a) -> Sig.T b@@ -77,13 +79,13 @@ phaseFreqMod :: (RealField.C a) => Wave.T a b -> Sig.T (Phase a) -> Sig.T a -> Sig.T b phaseFreqMod wave phases freqs =     map (Wave.apply wave)-        (zipWith Phase.increment phases (freqToPhase zero freqs))+        (zipWith Phase.increment phases (freqsToPhases zero freqs))  {- | oscillator with both shape and frequency modulation -} shapeFreqMod :: (RealField.C a) => (c -> Wave.T a b) -> Phase a -> Sig.T c -> Sig.T a -> Sig.T b shapeFreqMod wave phase parameters freqs =     zipWith (Wave.apply . wave) parameters $-    freqToPhase (Phase.fromRepresentative phase) freqs+    freqsToPhases (Phase.fromRepresentative phase) freqs   {- | oscillator with a sampled waveform with constant frequency@@ -124,11 +126,18 @@ shapeFreqModSample ip waves shape0 phase shapes freqs =     zipWith Wave.apply        (Interpolation.multiRelativeConstantPad ip shape0 shapes waves)-       (freqToPhase (Phase.fromRepresentative phase) freqs)+       (freqsToPhases (Phase.fromRepresentative phase) freqs) {- GNUPlot.plotList [] $ take 500 $ shapeFreqModSample Interpolation.cubic (map Wave.truncOddCosine [0..3]) (0.1::Double) (0::Double) (repeat 0.005) (repeat 0.02) -} +shapePhaseFreqModSample :: (RealField.C c, RealField.C b) =>+    Interpolation.T c (Wave.T b a) -> [Wave.T b a] -> c -> Sig.T c -> Sig.T (Phase b) -> Sig.T b -> Sig.T a+shapePhaseFreqModSample ip waves shape0 shapes phases freqs =+    zipWith Wave.apply+       (Interpolation.multiRelativeConstantPad ip shape0 shapes waves)+       (zipWith Phase.increment phases (freqsToPhases zero freqs))+ {- | Time stretching and frequency modulation of a pure tone. @@ -149,6 +158,10 @@ and waves would be padded locally cyclically. The latter one is not wanted since we want padding according to the adjacencies in the source tone.+Note that differently from 'shapeFreqModSample'+the shape control difference @1@ does not mean to skip to the next wave,+since this oscillator has no discrete waveforms.+Instead @1@ means that the shape alters as fast as in the prototype signal.  Although the shape difference values must be non-negative I hesitate to give them the type @Number.NonNegative.T t@@@ -165,16 +178,38 @@ shapeFreqModFromSampledTone       ipLeap ipStep period sampledTone       shape0 phase shapes freqs =-   map-      (uncurry (ToneMod.interpolateCell ipLeap ipStep))-      (ToneMod.oscillatorCells-          ipLeap ipStep period sampledTone-          (shape0, shapes) (Phase.fromRepresentative phase, freqs))+   let periodInt = round period+   in  map+          (uncurry (ToneMod.interpolateCell ipLeap ipStep))+          (ToneMod.oscillatorCells+              (Interpolation.margin ipLeap) (Interpolation.margin ipStep)+              periodInt period sampledTone+              (shape0, shapes) (Phase.fromRepresentative phase, freqs)) {- GNUPlot.plotList [] $ take 1000 $ shapeFreqModFromSampledTone Interpolation.linear Interpolation.linear (1/0.07::Double) (staticSine (0::Double) 0.07) 0 0 (repeat 0.1) (repeat 0.01) GNUPlot.plotList [] $ take 1000 $ shapeFreqModFromSampledTone Interpolation.linear Interpolation.linear (1/0.07::Double) (staticSine (0::Double) 0.07) 0 0 (repeat 0.1) (iterate (*(1-2e-3)) 0.01) GNUPlot.plotList [] $ take 101 $ shapeFreqModFromSampledTone Interpolation.linear Interpolation.linear (1/0.07::Double) (iterate (1+) (0::Double)) 0 0 (repeat 1) (repeat 0.7) -}++shapePhaseFreqModFromSampledTone :: (RealField.C t) =>+    Interpolation.T t y ->+    Interpolation.T t y ->+    t -> Sig.T y -> t -> t -> Sig.T t -> Sig.T t -> Sig.T t -> Sig.T y+shapePhaseFreqModFromSampledTone+      ipLeap ipStep period sampledTone+      shape0 phase shapes phases freqs =+   let periodInt = round period+       marginLeap = Interpolation.margin ipLeap+       marginStep = Interpolation.margin ipStep+   in  map+          (uncurry (ToneMod.interpolateCell ipLeap ipStep) .+           ToneMod.seekCell periodInt period) $+       zipWith (\p -> mapFst (mapSnd (Phase.increment p))) phases $+       ToneMod.oscillatorSuffixes+          marginLeap marginStep+          periodInt period sampledTone+          (shape0, shapes)+          (Phase.fromRepresentative phase, freqs)   {- * Oscillators with specific waveforms -}
+ src/Synthesizer/Plain/Play.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.Plain.Play where++import qualified Synthesizer.Plain.Builder as Builder+import qualified Synthesizer.Basic.Binary as BinSmp++import qualified Sound.Sox.Frame as Frame+import qualified Sound.Sox.Frame.Stereo as Stereo+import qualified Sound.Sox.Option.Format as SoxOpt+import qualified Sound.Sox.Play as Play+import qualified Sound.Sox.Signal.List as SoxList++import Foreign.Storable (Storable, )+import Data.Int (Int16, )++import Data.Monoid (mconcat, )++-- import qualified Synthesizer.Frame.Stereo as Stereo++import qualified Algebra.ToInteger as ToInteger+import qualified Algebra.RealField as RealField++import System.Exit (ExitCode, )++import PreludeBase+import NumericPrelude+++{- |+See 'Synthesizer.Plain.File.write'.+-}+render ::+   (Storable int, Frame.C int, ToInteger.C int, Bounded int,+    RealField.C a, BinSmp.C v) =>+   Builder.Put int -> a -> (a -> [v]) -> IO ExitCode+render put sampleRate renderer =+   auto put sampleRate (renderer sampleRate)++renderToInt16 :: (RealField.C a, BinSmp.C v) => a -> (a -> [v]) -> IO ExitCode+renderToInt16 sampleRate renderer =+   toInt16 sampleRate (renderer sampleRate)++renderMonoToInt16 :: (RealField.C a) => a -> (a -> [a]) -> IO ExitCode+renderMonoToInt16 sampleRate renderer =+   monoToInt16 sampleRate (renderer sampleRate)++renderStereoToInt16 :: (RealField.C a) => a -> (a -> [(a,a)]) -> IO ExitCode+renderStereoToInt16 sampleRate renderer =+   stereoToInt16 sampleRate (renderer sampleRate)+++{- |+See 'Synthesizer.Plain.File.write'.+-}+auto ::+   (Storable int, Frame.C int, ToInteger.C int, Bounded int,+    RealField.C a, BinSmp.C v) =>+   Builder.Put int -> a -> [v] -> IO ExitCode+auto put sampleRate signal =+   raw+      (SoxOpt.numberOfChannels (BinSmp.numberOfSignalChannels signal))+      sampleRate+      (Builder.run . mconcat . map (BinSmp.outputFromCanonical put) $+       signal)++toInt16 :: (RealField.C a, BinSmp.C v) => a -> [v] -> IO ExitCode+toInt16 =+   auto (Builder.put :: Builder.Put Int16)++monoToInt16 :: (RealField.C a) => a -> [a] -> IO ExitCode+monoToInt16 sampleRate signal =+   raw SoxOpt.none sampleRate+      (map BinSmp.int16FromCanonical signal)++stereoToInt16 :: (RealField.C a) => a -> [(a,a)] -> IO ExitCode+stereoToInt16 sampleRate signal =+   raw SoxOpt.none sampleRate+      (map (fmap BinSmp.int16FromCanonical . uncurry Stereo.cons) signal)+++raw :: (RealField.C a, Frame.C v, Storable v) =>+   SoxOpt.T -> a -> [v] -> IO ExitCode+raw opts sampleRate signal =+   Play.extended SoxList.put opts SoxOpt.none (round sampleRate) signal+++exampleMono :: IO ExitCode+exampleMono =+   monoToInt16 (11025::Double) (map sin [0::Double,0.2..])++exampleStereo :: IO ExitCode+exampleStereo =+   stereoToInt16 (11025::Double) $+      zip+         (map sin [0::Double,0.199..])+         (map sin [0::Double,0.201..])
src/Synthesizer/Plain/Signal.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -O -fglasgow-exts #-}+{-# OPTIONS_GHC -fglasgow-exts #-} {- glasgow-exts are for the rules -} {- | Copyright   :  (c) Henning Thielemann 2008@@ -10,18 +10,16 @@ -} module Synthesizer.Plain.Signal where -import qualified Synthesizer.Generic.Signal as SigG-import qualified Sound.Signal as Signal--import qualified Algebra.Additive              as Additive+import qualified Number.Peano as Peano  import qualified Synthesizer.Plain.Modifier as Modifier-import Synthesizer.Utility (viewListL, viewListR, ) -import qualified NumericPrelude.List as NPList-import qualified Data.List as List+import qualified Data.List.Match as ListMatch+import qualified Data.List       as List +import Data.Tuple.HT (forcePair, mapFst, mapSnd, ) + type T a = [a]  @@ -66,49 +64,41 @@   -instance Signal.C [] where-   singleton = (:[])-   unfoldR   = unfoldR-   reduceL   = reduceL-   mapAccumL = mapAccumL-   (++)      = (List.++)-   zipWith   = List.zipWith- unfoldR :: (acc -> Maybe (y, acc)) -> acc -> (acc, T y) unfoldR f =-   let recurse acc0 =+   let recourse acc0 =+          forcePair $           maybe              (acc0,[])              (\(y,acc1) ->-                let (accEnd, signal) = recurse acc1-                in  (accEnd, y : signal))+                mapSnd (y:) $ recourse acc1)              (f acc0)-   in  recurse+   in  recourse  reduceL :: (x -> acc -> Maybe acc) -> acc -> T x -> acc reduceL f =-   let recurse a xt =+   let recourse a xt =           case xt of              [] -> a              (x:xs) ->                 maybe a-                   (\ a' -> seq a' (recurse a' xs))+                   (\ a' -> seq a' (recourse a' xs))                    (f x a)-   in  recurse+   in  recourse  mapAccumL :: (x -> acc -> Maybe (y, acc)) -> acc -> T x -> (acc, T y) mapAccumL f =-   let recurse acc0 xt =+   let recourse acc0 xt =+          forcePair $           case xt of              [] -> (acc0,[])              (x:xs) ->                  maybe                     (acc0,[])                     (\(y,acc1) ->-                       let (accEnd, signal) = recurse acc1 xs-                       in  (accEnd, y : signal))+                       mapSnd (y:) $ recourse acc1 xs)                     (f x acc0)-   in  recurse+   in  recourse  crochetL :: (x -> acc -> Maybe (y, acc)) -> acc -> T x -> T y crochetL f a = snd . mapAccumL f a@@ -126,48 +116,13 @@  {-# RULES   "fix1/crochetL" forall f a b.-     fix1 a (Signal.crochetL f b) =-        Signal.generate (\(a0,b0) ->+     fix1 a (crochetL f b) =+        snd $ unfoldR (\(a0,b0) ->             do yb1@(y0,_) <- f a0 b0                return (y0, yb1)) (a,b) ;   #-}  -instance SigG.C [] where-   empty = []-   null = List.null-   cons = (:)-   fromList = id-   toList = id-   repeat = List.repeat-   cycle = List.cycle-   replicate = List.replicate-   iterate = List.iterate-   iterateAssoc = NPList.iterateAssoc-   unfoldR = List.unfoldr-   map = List.map-   mix = (Additive.+)-   zipWith = List.zipWith-   scanL = List.scanl-   viewL = viewListL-   viewR = viewListR-   foldL = List.foldl-   length = List.length-   take = List.take-   drop = List.drop-   splitAt = List.splitAt-   dropMarginRem = dropMarginRem-   takeWhile = List.takeWhile-   dropWhile = List.dropWhile-   span = List.span-   append = (List.++)-   concat = List.concat-   reverse = List.reverse-{--   mapAccumL = List.mapAccumL-   mapAccumR = List.mapAccumR--}-   crochetL = crochetL  {- instance SigG.Data [] y where@@ -196,9 +151,18 @@  dropMargin :: Int -> Int -> T a -> T a dropMargin n m xs =-   NPList.dropMatch (take m (drop n xs)) xs+   ListMatch.drop (take m (drop n xs)) xs + {- |+Test whether a list has at least @n@ elements.+-}+lengthAtLeast :: Int -> T a -> Bool+lengthAtLeast n xs =+   n<=0 || not (null (drop (n-1) xs))+++{- | Can be implemented more efficiently than just by 'zipWith' and 'List.tails' for other data structures.@@ -207,3 +171,38 @@    (y0 -> T y1 -> y2) -> T y0 -> T y1 -> T y2 zipWithTails f xs =    zipWith f xs . init . List.tails++zipWithRest ::+   (y0 -> y0 -> y1) ->+   T y0 -> T y0 ->+   (T y1, (Bool, T y0))+zipWithRest f xs ys =+   let len = min (List.genericLength xs) (List.genericLength ys) :: Peano.T+       (prefixX,suffixX) = List.genericSplitAt len xs+       (prefixY,suffixY) = List.genericSplitAt len ys+       second = null suffixX+   in  (zipWith f prefixX prefixY,+        (second, if second then suffixY else suffixX))++zipWithRest' ::+   (y0 -> y0 -> y1) ->+   T y0 -> T y0 ->+   (T y1, (Bool, T y0))+zipWithRest' f =+   let recourse xt yt =+          forcePair $+          case (xt,yt) of+             (x:xs, y:ys) ->+                mapFst (f x y :) (recourse xs ys)+             ([], _) -> ([], (True,  yt))+             (_, []) -> ([], (False, xt))+   in  recourse+{-+Test.QuickCheck.test (\xs ys -> zipWithRest (,) xs ys == zipWithRest' (,) xs (ys::[Int]))+-}++zipWithAppend ::+   (y -> y -> y) ->+   T y -> T y -> T y+zipWithAppend f xs ys =+   uncurry (++) $ mapSnd snd $ zipWithRest f xs ys
src/Synthesizer/Plain/ToneModulation.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -O2 -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright   :  (c) Henning Thielemann 2006 License     :  GPL@@ -48,9 +48,12 @@ -} module Synthesizer.Plain.ToneModulation where +import qualified Synthesizer.Basic.ToneModulation as ToneMod import qualified Synthesizer.Basic.Phase as Phase +import qualified Synthesizer.Plain.Signal as Sig import qualified Synthesizer.Plain.Interpolation as Interpolation+import Synthesizer.Interpolation (Margin, ) -- import qualified Data.Array as Array import Data.Array (Array, (!), listArray, ) @@ -64,12 +67,14 @@ import qualified Number.NonNegative       as NonNeg import qualified Number.NonNegativeChunky as Chunky -import Synthesizer.Utility (viewListL, viewListR, clip, mapPair, )-import Control.Monad (guard)+import Control.Monad (guard, ) -import qualified Data.List as List+import qualified Data.List       as List+import qualified Data.List.HT    as ListHT+import qualified Data.List.Match as ListMatch+import Data.Ord.HT (limit, )+import Data.Tuple.HT (mapPair, mapSnd, forcePair, ) -import NumericPrelude.List (replicateMatch, takeMatch, ) import NumericPrelude  -- import qualified Prelude as P@@ -79,128 +84,42 @@  -- * general helpers +type Cell y = Sig.T (Sig.T y)+ interpolateCell ::    Interpolation.T a y ->    Interpolation.T b y ->    (a, b) ->-   [[y]] -> y+   Cell y -> y interpolateCell ipLeap ipStep (qLeap,qStep) =    Interpolation.func ipStep qStep .    map (Interpolation.func ipLeap qLeap)  -{- |-Convert from the (shape,phase) parameter pair-to the index within a wave (step) and the index of a wave (leap)-in the sampled prototype tone.--}-untangleShapePhase :: (Field.C a) =>-   Int -> a -> (a, a) -> (a, a)-untangleShapePhase periodInt period (shape,phase) =-   let leap = shape/period - phase-       step = shape - leap * fromIntegral periodInt-   in  (leap, step)--untangleShapePhaseAnalytic :: (Field.C a) =>-   Int -> a -> (a, a) -> (a, a)-untangleShapePhaseAnalytic periodInt period (shape,phase) =-   let periodRound = fromIntegral periodInt-       vLeap = (periodRound, periodRound-period)-       vStep = (1,1)-   in  solveSLE2 (vLeap,vStep) (shape,period*phase)--{--Cramer's rule--see HTam/Numerics/ZeroFinder/Root, however the matrix is transposed--}-solveSLE2 :: Field.C a => ((a,a), (a,a)) -> (a,a) -> (a,a)-solveSLE2 a@(a0,a1) b =-   let det = det2 a-   in  (det2 (b, a1) / det,-        det2 (a0, b) / det)--det2 :: Ring.C a => ((a,a), (a,a)) -> a-det2 ((a00,a10),(a01,a11)) =-   a00*a11 - a10*a01--{--transpose :: ((a,a), (a,a)) -> ((a,a), (a,a))-transpose ((a00,a10),(a01,a11)) = ((a00,a01),(a10,a11))--}---flattenShapePhase :: RealField.C a =>-      Int-   -> a-   -> (a, Phase.T a)-   -> (Int, (a, a))-flattenShapePhase periodInt period (shape,phase) =-   let (xShape,xWave) =-          untangleShapePhase periodInt period (shape, Phase.toRepresentative phase)-       (nLeap,qLeap) = splitFraction xShape-       (nStep,qStep) = splitFraction xWave-       {- reverse solveSLE2 for the shape parameter-          with respect to the rounded (wave,shape) coordinates -}-       n = nStep + nLeap * periodInt-   in  (n,(qLeap,qStep))--shapeLimits :: Ring.C t =>-      Interpolation.T a v-   -> Interpolation.T a v-   -> Int-   -> t-   -> (t, t)-shapeLimits ipLeap ipStep periodInt len =-   let minShape =-          fromIntegral $-          interpolationOffset ipLeap ipStep periodInt +-          periodInt-       maxShape =-          minShape + len --             fromIntegral-                (Interpolation.number ipStep +-                 Interpolation.number ipLeap * periodInt)-   in  (minShape, maxShape)---interpolationOffset ::-      Interpolation.T a v-   -> Interpolation.T a v-   -> Int-   -> Int-interpolationOffset ipLeap ipStep periodInt =-   Interpolation.offset ipStep +-   Interpolation.offset ipLeap * periodInt---- -- * array based shape variable wave -data Prototype a v =+data Prototype t y =    Prototype {-      protoIpLeap,-      protoIpStep      :: Interpolation.T a v,+      protoMarginLeap,+      protoMarginStep  :: Margin,       protoIpOffset    :: Int,-      protoPeriod      :: a,+      protoPeriod      :: t,       protoPeriodInt   :: Int,-      protoShapeLimits :: (a,a),-      protoArray       :: Array Int v+      protoShapeLimits :: (t,t),+      protoArray       :: Array Int y    }  -makePrototype :: (RealField.C a) =>-   Interpolation.T a v ->-   Interpolation.T a v ->-   a -> [v] -> Prototype a v-makePrototype ipLeap ipStep period tone =-   let periodInt = round period-       ipOffset =-          interpolationOffset ipLeap ipStep periodInt+makePrototype :: (RealField.C t) =>+   Margin ->+   Margin ->+   Int -> t -> Sig.T y -> Prototype t y+makePrototype marginLeap marginStep periodInt period tone =+   let ipOffset =+          ToneMod.interpolationOffset marginLeap marginStep periodInt        len = length tone        (lower,upper) =-          shapeLimits ipLeap ipStep periodInt len+          ToneMod.shapeLimits marginLeap marginStep periodInt len        limits =           if lower > upper             then error "min>max"@@ -210,8 +129,8 @@        arr = listArray (0, pred len) tone     in  Prototype {-          protoIpLeap      = ipLeap,-          protoIpStep      = ipStep,+          protoMarginLeap  = marginLeap,+          protoMarginStep  = marginStep,           protoIpOffset    = ipOffset,           protoPeriod      = period,           protoPeriodInt   = periodInt,@@ -219,32 +138,22 @@           protoArray       = arr        } -sampledToneCell :: (RealField.C a) =>-   Prototype a v -> a -> Phase.T a -> ((a,a),[[v]])+sampledToneCell :: (RealField.C t) =>+   Prototype t y -> t -> Phase.T t -> ((t,t), Cell y) sampledToneCell p shape phase =    let (n, q) =-          flattenShapePhase (protoPeriodInt p) (protoPeriod p)-             (uncurry clip (protoShapeLimits p) shape, phase)+          ToneMod.flattenShapePhase (protoPeriodInt p) (protoPeriod p)+             (limit (protoShapeLimits p) shape, phase)    in  (q,         map (map (protoArray p ! ) . iterate (protoPeriodInt p +)) $         enumFrom (n - protoIpOffset p)) -sampledToneAltCell :: (RealField.C a) =>-   Prototype a v -> a -> Phase.T a -> ((a,a),[[v]])-sampledToneAltCell p shape phase =-   let (n, q) =-          flattenShapePhase (protoPeriodInt p) (protoPeriod p)-             (uncurry clip (protoShapeLimits p) shape, phase)-   in  (q,-        iterate (drop (protoPeriodInt p)) $-        map (protoArray p ! ) (enumFrom (n - protoIpOffset p))) - {-   M = ((1,1)^T, (periodRound, period-periodRound)^T)    equation for the line-   0 = (nStep  - offset ipStep) ++   0 = (nStep - offset ipStep) +        (nLeap - offset ipLeap) * periodInt     <(1,periodInt), (offset ipStep, offset ipLeap)>@@ -268,86 +177,123 @@   oscillatorCells :: (RealField.C t) =>-    Interpolation.T t y ->-    Interpolation.T t y ->-    t -> [y] -> (t,[t]) -> (Phase.T t,[t]) -> [((t,t),[[y]])]+    Margin ->+    Margin ->+    Int -> t ->+    Sig.T y -> (t, Sig.T t) -> (Phase.T t, Sig.T t) -> Sig.T ((t,t), Cell y) oscillatorCells-       ipLeap ipStep period sampledTone shapes freqs =-    let periodInt = round period-        ptrs =+       marginLeap marginStep periodInt period sampledTone shapes freqs =+    map (seekCell periodInt period) $+    oscillatorSuffixes+        marginLeap marginStep periodInt period sampledTone shapes freqs++seekCell :: (RealField.C t) =>+    Int -> t ->+    ((t, Phase.T t), Cell y) -> ((t,t), Cell y)+seekCell periodInt period =+    {- n will be zero within the data.+       We would need it only for extrapolation at the end.+       But this does not happen, since we limit the shape control parameter accordingly.+    -}+    (\(coords, ptr) ->+       let (k,q) = ToneMod.flattenShapePhase periodInt period coords+       in  if k>0+             then error "ToneModulation.oscillatorCells: k>0"+             else (q, drop (periodInt+k) ptr))++oscillatorSuffixes :: (RealField.C t) =>+    Margin ->+    Margin ->+    Int -> t -> Sig.T y ->+    (t, Sig.T t) -> (Phase.T t, Sig.T t) ->+    Sig.T ((t, Phase.T t), Cell y)+oscillatorSuffixes+       marginLeap marginStep periodInt period sampledTone shapes freqs =+    let ptrs =            List.transpose $            takeWhile (not . null) $            iterate (drop periodInt) sampledTone         ipOffset =-           interpolationOffset ipLeap ipStep periodInt+           periodInt ++           ToneMod.interpolationOffset marginLeap marginStep periodInt+{- I tried to switch integrateFractional and limitRelativeShapes+   in order to have a position where I can easily add phase distortion.+   However, limitting skip values after integrateFractional+   does not work this way, since once we start setting skip values to zero,+   we had to clear the fractional parts of the shape coordinate, too.+        (firstSkip:allSkips,coords) =+           unzip $+           integrateFractional period shapes freqs+        (skip,skips) =+           limitRelativeShapes marginLeap marginStep+              periodInt sampledTone (firstSkip,allSkips)+-}         (skip:skips,coords) =            unzip $-           oscillatorCoords periodInt period-              (limitRelativeShapes ipLeap ipStep periodInt sampledTone shapes)+           integrateFractional period+              (limitRelativeShapes marginLeap marginStep periodInt sampledTone shapes)               freqs-    in  zipWith-           -- n will be zero within the data, it's only needed for extrapolation-           (\(k,q) (n,ptr) ->-             if n>0-               then error "ToneModulation.oscillatorCells: limit of shape parameter is buggy"-               else-                 (q, drop (periodInt+k) ptr))-           coords $+    in  zip coords $+        map (\(n,ptr) ->+               if n>0+                 then error $ "ToneModulation.oscillatorCells: " +++                              "limit of shape parameter is buggy"+                 else ptr) $         tail $         scanl            {- since we clip the coordinates before calling oscillatorCells               we do not need 'dropRem', since 'drop' would never go beyond the list end -}            (\ (n,ptr0) d0 -> dropRem (n+d0) ptr0)            (0,ptrs)-           ((skip - ipOffset - periodInt) : skips)+           ((skip - ipOffset) : skips) -dropFrac :: RealField.C i => i -> [a] -> (Int, i, [a])+dropFrac :: RealField.C i => i -> Sig.T a -> (Int, i, Sig.T a) dropFrac =-   let recurse acc n xt =+   let recourse acc n xt =           if n>=1             then                case xt of-                  _:xs -> recurse (succ acc) (n-1) xs+                  _:xs -> recourse (succ acc) (n-1) xs                   [] -> (acc, n, [])             else (acc,n,xt)-   in  recurse 0+   in  recourse 0 -dropFrac' :: RealField.C i => i -> [a] -> (Int, i, [a])+dropFrac' :: RealField.C i => i -> Sig.T a -> (Int, i, Sig.T a) dropFrac' =-   let recurse acc n xt =+   let recourse acc n xt =           maybe              (acc,n,xt)-             (recurse (succ acc) (n-1) . snd)-             (guard (n>=1) >> viewListL xt)-   in  recurse 0+             (recourse (succ acc) (n-1) . snd)+             (guard (n>=1) >> ListHT.viewL xt)+   in  recourse 0 -propDropFrac :: (RealField.C i, Eq a) => i -> [a] -> Bool+propDropFrac :: (RealField.C i, Eq a) => i -> Sig.T a -> Bool propDropFrac n xs =    dropFrac n xs == dropFrac' n xs   -dropRem :: Int -> [a] -> (Int, [a])+dropRem :: Int -> Sig.T a -> (Int, Sig.T a) dropRem =-   let recurse n xt =+   let recourse n xt =           if n>0             then                case xt of-                  _:xs -> recurse (pred n) xs+                  _:xs -> recourse (pred n) xs                   [] -> (n, [])             else (n,xt)-   in  recurse+   in  recourse -dropRem' :: Int -> [a] -> (Int, [a])+dropRem' :: Int -> Sig.T a -> (Int, Sig.T a) dropRem' =-   let recurse n xt =+   let recourse n xt =           maybe              (n,xt)-             (recurse (pred n) . snd)-             (guard (n>0) >> viewListL xt)-   in  recurse+             (recourse (pred n) . snd)+             (guard (n>0) >> ListHT.viewL xt)+   in  recourse -propDropRem :: (Eq a) => Int -> [a] -> Bool+propDropRem :: (Eq a) => Int -> Sig.T a -> Bool propDropRem n xs =    dropRem n xs == dropRem' n xs @@ -360,51 +306,57 @@   oscillatorCoords :: (RealField.C t) =>-    Int -> t -> (t,[t]) -> (Phase.T t, [t]) -> [(Int,(Int,(t,t)))]-oscillatorCoords periodInt period-       (shape0, shapes) (phase, freqs) =+    Int -> t -> (t, Sig.T t) -> (Phase.T t, Sig.T t) -> Sig.T (ToneMod.Coords t)+oscillatorCoords periodInt period shapes freqs =+   map (mapSnd (ToneMod.flattenShapePhase periodInt period)) $+   integrateFractional period shapes freqs+{-+mapM print $ take 30 $ let period = 1/0.07::Double in oscillatorCoords (round period) period 0 0 (repeat 0.1) (repeat 0.01)++*Synthesizer.Plain.Oscillator> mapM print $ take 30 $ let period = 1/0.07::Rational in oscillatorCoords (round period) period 0 0 (repeat 1) (repeat 0.07)++*Synthesizer.Plain.Oscillator> mapM print $ take 30 $ let period = 1/0.07::Rational in oscillatorCoords (round period) period 0 0 (repeat 0.25) (repeat 0.0175)+-}+++integrateFractional :: (RealField.C t) =>+    t -> (t, Sig.T t) -> (Phase.T t, Sig.T t) -> Sig.T (ToneMod.Skip t)+integrateFractional period (shape0, shapes) (phase, freqs) =     let shapeOffsets =            scanl               (\(_,s) c -> splitFraction (s+c))               (splitFraction shape0) shapes         phases =            let (s:ss) = map (\(n,_) -> fromIntegral n / period) shapeOffsets-           in  freqToPhase-                  (Phase.increment (-s) phase)  -- phase - s+           in  freqsToPhases+                  (Phase.decrement s phase)  -- phase - s                   (zipWith (-) freqs ss)     in  zipWith---           (\(d,s) p -> (d, (s,p)))-           (\(d,s) p -> (d, flattenShapePhase periodInt period (s,p)))+           (\(d,s) p -> (d, (s,p)))            shapeOffsets            phases-{--mapM print $ take 30 $ let period = 1/0.07::Double in oscillatorCoords (round period) period 0 0 (repeat 0.1) (repeat 0.01) -*Synthesizer.Plain.Oscillator> mapM print $ take 30 $ let period = 1/0.07::Rational in oscillatorCoords (round period) period 0 0 (repeat 1) (repeat 0.07) -*Synthesizer.Plain.Oscillator> mapM print $ take 30 $ let period = 1/0.07::Rational in oscillatorCoords (round period) period 0 0 (repeat 0.25) (repeat 0.0175)--}-- -- this function fits better in the Oscillator module {- | Convert a list of phase steps into a list of momentum phases phase is a number in the interval [0,1) freq contains the phase steps -}-freqToPhase :: RealField.C a => Phase.T a -> [a] -> [Phase.T a]-freqToPhase phase freq = scanl (flip Phase.increment) phase freq+freqsToPhases :: RealField.C a => Phase.T a -> Sig.T a -> Sig.T (Phase.T a)+freqsToPhases phase freq = scanl (flip Phase.increment) phase freq   -limitRelativeShapes :: (RealField.C t) =>-    Interpolation.T t y ->-    Interpolation.T t y ->-    Int -> [y] -> (t,[t]) -> (t,[t])-limitRelativeShapes ipLeap ipStep periodInt sampledTone =+limitRelativeShapes :: (Ring.C t, Ord t) =>+    Margin ->+    Margin ->+    Int -> Sig.T y -> (t, Sig.T t) -> (t, Sig.T t)+limitRelativeShapes marginLeap marginStep periodInt sampledTone =     let -- len = List.genericLength sampledTone-        len = Chunky.fromChunks (replicateMatch sampledTone one)-        (minShape, maxShape) = shapeLimits ipLeap ipStep periodInt len+        len = Chunky.fromChunks (ListMatch.replicate sampledTone one)+        (minShape, maxShape) =+           ToneMod.shapeLimits marginLeap marginStep periodInt len         fromChunky = NonNeg.toNumber   . Chunky.toNumber         toChunky   = Chunky.fromNumber . NonNeg.fromNumber     in  mapPair (fromChunky, map fromChunky) .@@ -418,39 +370,41 @@   limitMinRelativeValues :: (Additive.C a, Ord a) =>-   a -> a -> [a] -> (a, [a])+   a -> a -> Sig.T a -> (a, Sig.T a) limitMinRelativeValues xMin x0 xs =    let (ys,zs) =           span ((<zero).fst) (zip (scanl (+) (x0-xMin) xs) (x0:xs))    in  case ys of           [] -> (x0,xs)-          (_:yr) -> (xMin, replicateMatch yr zero +++          (_:yr) -> (xMin, ListMatch.replicate yr zero ++               case zs of                  [] -> []                  (z:zr) -> fst z : map snd zr)  limitMaxRelativeValues :: (Additive.C a, Ord a) =>-   a -> a -> [a] -> (a, [a])+   a -> a -> Sig.T a -> (a, Sig.T a) limitMaxRelativeValues xMax x0 xs =    let (ys,zs) =           span (>zero) (scanl (-) (xMax-x0) xs)-   in  maybe-          (xMax, replicateMatch xs zero)-          (\ ~(yl,yr) -> (x0, takeMatch yl xs ++ takeMatch zs (yr : repeat zero)))-          (viewListR ys)+   in  forcePair $+       ListHT.switchR+          (xMax, ListMatch.replicate xs zero)+          (\ yl yr -> (x0, ListMatch.take yl xs ++ ListMatch.take zs (yr : repeat zero)))+          ys  {- | Avoids negative numbers and thus can be used with Chunky numbers. -} limitMaxRelativeValuesNonNeg :: (Additive.C a, Ord a) =>-   a -> a -> [a] -> (a, [a])+   a -> a -> Sig.T a -> (a, Sig.T a) limitMaxRelativeValuesNonNeg xMax x0 xs =    let (ys,zs) =           span fst (scanl (\(_,acc) d -> safeSub acc d) (safeSub xMax x0) xs)-   in  maybe-          (xMax, replicateMatch xs zero)-          (\ ~(yl, ~(_,yr)) -> (x0, takeMatch yl xs ++ takeMatch zs (yr : repeat zero)))-          (viewListR ys)+   in  forcePair $+       ListHT.switchR+          (xMax, ListMatch.replicate xs zero)+          (\ yl ~(_,yr) -> (x0, ListMatch.take yl xs ++ ListMatch.take zs (yr : repeat zero)))+          ys {- *Synthesizer.Plain.Oscillator> limitMaxRelativeValuesNonNeg (let inf = 1+inf in inf) (0::Chunky.T NonNeg.Rational) (repeat 2.5) -}
+ src/Synthesizer/Plain/Tutorial.hs view
@@ -0,0 +1,208 @@+{- |+This module gives some introductory examples to signal processing+with plain Haskell lists.+For more complex examples+see "Synthesizer.Plain.Instrument"+and "Synthesizer.Plain.Effect".+The examples require a basic understanding of audio signal processing.++In the Haddock documentation you will only see the API.+In order to view the example code,+please use the \"Source code\" links beside the function documentation.+This requires however,+that the Haddock was executed with @hyperlink-source@ option.++Using plain lists is not very fast,+particularly not fast enough for serious real-time applications.+It is however the most flexible data structure,+which you can also use without knowledge of low level programming.+For real-time applications see "Synthesizer.Generic.Tutorial".+-}+module Synthesizer.Plain.Tutorial+{-# DEPRECATED "do not import that module, it is only intended for demonstration" #-}+ where++import qualified Synthesizer.Plain.Play as Play+import qualified Synthesizer.Plain.File as File+import qualified Synthesizer.Plain.Signal as Sig+import qualified Synthesizer.Plain.Control as Ctrl+import qualified Synthesizer.Plain.Oscillator as Osci+import qualified Synthesizer.Plain.Filter.NonRecursive as Filt+import qualified Synthesizer.Plain.Filter.Recursive as FiltRec+import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter+import qualified Synthesizer.Basic.Wave as Wave++import qualified Algebra.Module as Module -- needed for Haddock++import System.Exit (ExitCode, )+import NumericPrelude+import PreludeBase+import Prelude ()+++{- |+Play a simple sine tone at 44100 sample rate and 16 bit.+These are the parameters used for compact disks.+The period of the tone is @2*pi*10@.+Playing at sample rate 44100 Hz results in a tone of @44100 / (20*pi) Hz@,+that is about @702 Hz@.+This is simple enough to be performed in real-time,+at least on my machine.+For playback we use @SoX@.+-}+sine :: IO ExitCode+sine =+   Play.monoToInt16 (44100::Double) (map sin [0::Double,0.1..])++{- |+Now the same for a stereo signal.+Both stereo channels are slightly detuned+in order to achieve a stereophonic phasing effect.+In principle there is no limit of the number of channels,+but with more channels playback becomes difficult.+Many signal processes in our package+support any tuple and even nested tuples+using the notion of an algebraic @module@ (see 'Module.C').+A module is a vector space where the scalar numbers+do not need to support division.+A vector space is often also called a linear space,+because all we require of vectors is that they can be added and scaled+and these two operations fulfill some natural laws.+-}+sineStereo :: IO ExitCode+sineStereo =+   Play.stereoToInt16 (44100::Double) $ zip (map sin [0::Double,0.0998..]) (map sin [0::Double,0.1002..])++{- |+Of course we can also write a tone to disk using @sox@.+-}+writeSine :: IO ExitCode+writeSine =+   File.writeToInt16 "sine.aiff" (44100::Double) (take 50000 $ map sin [0::Double,0.1..])+++{- |+For the following examples we will stick to monophonic sounds played at 44100 Hz.+Thus we define a function for convenience.+-}+play :: Sig.T Double -> IO ExitCode+play = Play.monoToInt16 (44100::Double)++{- |+Now, let's repeat the 'sine' example in a higher level style.+We use the oscillator 'Osci.static' that does not allow any modulation.+We can however use any waveform.+The waveform is essentially a function+which maps from the phase to the displacement.+Functional programming proves to be very useful here,+since anonymous functions as waveforms are optimally supported by the language.+We can also expect, that in compiled form+the oscillator does not have to call back the waveform function+by an expensive explicit function call,+but that the compiler will inline both oscillator and waveform+such that the oscillator is turned into a simple loop+which handles both oscillation and waveform computation.++Using the oscillator with 'Wave.sine' also has the advantage+that we do not have to cope with 'pi's any longer.+The frequency is given as ratio of the sample rate.+That is, @0.01@ at @44100 Hz@ sample rate means @441 Hz@.+This way all frequencies are given in the low-level signal processing.++It is not optimal to handle frequencies this way,+since all frequency values are bound to the sample rate.+For overcoming this problem, see the high level routines using physical dimensions.+For examples see "Synthesizer.Dimensional.RateAmplitude.Demonstration".+-}+oscillator :: IO ExitCode+oscillator =+   play (Osci.static Wave.sine 0 (0.01::Double))++{- |+It is very simple to switch to another waveform like a saw tooth wave.+Instead of a sharp saw tooth,+we use an extreme asymmetric triangle.+This is a poor man's band-limiting approach+that shall reduce aliasing at high oscillation frequencies.+We should really work on band-limited oscillators,+but this is hard in the general case.+-}+saw :: IO ExitCode+saw =+   play (Osci.static (Wave.triangleAsymmetric 0.9) 0 (0.01::Double))++{- |+When we apply a third power to each value of the saw tooths+we get an oscillator with cubic polynomial functions as waveform.+The distortion function applied to a saw wave can be used+to turn every function on the interval [-1,1] into a waveform.+-}+cubic :: IO ExitCode+cubic =+   play (Osci.static (Wave.distort (^3) Wave.saw) 0 (0.01::Double))++{- |+Now let's start with modulated tones.+The first simple example is changing the degree of asymmetry+according to a slow oscillator (LFO = low frequency oscillator).+-}+sawMorph :: IO ExitCode+sawMorph =+   play (Osci.shapeMod Wave.triangleAsymmetric 0 (0.01::Double) (Osci.static Wave.sine 0 (0.00001::Double)))++{- |+It's also very common to modulate the frequency of a tone.+-}+laser :: IO ExitCode+laser =+   play (Osci.freqMod Wave.saw 0 $ map (\f -> 0.02+0.01*f) $ Osci.static Wave.saw 0 (0.0001::Double))++pingSig :: Sig.T Double+pingSig =+   Filt.envelope (Ctrl.exponential 50000 1) (Osci.static Wave.sine 0 (0.01::Double))++{- |+A simple sine wave with exponentially decaying amplitude.+-}+ping :: IO ExitCode+ping =+   play pingSig++{- |+The 'ping' sound can also be used+to modulate the phase another oscillator.+This is a well-known effect used excessively in FM synthesis,+that was introduced by the Yamaha DX-7 synthesizer.+-}+fmPing :: IO ExitCode+fmPing =+   play (Osci.phaseMod Wave.sine (0.01::Double) $ map (2*) pingSig)++{- |+One of the most impressive sounds effects is certainly frequency filtering,+especially when the filter parameters are modulated.+In this example we use a resonant lowpass+whose resonance frequency is controlled by a slow sine wave.+The frequency filters usually use internal filter parameters+that are not very intuitive to use directly.+Thus we apply a function (here 'UniFilter.parameter')+in order to turn the intuitive parameters \"resonance frequency\" and \"resonance\"+(resonance frequency amplification while frequency zero is left unchanged)+into internal filter parameters.+We have not merged these two steps+since the computation of internal filter parameters+is more expensive then the filtering itself+and you may want to reduce the computation+by computing the internal filter parameters at a low sample rate+and interpolate them.+However, in the list implementation+this will not save you much time, if at all,+since the list operations are too expensive.++Now this is the example where my machine is no longer able to produce+a constant audio stream in real-time.+For tackling this problem, please continue with "Synthesizer.Generic.Tutorial".+-}+filterSaw :: IO ExitCode+filterSaw =+   play (map UniFilter.lowpass $ UniFilter.run (map (\f -> UniFilter.parameter $ FiltRec.Pole 10 (0.04+0.02*f)) $ Osci.static Wave.sine 0 (0.00001::Double)) $ Osci.static Wave.saw 0 (0.002::Double))
+ src/Synthesizer/Plain/Wave.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+module Synthesizer.Plain.Wave where++import qualified Synthesizer.Basic.Wave as Wave++import qualified Synthesizer.Plain.ToneModulation as ToneMod+import qualified Synthesizer.Plain.Interpolation  as Interpolation+import qualified Synthesizer.Plain.Signal as Sig+import Data.Array ((!), listArray)++-- import qualified Synthesizer.Basic.Phase as Phase++import qualified Algebra.RealField             as RealField+import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import NumericPrelude++-- import qualified Prelude as P+import PreludeBase+++sample :: (RealField.C a) =>+   Interpolation.T a v -> Sig.T v -> Wave.T a v+sample ip wave =+   let len = length wave+       arr = listArray (0, pred len) wave+   in  Wave.fromFunction $ \ phase ->+           let (n,q) = splitFraction (phase * fromIntegral len)+               xs = map (arr!) (map (flip mod len)+                      (enumFrom (n - Interpolation.offset ip)))+--                map (arr!) (enumFromTo (n - Interpolation.offset ip)) ++ cycle wave+           in  Interpolation.func ip q xs++{- |+We assume that a tone was generated by a shape modulated oscillator.+We try to reconstruct the wave function+(with parameters shape control and phase)+from a tone by interpolation.++The unit for the shape control parameter is the sampling period.+That is the shape parameter is a time parameter+pointing to a momentary shape of the prototype signal.+Of course this momentary shape does not exist+and we can only guess it using interpolation.++At the boundaries we repeat the outermost shapes+that can be reconstructed entirely from interpolated data+(that is, no extrapolation is needed).+This way we cannot reproduce the shape at the boundaries+because we have no data for cyclically extending it.+On the other hand this method guarantees a nice wave shape+with the required fractional period.++It must be+   @length tone >=+       Interpolation.number ipStep ++       Interpolation.number ipLeap * ceiling period@.+-}+sampledTone :: (RealField.C a) =>+   Interpolation.T a v ->+   Interpolation.T a v ->+   a -> Sig.T v -> a -> Wave.T a v+sampledTone ipLeap ipStep period tone shape = Wave.Cons $ \phase ->+   uncurry (ToneMod.interpolateCell ipLeap ipStep) $+   ToneMod.sampledToneCell+      (ToneMod.makePrototype+          (Interpolation.margin ipLeap) (Interpolation.margin ipStep)+          (round period) period tone)+      shape phase+{-+*Synthesizer.Basic.Wave>+GNUPlot.plotFunc [] (GNUPlot.linearScale 1000 (0,12)) (\t -> sampledTone Interpolation.linear Interpolation.linear (6::Double) ([-5,-3,-1,1,3,5,-4,-4,-4,4,4,4]++replicate 20 0) t (t/6))++*Synthesizer.Plain.Oscillator>+let period = 6.3::Double in GNUPlot.plotFunc [] (GNUPlot.linearScale 1000 (-10,20)) (\t -> Wave.sampledTone Interpolation.linear Interpolation.cubic period (take 20 $ staticSine 0 (1/period)) t (t/period))+-}+
src/Synthesizer/SampleRateContext/Filter.hs view
@@ -68,7 +68,7 @@ import qualified Synthesizer.Plain.Interpolation as Interpolation import qualified Synthesizer.Plain.Filter.Delay.Block as Delay -import Synthesizer.Utility(clip)+import Data.Ord.HT (limit, ) -}  import qualified Algebra.OccasionallyScalar as OccScalar
src/Synthesizer/SampleRateContext/Noise.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright   :  (c) Henning Thielemann 2008 License     :  GPL
src/Synthesizer/SampleRateContext/Oscillator.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright   :  (c) Henning Thielemann 2008 License     :  GPL
src/Synthesizer/SampleRateContext/Play.hs view
@@ -1,6 +1,6 @@ module Synthesizer.SampleRateContext.Play where -import qualified BinarySample as BinSmp+import qualified Synthesizer.Basic.Binary as BinSmp  import qualified Synthesizer.SampleRateContext.Signal as SigC import qualified Synthesizer.SampleRateContext.Rate   as Rate@@ -12,11 +12,14 @@ import qualified Algebra.RealField          as RealField import qualified Algebra.Field              as Field +import System.Exit(ExitCode) -auto :: (RealField.C t, BinSmp.C yv,-         Field.C t', OccScalar.C t t',-         Field.C y', OccScalar.C y y',-         VectorSpace.C y yv) =>-   t' -> y' -> t' -> (Rate.T t t' -> SigC.T y y' yv) -> IO ()-auto freqUnit amp sampleRate proc =-   PlayP.auto freqUnit amp (SigP.runPlain sampleRate proc)++toInt16 ::+   (RealField.C t, BinSmp.C yv,+    Field.C t', OccScalar.C t t',+    Field.C y', OccScalar.C y y',+    VectorSpace.C y yv) =>+   t' -> y' -> t' -> (Rate.T t t' -> SigC.T y y' yv) -> IO ExitCode+toInt16 freqUnit amp sampleRate proc =+   PlayP.toInt16 freqUnit amp (SigP.runPlain sampleRate proc)
src/Synthesizer/State/Analysis.hs view
@@ -1,4 +1,6 @@-{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-} module Synthesizer.State.Analysis where  import qualified Synthesizer.State.Control as Ctrl@@ -105,15 +107,13 @@ {-# INLINE bounds #-} bounds :: (Ord y) => Sig.T y -> (y,y) bounds =-   maybe+   Sig.switchL       (error "Analysis.bounds: List must contain at least one element.")-      (\(x,xs) ->+      (\x xs ->           Sig.foldL (\(minX,maxX) y -> (min y minX, max y maxX)) (x,x) xs)-   . Sig.viewL   - {- * Miscellaneous -}  {-@@ -297,19 +297,32 @@ -} {-# INLINE centroid #-} centroid :: Field.C y => Sig.T y -> y-centroid xs =-   scalarProduct (Sig.iterate (one+) zero) xs / Sig.sum xs+centroid =+   uncurry (/) .+   Sig.sum .+   Sig.zipWith+      (\k x -> (k*x, x))+      (Sig.iterate (one+) zero) -{--centroidAlt :: Field.C y => Sig.T y -> y-centroidAlt xs =-   Sig.sum (scanr (+) zero (tail xs)) / sum xs--}+centroidRecompute :: Field.C y => Sig.T y -> y+centroidRecompute xs =+   firstMoment xs / Sig.sum xs +{-# INLINE firstMoment #-}+firstMoment :: Field.C y => Sig.T y -> y+firstMoment xs =+   scalarProduct (Sig.iterate (one+) zero) xs + {-# INLINE average #-} average :: Field.C y => Sig.T y -> y-average x =+average =+   uncurry (/) .+   Sig.sum .+   Sig.map (flip (,) one)++averageRecompute :: Field.C y => Sig.T y -> y+averageRecompute x =    Sig.sum x / fromIntegral (Sig.length x)  {-# INLINE rectify #-}
src/Synthesizer/State/Control.hs view
@@ -1,4 +1,6 @@-{-# OPTIONS_GHC -O2 -fglasgow-exts -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-} {- | Copyright   :  (c) Henning Thielemann 2008 License     :  GPL@@ -26,8 +28,6 @@  -- import Number.Complex (cis,real) -- import qualified Number.Complex as Complex--- import Data.List (zipWith4, tails)--- import NumericPrelude.List (iterateAssoc)  import qualified Prelude as P import PreludeBase@@ -68,6 +68,22 @@ linearMultiscaleNeutral slope =    curveMultiscaleNeutral (+) slope zero +{- |+Linear curve of a fixed length.+The final value is not actually reached,+instead we stop one step before.+This way we can concatenate several lines+without duplicate adjacent values.+-}+{-# INLINE line #-}+line :: Field.C y =>+      Int     {-^ length -}+   -> (y,y)   {-^ initial and final value -}+   -> Sig.T y {-^ linear progression -}+line n (y0,y1) =+   Sig.take n $ linear ((y1-y0) / fromIntegral n) y0++ {-# INLINE exponential #-} {-# INLINE exponentialMultiscale #-} exponential, exponentialMultiscale :: Trans.C a =>@@ -242,9 +258,9 @@ {-# INLINE curveMultiscale #-} curveMultiscale :: (y -> y -> y) -> y -> y -> Sig.T y curveMultiscale op d y0 =-   Sig.cons y0 (Sig.map (op y0) (Sig.iterateAssoc op d))+   Sig.cons y0 (Sig.map (op y0) (Sig.iterateAssociative op d))  {-# INLINE curveMultiscaleNeutral #-} curveMultiscaleNeutral :: (y -> y -> y) -> y -> y -> Sig.T y curveMultiscaleNeutral op d neutral =-   Sig.cons neutral (Sig.iterateAssoc op d)+   Sig.cons neutral (Sig.iterateAssociative op d)
src/Synthesizer/State/Cut.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright   :  (c) Henning Thielemann 2006 License     :  GPL@@ -32,7 +32,7 @@ import Control.Applicative (Applicative, ) import Data.Traversable (sequenceA, ) -import Synthesizer.Utility (mapSnd, )+import Data.Tuple.HT (mapSnd, )  import qualified Number.NonNegative as NonNeg @@ -150,7 +150,7 @@                 then                   fmap                      (mapSnd (\(xs1,ys1) -> ((zero,ys1),xs1)))-                     (Sig.mixStep (xs0, ys0))+                     (Sig.zipStep (+) (xs0, ys0))                 else                   Just $ mapSnd ((,) (pred d, ys0)) $                   Sig.switchL (zero, xs0) (,) xs0)
src/Synthesizer/State/Displacement.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} module Synthesizer.State.Displacement where  import qualified Synthesizer.State.Signal as Sig
src/Synthesizer/State/Filter/Delay.hs view
@@ -1,7 +1,8 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} module Synthesizer.State.Filter.Delay where -import qualified Synthesizer.State.Interpolation as Interpolation+import qualified Synthesizer.Interpolation as Interpolation+import qualified Synthesizer.State.Interpolation as InterpolationS import qualified Synthesizer.State.Signal as Sig  import qualified Algebra.RealField as RealField@@ -21,7 +22,7 @@  {-# INLINE staticPad #-} staticPad :: y -> Int -> Sig.T y -> Sig.T y-staticPad = Interpolation.delayPad+staticPad = InterpolationS.delayPad  {-# INLINE staticPos #-} staticPos :: Additive.C y => Int -> Sig.T y -> Sig.T y@@ -38,7 +39,7 @@    Interpolation.T a v -> Int -> Sig.T a -> Sig.T v -> Sig.T v modulatedCore ip size =    Sig.zipWithTails-      (\t -> Interpolation.single ip (fromIntegral size + t))+      (\t -> InterpolationS.single ip (fromIntegral size + t))  {- modulatedCoreSlow :: (RealField.C a, Additive.C v) =>
src/Synthesizer/State/Filter/NonRecursive.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright   :  (c) Henning Thielemann 2008 License     :  GPL@@ -23,7 +23,7 @@  import Algebra.Module( {- linearComb, -} (*>)) -import Synthesizer.Utility (nest)+import Data.Function.HT (nest, )  import PreludeBase import NumericPrelude@@ -261,6 +261,7 @@  ToDo: Vector variant -}+{- We use zapWith in order to avoid recomputation of the input signal -} {-# INLINE differentiateCenter #-} differentiateCenter :: Field.C v => Sig.T v -> Sig.T v differentiateCenter =
src/Synthesizer/State/Filter/Recursive/Comb.hs view
@@ -1,4 +1,6 @@-{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-} {- | Copyright   :  (c) Henning Thielemann 2008 License     :  GPL
src/Synthesizer/State/Filter/Recursive/Integration.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright   :  (c) Henning Thielemann 2008 License     :  GPL@@ -12,6 +12,7 @@ module Synthesizer.State.Filter.Recursive.Integration where  import qualified Synthesizer.State.Signal  as Sig+import qualified Synthesizer.Causal.Process as Causal  -- import qualified Algebra.Field                 as Field -- import qualified Algebra.Ring                  as Ring@@ -41,5 +42,19 @@ {-# INLINE runInit #-} runInit :: Additive.C v => v -> Sig.T v -> Sig.T v runInit = Sig.scanL (+)+++{-# INLINE causal #-}+causal :: Additive.C v => Causal.T v v+causal = Causal.scanL1 (+)++{- |+Integrate with initial condition.+First emitted value is the initial condition.+The signal become one element longer.+-}+{-# INLINE causalInit #-}+causalInit :: Additive.C v => v -> Causal.T v v+causalInit = Causal.scanL (+)  {- other quadrature methods may follow -}
src/Synthesizer/State/Filter/Recursive/MovingAverage.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright   :  (c) Henning Thielemann 2008 License     :  GPL@@ -98,7 +98,7 @@  getNext :: Accumulator v a getNext =-   lift $ StateT $ viewListL+   lift $ StateT $ ListHT.viewL  addAccum :: Additive.C v => v -> Accumulator v () addAccum x = tell ((x+) $!)@@ -128,7 +128,7 @@ bindAccum (Accumulator f) (Accumulator g) =    Accumulator $ \x s0 ->       let (ys,s1) = f x s0-      in  maybe s1 () (viewListL ys)+      in  maybe s1 () (ListHT.viewL ys) -}
src/Synthesizer/State/Interpolation.hs view
@@ -1,63 +1,24 @@-{-# OPTIONS -fno-implicit-prelude #-}-{- |-ToDo:-use AffineSpace instead of Module for the particular interpolation types,-since affine combinations assert reconstruction of constant functions.-They are more natural for interpolation of internal control parameters.-However, how can cubic interpolation expressed by affine combinations-without divisions?--}+{-# LANGUAGE NoImplicitPrelude #-} module Synthesizer.State.Interpolation where -import qualified Synthesizer.State.Signal  as Sig-import qualified Synthesizer.Plain.Control as Ctrl+import qualified Synthesizer.Interpolation as Interpolation+import Synthesizer.Interpolation+   (T, offset, number, func, ) -import qualified Synthesizer.Generic.Interpolation as InterpolationG-import qualified Synthesizer.Generic.Signal as SigG-import qualified Synthesizer.Generic.SampledValue as Sample+import qualified Synthesizer.State.Signal  as Sig -import qualified Algebra.Module    as Module+-- import qualified Algebra.Module    as Module import qualified Algebra.RealField as RealField-import qualified Algebra.Field     as Field+-- import qualified Algebra.Field     as Field import qualified Algebra.Ring      as Ring import qualified Algebra.Additive  as Additive -import Algebra.Module((*>)) import Data.Maybe (fromMaybe) -import Control.Monad.State (StateT(StateT), evalStateT, ap, )-import Control.Applicative (Applicative(pure, (<*>)), (<$>), liftA2, )-import Synthesizer.ApplicativeUtility (liftA4, )-import Synthesizer.Utility (affineComb, )- import PreludeBase import NumericPrelude  ---{- | interpolation as needed for resampling -}-data T t y =-  Cons {-    number :: Int,  -- interpolation requires a total number of 'number'-    offset :: Int,  -- interpolation requires 'offset' values before the current-    func   :: t -> Sig.T y -> y-  }---{-# INLINE toGeneric #-}-toGeneric ::-   (Sample.C y, SigG.C sig) =>-   T t y -> InterpolationG.T sig t y-toGeneric ip =-   InterpolationG.Cons {-      InterpolationG.number = number ip,-      InterpolationG.offset = offset ip,-      InterpolationG.func = \ t x -> func ip t (Sig.fromGenericSignal x)-   }--- {-* Interpolation with various padding methods -}  {-# INLINE zeroPad #-}@@ -127,148 +88,6 @@ --   curry (uncurry (func ip) . skip ip) {- GNUPlot.plotFunc [] (GNUPlot.linearScale 1000 (0,2)) (\t -> single linear (t::Double) [0,4,1::Double])--}----{-* Different kinds of interpolation -}--{-** Hard-wired interpolations -}--data PrefixReader y a =-   PrefixReader Int (StateT (Sig.T y) Maybe a)--instance Functor (PrefixReader y) where-   fmap f (PrefixReader count parser) =-      PrefixReader count (fmap f parser)--instance Applicative (PrefixReader y) where-   pure = PrefixReader 0 . return-   (PrefixReader count0 parser0) <*> (PrefixReader count1 parser1) =-       PrefixReader (count0+count1) (parser0 `ap` parser1)--{-# INLINE getNode #-}-getNode :: PrefixReader y y-getNode = PrefixReader 1 (StateT Sig.viewL)--{-# INLINE fromPrefixReader #-}-fromPrefixReader :: String -> Int -> PrefixReader y (t -> y) -> T t y-fromPrefixReader name off (PrefixReader count parser) =-   Cons count off-      (\t xs ->-          maybe-             (error (name ++ " interpolation: not enough nodes"))-             ($t)-             (evalStateT parser xs))--{-| Consider the signal to be piecewise constant. -}-{-# INLINE constant #-}-constant :: T t y-constant =-   fromPrefixReader "constant" 0 (const <$> getNode)--{-| Consider the signal to be piecewise linear. -}-{-# INLINE linear #-}-linear :: (Module.C t y) => T t y-linear =-   fromPrefixReader "linear" 0-      (liftA2-          (\x0 x1 phase -> affineComb phase (x0,x1))-          getNode getNode)--{-| Consider the signal to be piecewise cubic,-    with smooth connections at the nodes.-    It uses a cubic curve which has node values-    x0 at 0 and x1 at 1 and derivatives-    (x1-xm1)/2 and (x2-x0)/2, respectively.-    You can see how it works-    if you evaluate the expression for t=0 and t=1-    as well as the derivative at these points. -}-{-# INLINE cubic #-}-cubic :: (Field.C t, Module.C t y) => T t y-cubic =-   fromPrefixReader "cubic" 1-      (liftA4-         (\xm1 x0 x1 x2 t ->-            let lipm12 = affineComb t (xm1,x2)-                lip01  = affineComb t (x0, x1)-                three  = 3 `asTypeOf` t-            in  lip01 + (t*(t-1)/2) *>-                           (lipm12 + (x0+x1) - three *> lip01))-         getNode getNode getNode getNode)--{-# INLINE cubicAlt #-}-cubicAlt :: (Field.C t, Module.C t y) => T t y-cubicAlt =-   fromPrefixReader "cubicAlt" 1-      (liftA4-         (\xm1 x0 x1 x2 t ->-          let half = 1/2 `asTypeOf` t-          in  cubicHalf    t  x0 (half *> (x1-xm1)) +-              cubicHalf (1-t) x1 (half *> (x0-x2)))-         getNode getNode getNode getNode)---{- \t -> cubicHalf t x x' has a double zero at 1 and-   at 0 it has value x and steepness x' -}-{-# INLINE cubicHalf #-}-cubicHalf :: (Module.C t y) => t -> y -> y -> y-cubicHalf t x x' =-   (t-1)^2 *> ((1+2*t)*>x + t*>x')----{-** Interpolation based on piecewise defined functions -}--{-# INLINE piecewise #-}-piecewise :: (Module.C t y) =>-   Int -> [t -> t] -> T t y-piecewise center ps =-   Cons (length ps) (center-1)-      (\t -> Sig.linearComb (Sig.fromList (map ($t) (reverse ps))))--{-# INLINE piecewiseConstant #-}-piecewiseConstant :: (Module.C t y) => T t y-piecewiseConstant =-   piecewise 1 [const 1]--{-# INLINE piecewiseLinear #-}-piecewiseLinear :: (Module.C t y) => T t y-piecewiseLinear =-   piecewise 1 [id, (1-)]--{-# INLINE piecewiseCubic #-}-piecewiseCubic :: (Field.C t, Module.C t y) => T t y-piecewiseCubic =-   piecewise 2 $-      Ctrl.cubicFunc (0,(0,0))    (1,(0,1/2)) :-      Ctrl.cubicFunc (0,(0,1/2))  (1,(1,0)) :-      Ctrl.cubicFunc (0,(1,0))    (1,(0,-1/2)) :-      Ctrl.cubicFunc (0,(0,-1/2)) (1,(0,0)) :-      []--{--GNUPlot.plotList [] $ take 100 $ interpolate (Zero 0) piecewiseCubic (-2.3 :: Double) (repeat 0.1) [2,1,2::Double]--}---{-** Interpolation based on arbitrary functions -}--{- | with this wrapper you can use the collection of interpolating functions from Donadio's DSP library -}-{-# INLINE function #-}-function :: (Module.C t y) =>-      (Int,Int)   {- ^ @(left extent, right extent)@, e.g. @(1,1)@ for linear hat -}-   -> (t -> t)-   -> T t y-function (left,right) f =-   let len = left+right-       ps  = Sig.take len $ Sig.iterate pred (pred right)-       -- ps = Sig.reverse $ Sig.take len $ Sig.iterate succ (-left)-   in  Cons len left-          (\t -> Sig.linearComb $-                   Sig.map (\x -> f (t + fromIntegral x)) ps)-{--GNUPlot.plotList [] $ take 300 $ interpolate (Zero 0) (function (1,1) (\x -> exp (-6*x*x))) (-2.3 :: Double) (repeat 0.03) [2,1,2::Double] -}
src/Synthesizer/State/Miscellaneous.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} module Synthesizer.State.Miscellaneous where  import qualified Synthesizer.State.Signal as Signal
src/Synthesizer/State/Noise.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} {- | Noise and random processes. -} module Synthesizer.State.Noise where
src/Synthesizer/State/NoiseCustom.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} {- | Noise and random processes. This uses a fast reimplementation of 'System.Random.randomR'
src/Synthesizer/State/Oscillator.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -O2 -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright   :  (c) Henning Thielemann 2006 License     :  GPL@@ -19,9 +19,11 @@ import qualified Synthesizer.Causal.Process as Causal import qualified Synthesizer.State.Signal as Sig -import qualified Synthesizer.State.Interpolation as Interpolation+import qualified Synthesizer.Generic.Signal as SigG +import qualified Synthesizer.Interpolation as Interpolation + import qualified Algebra.Transcendental        as Trans import qualified Algebra.RealField             as RealField @@ -108,6 +110,42 @@     Interpolation.T a b -> Sig.T b -> Phase.T a -> Sig.T a -> Sig.T b freqModSample ip wave phase =     Causal.apply (Osci.freqModSample ip wave phase)++{-# INLINE shapeFreqModSample #-}+shapeFreqModSample :: (RealField.C c, RealField.C a) =>+    Interpolation.T c (Wave.T a b) -> Sig.T (Wave.T a b) ->+    c -> Phase.T a ->+    Sig.T c -> Sig.T a -> Sig.T b+shapeFreqModSample ip waves shape0 phase =+    Causal.apply2 (Osci.shapeFreqModSample ip waves shape0 phase)++{-# INLINE shapeFreqModFromSampledTone #-}+shapeFreqModFromSampledTone ::+    (RealField.C a, SigG.Transform sig b) =>+    Interpolation.T a b ->+    Interpolation.T a b ->+    a -> sig b ->+    a -> Phase.T a ->+    Sig.T a -> Sig.T a -> Sig.T b+shapeFreqModFromSampledTone+      ipLeap ipStep period sampledTone shape0 phase =+    Causal.apply2+       (Osci.shapeFreqModFromSampledTone+          ipLeap ipStep period sampledTone shape0 phase)++{-# INLINE shapePhaseFreqModFromSampledTone #-}+shapePhaseFreqModFromSampledTone ::+    (RealField.C a, SigG.Transform sig b) =>+    Interpolation.T a b ->+    Interpolation.T a b ->+    a -> sig b ->+    a -> Phase.T a ->+    Sig.T a -> Sig.T a -> Sig.T a -> Sig.T b+shapePhaseFreqModFromSampledTone+      ipLeap ipStep period sampledTone shape0 phase =+    Causal.apply3+       (Osci.shapePhaseFreqModFromSampledTone+          ipLeap ipStep period sampledTone shape0 phase)
src/Synthesizer/State/Signal.hs view
@@ -1,10 +1,14 @@-{-# OPTIONS_GHC -O -fglasgow-exts -fno-implicit-prelude #-}-{- glasgow-exts are for higher rank types -}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ExistentialQuantification #-}+{- |+ToDo:+Better name for the module is certainly+  Synthesizer.Generator.Signal+-} module Synthesizer.State.Signal where -import qualified Synthesizer.Generic.Signal as SigG-import qualified Synthesizer.Generic.SampledValue as Sample- -- import qualified Synthesizer.Plain.Signal   as Sig import qualified Synthesizer.Plain.Modifier as Modifier import qualified Data.List as List@@ -17,19 +21,23 @@  import qualified Synthesizer.Format as Format -import Control.Monad.State-          (State, runState, StateT(StateT), runStateT, liftM2, )+import Control.Monad.Trans.State+          (runState, StateT(StateT), runStateT, ) import Control.Monad (Monad, mplus, msum,            (>>), (>>=), fail, return, (=<<),+           liftM2,            Functor, fmap, ) +import Data.Monoid (Monoid, mappend, mempty, )+ import qualified Synthesizer.Storable.Signal as SigSt+import qualified Data.StorableVector.Lazy.Pattern as SVL import Foreign.Storable (Storable) -import Synthesizer.Utility-   (viewListL, mapFst, mapSnd, mapPair, fst3, snd3, thd3, nest, )--import NumericPrelude.Condition (toMaybe)+import qualified Data.List.HT as ListHT+import Data.Tuple.HT (mapFst, mapSnd, mapPair, fst3, snd3, thd3, )+import Data.Function.HT (nest, )+import Data.Maybe.HT (toMaybe, ) import NumericPrelude (fromInteger, )  import Text.Show (Show(showsPrec), showParen, showString, )@@ -61,45 +69,7 @@    fmap = map  -instance SigG.C T where-   empty = empty-   null = null-   cons = cons-   fromList = fromList-   toList = toList-   repeat = repeat-   cycle = cycle-   replicate = replicate-   iterate = iterate-   iterateAssoc op x = iterate (op x) x -- should be optimized-   unfoldR = generate-   map = map-   mix = mix-   zipWith = zipWith-   scanL = scanL-   viewL = viewL-   viewR = viewR-   foldL = foldL-   length = length-   take = take-   drop = drop-   splitAt = splitAt-   dropMarginRem = dropMarginRem-   takeWhile = takeWhile-   dropWhile = dropWhile-   span = span-   append = append-   concat = concat-   reverse = reverse-{--   mapAccumL = mapAccumL-   mapAccumR = mapAccumR--}-   crochetL = crochetL --- {-# INLINE generate #-} generate :: (acc -> Maybe (y, acc)) -> acc -> T y generate f = Cons (StateT f)@@ -114,7 +84,7 @@  {-# INLINE fromList #-} fromList :: [y] -> T y-fromList = generate viewListL+fromList = generate ListHT.viewL  {-# INLINE toList #-} toList :: T y -> [y]@@ -122,21 +92,6 @@    List.unfoldr (runStateT f) x0  -{-# INLINE fromGenericSignal #-}-fromGenericSignal ::-   (Sample.C a, SigG.C sig) =>-   sig a -> T a-fromGenericSignal =-   generate SigG.viewL--{-# INLINE toGenericSignal #-}-toGenericSignal ::-   (Sample.C a, SigG.C sig) =>-   T a -> sig a-toGenericSignal (Cons f a) =-   SigG.unfoldR (runStateT f) a-- {-# INLINE fromStorableSignal #-} fromStorableSignal ::    (Storable a) =>@@ -151,15 +106,23 @@ toStorableSignal size (Cons f a) =    SigSt.unfoldr size (runStateT f) a +-- needed in synthesizer-alsa+{-# INLINE toStorableSignalVary #-}+toStorableSignalVary ::+   (Storable a) =>+   SVL.LazySize -> T a -> SigSt.T a+toStorableSignalVary size (Cons f a) =+   fst $ SVL.unfoldrN size (runStateT f) a  + {-# INLINE iterate #-} iterate :: (a -> a) -> a -> T a iterate f = generateInfinite (\x -> (x, f x)) -{-# INLINE iterateAssoc #-}-iterateAssoc :: (a -> a -> a) -> a -> T a-iterateAssoc op x = iterate (op x) x -- should be optimized+{-# INLINE iterateAssociative #-}+iterateAssociative :: (a -> a -> a) -> a -> T a+iterateAssociative op x = iterate (op x) x -- should be optimized  {-# INLINE repeat #-} repeat :: a -> T a@@ -197,6 +160,11 @@ map f = crochetL (\x _ -> Just (f x, ())) ()  +{- |+This function will recompute the input lists+and is thus probably not what you want.+If you want to avoid recomputation please consider Causal.Process.+-} {-# INLINE unzip #-} unzip :: T (a,b) -> (T a, T b) unzip x = (map fst x, map snd x)@@ -244,6 +212,16 @@              Just (h y0 x0, a1))       a +{-# INLINE zipWithStorable #-}+zipWithStorable :: (Storable b, Storable c) =>+   (a -> b -> c) -> (T a -> SigSt.T b -> SigSt.T c)+zipWithStorable h (Cons f a) =+   SigSt.crochetL+      (\x0 a0 ->+          do (y0,a1) <- runStateT f a0+             Just (h y0 x0, a1))+      a+ {-# INLINE zipWith3 #-} zipWith3 :: (a -> b -> c -> d) -> (T a -> T b -> T c -> T d) zipWith3 f s0 s1 =@@ -478,18 +456,7 @@  {-# INLINE mix #-} mix :: Additive.C a => T a -> T a -> T a-mix =-   curry (unfoldR mixStep)---mixStep :: (Additive.C a) =>-   (T a, T a) -> Maybe (a, (T a, T a))-mixStep (xt,yt) =-   case (viewL xt, viewL yt) of-      (Just (x,xs), Just (y,ys)) -> Just (x Additive.+ y, (xs,ys))-      (Nothing,     Just (y,ys)) -> Just (y,   (xt,ys))-      (Just (x,xs), Nothing)     -> Just (x,   (xs,yt))-      (Nothing,     Nothing)     -> Nothing+mix = zipWithAppend (Additive.+)   {-# INLINE sub #-}@@ -545,7 +512,7 @@    generate       (msum .        List.map-          (\ x -> viewListL x >>=+          (\ x -> ListHT.viewL x >>=            \(y,ys) -> viewL y >>=            \(z,zs) -> Just (z,zs:ys)) .        List.init . List.tails)@@ -592,7 +559,7 @@ maximum :: (Ord a) => T a -> a maximum =    switchL-      (error "FusionList.maximum: empty list")+      (error "StateSignal.maximum: empty list")       (foldL' max)  {-@@ -605,7 +572,7 @@ init :: T y -> T y init =    switchL-      (error "FusionList.init: empty list")+      (error "StateSignal.init: empty list")       (crochetL (\x acc -> Just (acc,x)))  {-# INLINE sliceVert #-}@@ -673,6 +640,41 @@          (_,ys) <- viewL ys0          return (f x ys0, (xs,ys))) +{-+This can hardly be implemented in an efficient way.+But this means, we cannot implement the Generic.Transform class.++zipWithRest ::+   (y0 -> y0 -> y1) ->+   T y0 -> T y0 ->+   (T y1, (Bool, T y0))+zipWithRest f =+   curry $ generate (\(xs0,ys0) ->+      do (x,xs) <- viewL xs0+         (y,ys) <- viewL ys0+         return (f x y, (xs,ys)))+-}+++{-# INLINE zipWithAppend #-}+zipWithAppend ::+   (y -> y -> y) ->+   T y -> T y -> T y+zipWithAppend f =+   curry (unfoldR (zipStep f))++{-# INLINE zipStep #-}+zipStep ::+   (a -> a -> a) -> (T a, T a) -> Maybe (a, (T a, T a))+zipStep f (xt,yt) =+   case (viewL xt, viewL yt) of+      (Just (x,xs), Just (y,ys)) -> Just (f x y, (xs,ys))+      (Nothing,     Just (y,ys)) -> Just (y,     (xt,ys))+      (Just (x,xs), Nothing)     -> Just (x,     (xs,yt))+      (Nothing,     Nothing)     -> Nothing+++ delayLoop ::       (T y -> T y)             -- ^ processor that shall be run in a feedback loop@@ -710,3 +712,17 @@ {-# INLINE mapM_ #-} mapM_ :: Monad m => (a -> m ()) -> T a -> m () mapM_ f = sequence_ . map f+++{- |+Counterpart to 'Data.Monoid.mconcat'.+-}+monoidConcat :: Monoid m => T m -> m+monoidConcat = foldR mappend mempty++monoidConcatMap :: Monoid m => (a -> m) -> T a -> m+monoidConcatMap f = monoidConcat . map f++instance Monoid (T y) where+   mempty = empty+   mappend = append
+ src/Synthesizer/State/ToneModulation.hs view
@@ -0,0 +1,233 @@+module Synthesizer.State.ToneModulation where++import qualified Synthesizer.Basic.ToneModulation as ToneMod++import qualified Synthesizer.Causal.Process as Causal+import qualified Synthesizer.Interpolation as Interpolation++import qualified Synthesizer.Generic.Signal as SigG++import qualified Synthesizer.State.Signal as SigS++import qualified Synthesizer.Basic.Phase as Phase++-- 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.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import Data.Ord.HT (limit, )++import NumericPrelude+-- import qualified Prelude as P+import PreludeBase+import Prelude ()+++type Cell sig y = SigS.T (sig y)++-- cells are organised in a transposed style, when compared with Plain.ToneModulation+interpolateCell ::+   (SigG.Read sig y) =>+   Interpolation.T a y ->+   Interpolation.T b y ->+   (a, b) ->+   Cell sig y -> y+interpolateCell ipLeap ipStep (qLeap,qStep) =+   Interpolation.func ipLeap qLeap .+   SigS.map (Interpolation.func ipStep qStep . SigG.toState)++++data Prototype sig a v =+   Prototype {+      protoMarginLeap,+      protoMarginStep  :: Interpolation.Margin,+      protoIpOffset    :: Int,+      protoPeriod      :: a,+      protoPeriodInt   :: Int,+      protoShapeLimits :: (a,a),+      protoSignal      :: sig v+   }+++makePrototype ::+   (RealField.C a, SigG.Read sig v) =>+   Interpolation.Margin ->+   Interpolation.Margin ->+   a -> sig v -> Prototype sig a v+makePrototype marginLeap marginStep period tone =+   let periodInt = round period+       ipOffset =+          ToneMod.interpolationOffset marginLeap marginStep periodInt+       len = SigG.length tone+       (lower,upper) =+          ToneMod.shapeLimits marginLeap marginStep periodInt len+       limits =+          if lower > upper+            then error "min>max"+            else+              (fromIntegral lower, fromIntegral upper)++   in  Prototype {+          protoMarginLeap  = marginLeap,+          protoMarginStep  = marginStep,+          protoIpOffset    = ipOffset,+          protoPeriod      = period,+          protoPeriodInt   = periodInt,+          protoShapeLimits = limits,+          protoSignal      = tone+       }++sampledToneCell ::+   (RealField.C a, SigG.Transform sig v) =>+   Prototype sig a v -> a -> Phase.T a -> ((a,a), Cell sig v)+sampledToneCell p shape phase =+   let (n, q) =+          ToneMod.flattenShapePhase (protoPeriodInt p) (protoPeriod p)+             (limit (protoShapeLimits p) shape, phase)+   in  (q,+        SigS.iterate (SigG.drop (protoPeriodInt p)) $+        SigG.drop (n - protoIpOffset p) $+        protoSignal p)+++-- * lazy oscillator++{-# DEPRECATED oscillatorCells "This function recomputes the shape and phase signals. Better use Causal.ToneModulation.oscillatorCells" #-}+{- |+This function should not be used,+since it requires recomputation of @shapes@ and @freqs@ lists.+-}+oscillatorCells :: (RealField.C t, SigG.Transform sig y) =>+    Interpolation.Margin ->+    Interpolation.Margin ->+    t -> sig y -> (t, SigS.T t) -> (Phase.T t, SigS.T t) ->+    SigS.T ((t,t), Cell sig y)+oscillatorCells+       marginLeap marginStep period sampledTone shapes freqs =+    let periodInt = round period+        margin =+           ToneMod.interpolationNumber marginLeap marginStep periodInt+        ipOffset =+           ToneMod.interpolationOffset marginLeap marginStep periodInt+        (skips,coords) =+           -- unzip requires recomputation+           SigS.unzip $+           oscillatorCoords periodInt period+              (limitRelativeShapes marginLeap marginStep periodInt shapes)+              freqs+    in  SigS.zipWith+           {-+           n will be zero within the data body.+           It's only needed for extrapolation at the end.+           Is it really needed?+           -}+           (\(k,q) (_n,ptr) ->+               (q, makeCell periodInt $+                      SigG.drop (checkNonNeg $ periodInt+k) ptr))+           coords $+        SigS.switchL (error "list of pointers must not be empty") (flip const) $+        SigS.scanL+           (\ (n,ptr) d -> SigG.dropMarginRem margin (n+d) ptr)+           (0, sampledTone)+           (SigS.switchL skips+               (\s -> SigS.cons (s - (ipOffset + periodInt)))+               skips)+{-+*Synthesizer.Generic.ToneModulation> let shapes = [0.3,0.4,0.2::Double]; phases = [0.43,0.72,0.91::Double]+*Synthesizer.Generic.ToneModulation> let marginLeap = Interpolation.Margin 1 3; marginStep = Interpolation.Margin 2 2+*Synthesizer.Generic.ToneModulation> List.map (Data.Tuple.HT.mapSnd List.transpose) $ ToneMod.oscillatorCells marginLeap marginStep 9 ['a'..'z'] (2.3,shapes) (Phase.fromRepresentative 0.6, phases)+[((0.28888888888888875,0.40000000000000124),["ghijklmnopqrstuvwxyz","pqrstuvwxyz","yz"]),((0.8588888888888888,0.27000000000000046),["bcdefghijklmnopqrstuvwxyz","klmnopqrstuvwxyz","tuvwxyz"]),((0.13888888888888884,0.7500000000000004),["hijklmnopqrstuvwxyz","qrstuvwxyz","z"]),((0.2288888888888887,0.9400000000000017),["ghijklmnopqrstuvwxyz","pqrstuvwxyz","yz"])]+*Synthesizer.Generic.ToneModulation> oscillatorCells marginLeap marginStep 9 ['a'..'z'] (2.3, SigS.fromList shapes) (Phase.fromRepresentative 0.6, SigS.fromList phases)+StateSignal.fromList [((0.4,0.3999999999999999),StateSignal.fromList ["fghijklmnopqrstuvwxyz","opqrstuvwxyz","xyz"]),((0.97,0.2699999999999996),StateSignal.fromList ["abcdefghijklmnopqrstuvwxyz","jklmnopqrstuvwxyz","stuvwxyz"]),((0.25,0.75),StateSignal.fromList ["ghijklmnopqrstuvwxyz","pqrstuvwxyz","yz"])]++They do only match when input list is large enough+-}++checkNonNeg :: (Ord a, Additive.C a, Show a) => a -> a+checkNonNeg x =+   if x<zero+     then error ("unexpected negative number: " ++ show x)+     else x++makeCell :: (SigG.Transform sig y) => Int -> sig y -> Cell sig y+makeCell periodInt =+   SigS.takeWhile (not . SigG.null) .+   SigS.iterate (SigG.drop periodInt)+++oscillatorCoords :: (RealField.C t) =>+    Int -> t ->+    (t, SigS.T t) -> (Phase.T t, SigS.T t) ->+    SigS.T (ToneMod.Coords t)+oscillatorCoords periodInt period+       (shape0, shapes) (phase, freqs) =+    let shapeOffsets =+           SigS.scanL+              (\(_,s) c -> splitFraction (s+c))+              (splitFraction shape0) shapes+        phases =+           -- FIXME: could be made without the dangerous irrefutable pattern+           let Just (s,ss) =+                  SigS.viewL $+                  SigS.map (\(n,_) -> fromIntegral n / period) $+                  shapeOffsets+           in  freqsToPhases+                  (Phase.decrement s phase)  -- phase - s+               `Causal.apply`+                  (SigS.zipWith (-) freqs ss)+    in  SigS.zipWith+           (\(d,s) p -> (d, ToneMod.flattenShapePhase periodInt period (s,p)))+           shapeOffsets+           phases++limitRelativeShapes :: (RealField.C t) =>+    Interpolation.Margin ->+    Interpolation.Margin ->+    Int -> (t, SigS.T t) -> (t, SigS.T t)+limitRelativeShapes marginLeap marginStep periodInt =+    limitMinRelativeValues $ fromIntegral $+    ToneMod.interpolationOffset marginLeap marginStep periodInt + periodInt++limitMinRelativeValues :: (Additive.C t, Ord t) =>+   t -> (t, SigS.T t) -> (t, SigS.T t)+limitMinRelativeValues xMin (x0, xs) =+   let x1 = xMin-x0+   in  if x1<=zero+         then (x0, xs)+         else (xMin,+               SigS.crochetL+                  (\x lim ->+                     let d = x-lim+                     in  Just $ if d>=zero+                           then (d,zero) else (zero, negate d)) x1 xs)+{-+Test.QuickCheck.test (\x (y,zi) -> let z=List.map abs zi in  Data.Tuple.HT.mapSnd SigS.toList (limitMinRelativeValues x (y, SigS.fromList z)) == ToneMod.limitMinRelativeValues (x::Int) y z)+-}++-- * handling of phases as needed for oscillators++{-# INLINE freqsToPhases #-}+{- |+Convert a list of phase steps into a list of momentum phases.+phase is a number in the interval [0,1).+freq contains the phase steps.+The last element is omitted.+-}+freqsToPhases :: RealField.C a =>+   Phase.T a -> Causal.T a (Phase.T a)+freqsToPhases =+   Causal.scanL (flip Phase.increment)++{- |+Like 'freqsToPhases' but the first element is omitted.+-}+{-# INLINE freqsToPhasesSync #-}+freqsToPhasesSync :: RealField.C a =>+   Phase.T a -> Causal.T a (Phase.T a)+freqsToPhasesSync =+   Causal.crochetL+      (\f p0 -> let p1 = Phase.increment f p0 in Just (p1,p1))
src/Synthesizer/Storable/Cut.hs view
@@ -2,10 +2,18 @@  import qualified Synthesizer.Storable.Signal as Sig -import qualified Data.EventList.Relative.TimeBody as EventList-import Control.Monad.State (runState, modify, gets, put, )-import Synthesizer.Utility (mapSnd, )+import qualified Data.StorableVector.Lazy      as SVL+import qualified Data.StorableVector.ST.Strict as SVST +import Control.Monad.ST.Strict (ST, runST, )++import qualified Data.EventList.Relative.TimeBody  as EventList+import qualified Data.EventList.Relative.TimeMixed as EventListTM+import qualified Data.EventList.Absolute.TimeBody  as AbsEventList+import Control.Monad.Trans.State (runState, modify, gets, put, )+-- import Control.Monad (mapM, )+import Data.Tuple.HT (mapSnd, )+ -- import qualified Algebra.Real     as Real import qualified Algebra.Additive as Additive import qualified Number.NonNegative as NonNeg@@ -16,6 +24,9 @@ import NumericPrelude  +{- |+ChunkSize is only required for zero padding.+-} {-# INLINE arrange #-} arrange :: (Storable v, Additive.C v) =>        Sig.ChunkSize@@ -72,3 +83,55 @@    in  uncurry Sig.append $        mapSnd (flip Sig.mix py) $        Sig.splitAtPad size del px+++{- |+The result is a Lazy StorableVector with chunks of the given size.+-}+{-# INLINE arrangeEquidist #-}+arrangeEquidist :: (Storable v, Additive.C v) =>+       Sig.ChunkSize+    -> EventList.T NonNeg.Int (Sig.T v)+            {-^ A list of pairs: (relative start time, signal part),+                The start time is relative to the start time+                of the previous event. -}+    -> Sig.T v+            {-^ The mixed signal. -}+arrangeEquidist (SVL.ChunkSize sz) =+   let sznn = NonNeg.fromNumberMsg "arrangeEquidist" sz+       go acc evs =+          let (now,future) = EventListTM.splitAtTime sznn evs+              xs =+                 AbsEventList.toPairList $+                 EventList.toAbsoluteEventList 0 $+                 EventListTM.switchTimeR (const) now+              (chunk,newAcc) =+                 runST+                    (do v <- SVST.new sz zero+                        newAcc0 <- mapM (addToBuffer v 0) acc+--                        newAcc1 <- AbsEventList.mapM (addToBuffer v) xs+                        newAcc1 <-+                           mapM (\(i,s) -> addToBuffer v (NonNeg.toNumber i) s) xs+                        vf <- SVST.freeze v+                        return+                           (vf, filter (not . Sig.null) (newAcc0++newAcc1)))+          in  chunk : go newAcc future+   in  Sig.fromChunks . go []++++addToBuffer :: (Storable a, Additive.C a) =>+   SVST.Vector s a -> Int -> Sig.T a -> ST s (Sig.T a)+addToBuffer v start =+   let n = SVST.length v+       {-# INLINE go #-}+       go i =+          if i>=n+            then return+            else+              Sig.switchL+                 (return Sig.empty)+                 (\x xs ->+                     SVST.modify v i (x Additive.+) >>+                     go (succ i) xs)+   in  go start
− src/Synthesizer/Storable/Filter/Recursive/Comb.hs 
@@ -1,90 +0,0 @@-{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}-{- |-Copyright   :  (c) Henning Thielemann 2008-License     :  GPL--Maintainer  :  synthesizer@henning-thielemann.de-Stability   :  provisional-Portability :  requires multi-parameter type classes--Comb filters, useful for emphasis of tones with harmonics-and for repeated echos.--We cannot generalize this to "Synthesizer.Generic.Signal"-since we need control over the chunk size.--}-module Synthesizer.Storable.Filter.Recursive.Comb where--import qualified Synthesizer.Storable.Signal as Sig-import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1--import qualified Synthesizer.Generic.Signal as SigG-import qualified Synthesizer.Generic.SampledValue as Sample---- import qualified Synthesizer.Storable.Filter.Delay as Delay--import Foreign.Storable (Storable)--import qualified Algebra.Module                as Module--- import qualified Algebra.Field                 as Field-import qualified Algebra.Ring                  as Ring-import qualified Algebra.Additive              as Additive--import Algebra.Module((*>))--import qualified Prelude as P-import PreludeBase-import NumericPrelude---{- |-The most simple version of the Karplus-Strong algorithm-which is suitable to simulate a plucked string.-It is similar to the 'runProc' function.--}-{-# INLINE karplusStrong #-}-karplusStrong ::-   (Ring.C a, Module.C a v, Sample.C v) =>-   Filt1.Parameter a -> Sig.T v -> Sig.T v-karplusStrong c wave =-   Sig.delayLoop (SigG.modifyStatic Filt1.lowpassModifier c) wave---{- |-Infinitely many equi-delayed exponentially decaying echos.-The echos are clipped to the input length.-We think it is easier (and simpler to do efficiently)-to pad the input with zeros or whatever-instead of cutting the result according to the input length.--}-{-# INLINE run #-}-run :: (Module.C a v, Storable v) =>-   Int -> a -> Sig.T v -> Sig.T v-run time gain =-   Sig.delayLoopOverlap time (amplify gain)--{- |-Echos of different delays.-Chunk size must be smaller than all of the delay times.--}-{-# INLINE runMulti #-}-runMulti :: (Ring.C a, Module.C a v, Storable v) =>-   [Int] -> a -> Sig.T v -> Sig.T v-runMulti times gain x =-    let y = foldl-               (Sig.zipWith (+)) x-               (map (flip (Sig.delay Sig.defaultChunkSize zero) (amplify gain y)) times)---               (map (flip Delay.staticPos (gain *> y)) times)-    in  y--{- | Echos can be piped through an arbitrary signal processor. -}-{-# INLINE runProc #-}-runProc :: (Additive.C v, Storable v) =>-   Int -> (Sig.T v -> Sig.T v) -> Sig.T v -> Sig.T v-runProc = Sig.delayLoopOverlap---{-# INLINE amplify #-}-amplify :: (Storable v, Module.C a v) =>-   a -> Sig.T v -> Sig.T v-amplify gain = Sig.map (gain *>)
+ src/Synthesizer/Storable/Instance.hs view
@@ -0,0 +1,56 @@+{-+This should be in the standard library.+-}+module Synthesizer.Storable.Instance where++import Foreign.Storable (Storable (..), )+import qualified Foreign.Storable.Record as Store+import Control.Applicative (liftA2, liftA3, )++import Data.Tuple.HT (fst3, snd3, thd3, )+++instance (Storable a, Storable b) => Storable (a,b) where+   sizeOf    = Store.sizeOf storePair+   alignment = Store.alignment storePair+   peek      = Store.peek storePair+   poke      = Store.poke storePair++storePair ::+   (Storable a, Storable b) =>+   Store.Dictionary (a,b)+storePair =+   Store.run $+   liftA2 (,)+      (Store.element fst)+      (Store.element snd)+++instance (Storable a, Storable b, Storable c) => Storable (a,b,c) where+   sizeOf    = Store.sizeOf storeTriple+   alignment = Store.alignment storeTriple+   peek      = Store.peek storeTriple+   poke      = Store.poke storeTriple++storeTriple ::+   (Storable a, Storable b, Storable c) =>+   Store.Dictionary (a,b,c)+storeTriple =+   Store.run $+   liftA3 (,,)+      (Store.element fst3)+      (Store.element snd3)+      (Store.element thd3)+++{-+{- Why is this allowed? -}+test :: Char+test = const 'a' undefined++{- Why is type defaulting applied here? The type of 'c' should be fixed. -}+test1 :: (Integral a, RealField.C a) => a+test1 =+   let c = undefined+   in  asTypeOf (round c) c+-}
src/Synthesizer/Storable/Oscillator.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -O2 -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} {- | Copyright   :  (c) Henning Thielemann 2006 License     :  GPL
src/Synthesizer/Storable/Signal.hs view
@@ -1,4 +1,4 @@-{- OPTIONS_GHC -O2 -fglasgow-exts -}+{- OPTIONS_GHC -fglasgow-exts -} {- glasgow-exts are for the rules -} {- | Chunky signal stream build on StorableVector.@@ -18,7 +18,6 @@       Vector.iterate,       Vector.zipWith,       -- for State.Signal-      Vector.span,       Vector.append,       Vector.concat,       Vector.span,@@ -28,10 +27,13 @@       Vector.switchL,       Vector.unfoldr,       Vector.reverse,+      Vector.crochetL,       -- for Dimensional.File       Vector.writeFile,       -- for Storable.Cut       splitAtPad,+      Vector.null,+      Vector.fromChunks,       -- for Storable.Filter.Comb       delay,       delayLoop,@@ -47,11 +49,19 @@       fromList,       appendFromFusionList,       appendFusionList,+      -- for Generic.Signal+      zipWithRest,+      zipWithAppend,+      -- for Storable.ALSA.MIDI+      Vector.switchR,++      -- just for fun+      fromFusionList,+      genericLength,    ) where  -- import qualified Sound.Signal as Signal -import qualified Synthesizer.Generic.Signal as SigG import qualified Synthesizer.FusionList.Signal as FList  import qualified Data.List as List@@ -59,21 +69,15 @@ import qualified Data.StorableVector as V import Data.StorableVector.Lazy (ChunkSize(..)) -import Data.Maybe (Maybe(Just,Nothing), maybe, fromMaybe)--- import qualified Data.Char as Char--- import Data.Int (Int8)+-- import Data.Maybe (Maybe(Just,Nothing), maybe, fromMaybe) -import Data.StorableVector(Vector)+-- import Data.StorableVector(Vector) import Foreign.Storable (Storable)-import Foreign.Ptr (minusPtr)-import Foreign.ForeignPtr (withForeignPtr)-import Foreign.Marshal (advancePtr)-import StorableInstance ()  -- import qualified Synthesizer.Format as Format  -- import Control.Arrow ((***))-import Control.Monad (liftM, liftM2, {- guard, -} )+-- import Control.Monad (liftM, liftM2, {- guard, -} )  import qualified Algebra.Ring      as Ring import qualified Algebra.Additive  as Additive@@ -82,27 +86,31 @@ import qualified Number.NonNegativeChunky as Chunky import qualified Number.NonNegative       as NonNeg -import NumericPrelude.Condition (toMaybe)-import NumericPrelude.List (sliceVert, dropWhileRev, )--import Synthesizer.Utility (viewListL, viewListR, nest, mapFst, mapSnd, mapPair)+import qualified Data.List.HT as ListHT+import Data.Maybe.HT (toMaybe, )+import Data.Tuple.HT (mapFst, mapSnd, mapPair, forcePair, )  -- import qualified Algebra.Additive as Additive  -import System.IO (openBinaryFile, hClose, hPutBuf, IOMode(WriteMode), Handle)-import Control.Exception (bracket)+-- import System.IO (openBinaryFile, hClose, hPutBuf, IOMode(WriteMode), Handle)   import NumericPrelude-   (sum, (+), (-), divMod, fromIntegral, fromInteger, toInteger, isZero, zero, )+import PreludeBase+import Prelude () + {-+import NumericPrelude+   (sum, (+), (-), divMod, fromIntegral, fromInteger, toInteger, isZero, zero, )+ import Prelude hiding    (length, (++), iterate, foldl, map, repeat, replicate, null,     zip, zipWith, zipWith3, drop, take, splitAt, takeWhile, reverse) -} +{- import qualified Prelude as P import Prelude    (IO, ($), (.), fst, snd, id,@@ -113,6 +121,7 @@     Ord, (<), (>), (<=), {- (>=), (==), -} min, max,     mapM_, fmap, (=<<), return,     Enum, succ, pred, )+-}   -- this form is needed for Storable signal embed in amplitude signal@@ -131,75 +140,7 @@ defaultChunkSize :: ChunkSize defaultChunkSize = ChunkSize 1024 -instance SigG.C Vector.Vector where-   {-# INLINE empty #-}-   empty = Vector.empty-   {-# INLINE null #-}-   null = Vector.null-   {-# INLINE cons #-}-   cons = Vector.cons-   {-# INLINE fromList #-}-   fromList = Vector.pack defaultChunkSize-   {-# INLINE toList #-}-   toList = Vector.unpack-   {-# INLINE repeat #-}-   repeat = Vector.repeat defaultChunkSize-   {-# INLINE cycle #-}-   cycle = Vector.cycle-   {-# INLINE replicate #-}-   replicate = Vector.replicate defaultChunkSize-   {-# INLINE iterate #-}-   iterate = Vector.iterate defaultChunkSize-   {-# INLINE iterateAssoc #-}-   iterateAssoc op x = Vector.iterate defaultChunkSize (op x) x -- should be optimized-   {-# INLINE unfoldR #-}-   unfoldR = Vector.unfoldr defaultChunkSize-   {-# INLINE map #-}-   map = Vector.map-   {-# INLINE mix #-}-   mix = mix-   {-# INLINE zipWith #-}-   zipWith = Vector.zipWith-   {-# INLINE scanL #-}-   scanL = Vector.scanl-   {-# INLINE viewL #-}-   viewL = Vector.viewL-   {-# INLINE viewR #-}-   viewR = Vector.viewR-   {-# INLINE foldL #-}-   foldL = Vector.foldl-   {-# INLINE length #-}-   length = Vector.length-   {-# INLINE take #-}-   take = Vector.take-   {-# INLINE drop #-}-   drop = Vector.drop-   {-# INLINE splitAt #-}-   splitAt = Vector.splitAt-   {-# INLINE dropMarginRem #-}-   dropMarginRem = Vector.dropMarginRem  -- can occur in an inner loop in Interpolation-   {-# INLINE takeWhile #-}-   takeWhile = Vector.takeWhile-   {-# INLINE dropWhile #-}-   dropWhile = Vector.dropWhile-   {-# INLINE span #-}-   span = Vector.span-   {-# INLINE append #-}-   append = Vector.append-   {-# INLINE concat #-}-   concat = Vector.concat-   {-# INLINE reverse #-}-   reverse = Vector.reverse-{--   {-# INLINE mapAccumL #-}-   mapAccumL = Vector.mapAccumL-   {-# INLINE mapAccumR #-}-   mapAccumR = Vector.mapAccumR--}-   {-# INLINE crochetL #-}-   crochetL = Vector.crochetL - {- {- * Helper functions for StorableVector -} @@ -234,15 +175,15 @@ reduceLVector :: Storable x =>    (x -> acc -> Maybe acc) -> acc -> Vector x -> (acc, Bool) reduceLVector f acc0 x =-   let recurse i acc =+   let recourse i acc =           if i < Vector.length x             then (acc, True)             else                maybe                   (acc, False)-                  (recurse (succ i))+                  (recourse (succ i))                   (f (Vector.index x i) acc)-   in  recurse 0 acc0+   in  recourse 0 acc0   @@ -296,7 +237,7 @@    -> T y crochetL f acc0 =    Cons . List.unfoldr (\(xt,acc) ->-       do (x,xs) <- viewListL xt+       do (x,xs) <- ListHT.viewL xt           acc' <- acc           return $ mapSnd ((,) xs) $ crochetLVector f acc' x) .    flip (,) (Just acc0) .@@ -321,14 +262,14 @@ viewL :: Storable a => T a -> Maybe (a, T a) viewL (Cons xs0) =    -- dropWhile would be unnecessary if we require that all chunks are non-empty-   do (x,xs) <- viewListL (List.dropWhile Vector.null xs0)+   do (x,xs) <- ListHT.viewL (List.dropWhile Vector.null xs0)       (y,ys) <- viewLVector x       return (y, append (fromChunk ys) (Cons xs))  viewR :: Storable a => T a -> Maybe (T a, a) viewR (Cons xs0) =    -- dropWhile would be unnecessary if we require that all chunks are non-empty-   do (xs,x) <- viewListR (dropWhileRev Vector.null xs0)+   do (xs,x) <- ListHT.viewR (dropWhileRev Vector.null xs0)       (ys,y) <- Vector.viewR x       return (append (Cons xs) (fromChunk ys), y) @@ -340,7 +281,7 @@    -> T y crochetListL size f =    curry (unfoldr size (\(acc,xt) ->-      do (x,xs) <- viewListL xt+      do (x,xs) <- ListHT.viewL xt          (y,acc') <- f x acc          return (y, (acc',xs)))) -}@@ -358,7 +299,7 @@    crochetListL size (\x _ -> Just (x, ())) ()  fromListUnfoldr :: (Storable a) => ChunkSize -> [a] -> T a-fromListUnfoldr size = unfoldr size viewListL+fromListUnfoldr size = unfoldr size ListHT.viewL  fromListPack :: (Storable a) => ChunkSize -> [a] -> T a fromListPack (ChunkSize size) =@@ -431,15 +372,15 @@ reduceL :: Storable x =>    (x -> acc -> Maybe acc) -> acc -> T x -> acc reduceL f acc0 =-   let recurse acc xt =+   let recourse acc xt =           case xt of              [] -> acc              (x:xs) ->                  let (acc',continue) = reduceLVector f acc x                  in  if continue-                       then recurse acc' xs+                       then recourse acc' xs                        else acc'-   in  recurse acc0 . decons+   in  recourse acc0 . decons   @@ -513,14 +454,14 @@ {-# NOINLINE [0] splitAt #-} splitAt :: (Storable a) => Int -> T a -> (T a, T a) splitAt n0 =-   let recurse _ [] = ([], [])-       recurse 0 xs = ([], xs)-       recurse n (x:xs) =+   let recourse _ [] = ([], [])+       recourse 0 xs = ([], xs)+       recourse n (x:xs) =           let m = Vector.length x           in  if m<=n-                then mapFst (x:) $ recurse (n-m) xs+                then mapFst (x:) $ recourse (n-m) xs                 else mapPair ((:[]), (:xs)) $ Vector.splitAt n x-   in  mapPair (Cons, Cons) . recurse n0 . decons+   in  mapPair (Cons, Cons) . recourse n0 . decons   dropMarginRem :: (Storable a) => Int -> Int -> T a -> (Int, T a)@@ -562,13 +503,13 @@ {-# NOINLINE [0] span #-} span :: (Storable a) => (a -> Bool) -> T a -> (T a, T a) span p =-   let recurse [] = ([],[])-       recurse (x:xs) =+   let recourse [] = ([],[])+       recourse (x:xs) =           let (y,z) = Vector.span p x           in  if Vector.null z-                then mapFst (x:) (recurse xs)+                then mapFst (x:) (recourse xs)                 else (decons $ fromChunk y, (z:xs))-   in  mapPair (Cons, Cons) . recurse . decons+   in  mapPair (Cons, Cons) . recourse . decons {- span _ (Cons []) = (empty, empty) span p (Cons (x:xs)) =@@ -588,14 +529,14 @@ {-# NOINLINE [0] pad #-} pad :: (Storable a) => ChunkSize -> a -> Int -> T a -> T a pad size y n0 =-   let recurse n xt =+   let recourse n xt =           if n<=0             then xt             else               case xt of                  [] -> decons $ replicate size n y-                 x:xs -> x : recurse (n - Vector.length x) xs-   in  Cons . recurse n0 . decons+                 x:xs -> x : recourse (n - Vector.length x) xs+   in  Cons . recourse n0 . decons  padAlt :: (Storable a) => ChunkSize -> a -> Int -> T a -> T a padAlt size x n xs =@@ -751,7 +692,6 @@ {-# SPECULATE mix :: T Float -> T Float -> T Float #-} {-# SPECULATE mix :: T (Double,Double) -> T (Double,Double) -> T (Double,Double) #-} {-# SPECULATE mix :: T (Float,Float) -> T (Float,Float) -> T (Float,Float) #-}-{-# INLINE mix #-} {- 'mix' is more efficient since it appends the rest of the longer signal without copying.@@ -762,23 +702,32 @@       T x    -> T x    -> T x-mix xs ys =-   let len = min (lazyLength xs) (lazyLength ys) :: Chunky.T NonNeg.Int-       (prefixX,suffixX) = genericSplitAt len xs-       (prefixY,suffixY) = genericSplitAt len ys-   in  Vector.append-          (Vector.crochetL-              (\y xs0 ->-                  fmap (mapFst (y+)) (Vector.viewL xs0))-              prefixX prefixY)-          (if Vector.null suffixX-             then suffixY-             else suffixX)+mix = zipWithAppend (+) {- List.map V.unpack $ Vector.chunks $ mix (fromList defaultChunkSize [1,2,3,4,5::P.Double]) (fromList defaultChunkSize [1,2,3,4]) -} +zipWithAppend ::+   (Storable x) =>+   (x -> x -> x) ->+   T x -> T x -> T x+zipWithAppend f xs ys =+   uncurry Vector.append $ mapSnd snd $ zipWithRest f xs ys +zipWithRest ::+   (Storable c, Storable x) =>+   (x -> x -> c) ->+   T x ->+   T x ->+   (Vector.Vector c, (Bool, T x))+zipWithRest f xs ys =+   let len = min (lazyLength xs) (lazyLength ys) :: Chunky.T NonNeg.Int+       (prefixX,suffixX) = genericSplitAt len xs+       (prefixY,suffixY) = genericSplitAt len ys+       second = Vector.null suffixX+   in  (Vector.zipWith f prefixX prefixY,+        (second, if second then suffixY else suffixX))+ {- We should move that to StorableVector package, but we cannot, since that's Haskell 98.@@ -787,7 +736,8 @@    (Additive.C i, Ord i, ToInteger.C i, Storable x) =>    i -> T x -> (T x, T x) genericSplitAt n0 =-   let recurse n xs0 =+   let recourse n xs0 =+          forcePair $           maybe              ([], [])              (\(x,xs) ->@@ -796,13 +746,15 @@                   else                     let m = fromIntegral $ V.length x                     in  if m<=n-                          then mapFst (x:) $ recurse (n-m) xs+                          then mapFst (x:) $ recourse (n-m) xs                           else mapPair ((:[]), (:xs)) $                                V.splitAt (fromInteger $ toInteger n) x)-           $ viewListL xs0-   in  mapPair (Vector.SV, Vector.SV) . recurse n0 . Vector.chunks+           $ ListHT.viewL xs0+   in  mapPair (Vector.fromChunks, Vector.fromChunks) .+       recourse n0 . Vector.chunks  +-- cf. Data.StorableVector.Lazy.Pattern.length lazyLength :: (Ring.C i) =>    T x -> i lazyLength =@@ -874,7 +826,8 @@                  It's absolutely necessary that this function preserves the chunk structure                  and that it does not look a chunk ahead.                  That's guaranteed for processes that do not look ahead at all,-                 like 'Vector.map', 'Vector.crochetL' and the like. -}+                 like 'Vector.map', 'Vector.crochetL' and+                 all of type @Causal.Process@. -}    -> T y   -- ^ input    -> T y   -- ^ output has the same length as the input delayLoopOverlap time proc xs =@@ -1087,9 +1040,9 @@       Unfoldr a x    -> Int lengthUnfoldr (f,a0) =-   let recurse n a =-          maybe n (recurse (succ n) . snd) (f a)-   in  recurse 0 a0+   let recourse n a =+          maybe n (recourse (succ n) . snd) (f a)+   in  recourse 0 a0   {-# INLINE zipWithUnfoldr #-}@@ -1210,7 +1163,7 @@   "Storable.reduceL/unfoldr" forall size f g a b.      reduceL g b (unfoldr size f a) =         snd-          (FList.recurse (\(a0,b0) ->+          (FList.recourse (\(a0,b0) ->               do (y,a1) <- f a0                  b1 <- g y b0                  Just (a1, b1)) (a,b)) ;@@ -1268,7 +1221,7 @@  fromMapList :: (Storable y) => ChunkSize -> (x -> y) -> [x] -> T y fromMapList size f =-   unfoldr size (fmap (mapFst f) . viewListL)+   unfoldr size (fmap (mapFst f) . ListHT.viewL)  {-# RULES   "Storable.fromList/map" forall size f xs.
+ src/Synthesizer/Storage.hs view
@@ -0,0 +1,152 @@+{- |+Rendering sound effects off-line has its virtue,+but really cool is real-time signal generation.+For a long time I thought that it is the compiler's responsibility+to make list based signal processing fast enough.+However, the compiler has to respect correctness first.+That is, it cannot do too fancy optimization,+since the optimized program must still do the same as the unoptimized program.+So, when we write functions that rely on the maximal flexibility,+the compiler cannot turn it to something less flexible.+Actually, a list as in "Synthesizer.Plain.Signal"+is the best representation of a signal+in terms of flexibility:+It allows free choice of the element type, even functions,+it is element-wise lazy, allowing for short feedback,+it allows sharing of computed data.+The drawback is, that it is slow and memory inefficient.+In most cases we don't need this full flexibility,+but the compiler has no chance to find this out automatically.+It can merge several operations on a list+to a single operation by the fusion technique,+however even a single list operation is hard to get in real-time.++How do real-time software synthesizer achieve real-time performance?+They get the popular fast inner loops+by processing signals in chunks of raw data.+This way, they lose flexibility, because they cannot do quick feedback.+We can do the same in Haskell, getting the same restrictions.+Additionally, in order to store raw data+we must restrict the element types+e.g. to the @Storable@ class,+since we use @StorableVector@ in "Synthesizer.Storable.Signal".+With this technique single signal operations are fast,+but their combination cannot be optimized in many cases.+This is so, again, because top priority in optimization is correctness.+Consider @mix x (cons 0 x)@+where @cons 0 x@ means @0:x@ for our chunky signal data.+This expression is a perfect candidate for optimization.+But in this case it must not be applied since the chunk structures of+@x@ and @cons 0 x@ do not match.+In such cases we would not gain anything over SuperCollider and CSound.++Remember that we introduced the chunky signal representation+entirely because of efficiency concerns.+Actually we are not interested in a special chunk structure,+so this should not be a reason for disabling optimization.+Of course, we could ignore the correctness+and write incorrect optimizer rules+that are based on correct ideas.+However, experience shows that wrong optimization+leads to surprise and infelicities sooner or later.+The later the worse,+because the later the more code you have written+relying on invalid optimization.++What we can try is to use list representation,+enjoy the optimization that GHC already provides for it,+and then let fusion rules jump in+that make lists disappear when they are used in connection with chunky sequences.+E.g. @Chunky.fromList (List.oscillator freq)@+could be turned into @Chunky.oscillator freq@.+This approach would be really cool, but works only in theory.+In practice it is hard to predict how GHC transforms various operations.+Additionally to optimizer rule application+it also expands functions to their definitions (known as inlining/unfolding)+or specializes functions to fixed types.+We cannot rely on our optimizer rules being actually applied.+This means however, that in unpredictable cases+the optimization fails and the efficiency drops from real-time to non-real-time.+This is unacceptable.++The solution is a third signal representation,+see "Synthesizer.State.Signal".+(Already got tired?)+It consists of no actual data+but it is a function that generates elements.+Its type is @s -> Maybe (a,s)@ or short @StateT s Maybe a@.+Given a state of type @s@ it produces @Nothing@ when the list terminates+or @Just@ the next element and the updated state.+This can be easily converted from and to lists+while preserving laziness.+We convert to lists by @List.unfoldr@ and from lists using @viewL@.+Actually this signal representation is very close+to the list representation used in the streams package.+The main differences are:+Firstly, we do not use a list storage that is fused away when only used temporarily.+Thus we do not need a fusion rule (that could be skipped by the compiler).+Secondly, we have no notion of 'Skip',+since operations like 'filter' are uncommon in signal processing.+If we write our signal processing in terms of these virtual signals+and then convert the result to regular lists or chunky sequences,+then only one data structure will be built+and GHC does it's best to generate efficient inner loops.++We cannot use these virtual signals for sharing and feedback,+because there is no data structure that stores the data.+If we try to do so anyway, data will be recomputed.+Thus we still need chunky sequences or lists+for sharing of interim results and for feedback.+Actually, an expression like @mix x (reverse x)@+would definitely benefit from interim conversion to a chunky sequence,+but for @mix x (cons 0 x)@ this is overkill.++In order to get processes like the last one efficient+we have a new data type (no, not another one!)+but this time it is not a signal data type+but a signal processor type.+It is the result of thinking about+which processes allow sharing on a per-sample basis at all.+We come to the conclusion that these can be only causal processes,+i.e. processes that depend only on current and past data,+not on data from the future.+So, we already have a good name: "Synthesizer.Causal.Process".+Causal processes are "Control.Arrow"s,+however the higher level variant does no longer fit into the Arrow type class.+This means that there are various combinations+that turn causal processes into larger causal processes.+It needs a bit experience in pointfree coding style+in order to use the arrow combinators,+but there is no way around it,+when you want to use physical dimensions.+GHC's arrow notation does only support types of the Arrow class.+E.g. the expression @mix x (cons 0 x)@+becomes @Causal.mix <<< (Causal.id &&& Causal.cons 0)@.+When you manage this burden+you get processes that are warranted to be causal.+They can not only be used to make something efficient,+but they also allow to process data from the outside world+in a streaming way without 'unsafeInterleaveIO'+as required e.g. in JACK plugins.++For historical reasons there is also "Synthesizer.FusionList.Signal"+which is a wrapper around lists.+I used this data type to disable GHC's default list optimizer rules+and use my own ones.+The fusion is based on @unfoldr@ and @crochetL@+which is quite similar to the @stream-fusion@ package.+The @stream-fusion@ uses internally a @Skip@ constructor,+which, as far as I understand,+is better for the @filter@ function.+We do not need it,+because the @filter@ function is very uncommon in signal processing.+I think, @FusionList@ can be replaced by @stream-fusion@ functions.++We have now a pretty big set of signal storage types+that differ considerably in performance+but not in the set of operations.+This calls for a type class!+You find it in "Synthesizer.Generic.Signal"+and "Synthesizer.Generic.Signal2".+-}+module Synthesizer.Storage where
src/Synthesizer/Utility.hs view
@@ -11,70 +11,7 @@ import NumericPrelude  -{-# INLINE viewListL #-}-viewListL :: [a] -> Maybe (a, [a])-viewListL [] = Nothing-viewListL (x:xs) = Just (x,xs)---- for constant padding-{-# INLINE viewListR #-}-viewListR :: [a] -> Maybe ([a], a)-viewListR =-   foldr (\x -> Just . maybe ([],x) (mapFst (x:))) Nothing- {-|-Apply the function @f@ n times to the start value.--You can express that function using --> nest n f x = (iterate f x) !! n-> nest n f = foldl (.) id (replicate n f)--but this is not as elegant as calling @nest@.-Simon Thompson calls it @iter@.--}-{-# INLINE nest #-}-nest :: Int -> (a -> a) -> a -> a-nest 0 _ x = x-nest n f x = f (nest (n-1) f x)----- see event-list package--- | Control.Arrow.***-{-# INLINE mapPair #-}-mapPair :: (a -> c, b -> d) -> (a,b) -> (c,d)-mapPair ~(f,g) ~(x,y) = (f x, g y)---- | Control.Arrow.first-{-# INLINE mapFst #-}-mapFst :: (a -> c) -> (a,b) -> (c,b)-mapFst f ~(x,y) = (f x, y)---- | Control.Arrow.second-{-# INLINE mapSnd #-}-mapSnd :: (b -> d) -> (a,b) -> (a,d)-mapSnd g ~(x,y) = (x, g y)---{-# INLINE fst3 #-}-fst3 :: (a,b,c) -> a-fst3 (a,_,_) = a--{-# INLINE snd3 #-}-snd3 :: (a,b,c) -> b-snd3 (_,b,_) = b--{-# INLINE thd3 #-}-thd3 :: (a,b,c) -> c-thd3 (_,_,c) = c---{-# INLINE swap #-}-swap :: (a,b) -> (b,a)-swap (x,y) = (y,x)---{-| If two values are equal, then return one of them, otherwise raise an error. -}@@ -122,8 +59,3 @@    g -> Int -> y -> y -> [y] randomRsBalanced g n center width =    balanceLevel center (take n $ randomRs (zero,width) g)---{-# INLINE clip #-}-clip :: Ord a => a -> a -> a -> a-clip lower upper = max lower . min upper
src/Test/Main.hs view
@@ -5,12 +5,17 @@ import qualified Test.Sound.Synthesizer.Plain.Filter         as Filter import qualified Test.Sound.Synthesizer.Plain.Interpolation  as Interpolation import qualified Test.Sound.Synthesizer.Plain.Oscillator     as Oscillator-import qualified Test.Sound.Synthesizer.Plain.ToneModulation as ToneModulation import qualified Test.Sound.Synthesizer.Plain.Wave           as Wave+import qualified Test.Sound.Synthesizer.Basic.ToneModulation as ToneModulation+import qualified Test.Sound.Synthesizer.Plain.ToneModulation as ToneModulationL+import qualified Test.Sound.Synthesizer.Generic.ToneModulation as ToneModulationG +import Data.Tuple.HT (mapFst, )++ prefix :: String -> [(String, IO ())] -> [(String, IO ())] prefix msg =-   map (\(str,test) -> (msg ++ "." ++ str, test))+   map (mapFst (\str -> msg ++ "." ++ str))  main :: IO () main =@@ -21,6 +26,8 @@       prefix "Plain.Filter"         Filter.tests :       prefix "Plain.Interpolation"  Interpolation.tests :       prefix "Plain.Oscillator"     Oscillator.tests :-      prefix "Plain.ToneModulation" ToneModulation.tests :       prefix "Plain.Wave"           Wave.tests :+      prefix "Basic.ToneModulation" ToneModulation.tests :+      prefix "Plain.ToneModulation" ToneModulationL.tests :+      prefix "Generic.ToneModulation" ToneModulationG.tests :       []
+ src/Test/Sound/Synthesizer/Basic/ToneModulation.hs view
@@ -0,0 +1,98 @@+module Test.Sound.Synthesizer.Basic.ToneModulation where++import qualified Synthesizer.Interpolation  as Interpolation+import Synthesizer.Interpolation (margin, )++import qualified Synthesizer.Basic.Phase          as Phase+import qualified Synthesizer.Basic.ToneModulation as ToneMod++import qualified Test.Sound.Synthesizer.Plain.Interpolation as InterpolationTest++import Test.QuickCheck (test, Property, (==>), Testable, )+-- import Test.Utility++import qualified Number.NonNegative       as NonNeg+-- import qualified Number.NonNegativeChunky as Chunky++-- import qualified Algebra.RealTranscendental    as RealTrans+-- import qualified Algebra.Module                as Module+import qualified Algebra.RealField             as RealField+import qualified Algebra.Field                 as Field+-- import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive+++import NumericPrelude+import PreludeBase+import Prelude ()+++untangleShapePhase :: (Field.C a, Eq a) =>+   Int -> a -> (a, a) -> Property+untangleShapePhase periodInt period c =+   period /= zero ==>+      ToneMod.untangleShapePhase periodInt period c ==+      ToneMod.untangleShapePhaseAnalytic periodInt period c++flattenShapePhase :: (RealField.C a) =>+   Int -> a -> (a, Phase.T a) -> Property+flattenShapePhase periodInt period c =+   period /= zero ==>+      ToneMod.flattenShapePhase periodInt period c ==+      ToneMod.flattenShapePhaseAnalytic periodInt period c+++-- * auxiliary test functions++{-+Although that looks like a too small value, it is actually right,+because numberLeap counts intervals of size periodInt, not single elements.+So numberLeap=2 like in linear interpolation means 2*periodInt.+-}+minLength ::+   Interpolation.T a v ->+   Interpolation.T a v ->+   Int -> NonNeg.Int -> Int+minLength ipLeap ipStep =+   minLengthMargin (margin ipLeap) (margin ipStep)++minLengthMargin ::+   Interpolation.Margin ->+   Interpolation.Margin ->+   Int -> NonNeg.Int -> Int+minLengthMargin marginLeap marginStep periodInt ext =+   ToneMod.interpolationNumber+      marginLeap marginStep periodInt ++   NonNeg.toNumber ext++++shapeLimits ::+   Interpolation.T a v ->+   Interpolation.T a v ->+   Int -> Int -> (Int, Int)+shapeLimits ipLeap ipStep periodInt len =+   ToneMod.shapeLimits+      (margin ipLeap) (margin ipStep)+      periodInt len++++testRationalLineIp :: Testable test =>+   (InterpolationTest.LinePreserving Rational Rational -> test) -> IO ()+testRationalLineIp f  =  test f++testRationalIp :: Testable test =>+   (InterpolationTest.T Rational Rational -> test) -> IO ()+testRationalIp f  =  test f+++tests :: [(String, IO ())]+tests =+   ("untangleShapePhase",+      test (\periodInt period ->+                untangleShapePhase periodInt (period :: Rational))) :+   ("flattenShapePhase",+      test (\periodInt period ->+                flattenShapePhase periodInt (period :: Rational))) :+   []
+ src/Test/Sound/Synthesizer/Generic/ToneModulation.hs view
@@ -0,0 +1,313 @@+module Test.Sound.Synthesizer.Generic.ToneModulation (tests) where++import Test.Sound.Synthesizer.Basic.ToneModulation (+   minLength,+   minLengthMargin,+--   shapeLimits,+--   testRationalLineIp,+   testRationalIp,+   )++import Test.Sound.Synthesizer.Plain.ToneModulation (+   InfiniteList,+   listFromInfinite,+   )++import qualified Synthesizer.Causal.ToneModulation as ToneModC+import qualified Synthesizer.Generic.Wave as WaveG++import qualified Synthesizer.Plain.Signal         as Sig+import qualified Synthesizer.Plain.Oscillator     as Osci+import qualified Synthesizer.Plain.Interpolation  as Interpolation+import qualified Synthesizer.Plain.ToneModulation as ToneModL+import qualified Synthesizer.Plain.Wave   as WaveL+import Synthesizer.Interpolation (marginNumber, )++import qualified Synthesizer.Causal.Oscillator as OsciC+import qualified Synthesizer.Causal.Process as Causal++import qualified Synthesizer.State.Signal as SigS++import qualified Synthesizer.Basic.Wave           as Wave+import qualified Synthesizer.Basic.Phase          as Phase++import qualified Test.Sound.Synthesizer.Plain.Interpolation as InterpolationTest++import Test.QuickCheck (test, Property, (==>), )+import Test.Utility (ArbChar, )+-- import Debug.Trace (trace, )++import qualified Number.NonNegative       as NonNeg++-- import qualified Algebra.RealTranscendental    as RealTrans+-- import qualified Algebra.Module                as Module+import qualified Algebra.RealField             as RealField+-- import qualified Algebra.Field                 as Field+-- import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive+++import Data.List.HT (viewL, takeWhileJust, )+import Data.Tuple.HT (mapSnd, )+import qualified Data.List as List+++import NumericPrelude+import PreludeBase+import Prelude ()+++limitMinRelativeValues ::+   Int -> Int -> [NonNeg.Int] -> Bool+limitMinRelativeValues xMin x0 xsnn =+   let xs = map NonNeg.toNumber xsnn+       (y0,limiter) = ToneModC.limitMinRelativeValues xMin x0+   in  (y0, Causal.applyGeneric limiter xs) ==+          ToneModL.limitMinRelativeValues xMin x0 xs++integrateFractional :: (RealField.C t) =>+   NonNeg.T t -> t -> Phase.T t -> [NonNeg.T t] -> [t] -> Property+integrateFractional+     periodNN shape0 phase shapesNN freqs =+   let shapes = map NonNeg.toNumber shapesNN+       period    = NonNeg.toNumber periodNN+       (c0, coordinator) =+          ToneModC.integrateFractional+             period (shape0, phase)+       coords =+          ToneModL.integrateFractional+             period (shape0, shapes) (phase, freqs)+   in  period /= zero  ==>+          c0 : Causal.applyGeneric coordinator (zip shapes freqs) ==+          coords++-- oscillatorCellSize :: (Show t, Show v, RealField.C t, Eq v) =>+oscillatorCellSize :: (RealField.C t, Eq v) =>+   Interpolation.Margin ->+   Interpolation.Margin ->+   NonNeg.Int -> NonNeg.T t ->+   NonNeg.Int -> InfiniteList v ->+   t -> t -> [NonNeg.T t] -> [t] ->+   Property+oscillatorCellSize+      marginLeap marginStep periodIntNN periodNN ext+      ixs shape0 phase shapesNN freqs =+   let shapes = map NonNeg.toNumber shapesNN+       period    = NonNeg.toNumber periodNN+       periodInt = NonNeg.toNumber periodIntNN+       len = minLengthMargin marginLeap marginStep periodInt ext+       tone = take len (listFromInfinite ixs)+       resampledTone =+          ToneModC.oscillatorCells+             marginLeap marginStep periodInt period tone+             (shape0, Phase.fromRepresentative phase)+          `Causal.applyGeneric`+          zip shapes freqs+   in  period /= zero  &&+       marginNumber marginLeap > zero &&+       marginNumber marginStep > zero  ==>+       all+          ((\cell ->+              Sig.lengthAtLeast (marginNumber marginLeap) cell &&+              all (Sig.lengthAtLeast (marginNumber marginStep))+                  (take (marginNumber marginLeap) cell))+           . SigS.toList . snd)+          resampledTone++oscillatorSuffixes :: (RealField.C t, Eq v) =>+   Interpolation.Margin ->+   Interpolation.Margin ->+   NonNeg.Int -> NonNeg.T t ->+   NonNeg.Int -> InfiniteList v ->+   t -> t -> [NonNeg.T t] -> [t] ->+   Property+oscillatorSuffixes+      marginLeap marginStep periodIntNN periodNN ext+      ixs shape0 phase shapesNN freqs =+   let shapes = map NonNeg.toNumber shapesNN+       period    = NonNeg.toNumber periodNN+       periodInt = NonNeg.toNumber periodIntNN+       len = minLengthMargin marginLeap marginStep periodInt ext+       tone = take len (listFromInfinite ixs)+       resampledToneA =+          init $+          map (\(sp,cell) ->+             (sp, takeWhileJust . map (fmap fst . viewL) $ cell)) $+          ToneModL.oscillatorSuffixes+             marginLeap marginStep periodInt period tone+             (shape0, shapes) (Phase.fromRepresentative phase, freqs)+       resampledToneB =+          ToneModC.oscillatorSuffixes+             marginLeap marginStep periodInt period tone+             (shape0, Phase.fromRepresentative phase)+          `Causal.applyGeneric`+          zip shapes freqs+   in  period /= zero  &&+       periodInt /= zero  &&+       marginNumber marginLeap > zero &&+       marginNumber marginStep > zero  ==>+          resampledToneA == resampledToneB++oscillatorCells :: (RealField.C t, Eq v) =>+   Interpolation.Margin ->+   Interpolation.Margin ->+   NonNeg.Int -> NonNeg.T t ->+   NonNeg.Int -> InfiniteList v ->+   t -> t -> [NonNeg.T t] -> [t] ->+   Property+oscillatorCells+      marginLeap marginStep periodIntNN periodNN ext+      ixs shape0 phase shapesNN freqs =+   let shapes = map NonNeg.toNumber shapesNN+       period    = NonNeg.toNumber periodNN+       periodInt = NonNeg.toNumber periodIntNN+       len = minLengthMargin marginLeap marginStep periodInt ext+       tone = take len (listFromInfinite ixs)+       resampledToneA =+          init $ map (mapSnd List.transpose) $+          ToneModL.oscillatorCells+             marginLeap marginStep periodInt period tone+             (shape0, shapes) (Phase.fromRepresentative phase, freqs)+       resampledToneB =+          map (mapSnd SigS.toList) $+          ToneModC.oscillatorCells+             marginLeap marginStep periodInt period tone+             (shape0, Phase.fromRepresentative phase)+          `Causal.applyGeneric`+          zip shapes freqs+   in  period /= zero  &&+       periodInt /= zero  &&+       marginNumber marginLeap > zero &&+       marginNumber marginStep > zero  ==>+          resampledToneA == resampledToneB+{-+Margin {marginNumber = 1, marginOffset = 2}+Margin {marginNumber = 5, marginOffset = 5}+3 % 4+0+('\DEL',['~','~','"'])+-2 % 5+2 % 5+[2 % 1,3 % 4]+[-5 % 2,-1 % 2]+-}++{- |+'WaveL.sampledTone' and 'WaveG.sampledTone'+do not only differ in the signal types they process,+but also in the way they order the signal values.+The cells for 'WaveL.sampledTone' are transposed+with respect to 'WaveG.sampledTone'.+-}+sampledTone :: (RealField.C a, Eq v) =>+   InterpolationTest.T a v ->+   InterpolationTest.T a v ->+   NonNeg.T a -> NonNeg.Int -> InfiniteList v ->+   a -> Phase.T a -> Property+sampledTone =+   InterpolationTest.use2 $ \ ipLeap ipStep+         periodNN ext ixs shape phase ->+   let period = NonNeg.toNumber periodNN+       periodInt = round period+       len = minLength ipLeap ipStep periodInt ext+       tone = take len (listFromInfinite ixs)+   in  period /= zero ==>+          WaveG.sampledTone ipLeap ipStep period tone shape `Wave.apply` phase ==+          WaveL.sampledTone ipLeap ipStep period tone shape `Wave.apply` phase++++shapeFreqModFromSampledTone :: (RealField.C t, Eq v) =>+   InterpolationTest.T t v ->+   InterpolationTest.T t v ->+   NonNeg.T t ->+   NonNeg.Int -> InfiniteList v ->+   t -> Phase.T t -> [NonNeg.T t] -> [t] ->+   Property+shapeFreqModFromSampledTone =+   InterpolationTest.use2 $ \ ipLeap ipStep+         periodNN ext ixs shape0 phase shapesNN freqs ->+   let shapes = map NonNeg.toNumber shapesNN+       period = NonNeg.toNumber periodNN+       periodInt = round period+       len = minLength ipLeap ipStep periodInt ext+       tone = take len (listFromInfinite ixs)+       resampledToneA =+          init $+          Osci.shapeFreqModFromSampledTone ipLeap ipStep period tone+             shape0 (Phase.toRepresentative phase) shapes freqs+       resampledToneB =+          OsciC.shapeFreqModFromSampledTone+             ipLeap ipStep period tone shape0 phase+          `Causal.applyGeneric`+          zip shapes freqs+   in  period /= zero  ==>+          resampledToneA == resampledToneB+++{-+We have a problem here with the phase distortion signal,+because frequency and shape modulation control signals+are delayed by one element with respect to the phase distortion.+How can we cope with different lengths of the control signals,+without padding the phase control with zeros?+This one did not work:+   phaseDistorts = pd:pds+   resampledToneA =+      Osci.shapePhaseFreqModFromSampledTone ipLeap ipStep period tone+         shape0 (Phase.toRepresentative phase) shapes (init phaseDistorts) freqs+-}+shapePhaseFreqModFromSampledTone :: (RealField.C t, Eq v) =>+   InterpolationTest.T t v ->+   InterpolationTest.T t v ->+   NonNeg.T t ->+   NonNeg.Int -> InfiniteList v ->+   t -> Phase.T t -> [NonNeg.T t] -> (t,[t]) -> [t] ->+   Property+shapePhaseFreqModFromSampledTone =+   InterpolationTest.use2 $ \ ipLeap ipStep+         periodNN ext ixs shape0 phase shapesNN (pd,pds) freqs ->+   let period = NonNeg.toNumber periodNN+       periodInt = round period+       len = minLength ipLeap ipStep periodInt ext+       tone = take len (listFromInfinite ixs)+       shapes = map NonNeg.toNumber shapesNN+       phaseDistorts = pd:pds ++ repeat zero+       resampledToneA =+          init $+          Osci.shapePhaseFreqModFromSampledTone ipLeap ipStep period tone+             shape0 (Phase.toRepresentative phase) shapes phaseDistorts freqs+       resampledToneB =+          OsciC.shapePhaseFreqModFromSampledTone+             ipLeap ipStep period tone shape0 phase+          `Causal.applyGeneric`+          zip3 shapes phaseDistorts freqs+   in  period /= zero  ==>+          resampledToneA == resampledToneB++++tests :: [(String, IO ())]+tests =+   ("limitMinRelativeValues", test limitMinRelativeValues) :+   ("integrateFractional",+      test (\period -> integrateFractional (period :: NonNeg.Rational))) :+   ("oscillatorCellSize",+      test (\ml ms periodInt period ext ixs ->+               oscillatorCellSize ml ms periodInt (period :: NonNeg.Rational)+                  ext (ixs :: InfiniteList ArbChar))) :+   ("oscillatorSuffixes",+      test (\ml ms periodInt period ext ixs ->+               oscillatorSuffixes ml ms periodInt (period :: NonNeg.Rational)+                  ext (ixs :: InfiniteList ArbChar))) :+   ("oscillatorCells",+      test (\ml ms periodInt period ext ixs ->+               oscillatorCells ml ms periodInt (period :: NonNeg.Rational)+                  ext (ixs :: InfiniteList ArbChar))) :+   ("sampledTone",+      testRationalIp sampledTone) :+   ("shapeFreqModFromSampledTone",+      testRationalIp shapeFreqModFromSampledTone) :+   ("shapePhaseFreqModFromSampledTone",+      testRationalIp shapePhaseFreqModFromSampledTone) :+   []
src/Test/Sound/Synthesizer/Plain/Interpolation.hs view
@@ -1,11 +1,17 @@-module Test.Sound.Synthesizer.Plain.Interpolation-   (T, ip,-    LinePreserving, lpIp,-    tests) where+module Test.Sound.Synthesizer.Plain.Interpolation (+   T, ip,+   LinePreserving, lpIp,+   tests,+   use, useLP, use2,+   ) where  import qualified Synthesizer.Plain.Interpolation as Interpolation+import qualified Synthesizer.Interpolation.Class as Interpol+import qualified Synthesizer.Interpolation.Custom as ExampleCustom+import qualified Synthesizer.Interpolation.Module as ExampleModule+import qualified Synthesizer.Interpolation as InterpolationCore -import Test.QuickCheck (test, Arbitrary(..), elements, {- Property, (==>), -} )+import Test.QuickCheck (test, Arbitrary(..), elements, {- Property, (==>), -} Testable, ) -- import Test.Utility  import qualified Algebra.VectorSpace           as VectorSpace@@ -15,26 +21,59 @@ -- import qualified Algebra.Ring                  as Ring -- import qualified Algebra.Additive              as Additive -import Test.Utility (equalList)+import Control.Monad (liftM2, ) +import Test.Utility (equalList, ) + import NumericPrelude import PreludeBase import Prelude ()   +instance Arbitrary InterpolationCore.Margin where+   arbitrary =+      liftM2 InterpolationCore.Margin+         (fmap abs arbitrary)+         (fmap abs arbitrary)+   coarbitrary = undefined ++use ::+   (Interpolation.T a v -> x) ->+   (T a v -> x)+use f ipt =+   f (ip ipt)++useLP ::+   (Interpolation.T a v -> x) ->+   (LinePreserving a v -> x)+useLP f ipt =+   f (lpIp ipt)++use2 ::+   (Interpolation.T a v ->+    Interpolation.T a v -> x) ->+   (T a v ->+    T a v -> x)+use2 f =+   use $ \ ipLeap ->+   use $ \ ipStep ->+      f ipLeap ipStep+++ data T a v = Cons {name :: String, ip :: Interpolation.T a v}  instance Show (T a v) where    show x = name x -instance (Field.C a, Module.C a v) => Arbitrary (T a v) where+instance (Field.C a, Interpol.C a v) => Arbitrary (T a v) where    arbitrary = elements $-      Cons "constant" Interpolation.constant :-      Cons "linear"   Interpolation.linear :-      Cons "cubic"    Interpolation.cubic :+      Cons "constant" ExampleCustom.constant :+      Cons "linear"   ExampleCustom.linear :+      Cons "cubic"    ExampleCustom.cubic :       []    coarbitrary = undefined @@ -46,42 +85,58 @@ instance Show (LinePreserving a v) where    show x = lpName x -instance (Field.C a, Module.C a v) => Arbitrary (LinePreserving a v) where+instance (Field.C a, Interpol.C a v) => Arbitrary (LinePreserving a v) where    arbitrary = elements $-      LPCons "linear"   Interpolation.linear :-      LPCons "cubic"    Interpolation.cubic :+      LPCons "linear"   ExampleCustom.linear :+      LPCons "cubic"    ExampleCustom.cubic :       []    coarbitrary = undefined   -constant :: (Module.C a v, Eq v) => a -> v -> [v] -> Bool+constant ::+   (Interpol.C a v, Module.C a v, Eq v) =>+   a -> v -> [v] -> Bool constant t x0 xs =    equalList $ map ($(x0:xs)) $ map ($t) $-      Interpolation.func Interpolation.constant :-      Interpolation.func Interpolation.piecewiseConstant :+      Interpolation.func ExampleCustom.constant :+      Interpolation.func ExampleCustom.piecewiseConstant :+      Interpolation.func ExampleModule.constant :+      Interpolation.func ExampleModule.piecewiseConstant :       [] -linear :: (Module.C a v, Eq v) => a -> v -> v -> [v] -> Bool+linear ::+   (Interpol.C a v, Module.C a v, Eq v) =>+   a -> v -> v -> [v] -> Bool linear t x0 x1 xs =    equalList $ map ($(x0:x1:xs)) $ map ($t) $-      Interpolation.func Interpolation.linear :-      Interpolation.func Interpolation.piecewiseLinear :+      Interpolation.func ExampleCustom.linear :+      Interpolation.func ExampleCustom.piecewiseLinear :+      Interpolation.func ExampleModule.linear :+      Interpolation.func ExampleModule.piecewiseLinear :       [] -cubic :: (VectorSpace.C a v, Eq v) => a -> v -> v -> v -> v -> [v] -> Bool+cubic ::+   (Interpol.C a v, VectorSpace.C a v, Eq v) =>+   a -> v -> v -> v -> v -> [v] -> Bool cubic t x0 x1 x2 x3 xs =    equalList $ map ($(x0:x1:x2:x3:xs)) $ map ($t) $-      Interpolation.func Interpolation.cubic :-      Interpolation.func Interpolation.cubicAlt :-      Interpolation.func Interpolation.piecewiseCubic :+      Interpolation.func ExampleCustom.cubic :+      Interpolation.func ExampleCustom.piecewiseCubic :+      Interpolation.func ExampleModule.cubic :+      Interpolation.func ExampleModule.cubicAlt :+      Interpolation.func ExampleModule.piecewiseCubic :       []  +testRational ::+   (Testable t) =>+   (Rational -> Rational -> t) -> IO ()+testRational = test  tests :: [(String, IO ())] tests =-   ("constant", test (\t x -> constant (t::Rational) (x::Rational))) :-   ("linear",   test (\t x -> linear   (t::Rational) (x::Rational))) :-   ("cubic",    test (\t x -> cubic    (t::Rational) (x::Rational))) :+   ("constant", testRational constant) :+   ("linear",   testRational linear  ) :+   ("cubic",    testRational cubic   ) :    []
src/Test/Sound/Synthesizer/Plain/ToneModulation.hs view
@@ -1,15 +1,29 @@-module Test.Sound.Synthesizer.Plain.ToneModulation (tests) where+module Test.Sound.Synthesizer.Plain.ToneModulation (tests,+   listFromInfinite,+   InfiniteList,+   ) where +import Test.Sound.Synthesizer.Basic.ToneModulation (+   minLength,+   minLengthMargin,+   shapeLimits,+   testRationalLineIp,+   testRationalIp,+   )+ import qualified Synthesizer.Plain.Oscillator     as Osci+import qualified Synthesizer.Plain.Interpolation  as Interpolation+import qualified Synthesizer.Plain.ToneModulation as ToneModL+import qualified Synthesizer.Plain.Wave           as WaveL+import Synthesizer.Interpolation (marginNumber, )+ import qualified Synthesizer.Basic.Wave           as Wave import qualified Synthesizer.Basic.Phase          as Phase-import qualified Synthesizer.Plain.Interpolation  as Interpolation-import qualified Synthesizer.Plain.ToneModulation as ToneMod  import qualified Test.Sound.Synthesizer.Plain.Interpolation as InterpolationTest -import Test.QuickCheck (test, Property, (==>), Testable, )--- import Test.Utility+import Test.QuickCheck (test, Property, (==>), Arbitrary, arbitrary, coarbitrary, )+import Test.Utility (ArbChar, )  import qualified Number.NonNegative       as NonNeg import qualified Number.NonNegativeChunky as Chunky@@ -21,8 +35,10 @@ import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive --import Synthesizer.Utility (clip, mapPair, )+import Control.Monad (liftM2, )+import Data.List.HT (isAscending, )+import Data.Ord.HT (limit, )+import Data.Tuple.HT (mapPair, mapSnd, ) import qualified Data.List as List  @@ -31,15 +47,38 @@ import Prelude ()  +{-+Properties that do not hold:+  commutativity of limitRelativeShapes and integrateFractional:+    Does not hold because when you clip the integral skips at the end,+    you would have to clear the fractional part, too.+-} -untangleShapePhase :: (Field.C a, Eq a) =>-   Int -> a -> (a, a) -> Property-untangleShapePhase periodInt period c =-   period /= zero ==>-      ToneMod.untangleShapePhase periodInt period c ==-      ToneMod.untangleShapePhaseAnalytic periodInt period c  +data InfiniteList a =+   InfiniteList a [a]++listFromInfinite :: InfiniteList a -> [a]+listFromInfinite (InfiniteList x xs) =+   cycle (x:xs)++instance Functor InfiniteList where+   fmap f (InfiniteList x xs) =+      InfiniteList (f x) (map f xs)++instance Arbitrary a => Arbitrary (InfiniteList a) where+   arbitrary = liftM2 InfiniteList arbitrary arbitrary+   coarbitrary = undefined++instance Show a => Show (InfiniteList a) where+   showsPrec p (InfiniteList x xs) =+      showParen (p >= 10) $+      showString "cycle " .+      showsPrec 11 (x:xs)+++ absolutize :: (Additive.C a) => a -> [a] -> [a] absolutize = scanl (+) @@ -48,108 +87,62 @@ limitMinRelativeValues xMin x0 xsnn =    let xs = map NonNeg.toNumber xsnn    in  map (max xMin) (absolutize x0 xs) ==-          uncurry absolutize (ToneMod.limitMinRelativeValues xMin x0 xs)+          uncurry absolutize (ToneModL.limitMinRelativeValues xMin x0 xs)  limitMaxRelativeValues ::    Int -> Int -> [NonNeg.Int] -> Bool limitMaxRelativeValues xMax x0 xsnn =    let xs = map NonNeg.toNumber xsnn    in  map (min xMax) (absolutize x0 xs) ==-          uncurry absolutize (ToneMod.limitMaxRelativeValues xMax x0 xs)+          uncurry absolutize (ToneModL.limitMaxRelativeValues xMax x0 xs)  limitMaxRelativeValuesNonNeg ::    Int -> Int -> [NonNeg.Int] -> Bool limitMaxRelativeValuesNonNeg xMax x0 xsnn =    let xs = map NonNeg.toNumber xsnn    in  map (min xMax) (absolutize x0 xs) ==-          uncurry absolutize (ToneMod.limitMaxRelativeValuesNonNeg xMax x0 xs)+          uncurry absolutize (ToneModL.limitMaxRelativeValuesNonNeg xMax x0 xs)  -- chunky type is not necessary here but testing it a little is not wrong limitMinRelativeValuesIdentity ::    Chunky.T NonNeg.Int -> [Chunky.T NonNeg.Int] -> Bool limitMinRelativeValuesIdentity x0 xs =-   (x0,xs) == ToneMod.limitMinRelativeValues 0 x0 xs+   (x0,xs) == ToneModL.limitMinRelativeValues 0 x0 xs  limitMaxRelativeValuesIdentity ::    Chunky.T NonNeg.Int -> [Chunky.T NonNeg.Int] -> Bool limitMaxRelativeValuesIdentity x0 xs =    let inf = 1 + inf-   in  (x0,xs) == ToneMod.limitMaxRelativeValues inf x0 xs+   in  (x0,xs) == ToneModL.limitMaxRelativeValues inf x0 xs  limitMaxRelativeValuesNonNegIdentity ::    Chunky.T NonNeg.Int -> [Chunky.T NonNeg.Int] -> Bool limitMaxRelativeValuesNonNegIdentity x0 xs =    let inf = 1 + inf-   in  (x0,xs) == ToneMod.limitMaxRelativeValuesNonNeg inf x0 xs+   in  (x0,xs) == ToneModL.limitMaxRelativeValuesNonNeg inf x0 xs  limitMaxRelativeValuesInfinity ::-   Chunky.T NonNeg.Int -> (Chunky.T NonNeg.Int, [Chunky.T NonNeg.Int]) -> Bool-limitMaxRelativeValuesInfinity x0 (x,xs) =+   Chunky.T NonNeg.Int -> InfiniteList (Chunky.T NonNeg.Int) -> Bool+limitMaxRelativeValuesInfinity x0 ixs =    let inf = 1 + inf-       ys = cycle (x:xs)-       (z0,zs) = ToneMod.limitMaxRelativeValues inf x0 ys+       ys = listFromInfinite ixs+       (z0,zs) = ToneModL.limitMaxRelativeValues inf x0 ys    in  (x0, take 100 ys) == (z0, take 100 zs)  limitMaxRelativeValuesNonNegInfinity ::-   Chunky.T NonNeg.Int -> (Chunky.T NonNeg.Int, [Chunky.T NonNeg.Int]) -> Bool-limitMaxRelativeValuesNonNegInfinity x0 (x,xs) =+   Chunky.T NonNeg.Int -> InfiniteList (Chunky.T NonNeg.Int) -> Bool+limitMaxRelativeValuesNonNegInfinity x0 ixs =    let inf = 1 + inf-       ys = cycle (x:xs)-       (z0,zs) = ToneMod.limitMaxRelativeValuesNonNeg inf x0 ys+       ys = listFromInfinite ixs+       (z0,zs) = ToneModL.limitMaxRelativeValuesNonNeg inf x0 ys    in  (x0, take 100 ys) == (z0, take 100 zs)  -dropRem :: Eq a => Int -> [a] -> Bool-dropRem n xs =-   let n1 = abs n-   in  map (flip ToneMod.dropRem xs) [0 .. n1 + length xs] ==-       map ((,) 0) (List.tails xs) ++ map (flip (,) []) [1..n1]---withInterpolation ::-   (Interpolation.T a v -> x) ->-   (InterpolationTest.T a v -> x)-withInterpolation f ipt =-   f (InterpolationTest.ip ipt)--withLPInterpolation ::-   (Interpolation.T a v -> x) ->-   (InterpolationTest.LinePreserving a v -> x)-withLPInterpolation f ipt =-   f (InterpolationTest.lpIp ipt)--withInterpolation2 ::-   (Interpolation.T a v ->-    Interpolation.T a v -> x) ->-   (InterpolationTest.T a v ->-    InterpolationTest.T a v -> x)-withInterpolation2 f =-   withInterpolation $ \ ipLeap ->-   withInterpolation $ \ ipStep ->-      f ipLeap ipStep--minLength ::-   Interpolation.T a v ->-   Interpolation.T a v ->-   Int -> NonNeg.Int -> Int-minLength ipLeap ipStep periodInt ext =-   Interpolation.number ipStep +-   Interpolation.number ipLeap * periodInt +-   NonNeg.toNumber ext--sampledTone :: (RealField.C a, Eq v) =>-   InterpolationTest.T a v ->-   InterpolationTest.T a v ->-   NonNeg.T a -> NonNeg.Int -> (v,[v]) -> a -> Phase.T a -> Property-sampledTone =-   withInterpolation2 $ \ ipLeap ipStep-         periodNN ext (x,xs) shape phase ->-   let period = NonNeg.toNumber periodNN-       len = minLength ipLeap ipStep (ceiling period) ext-       tone = take len (List.cycle (x:xs))-   in  period /= zero ==>-          Wave.sampledToneAlt ipLeap ipStep period tone shape `Wave.apply` phase ==-             Wave.sampledTone ipLeap ipStep period tone shape `Wave.apply` phase+dropRem :: Eq a => NonNeg.Int -> [a] -> Bool+dropRem nn xs =+   let n = NonNeg.toNumber nn+   in  map (flip ToneModL.dropRem xs) [0 .. n + length xs] ==+       map ((,) 0) (List.tails xs) ++ map (flip (,) []) [1..n]   sampledToneSine :: (RealTrans.C a, Module.C a a) =>@@ -159,9 +152,10 @@        ipStep = Interpolation.cubic        ten = fromInteger 10        period = ten + NonNeg.toNumber periodNN-       len = minLength ipLeap ipStep (ceiling period) ext+       periodInt = round period+       len = minLength ipLeap ipStep periodInt ext        tone = take len (Osci.staticSine phase0 (recip period))-   in  abs (Wave.sampledTone ipLeap ipStep period tone shape `Wave.apply` (Phase.fromRepresentative phase) -+   in  abs (WaveL.sampledTone ipLeap ipStep period tone shape `Wave.apply` (Phase.fromRepresentative phase) -             head (Osci.staticSine (phase0+phase) zero)) < ten ^- (-2)  @@ -172,11 +166,12 @@        ipStep = Interpolation.cubic        ten = fromInteger 10        period = ten + NonNeg.toNumber periodNN-       len = minLength ipLeap ipStep (ceiling period) ext+       periodInt = round period+       len = minLength ipLeap ipStep periodInt ext        tone = take len (Osci.staticSine origPhase (recip period))    in  all ((< ten ^- (-2)) . abs) $        zipWith (-)-          (Osci.shapeFreqMod (Wave.sampledTone ipLeap ipStep period tone)+          (Osci.shapeFreqMod (WaveL.sampledTone ipLeap ipStep period tone)                phase shapes freqs)           (Osci.freqModSine (origPhase+phase) freqs) @@ -186,28 +181,29 @@    InterpolationTest.LinePreserving a v ->    NonNeg.T a -> NonNeg.Int -> (v,v) -> a -> Phase.T a -> Property sampledToneLinear =-   withLPInterpolation $ \ ipLeap ->-   withLPInterpolation $ \ ipStep ->+   InterpolationTest.useLP $ \ ipLeap ->+   InterpolationTest.useLP $ \ ipStep ->          \ periodNN ext (i,d) shape phase ->    let period = NonNeg.toNumber periodNN-       len = minLength ipLeap ipStep (ceiling period) ext+       periodInt = round period+       len = minLength ipLeap ipStep periodInt ext        ramp = take len (List.iterate (d+) i)        limits =           mapPair (fromIntegral, fromIntegral) $-             ToneMod.shapeLimits ipLeap ipStep (round period) len+             shapeLimits ipLeap ipStep periodInt len    in  period /= zero ==>           -- should be (fraction phase), right?-          Wave.sampledTone ipLeap ipStep period ramp shape `Wave.apply` phase ==-             i + uncurry clip limits shape *> d+          WaveL.sampledTone ipLeap ipStep period ramp shape `Wave.apply` phase ==+             i + limit limits shape *> d {--let len=100; period=1/0.06::Double; ip = Interpolation.linear in GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (0,fromIntegral len)) [\s -> Wave.sampledTone ip ip period (take len $ iterate (1+) (0::Double)) s 0, uncurry clip (mapPair (fromIntegral, fromIntegral) $ Wave.shapeLimits ip ip (round period::Int) len)]+let len=100; period=1/0.06::Double; ip = Interpolation.linear in GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (0,fromIntegral len)) [\s -> WaveL.sampledTone ip ip period (take len $ iterate (1+) (0::Double)) s 0, limit (mapPair (fromIntegral, fromIntegral) $ shapeLimits ip ip (round period::Int) len)] -}  sampledToneStair :: (RealField.C a, Module.C a v, Eq v) =>    InterpolationTest.LinePreserving a v ->    NonNeg.Int -> NonNeg.Int -> (v,v) -> a -> Property sampledToneStair =-   withLPInterpolation $ \ ipLeap+   InterpolationTest.useLP $ \ ipLeap          periodIntNN ext (i,d) shape ->    let ipStep = Interpolation.constant        periodInt = NonNeg.toNumber periodIntNN@@ -220,12 +216,12 @@           take (negate rep) (List.iterate (period*>d+) i)        limits =           mapPair (fromIntegral, fromIntegral) $-             ToneMod.shapeLimits ipLeap ipStep periodInt len+             shapeLimits ipLeap ipStep periodInt len    in  periodInt /= zero ==>-          Wave.sampledTone ipLeap ipStep period stair shape `Wave.apply` zero ==-             i + uncurry clip limits shape *> d+          WaveL.sampledTone ipLeap ipStep period stair shape `Wave.apply` zero ==+             i + limit limits shape *> d {--let len=periodInt*rep; rep=10; periodInt = 14::Int; period=fromIntegral periodInt; ipl = Interpolation.linear; ipc = Interpolation.constant in GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (-10,10+fromIntegral len)) [\s -> Wave.sampledTone ipl ipc period (concatMap (replicate periodInt) $ take rep $ iterate (period+) (0::Double)) s 0, uncurry clip (mapPair (fromIntegral, fromIntegral) $ Wave.shapeLimits ipl ipc periodInt len)]+let len=periodInt*rep; rep=10; periodInt = 14::Int; period=fromIntegral periodInt; ipl = Interpolation.linear; ipc = Interpolation.constant in GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (-10,10+fromIntegral len)) [\s -> WaveL.sampledTone ipl ipc period (concatMap (replicate periodInt) $ take rep $ iterate (period+) (0::Double)) s 0, limit (mapPair (fromIntegral, fromIntegral) $ shapeLimits ipl ipc periodInt len)] -}  {-@@ -244,7 +240,7 @@           concat $ replicate rep $           take periodInt $ List.iterate (d+) i    in  periodInt /= zero ==>-          Wave.sampledTone ipLeap ipStep period saw shape phase ==+          WaveL.sampledTone ipLeap ipStep period saw shape phase ==              i + fraction phase *> d -} @@ -253,7 +249,7 @@    InterpolationTest.T a v ->    NonNeg.Int -> (v,[v]) -> a -> a -> Property sampledToneStatic =-   withInterpolation2 $ \ ipLeap ipStep+   InterpolationTest.use2 $ \ ipLeap ipStep          ext (x,xs) shape phase ->    let wave = x:xs        periodInt = length wave@@ -262,37 +258,27 @@        rep = negate $ div (negate len) periodInt        tone = concat $ replicate rep wave    in  period /= zero ==>-          Wave.sampledTone ipLeap ipStep period tone shape `Wave.apply` (Phase.fromRepresentative phase) ==+          WaveL.sampledTone ipLeap ipStep period tone shape `Wave.apply` (Phase.fromRepresentative phase) ==           Interpolation.cyclicPad Interpolation.single ipStep (phase*period) wave {--let wave = [1,-1,0.5,-0.5::Double]; period = fromIntegral (length wave) :: Double; ip = Interpolation.linear in GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (-1,3)) [Wave.sampledTone ip ip period (concat $ replicate 3 wave) 0.3, \phase -> Interpolation.cyclicPad Interpolation.single Interpolation.linear (phase*period) wave]+let wave = [1,-1,0.5,-0.5::Double]; period = fromIntegral (length wave) :: Double; ip = Interpolation.linear in GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (-1,3)) [WaveL.sampledTone ip ip period (concat $ replicate 3 wave) 0.3, \phase -> Interpolation.cyclicPad Interpolation.single Interpolation.linear (phase*period) wave] -}   --- candidate for Utility-zapWith :: (a -> a -> b) -> [a] -> [b]-zapWith f xs = zipWith f xs (tail xs)---- candidate for Utility-monotoniclyIncreasing :: Ord a => [a] -> Bool-monotoniclyIncreasing [] = True-monotoniclyIncreasing xs = and $ zapWith (<=) xs-- shapeFreqModFromSampledToneLimitIdentity :: (RealField.C t) =>-   InterpolationTest.T t y ->-   InterpolationTest.T t y ->-   NonNeg.Int -> (y,[y]) -> (t, [NonNeg.T t]) -> Bool-shapeFreqModFromSampledToneLimitIdentity =-   withInterpolation2 $ \ ipLeap ipStep-          periodIntNN (x,xs) (shape0,shapesNN) ->+   Interpolation.Margin ->+   Interpolation.Margin ->+   NonNeg.Int -> InfiniteList y -> (t, InfiniteList (NonNeg.T t)) -> Bool+shapeFreqModFromSampledToneLimitIdentity+      marginLeap marginStep periodIntNN ixs (shape0,shapesNN) =    let periodInt = NonNeg.toNumber periodIntNN-       shapes = map NonNeg.toNumber shapesNN-       a =-          snd (ToneMod.limitRelativeShapes-             ipLeap ipStep periodInt (List.cycle (x:xs))-             (shape0, cycle (zero:shapes))) !! 100+       shapes = fmap NonNeg.toNumber shapesNN+       a = snd+          (ToneModL.limitRelativeShapes+             marginLeap marginStep+             periodInt (listFromInfinite ixs)+             (shape0, listFromInfinite shapes)) !! 100    in  a == a  @@ -305,16 +291,16 @@        periodInt = NonNeg.toNumber periodIntNN        periodRound = fromIntegral periodInt        coords =-          ToneMod.oscillatorCoords+          ToneModL.oscillatorCoords              periodInt period              (shape0, shapes) (phase, freqs)    in  period /= zero  &&  periodInt /= zero  ==>           all              (\(skip,(k,(qShape,qWave))) ->                   skip >= zero &&-                  monotoniclyIncreasing [negate periodInt, k, zero] &&-                  monotoniclyIncreasing [zero, qShape, one] &&-                  monotoniclyIncreasing [zero, qWave, periodRound])+                  isAscending [negate periodInt, k, zero] &&+                  isAscending [zero, qShape, one] &&+                  isAscending [zero, qWave, periodRound])              (tail coords)  @@ -330,7 +316,7 @@    in  period /= zero  ==>           all              (isZero . fst . snd . snd)-             (ToneMod.oscillatorCoords+             (ToneModL.oscillatorCoords                  periodInt period (shape0, shapes) (phase, freqs))  @@ -338,86 +324,122 @@    InterpolationTest.T t v ->    InterpolationTest.T t v ->    NonNeg.T t ->-   NonNeg.Int -> (v,[v]) ->+   NonNeg.Int -> InfiniteList v ->    t -> t -> [NonNeg.T t] -> [t] ->    Property shapeFreqModFromSampledTone =-   withInterpolation2 $ \ ipLeap ipStep-         periodNN ext (x,xs) shape0 phase shapesNN freqs ->+   InterpolationTest.use2 $ \ ipLeap ipStep+         periodNN ext ixs shape0 phase shapesNN freqs ->    let shapes = map NonNeg.toNumber shapesNN        period = NonNeg.toNumber periodNN-       len = minLength ipLeap ipStep (ceiling period) ext-       tone = take len (List.cycle (x:xs))+       periodInt = round period+       len = minLength ipLeap ipStep periodInt ext+       tone = take len (listFromInfinite ixs)        resampledToneA =           Osci.shapeFreqModFromSampledTone ipLeap ipStep period tone              shape0 phase shapes freqs        resampledToneB =           Osci.shapeFreqMod-             (Wave.sampledTone ipLeap ipStep period tone)+             (WaveL.sampledTone ipLeap ipStep period tone)              phase (scanl (+) shape0 shapes) freqs    in  period /= zero  ==>           resampledToneA == resampledToneB {--let len=100; period=1/0.06::Double; ip = Interpolation.linear; tone = take len $ iterate (1+) (0::Double); shape0=0; shapes = replicate 100 1; in GNUPlot.plotLists [] [Osci.shapeFreqMod (Wave.sampledTone ip ip period tone) 0 (scanl (+) shape0 shapes) (repeat 0), Osci.shapeFreqModFromSampledTone ip ip period tone shape0 0 shapes (repeat 0)]-*Test.Sound.Synthesizer.Plain.Oscillator> let len=100; period=1/0.06::Double; ip = Interpolation.linear; tone = take len $ iterate (1+) (0::Double); shape0=0; shapes = concat $ replicate 50 [1.5,0.5]; in GNUPlot.plotLists [] [Osci.shapeFreqMod (Wave.sampledTone ip ip period tone) 0 (scanl (+) shape0 shapes) (repeat 0), Osci.shapeFreqModFromSampledTone ip ip period tone shape0 0 shapes (repeat 0)]-*Test.Sound.Synthesizer.Plain.Oscillator> let len=100; period=1/0.06::Rational; ipLeap = Interpolation.linear; ipStep = Interpolation.constant; tone = take len $ iterate (1+) (0::Rational); shape0=0; shapes = concat $ replicate 50 [1.5,0.5]; in GNUPlot.plotLists [] (map (map (\x -> fromRational' x :: Double)) [Osci.shapeFreqMod (Wave.sampledTone ipLeap ipStep period tone) 0 (scanl (+) shape0 shapes) (repeat 0), Osci.shapeFreqModFromSampledTone ipLeap ipStep period tone shape0 0 shapes (repeat 0)])+let len=100; period=1/0.06::Double; ip = Interpolation.linear; tone = take len $ iterate (1+) (0::Double); shape0=0; shapes = replicate 100 1; in GNUPlot.plotLists [] [Osci.shapeFreqMod (WaveL.sampledTone ip ip period tone) 0 (scanl (+) shape0 shapes) (repeat 0), Osci.shapeFreqModFromSampledTone ip ip period tone shape0 0 shapes (repeat 0)]+*Test.Sound.Synthesizer.Plain.Oscillator> let len=100; period=1/0.06::Double; ip = Interpolation.linear; tone = take len $ iterate (1+) (0::Double); shape0=0; shapes = concat $ replicate 50 [1.5,0.5]; in GNUPlot.plotLists [] [Osci.shapeFreqMod (WaveL.sampledTone ip ip period tone) 0 (scanl (+) shape0 shapes) (repeat 0), Osci.shapeFreqModFromSampledTone ip ip period tone shape0 0 shapes (repeat 0)]+*Test.Sound.Synthesizer.Plain.Oscillator> let len=100; period=1/0.06::Rational; ipLeap = Interpolation.linear; ipStep = Interpolation.constant; tone = take len $ iterate (1+) (0::Rational); shape0=0; shapes = concat $ replicate 50 [1.5,0.5]; in GNUPlot.plotLists [] (map (map (\x -> fromRational' x :: Double)) [Osci.shapeFreqMod (WaveL.sampledTone ipLeap ipStep period tone) 0 (scanl (+) shape0 shapes) (repeat 0), Osci.shapeFreqModFromSampledTone ipLeap ipStep period tone shape0 0 shapes (repeat 0)]) -} -oscillatorCells :: (RealField.C t, Eq v) =>++shapePhaseFreqModFromSampledTone :: (RealField.C t, Eq v) =>    InterpolationTest.T t v ->    InterpolationTest.T t v ->    NonNeg.T t ->-   NonNeg.Int -> (v,[v]) ->-   t -> t -> [NonNeg.T t] -> [t] ->+   NonNeg.Int -> InfiniteList v ->+   t -> t -> [NonNeg.T t] -> [t] -> [t] ->    Property-oscillatorCells =-   withInterpolation2 $ \ ipLeap ipStep-         periodNN ext (x,xs) shape0 phase shapesNN freqs ->+shapePhaseFreqModFromSampledTone =+   InterpolationTest.use2 $ \ ipLeap ipStep+         periodNN ext ixs shape0 phase shapesNN phaseDistorts freqs ->    let shapes = map NonNeg.toNumber shapesNN        period = NonNeg.toNumber periodNN-       len = minLength ipLeap ipStep (ceiling period) ext-       tone = take len (List.cycle (x:xs))-       crop = cropCell ipLeap ipStep+       periodInt = round period+       len = minLength ipLeap ipStep periodInt ext+       tone = take len (listFromInfinite ixs)        resampledToneA =-          ToneMod.oscillatorCells ipLeap ipStep period tone+          Osci.shapePhaseFreqModFromSampledTone ipLeap ipStep period tone+             shape0 phase shapes phaseDistorts freqs+       resampledToneB =+          Osci.shapeFreqMod+             (uncurry $+                Wave.phaseOffset .+                WaveL.sampledTone ipLeap ipStep period tone)+             phase (zip (scanl (+) shape0 shapes) phaseDistorts) freqs+   in  period /= zero  ==>+          resampledToneA == resampledToneB+++oscillatorCells :: (RealField.C t, Eq v) =>+   Interpolation.Margin ->+   Interpolation.Margin ->+   NonNeg.Int ->+   NonNeg.T t ->+   NonNeg.Int -> InfiniteList v ->+   t -> t -> [NonNeg.T t] -> [t] ->+   Property+oscillatorCells+      marginLeap marginStep periodIntNN periodNN ext ixs shape0 phase shapesNN freqs =+   let shapes = map NonNeg.toNumber shapesNN+       period    = NonNeg.toNumber periodNN+       periodInt = NonNeg.toNumber periodIntNN+       len = minLengthMargin marginLeap marginStep periodInt ext+       tone = take len (listFromInfinite ixs)+       crop = cropCell marginLeap marginStep+       resampledToneA =+          ToneModL.oscillatorCells+             marginLeap marginStep periodInt period tone              (shape0, shapes) (Phase.fromRepresentative phase, freqs)        resampledToneB =           Osci.shapeFreqMod-             (Wave.Cons . ToneMod.sampledToneCell-                (ToneMod.makePrototype ipLeap ipStep period tone))+             (Wave.Cons . ToneModL.sampledToneCell+                (ToneModL.makePrototype marginLeap marginStep+                    periodInt period tone))              phase (scanl (+) shape0 shapes) freqs-   in  period /= zero  ==>+   in  period /= zero  &&+       periodInt /= zero  &&+       marginNumber marginLeap > zero &&+       marginNumber marginStep > zero  ==>           map crop resampledToneA == map crop resampledToneB  cropCell ::-   Interpolation.T t v ->-   Interpolation.T t v ->-   ((t,t),[[v]]) -> ((t,t),[[v]])-cropCell ipLeap ipStep (q,cell) =-   (q,-      take (Interpolation.number ipStep) $-      map (take (Interpolation.number ipLeap)) $-      cell)+   Interpolation.Margin ->+   Interpolation.Margin ->+   ((t,t), ToneModL.Cell v) -> ((t,t), ToneModL.Cell v)+cropCell ipLeap ipStep =+   mapSnd+      (take (marginNumber ipStep) .+       map (take (marginNumber ipLeap)))   shapeFreqModFromSampledToneIdentity :: (RealField.C t, Eq v) =>    InterpolationTest.T t v ->    InterpolationTest.T t v ->    NonNeg.T t ->-   NonNeg.Int -> (v,[v]) ->+   NonNeg.Int -> InfiniteList v ->    Property shapeFreqModFromSampledToneIdentity =-   withInterpolation2 $ \ ipLeap ipStep-          periodNN ext (x,xs) ->+   InterpolationTest.use2 $ \ ipLeap ipStep+          periodNN ext ixs ->    let period = NonNeg.toNumber periodNN-       len = minLength ipLeap ipStep (ceiling period) ext-       tone = take len (List.cycle (x:xs))+       periodInt = round period+       len = minLength ipLeap ipStep periodInt ext+       tone = take len (listFromInfinite ixs)        shape0 = zero        shapes = repeat one        phase  = zero        freqs  = repeat (recip period)        (n0,n1) =-          ToneMod.shapeLimits ipLeap ipStep (round period) len+          shapeLimits ipLeap ipStep periodInt len         resampledTone =           Osci.shapeFreqModFromSampledTone ipLeap ipStep period tone@@ -426,20 +448,8 @@           and (drop n0 (take (succ n1) (zipWith (==) resampledTone tone)))  -testRationalLineIp :: Testable test =>-   (InterpolationTest.LinePreserving Rational Rational -> test) -> IO ()-testRationalLineIp f  =  test f--testRationalIp :: Testable test =>-   (InterpolationTest.T Rational Rational -> test) -> IO ()-testRationalIp f  =  test f-- tests :: [(String, IO ())] tests =-   ("untangleShapePhase",-      test (\periodInt period ->-                untangleShapePhase periodInt (period :: Rational))) :    ("limitMinRelativeValues", test limitMinRelativeValues) :    ("limitMaxRelativeValues", test limitMaxRelativeValues) :    ("limitMaxRelativeValuesNonNeg",@@ -454,9 +464,7 @@                               test limitMaxRelativeValuesInfinity) :    ("limitMaxRelativeValuesNonNegInfinity",                               test limitMaxRelativeValuesNonNegInfinity) :-   ("dropRem",                test (dropRem :: Int -> [Double] -> Bool)) :-   ("sampledTone",-      testRationalIp sampledTone) :+   ("dropRem",                test (dropRem :: NonNeg.Int -> [ArbChar] -> Bool)) :    ("sampledToneSine",       test (\period -> sampledToneSine (period :: NonNeg.Double))) :    ("sampledToneSineList",@@ -472,7 +480,9 @@    ("sampledToneStatic",       testRationalIp sampledToneStatic) :    ("shapeFreqModFromSampledToneLimitIdentity",-      testRationalIp shapeFreqModFromSampledToneLimitIdentity) :+      test (\ml ms p ixs (t,ts) ->+          shapeFreqModFromSampledToneLimitIdentity ml ms p+             (ixs::InfiniteList Rational) (t::Rational,ts))) :    ("oscillatorCoords",       test (\periodInt period ->                oscillatorCoords@@ -483,8 +493,12 @@                   periodInt (period :: NonNeg.Rational))) :    ("shapeFreqModFromSampledTone",       testRationalIp shapeFreqModFromSampledTone) :+   ("shapePhaseFreqModFromSampledTone",+      testRationalIp shapePhaseFreqModFromSampledTone) :    ("oscillatorCells",-      testRationalIp oscillatorCells) :+      test (\ml ms periodInt period ext ixs ->+               oscillatorCells ml ms periodInt (period :: NonNeg.Rational)+                  ext (ixs :: InfiniteList ArbChar))) :    ("shapeFreqModFromSampledToneIdentity",       testRationalIp shapeFreqModFromSampledToneIdentity) :    []
src/Test/Utility.hs view
@@ -1,11 +1,13 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} module Test.Utility where --- import Test.QuickCheck (Arbitrary(..))+import Test.QuickCheck (Arbitrary(..))  import qualified Algebra.Real                  as Real import qualified Algebra.Ring                  as Ring +import qualified Data.Char as Char+ import PreludeBase import NumericPrelude @@ -31,3 +33,15 @@        s = sum xs    in  sum (map (\x -> abs (n*x-s)) xs)  <=  eps ++-- see event-list++newtype ArbChar = ArbChar Char+   deriving (Eq, Ord)++instance Show ArbChar where+   showsPrec n (ArbChar c) = showsPrec n c++instance Arbitrary ArbChar where+   arbitrary = fmap (ArbChar . Char.chr . (32+) . flip mod 96) arbitrary+   coarbitrary = undefined
+ src/TruncatedSine.hs view
@@ -0,0 +1,57 @@+module TruncatedSine where++{- Fourier series of a sine of fractional frequency -}++import Graphics.Gnuplot.Simple (plotFuncs, linearScale, )+import qualified FourierSeries as FS++{- these are sine series -}+fourierSeriesRecip, fourierSeriesSincc :: Floating a => a -> [a]+fourierSeriesRecip = fourierSeries recip+fourierSeriesSincc = fourierSeries sincc1++fourierSeriesOddRat :: Floating a => a -> a -> [a]+fourierSeriesOddRat a = fourierSeries (oddRat a)++fourierSeries :: Floating a => (a -> a) -> a -> [a]+fourierSeries rec w =+   zipWith (\d0 d1 -> rec d0 - rec d1)+           (iterate (2+) w) (iterate (subtract 2) w)++{- This continously differentiable function+   is 1/x for all integral x, but 0 at position 0 -}+sincc1 :: Floating a => a -> a+sincc1 0 = 0+sincc1 t =+   let pit = pi*t+   in  (pit - sin pit) / (pit*t)++oddRat :: Fractional a => a -> a -> a+oddRat a t = a*t / (1+a*t*t)++plotRecip, plotSincc, plotSinccAngle, plotOddRat :: IO ()+plotRecip =+   plotFuncs [] (linearScale 300 (0, 2*pi))+                (map (\s -> FS.evalSineL (take 1000+                               (fourierSeriesRecip (s::Double))))+                     (linearScale 6 (1,3)))++plotSincc =+   plotFuncs [] (linearScale 300 (0, 2*pi))+                (map (\s -> FS.evalSineL (take 1000+                               (fourierSeriesSincc (s::Double))))+                     (linearScale 6 (1,3)))++plotSinccAngle =+   plotFuncs [] (linearScale 300 (0, 2*pi))+                (map (\s t -> acos (2/pi *+                             FS.evalSineL (take 1000+                               (fourierSeriesSincc (s::Double))) t) {- - t/2 -})+                     (linearScale 6 (1,3)))+++plotOddRat =+   plotFuncs [] (linearScale 300 (0, 2*pi))+                (map (\s -> FS.evalSineL (take 1000+                               (fourierSeriesOddRat 2 (s::Double))))+                     (linearScale 6 (1,3)))
synthesizer.cabal view
@@ -1,11 +1,10 @@ Name:           synthesizer-Version:        0.0.3+Version:        0.2 License:        GPL License-File:   LICENSE Author:         Henning Thielemann <haskell@henning-thielemann.de> Maintainer:     Henning Thielemann <haskell@henning-thielemann.de> Homepage:       http://www.haskell.org/haskellwiki/Synthesizer-Package-URL:    http://darcs.haskell.org/synthesizer/ Category:       Sound Synopsis:       Audio signal processing coded in Haskell Description:@@ -15,20 +14,34 @@    abstract from the sample rate and are really fast    due to StorableVector, Stream-like list type and aggressive inlining.    For an interface to Haskore see <http://darcs.haskell.org/haskore-synthesizer/>.-   For an introduction see @doc/Prologue.txt@.+   For introductory examples see "Synthesizer.Plain.Tutorial"+   and "Synthesizer.Generic.Tutorial".+   For an overview of the organization of the package+   and the discussion of various design issues see "Synthesizer.Overview". Stability:      Experimental Tested-With:    GHC==6.4.1, GHC==6.8.2-Cabal-Version:  >=1.2+Cabal-Version:  >=1.6 Build-Type:     Simple  Extra-Source-Files:   Makefile   src/OsciDiffEq.hs-  doc/Prologue.txt+  src-3/Synthesizer/Causal/Process.hs+  src-4/Synthesizer/Causal/Process.hs+  src-4/Synthesizer/Inference/DesignStudy/Applicative.hs+  src-4/Synthesizer/Inference/DesignStudy/Monad.hs+  src-4/Synthesizer/Inference/DesignStudy/Arrow.hs  Flag splitBase   description: Choose the new smaller, split-up base package. +Flag category+  description: Check whether Arrow class is split into Arrow and Category.++Flag optimizeAdvanced+  description: Enable advanced optimizations. They slow down compilation considerably.+  default:     True+ Flag buildExamples   description: Build example executables   default:     False@@ -42,60 +55,85 @@   default:     False  +Source-Repository this+  Tag:         0.2+  Type:        darcs+  Location:    http://darcs.haskell.org/synthesizer/++Source-Repository head+  Type:        darcs+  Location:    http://darcs.haskell.org/synthesizer/+ Library   Build-Depends:-    mtl >=1.1 && <1.2,-    event-list >=0.0.6 && <0.1,-    non-negative >=0.0.1 && <0.1,-    numeric-prelude >=0.0.4 && <0.1,+    transformers >=0.0.1 && <0.2,+    event-list >=0.0.8 && <0.1,+    non-negative >=0.0.5 && <0.1,+    numeric-prelude >=0.1.1 && <0.2,+    utility-ht >=0.0.5 && <0.1,+    storable-record >=0.0.1 && <0.1,+    sox >=0.0 && <0.1,+    gnuplot >=0.2 && <0.4,     -- numeric-quest/Orthogonals is only needed by Filter.Graph-    numeric-quest,+    numeric-quest >= 0.1 && <0.2,     -- bytestring and binary are only needed by SpeedTest     bytestring >= 0.9 && <0.10,     binary >=0.1 && <1,-    storablevector >=0.1.3,+    storablevector >=0.2.2 && <0.3,+    filepath >=1.1 && <1.2,+--    for ST.Lazy.read     -- QuickCheck is needed for Filter.Delay.Block     QuickCheck >=1 && <2 -  If flag(splitBase)+  If flag(category)+    Hs-Source-Dirs: src-4     Build-Depends:-      base >= 3, array >=0.1 && <0.2, containers >=0.1 && <0.2, random >=1.0 && <1.1, process >=1.0 && <1.1, unix >=2.3 && <2.4+      base >= 4 && <5,+      array >=0.1 && <0.3,+      containers >=0.1 && <0.3,+      random >=1.0 && <2.0,+      process >=1.0 && <1.1+    Other-Modules:+      Synthesizer.Inference.DesignStudy.Applicative+      Synthesizer.Inference.DesignStudy.Arrow+      Synthesizer.Inference.DesignStudy.Monad   Else-    Build-Depends:-      base >= 1.0 && < 2, special-functors+    Hs-Source-Dirs: src-3+    If flag(splitBase)+      Build-Depends:+        base >= 3 && <4,+        array >=0.1 && <0.3,+        containers >=0.1 && <0.3,+        random >=1.0 && <2.0,+        process >=1.0 && <1.1+    Else+      Build-Depends:+        base >= 1.0 && < 2,+        special-functors >= 1.0 && <1.1    GHC-Options:    -Wall   Hs-source-dirs: src   Exposed-modules:-    Sound.Signal-    Sound.Signal.Block-    Sound.Signal.StrictBlock-    -- further implementations of Signal class are in the Synthesizer.*.Signal modules-    StorableInstance-    BinarySample-    Filter.Basic-    Filter.Composition-    Filter.Example-    Filter.Fix-    Filter.Graph-    Filter.Graphic-    Filter.MonadFix-    Filter.OneWay-    Filter.TwoWay-    FourierSeries-    Sox-    Sox.File-    Sox.Play-    Synthesizer.Utility+    Synthesizer.Overview+    Synthesizer.Storage+    Synthesizer.Dimensional.Overview+    Synthesizer.Inference.Overview+     Synthesizer.ApplicativeUtility     Synthesizer.Format     Synthesizer.RandomKnuth     Synthesizer.Piecewise+    Synthesizer.Basic.Binary     Synthesizer.Basic.Distortion     Synthesizer.Basic.DistortionControlled     Synthesizer.Basic.Phase+    Synthesizer.Basic.ToneModulation     Synthesizer.Basic.Wave     Synthesizer.Basic.WaveSmoothed+    Synthesizer.Interpolation+    Synthesizer.Interpolation.Class+    Synthesizer.Interpolation.Module+    Synthesizer.Interpolation.Custom     Synthesizer.Frame.Stereo     Synthesizer.Plain.Signal     Synthesizer.Plain.Analysis@@ -110,10 +148,12 @@     Synthesizer.Plain.Filter.Recursive.Chebyshev     Synthesizer.Plain.Filter.Recursive.Comb     Synthesizer.Plain.Filter.Recursive.FirstOrder+    Synthesizer.Plain.Filter.Recursive.FirstOrderComplex     Synthesizer.Plain.Filter.Recursive.Integration     Synthesizer.Plain.Filter.Recursive.Moog     Synthesizer.Plain.Filter.Recursive.MovingAverage     Synthesizer.Plain.Filter.Recursive.SecondOrder+    Synthesizer.Plain.Filter.Recursive.SecondOrderCascade     Synthesizer.Plain.Filter.Recursive.Universal     Synthesizer.Plain.Filter.Recursive.Test     Synthesizer.Plain.Filter.Delay@@ -127,11 +167,16 @@     Synthesizer.Plain.Noise     Synthesizer.Plain.Oscillator     Synthesizer.Plain.ToneModulation+    Synthesizer.Plain.Wave     Synthesizer.Plain.Miscellaneous     Synthesizer.Plain.Instrument     Synthesizer.Plain.Effect     Synthesizer.Plain.Effect.Fly     Synthesizer.Plain.Effect.Glass+    Synthesizer.Plain.Builder+    Synthesizer.Plain.IO+    Synthesizer.Plain.File+    Synthesizer.Plain.Play     Synthesizer.FusionList.Control     Synthesizer.FusionList.Filter.NonRecursive     Synthesizer.FusionList.Oscillator@@ -139,7 +184,7 @@     Synthesizer.Storable.Cut     Synthesizer.Storable.Oscillator     Synthesizer.Storable.Signal-    Synthesizer.Storable.Filter.Recursive.Comb+    Synthesizer.Storable.Instance     Synthesizer.State.Analysis     Synthesizer.State.Control     Synthesizer.State.Cut@@ -155,71 +200,46 @@     Synthesizer.State.NoiseCustom     Synthesizer.State.Oscillator     Synthesizer.State.Signal+    Synthesizer.State.ToneModulation     Synthesizer.Causal.Process     Synthesizer.Causal.Displacement     Synthesizer.Causal.Interpolation     Synthesizer.Causal.Oscillator+    Synthesizer.Causal.ToneModulation     Synthesizer.Generic.Analysis+    Synthesizer.Generic.Cut     Synthesizer.Generic.Control     Synthesizer.Generic.Displacement     Synthesizer.Generic.Filter.NonRecursive     Synthesizer.Generic.Filter.Delay     Synthesizer.Generic.Filter.Recursive.Integration     Synthesizer.Generic.Filter.Recursive.MovingAverage+    Synthesizer.Generic.Filter.Recursive.Comb     Synthesizer.Generic.Interpolation     Synthesizer.Generic.Noise     Synthesizer.Generic.Oscillator-    Synthesizer.Generic.SampledValue     Synthesizer.Generic.Signal-  ---    Synthesizer.Physical-    Synthesizer.Physical.Cut-    Synthesizer.Physical.Control-    Synthesizer.Physical.File-    Synthesizer.Physical.Filter-    Synthesizer.Physical.Noise-    Synthesizer.Physical.Oscillator-    Synthesizer.Physical.Play-    Synthesizer.Physical.Signal-    Synthesizer.Physical.Displacement-    Synthesizer.Amplitude.Signal-    Synthesizer.Amplitude.Cut-    Synthesizer.Amplitude.Control-    Synthesizer.Amplitude.Filter-    Synthesizer.Amplitude.Displacement-    Synthesizer.SampleRateContext.Rate-    Synthesizer.SampleRateContext.Signal-    Synthesizer.SampleRateContext.Oscillator-    Synthesizer.SampleRateContext.Cut-    Synthesizer.SampleRateContext.Control-    Synthesizer.SampleRateContext.Filter-    Synthesizer.SampleRateContext.Displacement-    Synthesizer.SampleRateContext.Noise-    Synthesizer.SampleRateContext.Play-    Synthesizer.Inference.DesignStudy.Applicative-    Synthesizer.Inference.DesignStudy.Arrow-    Synthesizer.Inference.DesignStudy.Monad-    Synthesizer.Inference.Func.Cut-    Synthesizer.Inference.Func.Signal-    Synthesizer.Inference.Reader.Play-    Synthesizer.Inference.Reader.Process-    Synthesizer.Inference.Reader.Signal-    Synthesizer.Inference.Reader.Control-    Synthesizer.Inference.Reader.Cut-    Synthesizer.Inference.Reader.Filter-    Synthesizer.Inference.Reader.Noise-    Synthesizer.Inference.Reader.Oscillator-  --+    Synthesizer.Generic.Signal2+    Synthesizer.Generic.Wave+     Synthesizer.Dimensional.Abstraction.Flat     Synthesizer.Dimensional.Abstraction.Homogeneous+    Synthesizer.Dimensional.Abstraction.HomogeneousGen     Synthesizer.Dimensional.Abstraction.RateIndependent+    Synthesizer.Dimensional.Amplitude     Synthesizer.Dimensional.Amplitude.Analysis     Synthesizer.Dimensional.Amplitude.Cut     Synthesizer.Dimensional.Amplitude.Control     Synthesizer.Dimensional.Amplitude.Displacement     Synthesizer.Dimensional.Amplitude.Filter     Synthesizer.Dimensional.Amplitude.Signal+    Synthesizer.Dimensional.Arrow+    Synthesizer.Dimensional.Map     Synthesizer.Dimensional.Causal.Process+    Synthesizer.Dimensional.Causal.ControlledProcess+    Synthesizer.Dimensional.Causal.Displacement+    Synthesizer.Dimensional.Causal.Filter+    Synthesizer.Dimensional.Causal.Oscillator     Synthesizer.Dimensional.ControlledProcess     Synthesizer.Dimensional.Cyclic.Signal     Synthesizer.Dimensional.Process@@ -229,6 +249,7 @@     Synthesizer.Dimensional.Rate.Analysis     Synthesizer.Dimensional.Rate.Control     Synthesizer.Dimensional.Rate.Cut+    Synthesizer.Dimensional.Rate.Dirac     Synthesizer.Dimensional.Rate.Filter     Synthesizer.Dimensional.Rate.Oscillator     Synthesizer.Dimensional.RateAmplitude.Analysis@@ -244,19 +265,84 @@     Synthesizer.Dimensional.Straight.Displacement     Synthesizer.Dimensional.Straight.Signal +  -- historical and experimental modules+    Synthesizer.Filter.Basic+    Synthesizer.Filter.Composition+    Synthesizer.Filter.Example+    Synthesizer.Filter.Fix+    Synthesizer.Filter.Graph+    Synthesizer.Filter.Graphic+    Synthesizer.Filter.MonadFix+    Synthesizer.Filter.OneWay+    Synthesizer.Filter.TwoWay++    -- this approach is replaced by Generic modules+    -- but we may still define an UArray instance of Generic classes+    Sound.Signal+    Sound.Signal.Block+    Sound.Signal.StrictBlock++    Synthesizer.Physical+    Synthesizer.Physical.Cut+    Synthesizer.Physical.Control+    Synthesizer.Physical.File+    Synthesizer.Physical.Filter+    Synthesizer.Physical.Noise+    Synthesizer.Physical.Oscillator+    Synthesizer.Physical.Play+    Synthesizer.Physical.Signal+    Synthesizer.Physical.Displacement+    Synthesizer.Amplitude.Signal+    Synthesizer.Amplitude.Cut+    Synthesizer.Amplitude.Control+    Synthesizer.Amplitude.Filter+    Synthesizer.Amplitude.Displacement+    Synthesizer.SampleRateContext.Rate+    Synthesizer.SampleRateContext.Signal+    Synthesizer.SampleRateContext.Oscillator+    Synthesizer.SampleRateContext.Cut+    Synthesizer.SampleRateContext.Control+    Synthesizer.SampleRateContext.Filter+    Synthesizer.SampleRateContext.Displacement+    Synthesizer.SampleRateContext.Noise+    Synthesizer.SampleRateContext.Play+    -- that's only exposed for Haddock+    Synthesizer.Plain.Tutorial+    Synthesizer.Generic.Tutorial++  Other-Modules:+    TruncatedSine+    FourierSeries+    Synthesizer.Utility+ Executable demonstration   If !flag(buildExamples)     Buildable: False-  GHC-Options: -Wall -O2 -fexcess-precision -fvia-C -optc-O2+  GHC-Options: -Wall -fexcess-precision+  If flag(optimizeAdvanced)+    GHC-Options: -O2 -fvia-C -optc-O2 -- -ddump-simpl-stats   Hs-Source-Dirs: src-  Main-Is: Synthesizer/Dimensional/RateAmplitude/Demonstration.hs+  If flag(category)+    Hs-Source-Dirs: src-4+  Else+    Hs-Source-Dirs: src-3+  Main-Is:+    Demonstration.hs+  Other-Modules:+    Synthesizer.Dimensional.RateAmplitude.Demonstration  Executable traumzauberbaum   If !flag(buildExamples)     Buildable: False-  GHC-Options: -Wall -O2 -fexcess-precision -fvia-C -optc-O2+  GHC-Options: -Wall -fexcess-precision+  If flag(optimizeAdvanced)+    GHC-Options: -O2 -fvia-C -optc-O2   Hs-Source-Dirs: src+  If flag(category)+    Hs-Source-Dirs: src-4+  Else+    Hs-Source-Dirs: src-3   Main-Is: Synthesizer/Dimensional/RateAmplitude/Traumzauberbaum.hs  Executable test@@ -264,6 +350,10 @@     Buildable: False   GHC-Options: -Wall   Hs-Source-Dirs: src+  If flag(category)+    Hs-Source-Dirs: src-4+  Else+    Hs-Source-Dirs: src-3   Other-Modules:     Test.Utility     Test.Sound.Synthesizer.Plain.Analysis@@ -273,22 +363,36 @@     Test.Sound.Synthesizer.Plain.Oscillator     Test.Sound.Synthesizer.Plain.ToneModulation     Test.Sound.Synthesizer.Plain.Wave+    Test.Sound.Synthesizer.Basic.ToneModulation+    Test.Sound.Synthesizer.Generic.ToneModulation   Main-Is: Test/Main.hs  Executable fusiontest   If !flag(buildProfilers)     Buildable: False-  GHC-Options: -Wall -fexcess-precision -ddump-simpl-stats+  GHC-Options: -Wall -fexcess-precision+  If flag(optimizeAdvanced)+    GHC-Options: -ddump-simpl-stats   Hs-Source-Dirs: speedtest, src+  If flag(category)+    Hs-Source-Dirs: src-4+  Else+    Hs-Source-Dirs: src-3   Main-Is: FusionTest.hs  Executable speedtest   If !flag(buildProfilers)     Buildable: False-  GHC-Options: -Wall -fexcess-precision -optc-ffast-math -optc-O3+  GHC-Options: -Wall -fexcess-precision+  If flag(optimizeAdvanced)+    GHC-Options: -optc-ffast-math -optc-O3   --  -funfolding-use-threshold=20 -funfolding-creation-threshold=100   --  -optc-march=pentium4 -optc-mfpmath=sse   Hs-Source-Dirs: speedtest, src+  If flag(category)+    Hs-Source-Dirs: src-4+  Else+    Hs-Source-Dirs: src-3   Main-Is: SpeedTest.hs  Executable speedtest-exp@@ -296,6 +400,10 @@     Buildable: False   GHC-Options: -Wall -fexcess-precision   Hs-Source-Dirs: speedtest, src+  If flag(category)+    Hs-Source-Dirs: src-4+  Else+    Hs-Source-Dirs: src-3   Main-Is: SpeedTestExp.hs   If flag(splitBase)     Build-Depends:@@ -306,4 +414,8 @@     Buildable: False   GHC-Options: -Wall   Hs-Source-Dirs: speedtest, src+  If flag(category)+    Hs-Source-Dirs: src-4+  Else+    Hs-Source-Dirs: src-3   Main-Is: SpeedTestSimple.hs