packages feed

synthesizer-core 0.3.1 → 0.4

raw patch · 137 files changed

+1946/−4381 lines, 137 filesdep +deepseqdep +stream-fusiondep ~basedep ~event-listdep ~non-negative

Dependencies added: deepseq, stream-fusion

Dependency ranges changed: base, event-list, non-negative, numeric-prelude, sample-frame-np, sox

Files

− speedtest/FusionTest.hs 
@@ -1,819 +0,0 @@-{-# OPTIONS_GHC -O2 #-}-module Main (main) where--import qualified Synthesizer.Storable.Signal as SigSt-import qualified Synthesizer.Storable.Oscillator as OsciSt-import qualified Synthesizer.Storable.Cut as CutSt--import qualified Synthesizer.State.Signal as SigS-import qualified Synthesizer.State.Oscillator as OsciS-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.NoiseCustom as NoiseS-import qualified Synthesizer.State.Interpolation as InterpolationS--import qualified Synthesizer.FusionList.Signal as SigFL-import qualified Synthesizer.FusionList.Oscillator as OsciFL-import qualified Synthesizer.FusionList.Control as CtrlFL-import qualified Synthesizer.FusionList.Filter.NonRecursive as FiltNRFL--import qualified Synthesizer.Generic.Signal as SigG-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-import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter-import qualified Synthesizer.Plain.Filter.Recursive    as FiltR-import qualified Synthesizer.Plain.Control as Ctrl-import Synthesizer.Piecewise ((|#), (#|-), (-|#), (#|), )--import qualified Data.EventList.Relative.TimeBody as EventList--import Synthesizer.Basic.Binary (int16FromCanonical, int16FromDouble, )-import Data.Int (Int8, Int16, )-import Foreign.Storable (Storable, )-import qualified Data.List as List-import qualified Data.Char as Char--import GHC.Float (double2Int, int2Double)-import NumericPrelude ((^?))-import qualified NumericPrelude as NP--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 System.Random (mkStdGen)-import qualified Synthesizer.RandomKnuth as Knuth---{--If you increase the chunk size to 10000 the computation becomes slower.-Is this reproducable?--}-defaultChunkSize :: SigSt.ChunkSize-defaultChunkSize = SigSt.chunkSize 1000---{-# INLINE storableFromFusionList #-}-storableFromFusionList :: Storable a => SigFL.T a -> SigSt.T a-storableFromFusionList =-   SigFL.toStorableSignal defaultChunkSize---   SigSt.fromFusionList defaultChunkSize--mapTest0 :: SigSt.T Char-mapTest0 =-   SigSt.fromList defaultChunkSize-      (List.map succ (List.replicate 200000 'a'))--mapTest1 :: [Char] -> SigSt.T Char-mapTest1 =-   SigSt.fromList defaultChunkSize . List.map Char.toUpper--mapTest2 :: [Char] -> SigSt.T Char-mapTest2 xs =-   SigSt.fromList defaultChunkSize (List.map Char.toUpper xs)--mapTest3 :: SigSt.T Int8-mapTest3 =-   SigSt.fromList defaultChunkSize-      (List.map succ (List.replicate 200000 1234))--mapTest4 :: SigSt.T Int8-mapTest4 =-   SigSt.fromList defaultChunkSize-      (List.map pred (List.replicate 200000 1234))--mapTest5 :: SigSt.T Int8-mapTest5 =-   storableFromFusionList-      (SigFL.map pred (SigFL.replicate 200000 1234))--{- inlining here even reduces the application of rules - Why? -}-{- INLINE mapTest6 -}-mapTest6 :: SigSt.T Int16-mapTest6 =-   storableFromFusionList $ SigFL.take 200000 $-   SigFL.map int16FromCanonical $---   SigFL.map (^2) $-   SigFL.repeat (3::Double)---{-# INLINE zeroPhase #-}-zeroPhase :: Phase.T Double-zeroPhase = NP.zero--osciTest0 :: SigSt.T Int16-osciTest0 =-   storableFromFusionList $-   SigFL.take 200000 $-   -- 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 int16FromDouble $-   OsciFL.staticSaw zeroPhase 0.01--{--{-# INLINE exponential2 #-}-exponential2 :: Trans.C a =>-      a   {-^ half life -}-   -> a   {-^ initial value -}-   -> SigFL.T a-          {-^ exponential decay -}-exponential2 halfLife =-   SigFL.iterate (((Ring.one Field./ (Ring.one Additive.+ Ring.one)) Trans.^? Field.recip halfLife) Ring.*)--}---osciTest0b :: SigSt.T Int16-osciTest0b =-   storableFromFusionList $-   SigFL.take 200000 $-   SigFL.map int16FromDouble $-   FiltNRFL.envelope-      (CtrlFL.exponential2 50000 1)-      (OsciFL.staticSaw zeroPhase 0.01)--osciTest0ba :: SigSt.T Int16-osciTest0ba =-   storableFromFusionList $-   SigFL.take 200000 $-   SigFL.map int16FromDouble $-   CtrlFL.exponential2 50000 1--osciTest0c :: SigSt.T Int16-osciTest0c =-   storableFromFusionList $-   SigFL.take 200000 $-   SigFL.map int16FromDouble $-   FiltNRFL.envelope-      (CtrlFL.exponential2 50000 0.5)-      (OsciFL.shapeMod Wave.squareBalanced zeroPhase 0.01 $-          SigFL.map (0.5*) $ OsciFL.staticSine zeroPhase 0.00002)--osciTest0d :: SigSt.T Int16-osciTest0d =-   storableFromFusionList $-   SigFL.take 200000 $-   SigFL.map int16FromDouble $-   FiltNRFL.envelope---      (exponential2 50000 0.5)-      (CtrlFL.exponential2 50000 0.5)---      (SigFL.iterate ((0.5 ^? recip 50000)*) 0.5)-      (OsciFL.freqMod Wave.square zeroPhase-          (SigFL.map (0.01+) $ SigFL.map (0.0001*) $ OsciFL.staticSine zeroPhase 0.0001))--osciTest0e :: SigSt.T Int16-osciTest0e =-   storableFromFusionList $-   SigFL.take 200000 $-   SigFL.map int16FromDouble $-   FiltNRFL.envelope-      (CtrlFL.exponential2 50000 0.5)-      (OsciFL.shapeFreqMod Wave.squareBalanced zeroPhase-          (SigFL.map (0.5*) $ OsciFL.staticSine zeroPhase 0.00002)-          (SigFL.map (0.01+) $ SigFL.map (0.0001*) $ OsciFL.staticSine zeroPhase 0.0001))--osciTest0ea :: SigSt.T Int16-osciTest0ea =-   storableFromFusionList $-   SigFL.take 200000 $-   SigFL.map int16FromDouble $-      (OsciFL.shapeFreqMod Wave.squareBalanced zeroPhase-          (OsciFL.staticSine zeroPhase 0.00002)-          (OsciFL.staticSine zeroPhase 0.0001))--osciTest0f :: SigSt.T Int16-osciTest0f =-   storableFromFusionList $-   SigFL.take 200000 $-   SigFL.map int16FromDouble $-   FiltNRFL.envelope-      (CtrlFL.exponential2 50000 1)---      (SigFL.zipWith (\x y -> (x+y)/2)---      (MiscFL.mix-      (SigFL.mix-         (OsciFL.static Wave.saw zeroPhase 0.01003)-         (OsciFL.static Wave.saw zeroPhase 0.00997))--- staticSaw blocks fusion---         (OsciFL.staticSaw zeroPhase 0.01003)---         (OsciFL.staticSaw zeroPhase 0.00997))--osciTest0fa :: SigSt.T Int16-osciTest0fa =-   storableFromFusionList $-   SigFL.take 200000 $-   SigFL.map int16FromDouble $-   FiltNRFL.envelope-      (CtrlFL.exponential2 50000 1)-      (SigFL.mix-         (SigFL.mix-            (OsciFL.staticSaw zeroPhase 0.01001)-            (OsciFL.staticSaw zeroPhase 0.00998))-         (SigFL.mix-            (OsciFL.staticSaw zeroPhase 0.01005)-            (OsciFL.staticSaw zeroPhase 0.00996)))--osciTest1 :: SigSt.T Double-osciTest1 =-   storableFromFusionList $-   SigFL.take 200000 $-   (OsciFL.staticSaw zeroPhase 0.01 :: SigFL.T Double)--osciTest2 :: SigSt.T Int16-osciTest2 =-   storableFromFusionList $-   SigFL.take 200000 $-   SigFL.iterate (200+) 0--osciTest3 :: SigSt.T Double-osciTest3 =-   SigSt.take 200000 $-   SigSt.map (\x->x*x) $-   SigSt.iterate defaultChunkSize (200+) 0--osciTest4 :: SigSt.T Int16-osciTest4 =-   SigSt.take 200000 $-   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 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 int16FromDouble $-   (SigSt.iterate defaultChunkSize (1+) 0 :: SigSt.T Double)---{--waveSine :: Floating a => a -> a-waveSine x = sin (2*pi*x)--}--{--waveSine :: Trans.C a => a -> a-waveSine x = Trans.sin (NP.fromInteger 2 NP.* Trans.pi NP.* x)--incrFracDouble :: Double -> Double -> Double-incrFracDouble d x = NP.fraction (d + x)--{-# ONLINE incrFrac #-}-incrFrac :: NP.RealFrac a => a -> a -> a-incrFrac d x = NP.fraction (d NP.+ x)--fraction :: Double -> Double-fraction x =-   let second :: (Int, a) -> a-       second = snd-       f = second (properFraction x)-   in  if f>=0 then f else f+1--}--{--fraction :: Double -> Double-fraction x = x - fromIntegral (floor x :: Int)--}--{--fraction :: Double -> Double-fraction x = x - int2Double (double2Int x)--incrFracDouble :: Double -> Double -> Double-incrFracDouble d x = fraction (d + x)--}--{--incrFracDouble :: Double -> Double -> Double-incrFracDouble d x = d + x--}---osciTest7 :: SigSt.T Int16-osciTest7 =-   SigSt.take 200000 $-   SigSt.map int16FromDouble $---   SigSt.map (\x -> sin (2*pi*x)) $-   SigSt.map (Wave.apply Wave.sine) $---   SigSt.map (Wave.apply waveSine) $---   (SigSt.iterate defaultChunkSize (0.01 +) NP.zero :: SigSt.T (Phase.T Double))-   (SigSt.iterate defaultChunkSize (Phase.increment 0.01) NP.zero :: SigSt.T (Phase.T Double))---   (SigSt.iterate defaultChunkSize (incrFrac 0.01) NP.zero :: SigSt.T (Phase.T Double))---   (SigSt.iterate defaultChunkSize (incrFracDouble 0.01) NP.zero :: SigSt.T (Phase.T Double))--osciTest8 :: SigSt.T Int16-osciTest8 =-   SigSt.take 200000 $-   SigSt.map int16FromDouble $-   (OsciSt.staticSaw defaultChunkSize zeroPhase 0.01 :: SigSt.T Double)---appendTest0 :: SigSt.T Int16-appendTest0 =-   storableFromFusionList $-   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--appendTest1 :: SigSt.T Int16-appendTest1 =-   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 int16FromDouble $-       SigFL.append tone0 tone1--appendTest2 :: SigSt.T Int16-appendTest2 =-   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)--appendTest3 :: SigSt.T Int16-appendTest3 =-   storableFromFusionList $-   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 int16FromDouble $-   SigSt.mixSize defaultChunkSize-      (SigSt.replicate defaultChunkSize 100000 NP.zero)-      (SigSt.replicate defaultChunkSize 100001 NP.one)--mixTest3 :: SigSt.T Int16-mixTest3 =-   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)-      (storableFromFusionList $ SigFL.take 100001 $ OsciFL.static Wave.saw zeroPhase 0.015)-      (SigSt.empty)--mixTest4 :: SigSt.T Int16-mixTest4 =-   SigSt.map int16FromDouble $-   SigSt.mixSize defaultChunkSize-      (SigSt.take 100002 $ OsciSt.staticSine defaultChunkSize zeroPhase 0.020) $-   SigSt.mixSize defaultChunkSize-      (SigSt.take 100001 $ OsciSt.staticSine defaultChunkSize zeroPhase 0.010)-      (SigSt.take 100000 $ OsciSt.staticSaw  defaultChunkSize zeroPhase 0.015)---mixTest5 :: SigSt.T Int16-mixTest5 =-   SigSt.map int16FromDouble $-   SigSt.take 441000 $---   SigSt.append-   SigSt.mix---   SigSt.mixSize defaultChunkSize-      (SigSt.iterate defaultChunkSize ((1-1e-6)*) 0.5)-      (SigSt.iterate defaultChunkSize (1e-6 +) 0)--mixTest6 :: SigSt.T Int16-mixTest6 =-   SigSt.map int16FromDouble $-   SigSt.take 441000 $---   SigSt.append-   SigSt.mix---   SigSt.mixSize defaultChunkSize-      (SigS.toStorableSignal defaultChunkSize $ SigS.iterate ((1-1e-6)*) 0.5)-      (SigS.toStorableSignal defaultChunkSize $ SigS.iterate (1e-6 +) 0)---stateTest0 :: SigSt.T Int16-stateTest0 =-   SigS.toStorableSignal defaultChunkSize $-   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) $-   SigS.map sin $-   SigS.iterate ((2*pi/100)+) (0::Double)--stateTest1 :: SigSt.T Int16-stateTest1 =-   SigS.toStorableSignal defaultChunkSize $-   SigS.map int16FromDouble $-   SigS.take 100000 $-   SigS.zipWith Dist.sine (SigS.iterate ((1-0.3e-4)*) 1) $-   SigS.map (Wave.apply Wave.sine) $-   SigS.iterate (Phase.increment 0.01) zeroPhase--stateTest2 :: SigSt.T Int16-stateTest2 =-   SigS.toStorableSignal defaultChunkSize $-   SigS.map int16FromDouble $-   SigS.take 100000 $-   SigS.map (Dist.logit 1) $-   SigS.map (Dist.sine 5) $-   SigS.zipWith (*) (SigS.iterate ((1-0.3e-4)*) 30) $-   SigS.map (Wave.apply Wave.sine) $-   SigS.iterate (Phase.increment 0.01) zeroPhase--stateOsciTest0 :: SigSt.T Int16-stateOsciTest0 =-   SigS.toStorableSignal defaultChunkSize $-   SigS.take 200000 $-   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 int16FromDouble $-   OsciS.static Wave.saw zeroPhase 0.01--stateOsciTest0fa :: SigSt.T Int16-stateOsciTest0fa =-   SigS.toStorableSignal defaultChunkSize $-   SigS.take 200000 $-   SigS.map int16FromDouble $---   FiltNRS.envelope---      (CtrlS.exponential2 50000 1)-   SigS.map (0.5*) $-      (SigS.mix-         (SigS.mix-            (OsciS.static Wave.saw (Phase.fromRepresentative 0.1) 0.01001)-            (OsciS.static Wave.saw (Phase.fromRepresentative 0.7) 0.00998))-         (SigS.mix-            (OsciS.static Wave.saw (Phase.fromRepresentative 0.2) 0.01005)-            (OsciS.static Wave.saw (Phase.fromRepresentative 0.4) 0.00996)))--{-# INLINE chord #-}-chord :: SigS.T Double-chord =-   let freq = 0.005-       {-# INLINE tone #-}-       tone f =-          SigS.mix-             (SigS.mix-                (OsciS.static Wave.saw zeroPhase (f*1.001))-                (OsciS.static Wave.saw zeroPhase (f*0.998)))-             (SigS.mix-                (OsciS.static Wave.saw zeroPhase (f*1.005))-                (OsciS.static Wave.saw zeroPhase (f*0.996)))-   in  tone (freq*1.00) `SigS.mix`-       tone (freq*1.25) `SigS.mix`-       tone (freq*1.50)--stateOsciTestChord :: SigSt.T Int16-stateOsciTestChord =-   SigS.toStorableSignal defaultChunkSize $-   SigS.take 200000 $-   SigS.map int16FromDouble $-   SigS.map (0.2*) $-   chord--stateFilterTest :: SigSt.T Int16-stateFilterTest =-   SigS.toStorableSignal defaultChunkSize $-   SigS.take 200000 $-   SigS.map int16FromDouble $-   SigS.map (0.05*) $-   SigS.map UniFilter.lowpass $-   SigS.modifyModulated-      UniFilter.modifier-      (SigS.map UniFilter.parameter $-       SigS.zipWith FiltR.Pole-          (SigS.repeat (5::Double))-          (SigS.map (\f -> 0.02*3 ^? f) $-           OsciS.static Wave.fastSine2 (Phase.fromRepresentative 0.75) 0.000005)) $-   chord--stateAppendTest0 :: SigSt.T Int16-stateAppendTest0 =-   SigS.toStorableSignal defaultChunkSize $-   SigS.map int16FromDouble $-      let tone f =-             SigS.take 50000 $-             SigS.map (Wave.apply Wave.saw) $-             SigS.iterate (Phase.increment f) zeroPhase-      in  tone 0.010 `SigS.append`-          tone 0.015 `SigS.append`-          tone 0.020--stateAppendTest1 :: SigSt.T Int16-stateAppendTest1 =-   SigS.toStorableSignal defaultChunkSize $-   SigS.map int16FromDouble $-      let tone f =-             SigS.take 50000 $-             SigS.map (Wave.apply Wave.saw) $-             SigS.iterate (Phase.increment f) zeroPhase-      in  tone 0.010 `SigS.appendStored`-          tone 0.015 `SigS.appendStored`-          tone 0.020--stateAppendTest2 :: SigSt.T Int16-stateAppendTest2 =-   SigSt.map int16FromDouble $-      let tone f =-             SigS.toStorableSignal defaultChunkSize $-             SigS.take 50000 $-             SigS.map (Wave.apply Wave.saw) $-             SigS.iterate (Phase.increment f) zeroPhase-      in  tone 0.010 `SigSt.append`-          tone 0.015 `SigSt.append`-          tone 0.020--stateConcatTest0 :: SigSt.T Int16-stateConcatTest0 =-   SigS.toStorableSignal defaultChunkSize $-   SigS.map int16FromDouble $-      let tone f =-             SigS.take 50000 $-             SigS.map (Wave.apply Wave.saw) $-             SigS.iterate (Phase.increment f) zeroPhase-      in  SigS.concat $-             tone 0.010 :-             tone 0.015 :-             tone 0.020 :-             []--stateConcatTest1 :: SigSt.T Int16-stateConcatTest1 =-   SigS.toStorableSignal defaultChunkSize $-   SigS.map int16FromDouble $-      let tone f =-             SigS.take 50000 $-             SigS.map (Wave.apply Wave.saw) $-             SigS.iterate (Phase.increment f) zeroPhase-      in  SigS.concatStored $-             tone 0.010 :-             tone 0.015 :-             tone 0.020 :-             []--{-# NOINLINE storablePercTone #-}-storablePercTone :: Double -> SigSt.T Double-storablePercTone f =-   SigS.toStorableSignal defaultChunkSize $-   SigS.take 22000 $-   FiltNRS.envelope (CtrlS.exponential2 10000 1) $---   OsciS.static Wave.saw zero f-   SigS.map (0.5*) $-   SigS.mix-      (OsciS.static Wave.saw zeroPhase (f*0.999))-      (OsciS.static Wave.saw zeroPhase (f*1.001))--storableConcatTest :: SigSt.T Int16-storableConcatTest =-   SigSt.map int16FromDouble $-   SigSt.concat $-   take 13 $-   map storablePercTone $-   iterate (* 2^?(1/12)) 0.005--storableArrangeTest :: SigSt.T Int16-storableArrangeTest =-   SigSt.map int16FromDouble $-   SigSt.map (0.5*) $-   CutSt.arrange defaultChunkSize $-   foldr (EventList.cons 4000) (EventList.empty) $---   foldr (EventList.cons 4000) (EventList.pause 0) $-   take 25 $-   map storablePercTone $-   iterate (* 2^?(1/12)) 0.005---- This is much faster than Arrange.--- about 2 seconds-storableConcatInfTest :: SigSt.T Int16-storableConcatInfTest =-   SigSt.map int16FromDouble $-   SigSt.map (0.5*) $-   SigSt.concat $-   take 110 $-   map storablePercTone $-   iterate (* 2^?(1/12)) 0.002---- about 5-6 seconds-storableArrangeInfTest :: SigSt.T Int16-storableArrangeInfTest =-   SigSt.map int16FromDouble $-   SigSt.map (0.5*) $-   SigSt.take 440000 $-   CutSt.arrange defaultChunkSize $-   foldr (EventList.cons 4000) (EventList.empty) $-   map storablePercTone $-   iterate (* 2^?(1/12)) 0.002----statePercTone :: Double -> SigS.T Double-statePercTone f =-   SigS.take 22000 $-   FiltNRS.envelope (CtrlS.exponential2 10000 1) $---   OsciS.static Wave.saw zeroPhase f-   SigS.map (0.5*) $-   SigS.mix-      (OsciS.static Wave.saw zeroPhase (f*0.999))-      (OsciS.static Wave.saw zeroPhase (f*1.001))--stateArrangeInfTest :: SigSt.T Int16-stateArrangeInfTest =-   SigS.toStorableSignal defaultChunkSize $-   SigS.map int16FromDouble $-   SigS.map (0.5*) $-   SigS.take 440000 $-   CutS.arrange $-   foldr (EventList.cons 4000) (EventList.empty) $-   map statePercTone $-   iterate (* 2^?(1/12)) 0.002---{-# INLINE fastSine2 #-}-fastSine2 :: (Ord a, Ring.C a, Num a) => a -> a-fastSine2 x =-   if 2*x<1-     then 1 - NP.sqr (4*x-1)-     else NP.sqr (4*x-3) - 1--fastSineTest :: SigSt.T Int16-fastSineTest =-   SigS.toStorableSignal defaultChunkSize $-   SigS.map int16FromDouble $-   SigS.take 440000 $---   OsciS.static Wave.sine zeroPhase $---   OsciS.static Wave.fastSine4 zeroPhase $-   OsciS.static Wave.fastSine2 zeroPhase $---   OsciS.static fastSine2 zeroPhase $-   0.01---{-# INLINE stateBubbles #-}-stateBubbles :: SigS.T Double-stateBubbles =-   OsciS.freqMod Wave.sine zeroPhase $-   SigS.map (\p -> 0.01 * exp(-p)) $-   SigS.mix-      (SigS.map (1.5*) $ OsciS.static Wave.saw zeroPhase 0.00001)-      (SigS.map (0.5*) $ OsciS.static Wave.saw zeroPhase 0.0002)--stateBubblesTest :: SigSt.T Int16-stateBubblesTest =-   SigS.toStorableSignal defaultChunkSize $-   SigS.map int16FromDouble $-   SigS.take 440000 $-   stateBubbles--storableCombTest :: SigSt.T Int16-storableCombTest =-   SigSt.map int16FromDouble $-   SigSt.delayLoopOverlap 11000 (SigSt.map (0.5*)) $-   SigS.toStorableSignal defaultChunkSize $---   SigS.append (statePercTone 0.01) (SigS.replicate 40000 0)-   SigS.take 440000 $-   SigS.map (0.5*) $-   stateBubbles---storableTakeTest :: SigSt.T Int16-storableTakeTest =-   SigSt.take 440000 $-   SigS.toStorableSignal defaultChunkSize $-   SigS.map int16FromDouble $-   OsciS.static Wave.saw zeroPhase 0.01---stateNoiseTest :: SigSt.T Int16-stateNoiseTest =-   SigS.toStorableSignal defaultChunkSize $-   SigS.take 440000 $-   SigS.map int16FromDouble $-   SigS.map (0.3*) $-   SigS.map UniFilter.lowpass $-   SigS.modifyModulated-      UniFilter.modifier-      (SigS.map UniFilter.parameter $-       SigS.zipWith FiltR.Pole-          (SigS.repeat (10::Double))-          (SigS.map (\f -> 0.02*3 ^? f) $-           OsciS.static Wave.sine (Phase.fromRepresentative 0.75) 0.000005)) $---   NoiseS.whiteGen (mkStdGen 1)-   NoiseS.whiteGen (Knuth.cons 1)---stateADSRTest :: SigSt.T Int16-stateADSRTest =-   SigS.toStorableSignal defaultChunkSize $-   SigS.map int16FromDouble $-   FiltNRS.envelope-      (CtrlS.piecewise-          (0    |#  (5000, CtrlS.cubicPiece 0.001 0) #|--           0.5 -|# (40000, CtrlS.stepPiece) #|--           0.5 -|#  (8000, CtrlS.exponentialPiece 0) #|-           0.01)) $-   OsciS.static Wave.saw zeroPhase 0.01---phaserTest :: SigSt.T Int16-phaserTest =-   SigSt.take 440000 $-   SigSt.map int16FromDouble $-   SigSt.map (0.5*) $-   (\noise ->-       SigSt.mix-          noise-          (DelayG.modulated InterpolationM.linear (-500)-             (SigS.toStorableSignal defaultChunkSize-                (SigS.map-                   (\x -> 100*(2+x) :: Double)-                   (OsciS.static Wave.sine zeroPhase 0.00001)))-             noise)) $-   SigS.toStorableSignal defaultChunkSize $---   OsciS.static Wave.saw zeroPhase 0.01-   NoiseS.whiteGen (Knuth.cons 1)---phaserTest0 :: SigSt.T Int16-phaserTest0 =-   SigSt.take 440000 $-   SigSt.map int16FromDouble $-   DelayG.modulated InterpolationM.constant (-500)-      (SigSt.repeat defaultChunkSize (142::Double)) $-   SigSt.repeat defaultChunkSize (23::Double)---phaserTest1 :: SigSt.T Int16-phaserTest1 =-   SigSt.take 440000 $-   SigSt.map int16FromDouble $---   SigG.mapTails (maybe 0 fst . SigSt.viewL . SigSt.drop 100) $-{--   (\noise ->-       SigSt.mix-          (SigG.zipWithTails-             (\n -> maybe 0 fst . SigSt.viewL . SigSt.drop (div n 50))-             (SigG.iterate succ 0) noise)-          noise) $--}-{--   SigG.zipWithTails-      (\n -> maybe 0 fst . SigSt.viewL . SigSt.drop (div n 50))-      (SigG.iterate succ 0) $--}-   (\noise -> SigSt.mix noise noise) $-   SigS.toStorableSignal defaultChunkSize $-   NoiseS.whiteGen (Knuth.cons 1)----main :: IO ()-main =-   do SigSt.writeFile "storable-fusion.sw" phaserTest-      -- SigSt.writeFile "storable-fusion.sw" stateFilterTest-      -- SigSt.writeFile "storable-fusion.sw" osciTest4-      -- SigSt.writeFile "storable-fusion.sw" mapTest5---{--show highlighted core output--ghc-core -o dist/build/fusiontest/fusiontest -O -Wall -fexcess-precision -package synthesizer speedtest/FusionTest.hs--use installed synthesizer package--ghc -o dist/build/fusiontest/fusiontest -O -Wall -fexcess-precision -ddump-simpl-stats -package synthesizer speedtest/FusionTest.hs--ghc -o dist/build/fusiontest/fusiontest -O -Wall -fexcess-precision -ddump-simpl-stats -ddump-simpl -package synthesizer speedtest/FusionTest.hs >dist/build/fusiontest/FusionTest.log---with make and no explicit package specification:--ghc -Idist/build -o dist/build/fusiontest/fusiontest --make -Wall -O2 -fexcess-precision -ddump-simpl-stats -i -idist/build/autogen -isrc -odir dist/build/fusiontest/fusiontest-tmp -hidir dist/build/fusiontest/fusiontest-tmp src/FusionTest.hs--with make and explicit package specification:--ghc -Idist/build -o dist/build/fusiontest/fusiontest --make -Wall -O2 -fexcess-precision -hide-all-packages -i -idist/build/autogen -isrc -odir dist/build/fusiontest/fusiontest-tmp -hidir dist/build/fusiontest/fusiontest-tmp -package base-1.0 -package mtl-1.0 -package non-negative-0.0.2 -package numeric-prelude-0.0.3 -package event-list-0.0.7 -package Haskore-0.0.2 -package HTam-0.0 -package numeric-quest-0.1 -package bytestring-0.9.0.5 -package binary-0.4.1 -package storablevector-0.1 -package UniqueLogicNP-0.0 -package QuickCheck-1.0 src/FusionTest.hs--without make and with detailed simplifier report:--ghc -Idist/build -o dist/build/fusiontest/fusiontest -Wall -O2 -fexcess-precision -ddump-simpl-stats -ddump-simpl-iterations -ddump-asm -i -idist/build/autogen -isrc -idist/build/fusiontest/fusiontest-tmp -odir dist/build/fusiontest/fusiontest-tmp -hidir dist/build/fusiontest/fusiontest-tmp -package base-1.0 -package mtl-1.0 -package non-negative-0.0.2 -package numeric-prelude-0.0.3 -package event-list-0.0.7 -package Haskore-0.0.2 -package HTam-0.0 -package numeric-quest-0.1 -package bytestring-0.9.0.5 -package binary-0.4.1 -package storablevector-0.1 -package UniqueLogicNP-0.0 -package QuickCheck-1.0 dist/build/HSsynthesizer*.o src/FusionTest.hs--ghc -Idist/build -o dist/build/fusiontest/fusiontest -Wall -O2 -fexcess-precision -ddump-simpl-stats -ddump-simpl-iterations -i -idist/build/autogen -isrc -idist/build/fusiontest/fusiontest-tmp -odir dist/build/fusiontest/fusiontest-tmp -hidir dist/build/fusiontest/fusiontest-tmp -package base-1.0 -package mtl-1.0 -package non-negative-0.0.2 -package numeric-prelude-0.0.3 -package event-list-0.0.7 -package Haskore-0.0.2 -package HTam-0.0 -package numeric-quest-0.1 -package bytestring-0.9.0.5 -package binary-0.4.1 -package storablevector-0.1 -package UniqueLogicNP-0.0 -package QuickCheck-1.0 dist/build/HSsynthesizer*.o src/FusionTest.hs >src/FusionTest.log--ghc-6.8.2 -Idist/build -o dist/build/fusiontest/fusiontest -Wall -O2 -fexcess-precision -ddump-simpl-stats -ddump-simpl-iterations -i -idist/build/autogen -isrc -idist/build/fusiontest/fusiontest-tmp -odir dist/build/fusiontest/fusiontest-tmp -hidir dist/build/fusiontest/fusiontest-tmp -package base -package mtl -package non-negative -package numeric-prelude -package event-list -package Haskore -package HTam -package numeric-quest -package bytestring -package binary -package storablevector -package UniqueLogicNP -package QuickCheck dist/build/HSsynthesizer*.o src/FusionTest.hs >src/FusionTest.log--}
speedtest/SpeedTest.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} module Main (main) where  -- import BinarySample (numToInt16)@@ -26,8 +26,8 @@ import Data.Maybe.HT (toMaybe, ) import Data.List.HT (sliceVertical, ) -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric  import qualified Prelude as P98 @@ -132,7 +132,7 @@ numToInt x = round (32767 * clip (-1) 1 x)  -- from BinarySample--- return type could be Int16, but that is not well supported by NumericPrelude+-- return type could be Int16, but that is not well supported by NumericPrelude.Numeric numToInt16 :: (RealField.C a) => a -> Int16 numToInt16 = P98.fromIntegral . numToInt
src/Synthesizer/ApplicativeUtility.hs view
@@ -4,6 +4,7 @@ import Control.Applicative (Applicative, (<*>), (<$>), liftA2, ) import Data.Traversable (Traversable, sequenceA, ) +import Control.Arrow (Arrow, (<<<), ) import Control.Monad.Fix (fix, )  @@ -56,8 +57,9 @@ -- ($::) f arg sr = f sr (map ($sr) arg)  {-# INLINE (.:) #-}-(.:) :: (Applicative f) => f (b -> c) -> f (a -> b) -> f (a -> c)-(.:) = liftA2 (.)+(.:) :: (Applicative f, Arrow arrow) =>+   f (arrow b c) -> f (arrow a b) -> f (arrow a c)+(.:) = liftA2 (<<<) -- (.:) f g sr x = f sr (g sr x) -- (.:) f g sr x = ($:) f (flip g x) sr @@ -68,8 +70,9 @@ -- ($^) f x = pure f $: x  {-# INLINE (.^) #-}-(.^) :: (Functor f) => (b -> c) -> f (a -> b) -> f (a -> c)-(.^) f = fmap (f.)+(.^) :: (Functor f, Arrow arrow) =>+   arrow b c -> f (arrow a b) -> f (arrow a c)+(.^) f = fmap (f <<<) -- (.^) f = (.:) (pure f)  {-# INLINE ($#) #-}@@ -82,7 +85,8 @@ Our signal processors have types like @f (a -> b -> c)@. They could also have the type @a -> b -> f c@ or @f a -> f b -> f c@.-We did not choose the last variant for reduction of redundancy in type signatures,+We did not choose the last variant for reduction of redundancy in type signatures+and for simplifying sharing, and we did not choose the second variant for easy composition of processors. However the forms are freely convertible, and if you prefer the last one because you do not want to sprinkle '($:)' in your code,
src/Synthesizer/Basic/Binary.hs view
@@ -12,7 +12,7 @@  import qualified Algebra.ToInteger as ToInteger import qualified Algebra.RealField as RealField-import qualified Algebra.Real      as Real+import qualified Algebra.RealRing  as RealRing import qualified Algebra.Field     as Field import qualified Algebra.Ring      as Ring @@ -23,8 +23,8 @@  import qualified Prelude as P98 -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   @@ -77,7 +77,7 @@  {-# INLINE fromCanonicalWith #-} fromCanonicalWith ::-   (Real.C real, Bounded int, ToInteger.C int) =>+   (RealRing.C real, Bounded int, ToInteger.C int) =>    (real -> int) -> (real -> int) fromCanonicalWith rnd r =    let s = fromIntegral (maxBound `asTypeOf` i)@@ -99,7 +99,7 @@ scale16 x = 32767 * limit (-1, 1) x  {-# INLINE int16FromCanonical #-}-int16FromCanonical :: (RealField.C a) => a -> Int16+int16FromCanonical :: (RealRing.C a) => a -> Int16 {- The round procedure is complicated and usually unnecessary int16FromCanonical = (P98.fromIntegral :: Int -> Int16) . round . scale16@@ -108,7 +108,7 @@ int16FromCanonical = round . scale16 -} int16FromCanonical =-   (P98.fromIntegral :: Int -> Int16) . truncate . (0.5+) . scale16+   (P98.fromIntegral :: Int -> Int16) . RealRing.roundSimple . scale16  {-# INLINE int16FromFloat #-} int16FromFloat :: Float -> Int16
src/Synthesizer/Basic/ComplexModule.hs view
@@ -9,8 +9,8 @@ import Algebra.Module ((*>), )  import qualified Prelude as P--- import PreludeBase-import NumericPrelude+-- import NumericPrelude.Base+import NumericPrelude.Numeric   {-# INLINE scale #-}
src/Synthesizer/Basic/Distortion.hs view
@@ -1,22 +1,33 @@ {-# LANGUAGE NoImplicitPrelude #-}+{- |+The distortion functions have slope 1 at zero,+if they are differentiable at that point, at all.+This ensures that signals with low amplitude+are only slightly altered.+Non-differentiable distortions try to have an overall slope of 1.+-} module Synthesizer.Basic.Distortion (    clip, logit,    zigZag, sine,+   oddChebyshev, {- swing, -}    quantize,    ) where  import qualified Algebra.Transcendental        as Trans import qualified Algebra.RealField             as RealField import qualified Algebra.Field                 as Field-import qualified Algebra.Real                  as Real+import qualified Algebra.RealRing                  as RealRing import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive  import Data.Ord.HT (limit, ) +import Data.List.HT (mapAdjacent, )+import Data.List ((!!), map, iterate, take, foldl, {- tail, (++), zipWith, -} )+ -- import qualified Prelude as P--- import PreludeBase-import NumericPrelude+-- import NumericPrelude.Base+import NumericPrelude.Numeric   {- * Clipping -}@@ -24,7 +35,7 @@ {- | limit, fuzz booster -}-clip :: (Real.C a) => a -> a+clip :: (RealRing.C a) => a -> a clip = limit (negate one, one)  {- |@@ -57,6 +68,77 @@ sine :: (Trans.C a) => a -> a sine = sin ++{- |+Odd Chebyshev polynomial++@oddChebyshev n@ is an appropriately scaled Chebyshev polynomial of order @2*n+1@.+The argument @n@ must be non-negative.++> Graphics.Gnuplot.Simple.plotFuncs [Graphics.Gnuplot.Simple.YRange (-1,1)] (Graphics.Gnuplot.Simple.linearScale 1000 (-7,7::Double)) (List.map oddChebyshev [0..5])+-}+oddChebyshev :: (Trans.C a) => (Field.C a) => Int -> a -> a+oddChebyshev n xn =+   let order = 2*n+1+       {-+       slope of normal Chebyshev polynomials at zero is @order@+       which can be seen when considering slope of @x -> cos (order * arccos x)@+       -}+       x  = parityFlip n (xn / fromIntegral order)+       ys = 1 : x : mapAdjacent (\x0 x1 -> 2*x*x1 - x0) ys+   in  ys !! order++parityFlip :: Ring.C a => Int -> a -> a+parityFlip n x =+   if even n then x else -x+++{- |+A polynomial function with zeros at every integral point+weighted in order to equalize the local extreme points.++However, the weighting is difficult enough,+that it might be easier to use just a truncated Taylor series of sine.++We could compute a weighting denominator polynomial+by dividing our equidistant zeros polynomial by the sine series.++equidist / weight = sine+weight = equidist / sine++However we have to normalize the zeros,+thus powers of pi enter the scene+and then power series division becomes inexact.+-}+_swing :: (Trans.C a) => (Field.C a) => Int -> a -> a+_swing n x =+{-+   foldl (*) x+      (map+         (\ni ->+            let x2 = x^2+                n2 = ni^2+            in  (x2-n2)/sqrt(x2+n2))+         (take n (iterate (1+) 1)))+-}+   foldl (*) x+      (map+         (\ni ->+            let x2 = x^2+                n2 = ni^2+            in  (x2-n2)/(x2+n2))+         (take n (iterate (1+) 1)))+{-+   foldl (*) x+      (map (\ni -> (x/ni)^2-1)+         (take n (iterate (1+) 1)))+-}+{-+   let xu = iterate (1+) x+       xl = iterate (subtract 1) x+   in  foldl (*) x (take n (tail (zipWith (*) xu xl)))+-}+--   in  product (x : take n (tail xu) ++ take n (tail xl))
src/Synthesizer/Basic/DistortionControlled.hs view
@@ -10,22 +10,22 @@ import qualified Algebra.Transcendental        as Trans import qualified Algebra.RealField             as RealField import qualified Algebra.Field                 as Field-import qualified Algebra.Real                  as Real+import qualified Algebra.RealRing                  as RealRing import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive  import Data.Ord.HT (limit, )  -- import qualified Prelude as P--- import PreludeBase-import NumericPrelude+-- import NumericPrelude.Base+import NumericPrelude.Numeric  {- * Clipping -}  {- | limit, fuzz booster -}-clip :: (Real.C a) => a -> a -> a+clip :: (RealRing.C a) => a -> a -> a clip c = limit (negate c, c)  {- |
src/Synthesizer/Basic/Phase.hs view
@@ -7,14 +7,14 @@     multiply,    ) where -import qualified Algebra.RealField             as RealField+import qualified Algebra.RealRing              as RealRing import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive  import qualified Algebra.ToInteger             as ToInteger  import System.Random (Random(..))-import Test.QuickCheck (Arbitrary(..), choose)+import Test.QuickCheck (Arbitrary(arbitrary), choose)  import Foreign.Storable (Storable(..), ) import Foreign.Ptr (castPtr, )@@ -22,9 +22,9 @@ -- import Data.Function.HT (powerAssociative, ) import Data.Tuple.HT (mapFst, ) -import qualified NumericPrelude as NP-import NumericPrelude-import PreludeBase+import qualified NumericPrelude.Numeric as NP+import NumericPrelude.Numeric+import NumericPrelude.Base import Prelude ()  import qualified GHC.Float as GHC@@ -60,8 +60,8 @@   {-# INLINE fromRepresentative #-}-fromRepresentative :: RealField.C a => a -> T a-fromRepresentative = Cons . RealField.fraction+fromRepresentative :: RealRing.C a => a -> T a+fromRepresentative = Cons . RealRing.fraction  {-# INLINE toRepresentative #-} toRepresentative :: T a -> a@@ -69,20 +69,20 @@  {- test, how fast the function can be, if we assume that the increment is smaller than one {-# INLINE increment #-}-increment :: RealField.C a => a -> T a -> T a+increment :: RealRing.C a => a -> T a -> T a increment d = (+ Cons d)  {-# INLINE decrement #-}-decrement :: RealField.C a => a -> T a -> T a+decrement :: RealRing.C a => a -> T a -> T a decrement d = Additive.subtract (Cons d) -}  {-# INLINE increment #-}-increment :: RealField.C a => a -> T a -> T a+increment :: RealRing.C a => a -> T a -> T a increment d = lift (d Additive.+)  {-# INLINE decrement #-}-decrement :: RealField.C a => a -> T a -> T a+decrement :: RealRing.C a => a -> T a -> T a decrement d = lift (Additive.subtract d)  @@ -104,7 +104,7 @@    Cons $ if x==zero then zero else one-x  {-# INLINE multiply #-}-multiply :: (RealField.C a, ToInteger.C b) => b -> T a -> T a+multiply :: (RealRing.C a, ToInteger.C b) => b -> T a -> T a multiply n = lift (NP.fromIntegral n Ring.*)  {-@@ -121,7 +121,7 @@ > Phase.fromRepresentative 0.999999999825377  {-# INLINE multiplyPrecise #-}-multiplyPrecise :: (RealField.C a, ToInteger.C b) => b -> T a -> T a+multiplyPrecise :: (RealRing.C a, ToInteger.C b) => b -> T a -> T a multiplyPrecise n x =    if n<zero      then powerAssociative (+) zero (neg x) (fromIntegral (negate n))@@ -129,7 +129,7 @@ -}  -instance RealField.C a => Additive.C (T a) where+instance RealRing.C a => Additive.C (T a) where    {-# INLINE zero #-}    {-# INLINE (+) #-}    {-# INLINE (-) #-}@@ -148,14 +148,14 @@ -}  {-# INLINE lift #-}-lift :: (RealField.C b) =>+lift :: (RealRing.C b) =>    (a -> b) -> T a -> T b lift f =    fromRepresentative . f . toRepresentative  {- {-# INLINE lift2 #-}-lift2 :: (RealField.C c) =>+lift2 :: (RealRing.C c) =>    (a -> b -> c) -> T a -> T b -> T c lift2 f x y =    fromRepresentative (f (toRepresentative x) (toRepresentative y))
src/Synthesizer/Basic/ToneModulation.hs view
@@ -8,14 +8,14 @@ -- import qualified Algebra.Transcendental        as Trans import qualified Algebra.RealField             as RealField import qualified Algebra.Field                 as Field--- import qualified Algebra.Real                  as Real+-- import qualified Algebra.RealRing                  as RealRing import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive -import NumericPrelude+import NumericPrelude.Numeric  -- import qualified Prelude as P-import PreludeBase+import NumericPrelude.Base   {- |
src/Synthesizer/Basic/Wave.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {- |-Copyright   :  (c) Henning Thielemann 2006+Copyright   :  (c) Henning Thielemann 2006-2010 License     :  GPL  Maintainer  :  synthesizer@henning-thielemann.de@@ -24,7 +24,8 @@ import qualified Algebra.Algebraic             as Algebraic import qualified Algebra.Module                as Module import qualified Algebra.Field                 as Field-import qualified Algebra.Real                  as Real+import qualified Algebra.RealRing              as RealRing+import qualified Algebra.Absolute              as Absolute import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive import qualified Algebra.ToInteger             as ToInteger@@ -32,11 +33,13 @@ import qualified MathObj.Polynomial as Poly import qualified Number.Complex     as Complex +import qualified Control.Applicative as App+ import Data.Bool.HT (select, if', )-import NumericPrelude+import NumericPrelude.Numeric  -- import qualified Prelude as P-import PreludeBase+import NumericPrelude.Base   {- * Definition and construction -}@@ -89,15 +92,29 @@    s *> w = distort (s*>) w  +instance Functor (T t) where+   {-# INLINE fmap #-}+   fmap = distort++instance App.Applicative (T t) where+   {-# INLINE pure #-}+   pure y = Cons (const y)+   {-# INLINE (<*>) #-}+   Cons f <*> Cons y = Cons (\t -> f t (y t))++ {- | Turn an unparametrized waveform into a parametrized one, where the parameter is a phase offset. This way you express a phase modulated oscillator using a shape modulated oscillator.++@flip phaseOffset@ could have also be named @rotateLeft@,+since it rotates the wave to the left. -} {- disabled SPECIALISE phaseOffset :: (T Double b) -> (Double -> T Double b) -} {-# INLINE phaseOffset #-}-phaseOffset :: (RealField.C a) => T a b -> (a -> T a b)+phaseOffset :: (RealRing.C a) => T a b -> (a -> T a b) phaseOffset (Cons wave) offset =    Cons (wave . Phase.increment offset) @@ -124,21 +141,74 @@  {- | Approximation of sine by parabolas.-Surprisingly not really faster than 'sine'.+Surprisingly it is not really faster than 'sine'.+The wave results from integrating the 'triangle' wave,+thus it the @k@-th harmonic has amplitude @recip (k^3)@. -} {-# INLINE fastSine2 #-} fastSine2 :: (Ord a, Ring.C a) => T a a fastSine2 = fromFunction $ \x ->    if 2*x<1+     then -8*x*(2*x-1)+     else 8*(2*x-1)*(x-1)+{-+   if 2*x<1      then 1 - sqr (4*x-1)      else sqr (4*x-3) - 1+-} +{-# INLINE fastSine2Alt #-}+fastSine2Alt :: (RealRing.C a) => T a a+fastSine2Alt =+   distort (\x -> 4*x*(1-abs x)) saw+ {- |-Approximation of sine by fourth order polynomials.+Piecewise third order polynomial approximation by integrating 'fastSine2'. -}+{-# INLINE fastSine3 #-}+fastSine3 :: (Ord a, Ring.C a) => T a a+fastSine3 = fromFunction $ \x ->+   if' (4*x<1) (2* x   *(3 - (4* x   )^2)) $+   if' (4*x>3) (2*(x-1)*(3 - (4*(x-1))^2)) $+   (1-2*x) * (3 - (4*x-2)^2)+{-+   if' (4*x<1) ((4*x+1)^2*(1-2*x) - 1) $+   if' (4*x>3) ((4*x-3)^2*(3-2*x) - 1) $+   (1 - 2*(4*x-1)^2*(1-x))+-}++{-# INLINE fastSine3Alt #-}+fastSine3Alt :: (RealRing.C a, Field.C a) => T a a+fastSine3Alt =+   distort (\x -> 0.5*x * (3 - x^2)) triangle++{- |+Piecewise fourth order polynomial approximation by integrating 'fastSine3'.+-} {-# INLINE fastSine4 #-}-fastSine4 :: (Ord a, Trans.C a) => T a a+fastSine4 :: (Ord a, Field.C a) => T a a fastSine4 = fromFunction $ \x ->+   let x2 = 2*x+   in  if x2<1+         then 16/5*x2*(x2-1)*(x2^2-x2-1)+         else 16/5*(2-x2)*(x2-1)*(x2^2-3*x2+1)++{-# INLINE fastSine4Alt #-}+fastSine4Alt :: (RealRing.C a, Field.C a) => T a a+fastSine4Alt =+   distort+      (\x ->+         let ax = 1 - abs x+         in  16/5*ax*x*(1+ax-ax^2))+      saw++{- |+Least squares approximation of sine by fourth order polynomials+computed with MuPad.+-}+{-# INLINE fastSine4LeastSquares #-}+fastSine4LeastSquares :: (Ord a, Trans.C a) => T a a+fastSine4LeastSquares = fromFunction $ \x ->    -- minimal least squares fit    let pi2 = pi*pi        pi3 = pi2*pi@@ -156,10 +226,94 @@ -}  {--GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (0,1::Double)) [sine, fastSine2, fastSine4]+GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (0,1::Double)) $ map (\f t -> apply f (Phase.fromRepresentative t)) [sine, fastSine2, fastSine3, fastSine4, fastSine4LeastSquares] -} +{- |+The coefficient of the highest power is the reciprocal of an element from+http://www.research.att.com/~njas/sequences/A000111+and the polynomial coefficients are+http://www.research.att.com/~njas/sequences/A119879 . +> mapM_ print $ map (\p -> fmap ((round :: Rational -> Integer) . (/last(Poly.coeffs p))) p) (take 10 $ fastSinePolynomials)+-}+{-# INLINE fastSinePolynomials #-}+fastSinePolynomials :: (Field.C a) => [Poly.T a]+fastSinePolynomials =+   concatMap (\(p0,p1) -> [p0,p1]) $+   iterate+      (\(_,p1) ->+         let integrateNormalize p =+                let pint = Poly.integrate zero p+                in  fmap (/ Poly.evaluate pint one) pint+             p2 = one - integrateNormalize p1+             p3 = integrateNormalize p2+         in  (p2,p3))+      (one, Poly.fromCoeffs [zero, one])+{-+GNUPlot.plotFuncs [] (GNUPlot.linearScale 100 (-1,1::Double)) (map Poly.evaluate $ take 8 fastSinePolynomials)+-}++{-# INLINE fastSines #-}+fastSines :: (RealField.C a) => [T a a]+fastSines =+   zipWith ($)+      (cycle+         [\p ->+             {- square and (overtone 2 saw) could be generated in one go+                using splitFraction -}+             App.liftA2 (*) square $+                distort (Poly.evaluate p) $+                overtone (2::Int) saw,+          \p -> distort (Poly.evaluate p) triangle])+      fastSinePolynomials+{-+GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (-2,2::Double)) $ map (\w t -> apply w (Phase.fromRepresentative t)) (take 10 fastSines)+-}++{- |+This is a helix that is distorted in phase+such that is a purely rational function.+It is guaranteed that the magnitude of the wave is one.+For the distortion factor @recip pi@ you get the closest approximation+to an undistorted helix.+We have chosen this scaling in order to stay with field operations.+-}+{-# INLINE rationalHelix1 #-}+rationalHelix1 :: Field.C a => a -> T a (Complex.T a)+rationalHelix1 k = fromFunction $ \t ->+   let num = k * (2*t-1)+       den = (1-t)*t+   in  negate $+       Complex.scale (recip (den^2+num^2))+          ((den^2-num^2) Complex.+: (2*den*num))+{-+GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (0,5::Double)) $ map (. apply (rationalHelix1 (recip pi)) . Phase.fromRepresentative) [Complex.real, Complex.imag]+-}++rationalHelix1Alt :: Field.C a => a -> T a (Complex.T a)+rationalHelix1Alt k = fromFunction $ \t ->+   negate $ helixFromTangent (k * (recip (1-t) - recip t))++{- |+Here we distort the rational helix in phase+using tangent approximations by a sum of 2*n reciprocal functions.+For the tangent function we obtain perfect cosine and sine,+thus for @k = recip pi@ and high @n@ we approach an undistorted complex helix.+-}+{-# INLINE rationalHelix #-}+rationalHelix :: Field.C a => Int -> a -> T a (Complex.T a)+rationalHelix n k = fromFunction $ \t ->+   negate $ helixFromTangent $ (* negate k) $ sum $ take n $+   zipWith (\d0 d1 -> recip (t + d0) + recip (t + d1))+      (tail $ iterate (subtract 1) 0)+      (iterate (1+) 0)++{-# INLINE helixFromTangent #-}+helixFromTangent :: Field.C a => a -> Complex.T a+helixFromTangent t =+   Complex.scale (recip (1+t^2)) ((1-t^2) Complex.+: (2*t))+ {- | saw tooth, it's a ramp down in order to have a positive coefficient for the first partial sine -}@@ -175,7 +329,7 @@ The formula is derived from 'sawComplex'. -} {-# INLINE sawCos #-}-sawCos :: (Real.C a, Trans.C a) => T a a+sawCos :: (RealRing.C a, Trans.C a) => T a a sawCos = fromFunction $ \x -> log (2 * sin (pi*x)) * (-2/pi)  {- |@@ -191,7 +345,7 @@    T a (Complex.T a) sawComplex = fromFunction $ \x -> log (1 + Complex.cis (-pi*(1-2*x))) * (-2/pi) {--GNUPlot.plotFuncs [] (GNUPlot.linearScale 100 (0,1::Double)) [Complex.real . sawComplex, sawCos]+GNUPlot.plotFuncs [] (GNUPlot.linearScale 100 (0,1::Double)) [Complex.real . apply sawComplex . Phase.fromRepresentative, apply sawCos . Phase.fromRepresentative]  GNUPlot.plotFuncs [] (GNUPlot.linearScale 100 (0,1::Double)) [sawCos, composedHarmonics (take 20 $ harmonic 0 0 : map (\n -> harmonic 0.25 ((2/pi) / fromInteger n)) [1..])] -}@@ -199,7 +353,7 @@ {- Matching implementation that do not match 'saw' exactly. -sawCos :: (Real.C a, Trans.C a) => T a a+sawCos :: (RealRing.C a, Trans.C a) => T a a sawCos = fromFunction $ \x -> log (2 * abs (cos (pi*x)))  sawComplex ::@@ -256,7 +410,15 @@ GNUPlot.plotFuncs [] (GNUPlot.linearScale 100 (0,1::Double)) [squareCos, composedHarmonics (take 20 $ zipWith (\b n -> harmonic 0.25 (if b then (4/pi) / fromInteger n else 0)) (cycle [False,True]) [0..])] -} +{-+The harmonics 0,0,1,0,-1,0,1,0,-1 etc.+would lead to tangent function wave.+This can be derived from dividing+the series for sine by the series for cosine:+   [-1, _0_, 1] / [1, _0_, 1]+-} + {- | triangle -} {- disabled SPECIALISE triangle :: Double -> Double -} {-# INLINE triangle #-}@@ -368,17 +530,17 @@ normalizes the mapping over @[-1,1]@ to L2 norm of 1. -} {-# INLINE powerNormed #-}-powerNormed :: (Real.C a, Trans.C a) => a -> T a a+powerNormed :: (Absolute.C a, Trans.C a) => a -> T a a powerNormed p = fromFunction $ \x -> power01Normed p (2*x-1)  -- | auxiliary {-# INLINE power01Normed #-}-power01Normed :: (Real.C a, Trans.C a) => a -> a -> a+power01Normed :: (Absolute.C a, Trans.C a) => a -> a -> a power01Normed p x = (p+0.5) * powerSigned p x  -- | auxiliary {-# INLINE powerSigned #-}-powerSigned :: (Real.C a, Trans.C a) => a -> a -> a+powerSigned :: (Absolute.C a, Trans.C a) => a -> a -> a powerSigned p x = signum x * abs x ** p  @@ -406,7 +568,7 @@ Interpolation between 'sine' and 'square'. -} {-# INLINE sineSquare #-}-sineSquare :: (Real.C a, Trans.C a) =>+sineSquare :: (RealRing.C a, Trans.C a) =>       a {- ^ 0 for 'sine', 1 for 'square' -}    -> T a a sineSquare c =@@ -533,6 +695,21 @@ affineComb phase (x0,x1) = (1-phase)*x0 + phase*x1  +{- |+Harmonics of a saw wave that is smoothed by a Gaussian lowpass filter.+This can also be used to interpolate between saw wave and sine.+The parameter is the cutoff-frequency+defined as the standard deviation of the Gaussian in frequency space.+That is, high values approximate a saw and need many harmonics,+whereas low values tend to a sine and need only few harmonics.+-}+sawGaussianHarmonics ::+   (RealField.C a, Trans.C a) => a -> [Harmonic a]+sawGaussianHarmonics cutoff =+   (harmonic zero 0 :) $+   map (\n -> harmonic zero (exp (-(n/cutoff)^2 / 2) * 2 / (pi*n))) $+   iterate (1+) 1+ {- {- | Smooth saw generated by a quintic polynomial function.@@ -580,7 +757,7 @@ -} {- disabled SPECIALISE trianglePike :: Double -> Double -> Double -} {-# INLINE trianglePike #-}-trianglePike :: (Real.C a, Field.C a) =>+trianglePike :: (RealRing.C a, Field.C a) =>       a  {- ^ pike width ranging from 0 to 1, 1 yields 'triangle' -}    -> T a a trianglePike r = fromFunction $ \x ->@@ -593,7 +770,7 @@ -} {- disabled SPECIALISE trianglePikeShift :: Double -> Double -> Double -> Double -} {-# INLINE trianglePikeShift #-}-trianglePikeShift :: (Real.C a, Field.C a) =>+trianglePikeShift :: (RealRing.C a, Field.C a) =>       a  {- ^ pike width ranging from 0 to 1 -}    -> a  {- ^ shift ranges from -1 to 1; 0 yields 'trianglePike' -}    -> T a a@@ -608,7 +785,7 @@ -} {- disabled SPECIALISE squarePike :: Double -> Double -> Double -} {-# INLINE squarePike #-}-squarePike :: (Real.C a) =>+squarePike :: (RealRing.C a) =>       a  {- ^ pike width ranging from 0 to 1, 1 yields 'square' -}    -> T a a squarePike r = fromFunction $ \x ->@@ -621,7 +798,7 @@ -} {- disabled SPECIALISE squarePikeShift :: Double -> Double -> Double -> Double -} {-# INLINE squarePikeShift #-}-squarePikeShift :: (Real.C a) =>+squarePikeShift :: (RealRing.C a) =>       a  {- ^ pike width ranging from 0 to 1 -}    -> a  {- ^ shift ranges from -1 to 1; 0 yields 'squarePike' -}    -> T a a@@ -676,7 +853,7 @@ -} {- disabled SPECIALISE trapezoid :: Double -> Double -> Double -} {-# INLINE trapezoid #-}-trapezoid :: (Real.C a, Field.C a) =>+trapezoid :: (RealRing.C a, Field.C a) =>       a  {- ^ width of the plateau ranging from 0 to 1:               0 yields 'triangle', 1 yields 'square' -}    -> T a a@@ -692,7 +869,7 @@ -} {- disabled SPECIALISE trapezoidAsymmetric :: Double -> Double -> Double -> Double -} {-# INLINE trapezoidAsymmetric #-}-trapezoidAsymmetric :: (Real.C a, Field.C a) =>+trapezoidAsymmetric :: (RealRing.C a, Field.C a) =>       a  {- ^ sum of the plateau widths ranging from 0 to 1:               0 yields 'triangleAsymmetric',               1 yields 'squareAsymmetric' -}@@ -722,7 +899,7 @@ -} {- disabled SPECIALISE trapezoidBalanced :: Double -> Double -> Double -> Double -} {-# INLINE trapezoidBalanced #-}-trapezoidBalanced :: (Real.C a, Field.C a) => a -> a -> T a a+trapezoidBalanced :: (RealRing.C a, Field.C a) => a -> a -> T a a trapezoidBalanced w r =    raise (-w*r) $ trapezoidAsymmetric w r @@ -744,7 +921,14 @@  {- | This is similar to Polar coordinates,-but the range of the phase is from @0@ to @1@, @0@ to @2*pi@.+but the range of the phase is from @0@ to @1@, not @0@ to @2*pi@.++If you need to represent a harmonic by complex coefficients+instead of the polar representation,+then please build a complex valued polynomial from your coefficients+and use it to distort a 'helix'.++> distort (Poly.evaluate (Poly.fromCoeffs complexCoefficients)) helix -} data Harmonic a =    Harmonic {harmonicPhase :: Phase.T a, harmonicAmplitude :: a}
src/Synthesizer/Basic/WaveSmoothed.hs view
@@ -43,17 +43,17 @@ -- import qualified Algebra.RealField             as RealField import qualified Algebra.Module                as Module import qualified Algebra.Field                 as Field-import qualified Algebra.Real                  as Real+import qualified Algebra.RealRing                  as RealRing import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive  import qualified MathObj.Polynomial as Poly import qualified Number.Complex     as Complex -import NumericPrelude+import NumericPrelude.Numeric  -- import qualified Prelude as P-import PreludeBase+import NumericPrelude.Base   {- * Definition and construction -}@@ -73,14 +73,14 @@ -} {-# INLINE fromWave #-} fromWave ::-   (Field.C t, Real.C t, Additive.C y) =>+   (Field.C t, RealRing.C t, Additive.C y) =>    Wave.T t y -> (T t y) fromWave wave =    fromControlledWaveAux (\f -> if abs f >= 1/2 then zero else wave)  {-# INLINE fromControlledWave #-} fromControlledWave ::-   (Field.C t, Real.C t, Additive.C y) =>+   (Field.C t, RealRing.C t, Additive.C y) =>    (t -> Wave.T t y) -> (T t y) fromControlledWave wave =    fromControlledWaveAux (\f0 ->@@ -139,11 +139,11 @@  {- | map a phase to value of a sine wave -} {-# INLINE sine #-}-sine :: (Trans.C a, Real.C a) => T a a+sine :: (Trans.C a, RealRing.C a) => T a a sine = fromWave Wave.sine  {-# INLINE cosine #-}-cosine :: (Trans.C a, Real.C a) => T a a+cosine :: (Trans.C a, RealRing.C a) => T a a cosine = fromWave Wave.cosine  @@ -151,21 +151,21 @@ it's a ramp down in order to have a positive coefficient for the first partial sine -} {-# INLINE saw #-}-saw :: (Real.C a, Field.C a) => T a a+saw :: (RealRing.C a, Field.C a) => T a a saw =    fromControlledWave (\f -> Wave.triangleAsymmetric (2*f-1))   {- | square -} {-# INLINE square #-}-square :: (Real.C a, Field.C a) => T a a+square :: (RealRing.C a, Field.C a) => T a a square =    fromControlledWave (\f -> Wave.trapezoid (1-2*f))   {- | triangle -} {-# INLINE triangle #-}-triangle :: (Real.C a, Field.C a) => T a a+triangle :: (RealRing.C a, Field.C a) => T a a triangle = fromWave Wave.triangle  @@ -179,7 +179,7 @@ using a complex exponential as argument. -} {-# INLINE composedHarmonics #-}-composedHarmonics :: (Trans.C a, Real.C a) => [Wave.Harmonic a] -> T a a+composedHarmonics :: (Trans.C a, RealRing.C a) => [Wave.Harmonic a] -> T a a composedHarmonics hs =    let c = map (\h -> Complex.fromPolar (Wave.harmonicAmplitude h)                    (2*pi * Phase.toRepresentative (Wave.harmonicPhase h))) hs
src/Synthesizer/Causal/Cut.hs view
@@ -8,8 +8,8 @@ import Control.Monad.Trans.State (StateT(StateT), )  -- import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   {-# INLINE take #-}
src/Synthesizer/Causal/Displacement.hs view
@@ -1,16 +1,18 @@ {-# LANGUAGE NoImplicitPrelude #-} module Synthesizer.Causal.Displacement where -import qualified Synthesizer.Causal.Process as Causal+import qualified Control.Arrow as A +import qualified Algebra.Transcendental        as Trans+import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive  import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric  -{- * Mixing -}+-- * Mixing  {-| Mix two signals.@@ -18,8 +20,8 @@ that is the result is as long as the shorter of both inputs. -} {-# INLINE mix #-}-mix :: (Additive.C v) => Causal.T (v,v) v-mix = Causal.map (uncurry (+))+mix :: (Additive.C v, A.Arrow arrow) => arrow (v,v) v+mix = A.arr (uncurry (+))   {-|@@ -27,15 +29,36 @@ This is useful for adjusting the center of a modulation. -} {-# INLINE raise #-}-raise :: (Additive.C v) => v -> Causal.T v v-raise x = Causal.map (x+)+raise :: (Additive.C v, A.Arrow arrow) => v -> arrow v v+raise x = A.arr (x+)  -{- * Distortion -}+-- * Distortion {-| In "Synthesizer.Basic.Distortion" you find a collection of appropriate distortion functions. -} {-# INLINE distort #-}-distort :: (c -> a -> a) -> Causal.T (c,a) a-distort f = Causal.map (uncurry f)+distort :: (A.Arrow arrow) => (c -> a -> a) -> arrow (c,a) a+distort f = A.arr (uncurry f)++-- * Preprocessing of control curves++{-# INLINE mapLinear #-}+mapLinear :: (Ring.C a, A.Arrow arrow) =>+   a ->+   a ->+   arrow a a+mapLinear depth center =+   A.arr (\x -> center*(one+x*depth))++{-# INLINE mapExponential #-}+mapExponential :: (Trans.C a, A.Arrow arrow) =>+   a ->+   a ->+   arrow a a+mapExponential depth center =+   -- Sig.map ((center*) . (depth**))+   -- should be faster+   let logDepth = log depth+   in  A.arr ((center*) . exp . (logDepth*))
src/Synthesizer/Causal/Filter/NonRecursive.hs view
@@ -14,8 +14,8 @@ import qualified Algebra.Ring           as Ring import qualified Algebra.Additive       as Additive -import PreludeBase-import NumericPrelude as NP+import NumericPrelude.Base+import NumericPrelude.Numeric as NP -- import qualified Prelude as P
src/Synthesizer/Causal/Filter/Recursive/Integration.hs view
@@ -18,8 +18,8 @@ -- import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric
src/Synthesizer/Causal/Interpolation.hs view
@@ -21,20 +21,21 @@  import qualified Algebra.Module    as Module import qualified Algebra.RealField as RealField+import qualified Algebra.RealRing  as RealRing import qualified Algebra.Additive  as Additive  import Algebra.Additive(zero)  -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   {-* Interpolation at multiple nodes with various padding methods -}  {- | All values of frequency control must be non-negative. -} {-# INLINE relative #-}-relative :: (RealField.C t) =>+relative :: (RealRing.C t) =>    Interpolation.T t y -> t -> Sig.T y -> Causal.T t y relative ip phase0 x0 =    Causal.crochetL@@ -45,19 +46,19 @@   {-# INLINE relativeZeroPad #-}-relativeZeroPad :: (RealField.C t) =>+relativeZeroPad :: (RealRing.C t) =>    y -> Interpolation.T t y -> t -> Sig.T y -> Causal.T t y relativeZeroPad z ip phase x =    InterpolationS.zeroPad relative z ip phase x  {-# INLINE relativeConstantPad #-}-relativeConstantPad :: (RealField.C t) =>+relativeConstantPad :: (RealRing.C t) =>    Interpolation.T t y -> t -> Sig.T y -> Causal.T t y relativeConstantPad ip phase x =    InterpolationS.constantPad relative ip phase x  {-# INLINE relativeCyclicPad #-}-relativeCyclicPad :: (RealField.C t) =>+relativeCyclicPad :: (RealRing.C t) =>    Interpolation.T t y -> t -> Sig.T y -> Causal.T t y relativeCyclicPad ip phase x =    InterpolationS.cyclicPad relative ip phase x@@ -66,7 +67,7 @@ The extrapolation may miss some of the first and some of the last points -} {-# INLINE relativeExtrapolationPad #-}-relativeExtrapolationPad :: (RealField.C t) =>+relativeExtrapolationPad :: (RealRing.C t) =>    Interpolation.T t y -> t -> Sig.T y -> Causal.T t y relativeExtrapolationPad ip phase x =    InterpolationS.extrapolationPad relative ip phase x@@ -79,14 +80,14 @@  {-# INLINE relativeZeroPadConstant #-} relativeZeroPadConstant ::-   (RealField.C t, Additive.C y) =>+   (RealRing.C t, Additive.C y) =>    t -> Sig.T y -> Causal.T t y relativeZeroPadConstant =    relativeZeroPad zero IpExample.constant  {-# INLINE relativeZeroPadLinear #-} relativeZeroPadLinear ::-   (RealField.C t, Module.C t y) =>+   (RealRing.C t, Module.C t y) =>    t -> Sig.T y -> Causal.T t y relativeZeroPadLinear =    relativeZeroPad zero IpExample.linear
src/Synthesizer/Causal/Oscillator.hs view
@@ -11,6 +11,8 @@ -} module Synthesizer.Causal.Oscillator where +import qualified Synthesizer.Causal.Oscillator.Core as Osci+ import qualified Synthesizer.Basic.WaveSmoothed as WaveSmooth import qualified Synthesizer.Basic.Wave         as Wave import qualified Synthesizer.Basic.Phase        as Phase@@ -24,135 +26,119 @@  import qualified Synthesizer.Generic.Signal as SigG -import Synthesizer.State.ToneModulation (freqsToPhases, )--{--import qualified Algebra.RealTranscendental    as RealTrans-import qualified Algebra.Field                 as Field-import qualified Algebra.Module                as Module-import qualified Algebra.VectorSpace           as VectorSpace--import Algebra.Module((*>))--} import qualified Algebra.Transcendental        as Trans import qualified Algebra.RealField             as RealField+import qualified Algebra.RealRing              as RealRing import qualified Algebra.Ring                  as Ring-import qualified Algebra.Additive              as Additive -import Control.Arrow ((^<<), (<<^), (<<<), (&&&), (***), second, returnA, )+import Control.Arrow ((^<<), (<<^), (<<<), (***), second, ) -import NumericPrelude+import NumericPrelude.Numeric  import qualified Prelude as P-import PreludeBase+import NumericPrelude.Base    {- * Oscillators with arbitrary but constant waveforms -} -{-# INLINE freqToPhases #-}-freqToPhases :: RealField.C a =>-   Phase.T a -> a -> Sig.T (Phase.T a)-freqToPhases phase freq =-   Sig.iterate (Phase.increment freq) phase-- {- {-# INLINE static #-} {- | oscillator with constant frequency -}-static :: (RealField.C a) =>-    Wave.T a b -> (Phase.T a -> a -> Sig.T b)+static :: (RealRing.C a) =>+   Wave.T a b -> (Phase.T a -> a -> Sig.T b) static wave phase freq =-    Sig.map (Wave.apply wave) (freqToPhases phase freq)+   Sig.map (Wave.apply wave) (Osci.static phase freq) -}   {-# INLINE phaseMod #-} {- | oscillator with modulated phase -}-phaseMod :: (RealField.C a) =>-    Wave.T a b -> a -> Causal.T a b-phaseMod wave = shapeMod (Wave.phaseOffset wave) zero+phaseMod :: (RealRing.C a) =>+   Wave.T a b -> a -> Causal.T a b+phaseMod wave freq =+   Wave.apply wave ^<< Osci.phaseMod freq  {-# INLINE shapeMod #-} {- | oscillator with modulated shape -}-shapeMod :: (RealField.C a) =>-    (c -> Wave.T a b) -> Phase.T a -> a -> Causal.T c b+shapeMod :: (RealRing.C a) =>+   (c -> Wave.T a b) -> Phase.T a -> a -> Causal.T c b shapeMod wave phase freq =-    Causal.applySnd-       (Causal.map (uncurry (Wave.apply . wave)))-       (freqToPhases phase freq)+   uncurry (Wave.apply . wave) ^<<+   Osci.shapeMod phase freq   {-# INLINE freqMod #-} {- | oscillator with modulated frequency -}-freqMod :: (RealField.C a) =>-    Wave.T a b -> Phase.T a -> Causal.T a b+freqMod :: (RealRing.C a) =>+   Wave.T a b -> Phase.T a -> Causal.T a b freqMod wave phase =-    Causal.map (Wave.apply wave) <<< freqsToPhases phase+   Wave.apply wave ^<< Osci.freqMod phase  {-# INLINE freqModAntiAlias #-} {- | oscillator with modulated frequency -}-freqModAntiAlias :: (RealField.C a) =>-    WaveSmooth.T a b -> Phase.T a -> Causal.T a b+freqModAntiAlias :: (RealRing.C a) =>+   WaveSmooth.T a b -> Phase.T a -> Causal.T a b freqModAntiAlias wave phase =-    Causal.map (uncurry (WaveSmooth.apply wave)) <<<-    returnA &&& freqsToPhases phase+   uncurry (WaveSmooth.apply wave) ^<<+   Osci.freqModAntiAlias phase  {-# INLINE phaseFreqMod #-} {- | oscillator with both phase and frequency modulation -}-phaseFreqMod :: (RealField.C a) =>-    Wave.T a b -> Causal.T (a,a) b-phaseFreqMod wave = shapeFreqMod (Wave.phaseOffset wave) zero+phaseFreqMod :: (RealRing.C a) =>+   Wave.T a b -> Causal.T (a,a) b+phaseFreqMod wave =+   Wave.apply wave ^<< Osci.phaseFreqMod  {-# INLINE shapeFreqMod #-} {- | oscillator with both shape and frequency modulation -}-shapeFreqMod :: (RealField.C a) =>-    (c -> Wave.T a b) -> Phase.T a -> Causal.T (c,a) b+shapeFreqMod :: (RealRing.C a) =>+   (c -> Wave.T a b) -> Phase.T a -> Causal.T (c,a) b shapeFreqMod wave phase =-    Causal.map (uncurry (Wave.apply . wave)) <<<-    second (freqsToPhases phase)+   uncurry (Wave.apply . wave) ^<<+   Osci.shapeFreqMod phase   {- {- | oscillator with a sampled waveform with constant frequency-     This essentially an interpolation with cyclic padding. -}+    This essentially an interpolation with cyclic padding. -} {-# INLINE staticSample #-}-staticSample :: RealField.C a =>-    Interpolation.T a b -> Sig.T b -> Phase.T a -> a -> Sig.T b+staticSample :: RealRing.C a =>+   Interpolation.T a b -> Sig.T b -> Phase.T a -> a -> Sig.T b staticSample ip wave phase freq =-    Causal.apply (freqModSample ip wave phase) (Sig.repeat freq)+   Causal.apply (freqModSample ip wave phase) (Sig.repeat freq) -}  {- | oscillator with a sampled waveform with modulated frequency-     Should behave homogenously for different types of interpolation. -}+    Should behave homogenously for different types of interpolation. -} {-# INLINE freqModSample #-}-freqModSample :: RealField.C a =>-    Interpolation.T a b -> Sig.T b -> Phase.T a -> Causal.T a b+freqModSample :: RealRing.C a =>+   Interpolation.T a b -> Sig.T b -> Phase.T a -> Causal.T a b freqModSample ip wave phase =-    let len = Sig.length wave-        pr  = fromIntegral len * Phase.toRepresentative phase-    in  InterpolationC.relativeCyclicPad ip pr wave-          <<< Causal.map (fromIntegral len *)+   let len = Sig.length 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 :: (RealRing.C c, RealRing.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)+   uncurry Wave.apply ^<<+      (InterpolationC.relativeConstantPad ip shape0 waves ***+       Osci.freqMod 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+   (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) ^<<@@ -163,12 +149,12 @@  {-# 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+   (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@@ -199,22 +185,22 @@  {-# INLINE freqModSine #-} {- | sine oscillator with modulated frequency -}-freqModSine :: (Trans.C a, RealField.C a) => Phase.T a -> Causal.T a a+freqModSine :: (Trans.C a, RealRing.C a) => Phase.T a -> Causal.T a a freqModSine = freqMod Wave.sine  {-# INLINE phaseModSine #-} {- | sine oscillator with modulated phase, useful for FM synthesis -}-phaseModSine :: (Trans.C a, RealField.C a) => a -> Causal.T a a+phaseModSine :: (Trans.C a, RealRing.C a) => a -> Causal.T a a phaseModSine = phaseMod Wave.sine  {- {-# INLINE staticSaw #-} {- | saw tooth oscillator with modulated frequency -}-staticSaw :: RealField.C a => Phase.T a -> a -> Sig.T a+staticSaw :: RealRing.C a => Phase.T a -> a -> Sig.T a staticSaw = static Wave.saw -}  {-# INLINE freqModSaw #-} {- | saw tooth oscillator with modulated frequency -}-freqModSaw :: RealField.C a => Phase.T a -> Causal.T a a+freqModSaw :: RealRing.C a => Phase.T a -> Causal.T a a freqModSaw = freqMod Wave.saw
+ src/Synthesizer/Causal/Oscillator/Core.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+Copyright   :  (c) Henning Thielemann 2010+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++Basics for building tone generators.+They generate signals of phases+and these signals can be converted to arbitrary waveforms+by mapping them via @Wave@ objects.+This is also the fundament for dimensional oscillators.+-}+module Synthesizer.Causal.Oscillator.Core where++import qualified Synthesizer.Basic.Phase as Phase++import qualified Synthesizer.Causal.Process as Causal+import qualified Synthesizer.State.Signal as Sig++import qualified Algebra.RealRing             as RealRing+import qualified Algebra.Additive              as Additive++import Control.Arrow ((^<<), (&&&), second, returnA, )++import NumericPrelude.Numeric++import qualified Prelude as P+import NumericPrelude.Base++++{-# INLINE static #-}+static :: RealRing.C a =>+   Phase.T a -> a -> Sig.T (Phase.T a)+static phase freq =+   Sig.iterate (Phase.increment freq) phase+++{-# INLINE phaseMod #-}+{- | oscillator with modulated phase -}+phaseMod :: (RealRing.C a) =>+   a -> Causal.T a (Phase.T a)+phaseMod freq =+   uncurry Phase.increment ^<<+      Causal.feedSnd (static zero freq)++{-# INLINE shapeMod #-}+{- | oscillator with modulated shape -}+shapeMod :: (RealRing.C a) =>+   Phase.T a -> a -> Causal.T c (c, Phase.T a)+shapeMod phase freq =+   Causal.feedSnd (static phase freq)++{-# INLINE freqMod #-}+{- |+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.+-}+freqMod :: RealRing.C a =>+   Phase.T a -> Causal.T a (Phase.T a)+freqMod =+   Causal.scanL (flip Phase.increment)++{- |+Like 'freqMod' but the first element is omitted.+-}+{-# INLINE freqModSync #-}+freqModSync :: RealRing.C a =>+   Phase.T a -> Causal.T a (Phase.T a)+freqModSync =+   Causal.crochetL+      (\f p0 -> let p1 = Phase.increment f p0 in Just (p1,p1))+++{-# INLINE freqModAntiAlias #-}+{- | oscillator with modulated frequency -}+freqModAntiAlias :: (RealRing.C a) =>+   Phase.T a -> Causal.T a (a, Phase.T a)+freqModAntiAlias phase =+   returnA &&& freqMod phase++{-# INLINE phaseFreqMod #-}+{- | oscillator with both phase and frequency modulation -}+phaseFreqMod :: (RealRing.C a) =>+   Causal.T (a,a) (Phase.T a)+phaseFreqMod =+   uncurry Phase.increment ^<<+   second (freqMod zero)++{-# INLINE shapeFreqMod #-}+{- | oscillator with both shape and frequency modulation -}+shapeFreqMod :: (RealRing.C a) =>+   Phase.T a -> Causal.T (c,a) (c, Phase.T a)+shapeFreqMod phase =+   second (freqMod phase)
src/Synthesizer/Causal/ToneModulation.hs view
@@ -13,8 +13,7 @@ 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, )+import qualified Synthesizer.Causal.Oscillator.Core as Osci  {- for testing in GHCi import qualified Synthesizer.Plain.ToneModulation as ToneModL@@ -32,16 +31,16 @@ -- import qualified Algebra.Transcendental        as Trans import qualified Algebra.RealField             as RealField -- import qualified Algebra.Field                 as Field--- import qualified Algebra.Real                  as Real+-- import qualified Algebra.RealRing                  as RealRing import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive  import Control.Arrow (first, (<<<), (<<^), (^<<), (&&&), (***), ) import Control.Monad.Trans.State (state, ) -import NumericPrelude+import NumericPrelude.Numeric -- import qualified Prelude as P-import PreludeBase+import NumericPrelude.Base import Prelude ()  @@ -161,7 +160,7 @@         -- phases :: RealField.C t => Causal.T ((Int,t), t) (Phase.T t)         phase0 = Phase.decrement (scale sf0) phase         phases =-           freqsToPhasesSync phase0+           Osci.freqModSync phase0               <<^ (\(s,f) -> f - scale s)     in  (regroup sf0 phase0,          uncurry regroup@@ -189,7 +188,7 @@         scale (n,_) = fromIntegral n / period         -- phases :: RealField.C t => Causal.T ((Int,t), t) (Phase.T t)         phases =-           freqsToPhases+           Osci.freqMod               (Phase.decrement (scale sf0) phase)               <<^ (\(s,f) -> f - scale s)     in  uncurry regroup
src/Synthesizer/ChunkySize/Cut.hs view
@@ -11,7 +11,6 @@  -- 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.Pattern as SigStV import qualified Data.StorableVector.Lazy as Vector@@ -40,8 +39,8 @@ import Data.Monoid (Monoid, )  import qualified Prelude as P-import NumericPrelude-import PreludeBase hiding (splitAt, Read, )+import NumericPrelude.Numeric+import NumericPrelude.Base hiding (splitAt, Read, ) {- import Prelude    (Bool, Int, String, (++), error, const,
src/Synthesizer/ChunkySize/Signal.hs view
@@ -10,7 +10,6 @@  -- 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.Pattern as SigStV import qualified Data.StorableVector.Lazy as Vector@@ -27,7 +26,7 @@  import qualified Data.List as List --- import NumericPrelude+-- import NumericPrelude.Numeric import Prelude    (Bool, Int, Maybe(Just), fst, (.), id, )
− src/Synthesizer/Filter/Basic.hs 
@@ -1,60 +0,0 @@-{-# 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 
@@ -1,150 +0,0 @@-{-# 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 
@@ -1,243 +0,0 @@-{-# 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 
@@ -1,38 +0,0 @@-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 
@@ -1,183 +0,0 @@-{-# 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 
@@ -1,7 +0,0 @@-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 
@@ -1,44 +0,0 @@-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.Class (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 
@@ -1,76 +0,0 @@-{-# 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 
@@ -1,247 +0,0 @@-{-# 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,8 +1,34 @@+module Synthesizer.Frame.Stereo+   (T, left, right, cons, map,+    arrowFromMono, arrowFromMonoControlled, arrowFromChannels, ) where++import Sound.Frame.NumericPrelude.Stereo as Stereo+import Control.Arrow (Arrow, (^<<), (<<^), (&&&), )+import Data.Tuple.HT (mapSnd, )++import Prelude hiding (map, )++ {- |-We just re-export @Sound.Frame.NumericPrelude.Stereo@.+Run a causal process independently on each stereo channel. -}-module Synthesizer.Frame.Stereo (T, left, right, cons, map, ) where+arrowFromMono ::+   (Arrow arrow) =>+   arrow a b -> arrow (Stereo.T a) (Stereo.T b)+arrowFromMono proc =+   uncurry Stereo.cons ^<<+   (proc<<^Stereo.left) &&& (proc<<^Stereo.right) -import Sound.Frame.NumericPrelude.Stereo+arrowFromMonoControlled ::+   (Arrow arrow) =>+   arrow (c,a) b -> arrow (c, Stereo.T a) (Stereo.T b)+arrowFromMonoControlled proc =+   uncurry Stereo.cons ^<<+   (proc <<^ mapSnd Stereo.left) &&& (proc <<^ mapSnd Stereo.right) -import Prelude hiding (map, )+arrowFromChannels ::+   (Arrow arrow) =>+   arrow a b -> arrow a b -> arrow (Stereo.T a) (Stereo.T b)+arrowFromChannels leftChan rightChan =+   uncurry Stereo.cons ^<<+   (leftChan<<^Stereo.left) &&& (rightChan<<^Stereo.right)
− src/Synthesizer/FusionList/Control.hs 
@@ -1,245 +0,0 @@-{-# 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--}-module Synthesizer.FusionList.Control where--import qualified Synthesizer.Plain.Control as Ctrl-import qualified Synthesizer.Piecewise as Piecewise---- import Synthesizer.FusionList.Displacement (raise)-import qualified Synthesizer.FusionList.Signal as Sig-import Synthesizer.State.Control (splitDurations, )--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.Ring                  as Ring-import qualified Algebra.Additive              as Additive--import Algebra.Module((*>))---- import Number.Complex (cis,real)--- import qualified Number.Complex as Complex--import qualified Prelude as P-import PreludeBase-import NumericPrelude---{- * Control curve generation -}--{-# INLINE constant #-}-constant :: a -> Sig.T a-constant = Sig.repeat--{-# INLINE linear #-}-linear :: Additive.C a =>-      a   {-^ steepness -}-   -> a   {-^ initial value -}-   -> Sig.T a-          {-^ linear progression -}-linear d y0 = Sig.iterate (d+) y0--{- |-As stable as the addition of time values.--}-{-# INLINE linearMultiscale #-}-linearMultiscale :: Additive.C y =>-      y-   -> y-   -> Sig.T y-linearMultiscale = curveMultiscale (+)--{- |-Linear curve starting at zero.--}-{-# INLINE linearMultiscaleNeutral #-}-linearMultiscaleNeutral :: Additive.C y =>-      y-   -> Sig.T y-linearMultiscaleNeutral slope =-   curveMultiscaleNeutral (+) slope zero--{-# INLINE exponential #-}-{-# INLINE exponentialMultiscale #-}-exponential, exponentialMultiscale :: Trans.C a =>-      a   {-^ time where the function reaches 1\/e of the initial value -}-   -> a   {-^ initial value -}-   -> Sig.T a-          {-^ exponential decay -}-exponential time =-   Sig.iterate (exp (- recip time) *)--exponentialMultiscale time = curveMultiscale (*) (exp (- recip time))--{-# INLINE exponentialMultiscaleNeutral #-}-exponentialMultiscaleNeutral :: Trans.C y =>-      y   {-^ time where the function reaches 1\/e of the initial value -}-   -> Sig.T y {-^ exponential decay -}-exponentialMultiscaleNeutral time =-   curveMultiscaleNeutral (*) (exp (- recip time)) one---{-# INLINE exponential2 #-}-{-# INLINE exponential2Multiscale #-}-exponential2, exponential2Multiscale :: Trans.C a =>-      a   {-^ half life -}-   -> a   {-^ initial value -}-   -> Sig.T a-          {-^ exponential decay -}-exponential2 halfLife =-   Sig.iterate (((Ring.one+Ring.one) ** (- recip halfLife)) *)---   Sig.iterate (((Ring.one/(Ring.one+Ring.one)) ** recip halfLife) *)--exponential2Multiscale halfLife = curveMultiscale (*) (0.5 ** recip halfLife)--{- the 0.5 constant seems to block fusion-   Sig.iterate ((0.5 ** recip halfLife) *)--}-{- dito fromInteger-   Sig.iterate ((fromInteger 2 ** (- recip halfLife)) *)--}--{-# INLINE exponential2MultiscaleNeutral #-}-exponential2MultiscaleNeutral :: Trans.C y =>-      y   {-^ half life -}-   -> Sig.T y {-^ exponential decay -}-exponential2MultiscaleNeutral halfLife =-   curveMultiscaleNeutral (*) (0.5 ** recip halfLife) one---{-# INLINE exponentialFromTo #-}-{-# INLINE exponentialFromToMultiscale #-}-exponentialFromTo, exponentialFromToMultiscale :: Trans.C y =>-      y   {-^ time where the function reaches 1\/e of the initial value -}-   -> y   {-^ initial value -}-   -> y   {-^ value after given time -}-   -> Sig.T y {-^ exponential decay -}-exponentialFromTo time y0 y1 =-   Sig.iterate (*  (y1/y0) ** recip time) y0-exponentialFromToMultiscale time y0 y1 =-   curveMultiscale (*) ((y1/y0) ** recip time) y0-----{-| This is an extension of 'exponential' to vectors-    which is straight-forward but requires more explicit signatures.-    But since it is needed rarely I setup a separate function. -}-{-# INLINE vectorExponential #-}-vectorExponential :: (Trans.C a, Module.C a v) =>-       a  {-^ time where the function reaches 1\/e of the initial value -}-   ->  v  {-^ initial value -}-   -> Sig.T v-          {-^ exponential decay -}-vectorExponential time y0 =-   Sig.iterate (exp (-1/time) *>) y0--{-# INLINE vectorExponential2 #-}-vectorExponential2 :: (Trans.C a, Module.C a v) =>-       a  {-^ half life -}-   ->  v  {-^ initial value -}-   -> Sig.T v-          {-^ exponential decay -}-vectorExponential2 halfLife y0 =-   Sig.iterate (0.5**(1/halfLife) *>) y0----{-# INLINE cosine #-}-cosine :: Trans.C a =>-       a  {-^ time t0 where  1 is approached -}-   ->  a  {-^ time t1 where -1 is approached -}-   -> Sig.T a-          {-^ a cosine wave where one half wave is between t0 and t1 -}-cosine = Ctrl.cosineWithSlope $-   \d x -> Sig.map cos (linear d x)----{-# INLINE cubicHermite #-}-cubicHermite :: Field.C a => (a, (a,a)) -> (a, (a,a)) -> Sig.T a-cubicHermite node0 node1 =-   Sig.map (Ctrl.cubicFunc node0 node1) (linear 1 0)------ * piecewise curves---{-# DEPRECATED Piece, piecewise "use Synthesizer.Generic.Piece instead" #-}-{-# INLINE piecewise #-}-piecewise :: (RealField.C a) =>-   Piecewise.T a a (a -> Sig.T a) -> Sig.T a-piecewise xs =-   Sig.concat $ zipWith-      (\(n, t) (Piecewise.PieceData c yi0 yi1 d) ->-           Sig.take n $ Piecewise.computePiece c yi0 yi1 d t)-      (splitDurations $ map Piecewise.pieceDur xs)-      xs---type Piece a =-   Piecewise.Piece a a-      (a {- fractional start time -} -> Sig.T a)---{-# INLINE stepPiece #-}-stepPiece :: Piece a-stepPiece =-   Piecewise.pieceFromFunction $ \ y0 _y1 _d _t0 ->-      constant y0--{-# INLINE linearPiece #-}-linearPiece :: (Field.C a) => Piece a-linearPiece =-   Piecewise.pieceFromFunction $ \ y0 y1 d t0 ->-      let s = (y1-y0)/d in linear s (y0-t0*s)--{-# INLINE exponentialPiece #-}-exponentialPiece :: (Trans.C a) => a -> Piece a-exponentialPiece saturation =-   Piecewise.pieceFromFunction $ \ y0 y1 d t0 ->-      let y0' = y0-saturation-          y1' = y1-saturation-          yd  = y0'/y1'-      in  raise saturation-             (exponential (d / log yd) (y0' * yd**(t0/d)))--{-# INLINE cosinePiece #-}-cosinePiece :: (Trans.C a) => Piece a-cosinePiece =-   Piecewise.pieceFromFunction $ \ y0 y1 d t0 ->-      Sig.map-         (\y -> (1+y)*(y0/2)+(1-y)*(y1/2))-         (cosine t0 (t0+d))--{-# INLINE cubicPiece #-}-cubicPiece :: (Field.C a) => a -> a -> Piece a-cubicPiece yd0 yd1 =-   Piecewise.pieceFromFunction $ \ y0 y1 d t0 ->-      cubicHermite (t0,(y0,yd0)) (t0+d,(y1,yd1))--raise :: Additive.C a => a -> Sig.T a -> Sig.T a-raise = Sig.map . (+)---- * auxiliary functions--{-# INLINE curveMultiscale #-}-curveMultiscale :: (y -> y -> y) -> y -> y -> Sig.T y-curveMultiscale op d y0 =-   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.iterateAssociative op d)
− src/Synthesizer/FusionList/Filter/NonRecursive.hs 
@@ -1,314 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{- |-Copyright   :  (c) Henning Thielemann 2008-License     :  GPL--Maintainer  :  synthesizer@henning-thielemann.de-Stability   :  provisional-Portability :  requires multi-parameter type classes--}-module Synthesizer.FusionList.Filter.NonRecursive where--import qualified Synthesizer.FusionList.Control as Ctrl-import qualified Synthesizer.FusionList.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 Algebra.Additive       as Additive--import Algebra.Module( {- linearComb, -} (*>), )--import Data.Function.HT (nest, )--import PreludeBase-import NumericPrelude----{- * Envelope application -}--{-# INLINE amplify #-}-amplify :: (Ring.C a) => a -> Sig.T a -> Sig.T a-amplify v = Sig.map (v*)--{-# INLINE amplifyVector #-}-amplifyVector :: (Module.C a v) => a -> Sig.T v -> Sig.T v-amplifyVector v = Sig.map (v*>)---{-# INLINE envelope #-}-envelope :: (Ring.C a) =>-      Sig.T a  {-^ the envelope -}-   -> Sig.T a  {-^ the signal to be enveloped -}-   -> Sig.T a-envelope = Sig.zipWith (*)--{-# INLINE envelopeVector #-}-envelopeVector :: (Module.C a v) =>-      Sig.T a  {-^ the envelope -}-   -> Sig.T v  {-^ the signal to be enveloped -}-   -> Sig.T v-envelopeVector = Sig.zipWith (*>)----{-# INLINE fadeInOut #-}-fadeInOut :: (Field.C a) =>-   Int -> Int -> Int -> Sig.T a -> Sig.T a-fadeInOut tIn tHold tOut =-   let leadIn  = Sig.take tIn  $ Ctrl.linear (  recip (fromIntegral tIn))  zero-       leadOut = Sig.take tOut $ Ctrl.linear (- recip (fromIntegral tOut)) one-       hold    = Sig.replicate tHold one-   in  envelope (leadIn `Sig.append` hold `Sig.append` leadOut)--{-# INLINE fadeInOutStored #-}-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-       leadOut = Sig.take tOut $ Ctrl.linear (- recip (fromIntegral tOut)) 1-       (partIn, partHoldOut) = Sig.splitAt tIn xs-       (partHold, partOut) = Sig.splitAt tHold partHoldOut-   in  envelope leadIn partIn `Sig.append`-       partHold `Sig.append`-       envelope leadOut partOut---{- * Shift -}--{-# INLINE delay #-}-delay :: Additive.C y => Int -> Sig.T y -> Sig.T y-delay = delayPad zero--{-# INLINE delayPad #-}-delayPad :: y -> Int -> Sig.T y -> Sig.T y-delayPad z n =-   if n<0-     then Sig.drop (negate n)-     else Sig.append (Sig.replicate n z)---{- * Smoothing -}---{-| Unmodulated non-recursive filter -}-{-# INLINE generic #-}-generic :: (Module.C a v) =>-   Sig.T a -> Sig.T v -> Sig.T v-generic m x =-   let mr = Sig.reverse m-       xp = delay (pred (Sig.length m)) x-   in  Sig.mapTails (Sig.linearComb mr) xp--{--genericSlow :: Module.C a v =>-   Sig.T a -> Sig.T v -> Sig.T v-genericSlow m x =-   let mr = Sig.reverse m-       xp = delay (pred (Sig.length m)) x-   in  Sig.fromList (map (Sig.linearComb mr) (init (Sig.tails xp)))--}--{--{- |-@eps@ is the threshold relatively to the maximum.-That is, if the gaussian falls below @eps * gaussian 0@,-then the function truncated.--}-gaussian ::-   (Trans.C a, RealField.C a, Module.C a v) =>-   a -> a -> a -> Sig.T v -> Sig.T v-gaussian eps ratio freq =-   let var    = ratioFreqToVariance ratio freq-       area   = var * sqrt (2*pi)-       gau t  = exp (-(t/var)^2/2) / area-       width  = ceiling (var * sqrt (-2 * log eps))  -- inverse gau-       gauSmp = map (gau . fromIntegral) [-width .. width]-   in  drop width . generic gauSmp--}--{--GNUPlot.plotList [] (take 1000 $ gaussian 0.001 0.5 0.04 (Filter.Test.chirp 5000) :: [Double])--The filtered chirp must have amplitude 0.5 at 400 (0.04*10000).--}--{--  We want to approximate a Gaussian by a binomial filter.-  The latter one can be implemented by a convolutional power.-  However we still require a number of operations per sample-  which is proportional to the variance.--}-{-# INLINE binomial #-}-binomial ::-   (Trans.C a, RealField.C a, Module.C a v) =>-   a -> a -> Sig.T v -> Sig.T v-binomial ratio freq =-   let width = ceiling (2 * ratioFreqToVariance ratio freq ^ 2)-   in  Sig.drop width . nest (2*width) ((asTypeOf 0.5 freq *>) . binomial1)--{--exp (-(t/var)^2/2) / area *> cis (2*pi*f*t)-  == exp (-(t/var)^2/2 +: 2*pi*f*t) / area-  == exp ((-t^2 +: 2*var^2*2*pi*f*t) / (2*var^2)) / area-  == exp ((t^2 - i*2*var^2*2*pi*f*t) / (-2*var^2)) / area-  == exp (((t^2 - i*var^2*2*pi*f)^2 + (var^2*2*pi*f)^2) / (-2*var^2)) / area-  == exp (((t^2 - i*var^2*2*pi*f)^2 / (-2*var^2) - (var*2*pi*f)^2/2)) / area--sumMap (\t -> exp (-(t/var)^2/2) / area *> cis (2*pi*f*t))-       [-infinity..infinity]-  ~ sumMap (\t -> exp (-(t/var)^2/2)) [-infinity..infinity]-       * exp (-(var*2*pi*f)^2/2) / area-  = exp (-(var*2*pi*f)^2/2)--}-{- |-  Compute the variance of the Gaussian-  such that its Fourier transform has value @ratio@ at frequency @freq@.--}-{-# INLINE ratioFreqToVariance #-}-ratioFreqToVariance :: (Trans.C a) => a -> a -> a-ratioFreqToVariance ratio freq =-   sqrt (-2 * log ratio) / (2*pi*freq)-           -- inverse of the fourier transformed gaussian--{-# INLINE binomial1 #-}-binomial1 :: (Additive.C v) => Sig.T v -> Sig.T v-binomial1 = Sig.mapAdjacent (+)------{- |-Moving (uniformly weighted) average in the most trivial form.-This is very slow and needs about @n * length x@ operations.--}-{-# INLINE sums #-}-sums :: (Additive.C v) => Int -> Sig.T v -> Sig.T v-sums n = Sig.mapTails (Sig.sum . Sig.take n)---{--sumsDownsample2 :: (Additive.C v) => Sig.T v -> Sig.T v-sumsDownsample2 (x0:x1:xs) = (x0+x1) : sumsDownsample2 xs-sumsDownsample2 xs         = xs--downsample2 :: Sig.T a -> Sig.T a-downsample2 (x0:_:xs) = x0 : downsample2 xs-downsample2 xs        = xs---{- |-Given a list of numbers-and a list of sums of (2*k) of successive summands,-compute a list of the sums of (2*k+1) or (2*k+2) summands.--Eample for 2*k+1--@- [0+1+2+3, 2+3+4+5, 4+5+6+7, ...] ->-    [0+1+2+3+4, 1+2+3+4+5, 2+3+4+5+6, 3+4+5+6+7, 4+5+6+7+8, ...]-@--Example for 2*k+2--@- [0+1+2+3, 2+3+4+5, 4+5+6+7, ...] ->-    [0+1+2+3+4+5, 1+2+3+4+5+6, 2+3+4+5+6+7, 3+4+5+6+7+8, 4+5+6+7+8+9, ...]-@--}-sumsUpsampleOdd :: (Additive.C v) => Int -> Sig.T v -> Sig.T v -> Sig.T v-sumsUpsampleOdd n {- 2*k -} xs ss =-   let xs2k = drop n xs-   in  (head ss + head xs2k) :-          concat (zipWith3 (\s x0 x2k -> [x0+s, s+x2k])-                           (tail ss)-                           (downsample2 (tail xs))-                           (tail (downsample2 xs2k)))--sumsUpsampleEven :: (Additive.C v) => Int -> Sig.T v -> Sig.T v -> Sig.T v-sumsUpsampleEven n {- 2*k -} xs ss =-   sumsUpsampleOdd (n+1) xs (zipWith (+) ss (downsample2 (drop n xs)))--sumsPyramid :: (Additive.C v) => Int -> Sig.T v -> Sig.T v-sumsPyramid n xs =-   let aux 1 ys = ys-       aux 2 ys = ys + tail ys-       aux m ys =-          let ysd = sumsDownsample2 ys-          in  if even m-                then sumsUpsampleEven (m-2) ys (aux (div (m-2) 2) ysd)-                else sumsUpsampleOdd  (m-1) ys (aux (div (m-1) 2) ysd)-   in  aux n xs---propSums :: Bool-propSums =-   let n  = 1000-       xs = [0::Double ..]-       naive   =              sums        n xs-       rec     = drop (n-1) $ sumsRec     n xs-       pyramid =              sumsPyramid n xs-   in  and $ take 1000 $-         zipWith3 (\x y z -> x==y && y==z) naive rec pyramid---}----{- * Filter operators from calculus -}--{- |-Forward difference quotient.-Shortens the signal by one.-Inverts 'Synthesizer.Plain.Filter.Recursive.Integration.run' in the sense that-@differentiate (zero : integrate x) == x@.-The signal is shifted by a half time unit.--}-{-# INLINE differentiate #-}-differentiate :: Additive.C v => Sig.T v -> Sig.T v-differentiate x = Sig.mapAdjacent subtract x--{- |-Central difference quotient.-Shortens the signal by two elements,-and shifts the signal by one element.-(Which can be fixed by prepending an appropriate value.)-For linear functions this will yield-essentially the same result as 'differentiate'.-You obtain the result of 'differentiateCenter'-if you smooth the one of 'differentiate'-by averaging pairs of adjacent values.--ToDo: Vector variant--}-{-# INLINE differentiateCenter #-}-differentiateCenter :: Field.C v => Sig.T v -> Sig.T v-differentiateCenter =-   Sig.mapAdjacent (\(x0,_) (_,x1) -> (x1 - x0) * (1/2)) .-   Sig.mapAdjacent (,)-{--differentiateCenter :: Field.C v => Sig.T v -> Sig.T v-differentiateCenter x =-   Sig.map ((1/2)*) $-   Sig.zipWith subtract x (Sig.tail (Sig.tail x))--}--{- |-Second derivative.-It is @differentiate2 == differentiate . differentiate@-but 'differentiate2' should be faster.--}-{-# INLINE differentiate2 #-}-differentiate2 :: Additive.C v => Sig.T v -> Sig.T v-differentiate2 = differentiate . differentiate-{--differentiate2 :: Additive.C v => Sig.T v -> Sig.T v-differentiate2 xs0 =-   let xs1 = Sig.tail xs0-       xs2 = Sig.tail xs1-   in  Sig.zipWith3 (\x0 x1 x2 -> x0+x2-(x1+x1)) xs0 xs1 xs2--}
− src/Synthesizer/FusionList/Oscillator.hs 
@@ -1,137 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{- |-Copyright   :  (c) Henning Thielemann 2006-License     :  GPL--Maintainer  :  synthesizer@henning-thielemann.de-Stability   :  provisional-Portability :  requires multi-parameter type classes--Tone generators--}-module Synthesizer.FusionList.Oscillator where--import qualified Synthesizer.Basic.Wave       as Wave-import qualified Synthesizer.Basic.Phase      as Phase--import qualified Synthesizer.FusionList.Signal as Sig---- import qualified Synthesizer.FusionList.Interpolation as Interpolation--{--import qualified Algebra.RealTranscendental    as RealTrans-import qualified Algebra.Module                as Module-import qualified Algebra.VectorSpace           as VectorSpace--import Algebra.Module((*>))--}-import qualified Algebra.Transcendental        as Trans-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 qualified Prelude as P-import PreludeBase----{- * Oscillators with arbitrary but constant waveforms -}--{-# INLINE freqToPhase #-}-{- | 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 -> Sig.T a -> Sig.T (Phase.T a)-freqToPhase phase freq = Sig.scanL (flip Phase.increment) phase freq---{- Inlining blocks fusion of map and iterate - on the other hand it enables fusion in the main program -}-{-# INLINE static #-}-{- | oscillator with constant frequency -}-static :: (RealField.C a) => Wave.T a b -> (Phase.T a -> a -> Sig.T b)-static wave phase freq =-    Sig.map (Wave.apply wave) (Sig.iterate (Phase.increment freq) phase)--{-# INLINE phaseMod #-}-{- | oscillator with modulated phase -}-phaseMod :: (RealField.C a) => Wave.T a b -> a -> Sig.T a -> Sig.T b-phaseMod wave = shapeMod (Wave.phaseOffset wave) zero--{-# INLINE shapeMod #-}-{- | oscillator with modulated shape -}-shapeMod :: (RealField.C a) =>-    (c -> Wave.T a b) -> Phase.T a -> a -> Sig.T c -> Sig.T b-shapeMod wave phase freq parameters =-    Sig.zipWith (Wave.apply . wave) parameters (Sig.iterate (Phase.increment freq) phase)--{-# INLINE freqMod #-}-{- | oscillator with modulated frequency -}-freqMod :: (RealField.C a) => Wave.T a b -> Phase.T a -> Sig.T a -> Sig.T b-freqMod wave phase freqs =-    Sig.map (Wave.apply wave) (freqToPhase phase freqs)--{-# INLINE phaseFreqMod #-}-{- | oscillator with both phase and frequency modulation -}-phaseFreqMod :: (RealField.C a) =>-    Wave.T a b -> Sig.T a -> Sig.T a -> Sig.T b-phaseFreqMod wave = shapeFreqMod (Wave.phaseOffset wave) zero--{-# INLINE shapeFreqMod #-}-{- | oscillator with both shape and frequency modulation -}-shapeFreqMod :: (RealField.C a) =>-    (c -> Wave.T a b) -> Phase.T a -> Sig.T c -> Sig.T a -> Sig.T b-shapeFreqMod wave phase parameters freqs =-    Sig.zipWith (Wave.apply . wave) parameters (freqToPhase phase freqs)--{--{- | oscillator with a sampled waveform with constant frequency-     This essentially an interpolation with cyclic padding. -}-{-# INLINE staticSample #-}-staticSample :: RealField.C a =>-    Interpolation.T a b -> Sig.T b -> Phase.T a -> a -> Sig.T b-staticSample ip wave phase freq =-    freqModSample ip wave phase (Sig.repeat freq)--{- | oscillator with a sampled waveform with modulated frequency-     Should behave homogenously for different types of interpolation. -}-{-# INLINE freqModSample #-}-freqModSample :: RealField.C a =>-    Interpolation.T a b -> Sig.T b -> Phase.T a -> Sig.T a -> Sig.T b-freqModSample ip wave phase freqs =-    let len = Sig.length wave-    in  Interpolation.multiRelativeCyclicPad-           ip (fromIntegral len * Phase.toRepresentative phase)-           (Sig.map (* fromIntegral len) freqs) wave--}----{- * Oscillators with specific waveforms -}--{-# INLINE staticSine #-}-{- | sine oscillator with static frequency -}-staticSine :: (Trans.C a, RealField.C a) => Phase.T a -> a -> Sig.T a-staticSine = static Wave.sine--{-# INLINE freqModSine #-}-{- | sine oscillator with modulated frequency -}-freqModSine :: (Trans.C a, RealField.C a) => Phase.T a -> Sig.T a -> Sig.T a-freqModSine = freqMod Wave.sine--{-# INLINE phaseModSine #-}-{- | sine oscillator with modulated phase, useful for FM synthesis -}-phaseModSine :: (Trans.C a, RealField.C a) => a -> Sig.T a -> Sig.T a-phaseModSine = phaseMod Wave.sine--{-# INLINE staticSaw #-}-{- | saw tooth oscillator with modulated frequency -}-staticSaw :: RealField.C a => Phase.T a -> a -> Sig.T a-staticSaw = static Wave.saw--{-# INLINE freqModSaw #-}-{- | saw tooth oscillator with modulated frequency -}-freqModSaw :: RealField.C a => Phase.T a -> Sig.T a -> Sig.T a-freqModSaw = freqMod Wave.saw
− src/Synthesizer/FusionList/Signal.hs 
@@ -1,720 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# OPTIONS_GHC -fglasgow-exts #-}-{- glasgow-exts are for the rules -}-module Synthesizer.FusionList.Signal where--import qualified Synthesizer.Plain.Signal   as Sig-import qualified Synthesizer.Plain.Modifier as Modifier-import qualified Data.List as List--import qualified Data.StorableVector.Lazy as Vector-import Data.StorableVector.Lazy (ChunkSize, Vector)-import Foreign.Storable (Storable, )--import qualified Algebra.Module   as Module-import qualified Algebra.Additive as Additive-import Algebra.Additive (zero)--import Algebra.Module ((*>))--import qualified Synthesizer.Format as Format--import Control.Monad.Trans.State (runState, )--import Data.Monoid (Monoid, mempty, mappend, )--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, )-import Data.Maybe (Maybe(Just, Nothing), maybe)-import Prelude-   ((.), ($), id, const, flip, curry, uncurry, fst, snd, error,-    (>), (>=), max, Ord,-    succ, pred, Bool, not, Int, Functor, fmap,-    (>>), (>>=), fail, return, (=<<),---    fromInteger,-    )--- import qualified Prelude as P-{--import Prelude hiding-   ((++), iterate, foldl, map, repeat, replicate,-    zipWith, zipWith3, take, takeWhile)--}---newtype T y = Cons {decons :: [y]}--instance (Show y) => Show (T y) where-   showsPrec p x =-      showParen (p >= 10)-         (showString "FusionList.fromList " . showsPrec 11 (toList x))--instance Format.C T where-   format = showsPrec--instance Functor T where-   fmap = map--instance Monoid (T y) where-   mempty = empty-   mappend = append---{- * functions based on 'generate' -}--{-# NOINLINE [0] generate #-}-generate :: (acc -> Maybe (y, acc)) -> acc -> T y-generate f = Cons . snd . Sig.unfoldR f--{-# INLINE unfoldR #-}-unfoldR :: (acc -> Maybe (y, acc)) -> acc -> T y-unfoldR = generate--{-# INLINE generateInfinite #-}-generateInfinite :: (acc -> (y, acc)) -> acc -> T y-generateInfinite f = generate (Just . f)--{-# INLINE fromList #-}-fromList :: [y] -> T y-fromList = generate ListHT.viewL--{-# INLINE toList #-}-toList :: T y -> [y]-toList = decons---toStorableSignal :: Storable y => ChunkSize -> T y -> Vector y-toStorableSignal size  =  Vector.pack size . decons--fromStorableSignal :: Storable y => Vector y -> T y-fromStorableSignal  =  Cons . Vector.unpack---{-# INLINE iterate #-}-iterate :: (a -> a) -> a -> T a-iterate f = generateInfinite (\x -> (x, f x))--{-# 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-repeat = iterate id---{- * functions based on 'crochetL' -}--{-# NOINLINE [0] crochetL #-}-crochetL :: (x -> acc -> Maybe (y, acc)) -> acc -> T x -> T y-crochetL f a = Cons . Sig.crochetL f a . decons--{-# INLINE scanL #-}-scanL :: (acc -> x -> acc) -> acc -> T x -> T acc-{--scanL f start xs =-   cons start-     (crochetL (\x acc -> let y = f acc x in Just (y, y)) start xs)--}-scanL f start =-   cons start .-   crochetL (\x acc -> let y = f acc x in Just (y, y)) start---- | input and output have equal length, that's better for fusion-scanLClip :: (acc -> x -> acc) -> acc -> T x -> T acc-scanLClip f start =-   crochetL (\x acc -> Just (acc, f acc x)) start--{-# INLINE map #-}-map :: (a -> b) -> (T a -> T b)-map f = crochetL (\x _ -> Just (f x, ())) ()--{- disabled RULES-  "FusionList.map-crochetL" forall f.-     map f = crochetL (\x _ -> Just (f x, ())) () ;--  "FusionList.repeat-iterate"-     repeat = iterate id ;--  "FusionList.iterate-generate" forall f.-     iterate f = generate (\x -> Just (x, f x)) ;--  "FusionList.take-crochetL"-     take = crochetL (\x n -> toMaybe (n>zero) (x, pred n)) ;--  "FusionList.unfold-dollar" forall f x.-     f $ x = f x ;--  "FusionList.unfold-dot" forall f g.-     f . g  =  \x -> f (g x) ;-  -}--{-# INLINE unzip #-}-unzip :: T (a,b) -> (T a, T b)-unzip x = (map fst x, map snd x)--{-# INLINE unzip3 #-}-unzip3 :: T (a,b,c) -> (T a, T b, T c)-unzip3 xs = (map fst3 xs, map snd3 xs, map thd3 xs)---{-# INLINE delay1 #-}-{- |-This is a fusion friendly implementation of delay.-However, in order to be a 'crochetL'-the output has the same length as the input,-that is, the last element is removed - at least for finite input.--}-delay1 :: a -> T a -> T a-delay1 = crochetL (flip (curry Just))--{-# INLINE delay #-}-delay :: y -> Int -> T y -> T y-delay z n = append (replicate n z)---{-# INLINE take #-}-take :: Int -> T a -> T a-take = crochetL (\x n -> toMaybe (n>zero) (x, pred n))--{-# INLINE takeWhile #-}-takeWhile :: (a -> Bool) -> T a -> T a-takeWhile p = crochetL (\x _ -> toMaybe (p x) (x, ())) ()--{-# INLINE replicate #-}-replicate :: Int -> a -> T a-replicate n = take n . repeat--{-# RULES-  "FusionList.map/repeat" forall f x.-     map f (repeat x) = repeat (f x) ;--  "FusionList.map/replicate" forall f n x.-     map f (replicate n x) = replicate n (f x) ;--  "FusionList.map/cons" forall f x xs.-      map f (cons x xs) = cons (f x) (map f xs) ;--  "FusionList.map/append" forall f xs ys.-      map f (append xs ys) = append (map f xs) (map f ys) ;--  {- should be subsumed by the map/cons rule,-       but it doesn't fire sometimes-  "FusionList.map/cons/compose" forall f g x xs.-      map f ((cons x . g) xs) = cons (f x) (map f (g xs)) ;-  -}--  {- this does not fire, since 'map' is inlined, crochetL/cons should fire instead -}-  "FusionList.map/scanL" forall f g x0 xs.-      map g (scanL f x0 xs) =-         cons (g x0)-            (crochetL (\x acc -> let y = f acc x in Just (g y, y)) x0 xs) ;--  "FusionList.map/zipWith" forall f g x y.-     map f (zipWith g x y) =-        zipWith (\xi yi -> f (g xi yi)) x y ;--  "FusionList.zipWith/map,*" forall f g x y.-     zipWith g (map f x) y =-        zipWith (\xi yi -> g (f xi) yi) x y ;--  "FusionList.zipWith/*,map" forall f g x y.-     zipWith g x (map f y) =-        zipWith (\xi yi -> g xi (f yi)) x y ;-  #-}--{- * functions consuming multiple lists -}--{-# NOINLINE [0] zipWith #-}-zipWith :: (a -> b -> c) -> (T a -> T b -> T c)-zipWith f s0 s1 =-   Cons $ List.zipWith f (decons s0) (decons s1)--{-# INLINE zipWith3 #-}-zipWith3 :: (a -> b -> c -> d) -> (T a -> T b -> T c -> T d)-zipWith3 f s0 s1 =-   zipWith (uncurry f) (zip s0 s1)--{-# INLINE zipWith4 #-}-zipWith4 :: (a -> b -> c -> d -> e) -> (T a -> T b -> T c -> T d -> T e)-zipWith4 f s0 s1 =-   zipWith3 (uncurry f) (zip s0 s1)---{-# INLINE zip #-}-zip :: T a -> T b -> T (a,b)-zip = zipWith (,)--{-# INLINE zip3 #-}-zip3 :: T a -> T b -> T c -> T (a,b,c)-zip3 = zipWith3 (,,)--{-# INLINE zip4 #-}-zip4 :: T a -> T b -> T c -> T d -> T (a,b,c,d)-zip4 = zipWith4 (,,,)---{- * functions based on 'reduceL' -}--reduceL :: (x -> acc -> Maybe acc) -> acc -> T x -> acc-reduceL f x = Sig.reduceL f x . decons--{-# INLINE foldL' #-}-foldL' :: (x -> acc -> acc) -> acc -> T x -> acc-foldL' f = reduceL (\x -> Just . f x)--{-# INLINE foldL #-}-foldL :: (acc -> x -> acc) -> acc -> T x -> acc-foldL f = foldL' (flip f)--{-# INLINE lengthSlow #-}-{- | can be used to check against native length implementation -}-lengthSlow :: T a -> Int-lengthSlow = foldL' (const succ) zero--{-# INLINE foldR #-}-foldR :: (x -> acc -> acc) -> acc -> T x -> acc-foldR f acc = List.foldr f acc . toList---{--Do we still need rules for fusion of-  map f (repeat x)-  zipWith f (repeat x) ys-?--}--{- * Fusion helpers -}--{-# INLINE zipWithGenerate #-}-zipWithGenerate ::-      (a -> b -> c)-   -> (acc -> Maybe (a, acc))-   -> acc-   -> T b -> T c-zipWithGenerate h f a y =-   crochetL (\y0 a0 ->-       do (x0,a1) <- f a0-          Just (h x0 y0, a1)) a y--{-# INLINE zipWithCrochetL #-}-zipWithCrochetL ::-      (a -> b -> c)-   -> (x -> acc -> Maybe (a, acc))-   -> acc-   -> T x -> T b -> T c-zipWithCrochetL h f a x y =-   crochetL (\(x0,y0) a0 ->-       do (z0,a1) <- f x0 a0-          Just (h z0 y0, a1))-      a (zip x y)--{-# INLINE mixGenerate #-}-mixGenerate :: (Additive.C a) =>-      (a -> a -> a)-   -> (acc -> Maybe (a, acc))-   -> acc-   -> T a -> T a-mixGenerate plus f a =-   crochetL-      (\y0 a0 ->-         Just (maybe-            (y0, Nothing)-            (\(x0,a1) -> (plus x0 y0, Just a1))-            (f =<< a0)))-      (Just a)--{-# INLINE crochetLCons #-}-crochetLCons ::-      (a -> acc -> Maybe (b, acc))-   -> acc-   -> a -> T a -> T b-crochetLCons f a0 x xs =-   maybe-      empty-      (\(y,a1) -> cons y (crochetL f a1 xs))-      (f x a0)--{--{-# INLINE crochetLAppend #-}-crochetLAppend ::-      (a -> acc -> Maybe (b, acc))-   -> acc-   -> a -> T a -> T a -> T b-crochetLAppend f a0 x xs ys =-   maybe-      empty-      (\(y,a1) -> cons y (crochetL f a1 xs))-      (f x a0)--}--{-# INLINE reduceLCons #-}-reduceLCons ::-      (a -> acc -> Maybe acc)-   -> acc-   -> a -> T a -> acc-reduceLCons f a0 x xs =-   maybe a0 (flip (reduceL f) xs) (f x a0)---{--applyThroughCons ::-   (a -> Maybe (b,acc)) -> (T a -> acc -> T b) -> T a -> T b-applyThroughCons f g =-   maybe empty-      (\(x,xs) -> cons (f x) (g xs)) . viewL--}--{-# INLINE zipWithCons #-}-zipWithCons ::-      (a -> b -> c)-   -> a -> T a -> T b -> T c-zipWithCons f x xs =-   maybe-      empty-      (\(y,ys) -> cons (f x y) (zipWith f xs ys))-    . viewL---{-# RULES-  "FusionList.crochetL/generate" forall f g a b.-     crochetL g b (generate f a) =-        generate (\(a0,b0) ->-            do (y0,a1) <- f a0-               (z0,b1) <- g y0 b0-               Just (z0, (a1,b1))) (a,b) ;--  "FusionList.crochetL/crochetL" forall f g a b x.-     crochetL g b (crochetL f a x) =-        crochetL (\x0 (a0,b0) ->-            do (y0,a1) <- f x0 a0-               (z0,b1) <- g y0 b0-               Just (z0, (a1,b1))) (a,b) x ;--  "FusionList.crochetL/cons" forall g b x xs.-     crochetL g b (cons x xs) =-        crochetLCons g b x xs ;---  "FusionList.tail/generate" forall f a.-     tail (generate f a) =-        maybe (error "FusionList.tail: empty list")-           (generate f . snd) (f a) ;--  "FusionList.tail/cons" forall x xs.-     tail (cons x xs) = xs ;--  "FusionList.zipWith/generate,*" forall f h a y.-     zipWith h (generate f a) y =-        zipWithGenerate h f a y ;--  "FusionList.zipWith/crochetL,*" forall f h a x y.-     zipWith h (crochetL f a x) y =-        zipWithCrochetL h f a x y ;--  "FusionList.zipWith/*,generate" forall f h a y.-     zipWith h y (generate f a) =-        zipWithGenerate (flip h) f a y ;--  "FusionList.zipWith/*,crochetL" forall f h a x y.-     zipWith h y (crochetL f a x) =-        zipWithCrochetL (flip h) f a x y ;--  "FusionList.mix/generate,*" forall f a y.-     mix (generate f a) y =-        mixGenerate (Additive.+) f a y ;--  "FusionList.mix/*,generate" forall f a y.-     mix y (generate f a) =-        mixGenerate (flip (Additive.+)) f a y ;---{- this blocks further fusion and-   is not necessary if the non-cons operand is a 'generate'-  "FusionList.zipWith/cons,*" forall h x xs ys.-     zipWith h (cons x xs) ys =-        zipWithCons h x xs ys ;--  "FusionList.zipWith/*,cons" forall h x xs ys.-     zipWith h ys (cons x xs) =-        zipWithCons (flip h) x xs ys ;--}--  "FusionList.zipWith/cons,cons" forall h x xs y ys.-     zipWith h (cons x xs) (cons y ys) =-        cons (h x y) (zipWith h xs ys) ;--  "FusionList.zipWith/share" forall (h :: a->a->b) (x :: T a).-     zipWith h x x = map (\xi -> h xi xi) x ;----  "FusionList.reduceL/generate" forall f g a b.-     reduceL g b (generate f a) =-        snd-          (recourse (\(a0,b0) ->-              do (y,a1) <- f a0-                 b1 <- g y b0-                 Just (a1, b1)) (a,b)) ;--  "FusionList.reduceL/crochetL" forall f g a b x.-     reduceL g b (crochetL f a x) =-        snd-          (reduceL (\x0 (a0,b0) ->-              do (y,a1) <- f x0 a0-                 b1 <- g y b0-                 Just (a1, b1)) (a,b) x) ;--  "FusionList.reduceL/cons" forall g b x xs.-     reduceL g b (cons x xs) =-        reduceLCons g b x xs ;---  "FusionList.viewL/cons" forall x xs.-     viewL (cons x xs) = Just (x,xs) ;--  "FusionList.viewL/generateInfinite" forall f x.-     viewL (generateInfinite f x) =-        Just (mapSnd (generateInfinite f) (f x)) ;--  "FusionList.viewL/generate" forall f x.-     viewL (generate f x) =-        fmap (mapSnd (generate f)) (f x) ;--  "FusionList.viewL/crochetL" forall f a xt.-     viewL (crochetL f a xt) =-        do (x,xs) <- viewL xt-           (y,a') <- f x a-           return (y, crochetL f a' xs) ;-  #-}---{- * Other functions -}--null :: T a -> Bool-null = List.null . decons--empty :: T a-empty = Cons []--singleton :: a -> T a-singleton = Cons . (: [])--{-# NOINLINE [0] cons #-}-cons :: a -> T a -> T a-cons x = Cons . (x :) . decons--length :: T a -> Int-length = List.length . decons--viewL :: T a -> Maybe (a, T a)-viewL =-   fmap (mapSnd Cons) . ListHT.viewL . decons--viewR :: T a -> Maybe (T a, a)-viewR =-   fmap (mapFst Cons) . ListHT.viewR . decons--extendConstant :: T a -> T a-extendConstant xt =-   maybe empty (append xt . repeat . snd) $-   viewR xt--{-# NOINLINE [0] tail #-}-tail :: T a -> T a-tail = Cons . List.tail . decons--head :: T a -> a-head = List.head . decons--drop :: Int -> T a -> T a-drop n = Cons . List.drop n . decons--dropMarginRem :: Int -> Int -> T a -> (Int, T a)-dropMarginRem n m = mapSnd Cons . Sig.dropMarginRem n m . decons--{--This implementation does only walk once through the dropped prefix.-It is maximally lazy and minimally space consuming.--}-dropMargin :: Int -> Int -> T a -> T a-dropMargin n m = Cons . Sig.dropMargin n m . decons---index :: Int -> T a -> a-index n = (List.!! n) . decons---splitAt :: Int -> T a -> (T a, T a)-splitAt n = mapPair (Cons, Cons) . List.splitAt n . decons--dropWhile :: (a -> Bool) -> T a -> T a-dropWhile p = Cons . List.dropWhile p . decons--span :: (a -> Bool) -> T a -> (T a, T a)-span p = mapPair (Cons, Cons) . List.span p . decons--mapAccumL :: (acc -> x -> (acc, y)) -> acc -> T x -> (acc, T y)-mapAccumL f acc = mapSnd Cons . List.mapAccumL f acc . decons--mapAccumR :: (acc -> x -> (acc, y)) -> acc -> T x -> (acc, T y)-mapAccumR f acc = mapSnd Cons . List.mapAccumR f acc . decons---cycle :: T a -> T a-cycle = Cons . List.cycle . decons--{-# NOINLINE [0] mix #-}-mix :: Additive.C a => T a -> T a -> T a-mix (Cons xs) (Cons ys)  =  Cons (xs Additive.+ ys)--{-# NOINLINE [0] sub #-}-sub :: Additive.C a => T a -> T a -> T a-sub (Cons xs) (Cons ys)  =  Cons (xs Additive.- ys)--{-# NOINLINE [0] neg #-}-neg :: Additive.C a => T a -> T a-neg (Cons xs)  =  Cons (Additive.negate xs)--instance Additive.C y => Additive.C (T y) where-   zero = empty-   (+) = mix-   (-) = sub-   negate = neg--instance Module.C y yv => Module.C y (T yv) where-   (*>) x y = map (x*>) y---infixr 5 `append`--{-# NOINLINE [0] append #-}-append :: T a -> T a -> T a-append (Cons xs) (Cons ys)  =  Cons (xs List.++ ys)--concat :: [T a] -> T a-concat  =  Cons . List.concat . List.map decons--reverse :: T a -> T a-reverse = Cons . List.reverse . decons----sum :: (Additive.C a) => T a -> a-sum = foldL' (Additive.+) Additive.zero--maximum :: (Ord a) => T a -> a-maximum =-   maybe-      (error "FusionList.maximum: empty list")-      (uncurry (foldL' max))-    . viewL--tails :: T y -> [T y]-tails = List.map Cons . List.tails . decons--init :: T y -> T y-init = Cons . List.init . decons--sliceVert :: Int -> T y -> [T y]-sliceVert n =-   List.map (take n) . List.takeWhile (not . null) . List.iterate (drop n)---mapAdjacent :: (a -> a -> b) -> T a -> T b-mapAdjacent f xs0 =-   let xs1 = maybe empty snd (viewL xs0)-   in  zipWith f xs0 xs1--modifyStatic :: Modifier.Simple s ctrl a b -> ctrl -> T a -> T b-modifyStatic modif control x =-   crochetL-      (\a acc ->-         Just (runState (Modifier.step modif control a) acc))-      (Modifier.init modif) x--{-| Here the control may vary over the time. -}-modifyModulated :: Modifier.Simple s ctrl a b -> T ctrl -> T a -> T b-modifyModulated modif control x =-   crochetL-      (\ca acc ->-         Just (runState (uncurry (Modifier.step modif) ca) acc))-      (Modifier.init modif)-      (zip control x)----- cf. Module.linearComb-linearComb ::-   (Module.C t y) =>-   T t -> T y -> y-linearComb ts ys =-   sum $ zipWith (*>) ts ys----- comonadic 'bind'--- only non-empty suffixes are processed-mapTails ::-   (T y0 -> y1) -> T y0 -> T y1-mapTails f =-   generate (\xs ->-      do (_,ys) <- viewL xs-         return (f xs, ys))---- only non-empty suffixes are processed-zipWithTails ::-   (y0 -> T y1 -> y2) -> T y0 -> T y1 -> T y2-zipWithTails f =-   curry $ generate (\(xs0,ys0) ->-      do (x,xs) <- viewL xs0-         (_,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-   -> T y   -- ^ prefix of the output, its length determines the delay-   -> T y-delayLoop proc prefix =-   let ys = append prefix (proc ys)-   in  ys--delayLoopOverlap ::-   (Additive.C y) =>-      Int-   -> (T y -> T y)-            -- ^ processor that shall be run in a feedback loop-   -> T y   -- ^ input-   -> T y   -- ^ output has the same length as the input-delayLoopOverlap time proc xs =-   let ys = zipWith (Additive.+) xs (delay zero time (proc ys))-   in  ys----- maybe candidate for Utility--recourse :: (acc -> Maybe acc) -> acc -> acc-recourse f =-   let aux x = maybe x aux (f x)-   in  aux-
src/Synthesizer/Generic/Analysis.hs view
@@ -15,7 +15,8 @@ import qualified Algebra.Algebraic             as Algebraic -- import qualified Algebra.RealField             as RealField import qualified Algebra.Field                 as Field-import qualified Algebra.Real                  as Real+import qualified Algebra.RealRing              as RealRing+import qualified Algebra.Absolute              as Absolute import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive @@ -32,8 +33,8 @@ -- import Data.Array (accumArray)  import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   {- * Notions of volume -}@@ -41,7 +42,7 @@ {- | Volume based on Manhattan norm. -}-volumeMaximum :: (Real.C y, SigG.Read sig y) => sig y -> y+volumeMaximum :: (RealRing.C y, SigG.Read sig y) => sig y -> y volumeMaximum =    Ana.volumeMaximum . SigG.toState @@ -59,7 +60,7 @@ {- | Volume based on Sum norm. -}-volumeSum :: (Field.C y, Real.C y, SigG.Read sig y) => sig y -> y+volumeSum :: (Field.C y, RealRing.C y, SigG.Read sig y) => sig y -> y volumeSum =    Ana.volumeSum . SigG.toState @@ -277,7 +278,7 @@ average =    Ana.average . SigG.toState -rectify :: (Real.C y, SigG.Transform sig y) => sig y -> sig y+rectify :: (RealRing.C y, SigG.Transform sig y) => sig y -> sig y rectify = SigG.map abs  {- |
src/Synthesizer/Generic/Control.hs view
@@ -10,7 +10,7 @@  import qualified Algebra.Module                as Module import qualified Algebra.Transcendental        as Trans-import qualified Algebra.RealField             as RealField+import qualified Algebra.RealRing              as RealRing import qualified Algebra.Field                 as Field import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive@@ -23,8 +23,8 @@ -- import Control.Applicative ((<$>), )  import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   {- * Control curve generation -}@@ -297,7 +297,7 @@ y0 |# ((d,c,y1), xs)  =  ControlPiece c y0 y1 d : xs  -piecewise :: (Trans.C y, RealField.C y, SigG.Write sig y) =>+piecewise :: (Trans.C y, RealRing.C y, SigG.Write sig y) =>    SigG.LazySize -> [ControlPiece y] -> sig y piecewise size xs =    let ts = scanl (\(_,fr) d -> splitFraction (fr+d))
src/Synthesizer/Generic/Cut.hs view
@@ -9,13 +9,15 @@  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 as SV import qualified Data.StorableVector.Lazy as Vector  import qualified Algebra.ToInteger as ToInteger import qualified Algebra.Ring as Ring +import qualified Data.EventList.Relative.BodyTime as EventList+ -- import qualified Number.NonNegative as NonNegW import qualified Algebra.NonNegative as NonNeg import qualified Number.NonNegativeChunky as Chunky@@ -23,30 +25,49 @@ -- import qualified Numeric.NonNegative.Wrapper as NonNegW98 import qualified Numeric.NonNegative.Class as NonNeg98 import qualified Numeric.NonNegative.Chunky as Chunky98+import Numeric.NonNegative.Class ((-|), ) -import Foreign.Storable (Storable)+import Foreign.Storable (Storable, )+import Control.DeepSeq (NFData, rnf, ) -import qualified Data.List as List+import qualified Data.List.HT as ListHT+import qualified Data.List.Stream as List import Data.Function (fix, )-import Data.Tuple.HT (mapPair, )+import Data.Tuple.HT (mapPair, mapFst, mapSnd, )  import qualified Data.Monoid as Monoid import Data.Monoid (Monoid, mempty, )  import qualified Prelude as P-import NumericPrelude+import NumericPrelude.Numeric import Prelude    (Bool, Int, String, (++), error,     pred, (<=), (>=), (<),-    (.), not, (||), (&&), )+    (.), ($), const, snd,+    not, (||), (&&), min, )   class Read sig where    null :: sig -> Bool    length :: sig -> Int +class (Read sig) => NormalForm sig where+   {- |+   Evaluating the first value of the signal+   is necessary for avoiding a space leaks+   if you repeatedly drop a prefix from the signal+   and do not consume something from it.+   -}+   evaluateHead :: sig -> ()+ class (Read sig, Monoid sig) => Transform sig where    {- Monoid functions+   {-+   In our categorization 'empty' would belong to the Write class,+   but since an empty signal contains no data,+   the maximum packet size is irrelevant.+   This makes e.g. the definition of mixMulti more general.+   -}    empty :: sig    cycle :: sig -> sig    append :: sig -> sig -> sig@@ -67,6 +88,20 @@    {-# INLINE length #-}    length = Vector.length +instance (Storable y) => NormalForm (Vector.Vector y) where+   {-# INLINE evaluateHead #-}+   evaluateHead =+      ListHT.switchL () (\x _ -> if SV.null x then () else ()) . Vector.chunks+--      ListHT.switchL () (\x _ -> rnf x) . Vector.chunks+--   evaluateHead x =+--      if Vector.null x then () else ()++{-+instance (Storable y, NFData y) => NormalForm (Vector.Vector y) where+   {-# INLINE evaluateHead #-}+   evaluateHead x = Vector.switchL () (\x _ -> rnf x)+-}+ instance Storable y => Transform (Vector.Vector y) where    {-    {-# INLINE empty #-}@@ -96,6 +131,10 @@    {-# INLINE length #-}    length = List.length +instance (NFData y) => NormalForm ([] y) where+   {-# INLINE evaluateHead #-}+   evaluateHead = ListHT.switchL () (\x _ -> rnf x)+ instance Transform ([] y) where    {-    {-# INLINE empty #-}@@ -119,42 +158,23 @@    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 (NFData y) => NormalForm (SigS.T y) where+   {-+   Evaluating the first element of a generator might look silly,+   since it is not stored in a data structure.+   However, the generator depends on an internal state,+   which might be in turn a list or a storable vector,+   which is evaluated then.+   -}+   {-# INLINE evaluateHead #-}+   evaluateHead = SigS.switchL () (\x _ -> rnf x)+ instance Transform (SigS.T y) where    {-    {-# INLINE empty #-}@@ -182,6 +202,70 @@    reverse = SigS.reverse  +{- |+We use event lists for efficient representation of piecewise constant signals.+-}+instance (P.Integral t) => Read (EventList.T t y) where+   null = EventList.null+   length = fromIntegral . P.toInteger . P.sum . EventList.getTimes++instance (P.Integral t, NFData y) => NormalForm (EventList.T t y) where+   evaluateHead = EventList.switchL () (\x _ _ -> rnf x)++{- |+The function defined here are based on the interpretation+of event lists as piecewise constant signals.+They do not fit to the interpretation of atomic events.+Because e.g. it makes no sense to split an atomic event into two instances by splitAt,+and it is also not clear, whether dropping the first chunk+shall leave a chunk of length zero+or remove that chunk completely.+-}+instance (P.Integral t, NonNeg98.C t) => Transform (EventList.T t y) where+   take n xs =+      EventList.foldrPair+         (\b t go remain ->+            if remain <= NonNeg98.zero+              then EventList.empty+              else+                let (m, ~(le,d)) = NonNeg98.split t remain+                in  EventList.cons b m $+                    go (if le then d else NonNeg98.zero))+         (const EventList.empty) xs+         (P.fromIntegral n)++   drop =+      let recourse n =+             EventList.switchL EventList.empty $ \b t xs ->+             let (le,d) = snd $ NonNeg98.split t n+             in  if le+                   then recourse d xs+                   else EventList.cons b d xs+      in  recourse . P.fromIntegral++   -- cf. ChunkySize.dropMarginRem+   dropMarginRem n m xs =+      List.foldl'+         (\(mi,xsi) k -> (mi-k, drop k xsi))+         (m, xs)+         (P.map P.fromIntegral $ EventList.getTimes $ take m $ drop n xs)++   -- cf. StorableVector.Lazy.splitAt+   splitAt =+      let recourse 0 = (,) EventList.empty+          recourse n =+             EventList.switchL (EventList.empty, EventList.empty) $ \b t xs ->+             let (m, ~(le,d)) = NonNeg98.split t n+             in  mapFst (EventList.cons b m) $+                 if le+                   then recourse d xs+                   else (EventList.empty, EventList.cons b d xs)+      in  recourse . P.fromIntegral++   reverse =+      EventList.fromPairList . List.reverse . EventList.toPairList++ {- useful for application of non-negative chunky numbers as gate signals -}@@ -191,7 +275,11 @@    {-# INLINE length #-}    length = sum . List.map (fromIntegral . toInteger) . Chunky.toChunks +instance (ToInteger.C a, NonNeg.C a, NFData a) => NormalForm (Chunky.T a) where+   {-# INLINE evaluateHead #-}+   evaluateHead = ListHT.switchL () (\x _ -> rnf x) . Chunky.toChunks + intToChunky :: (Ring.C a, NonNeg.C a) => String -> Int -> Chunky.T a intToChunky name =    Chunky.fromNumber .@@ -211,7 +299,7 @@    drop n x = x NonNeg.-| intToChunky "drop" n    {-# INLINE dropMarginRem #-}    dropMarginRem n m x =-      let (z,d,b) =+      let (z,~(b,d)) =              Chunky.minMaxDiff                 (intToChunky "dropMargin/n" n)                 (x NonNeg.-| intToChunky "dropMargin/m" m)@@ -219,8 +307,9 @@            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 mempty)+      mapSnd+         (\ ~(b,d) -> if b then d else mempty)+         (Chunky.minMaxDiff (intToChunky "splitAt" n) x)    {-# INLINE reverse #-}    reverse = Chunky.fromChunks . List.reverse . Chunky.toChunks @@ -232,8 +321,13 @@    {-# INLINE length #-}    length = sum . List.map (P.fromIntegral . P.toInteger) . Chunky98.toChunks +instance (P.Integral a, NonNeg.C a, NFData a) =>+      NormalForm (Chunky98.T a) where+   {-# INLINE evaluateHead #-}+   evaluateHead = ListHT.switchL () (\x _ -> rnf x) . Chunky98.toChunks -intToChunky98 :: (NonNeg98.C a) => String -> Int -> Chunky98.T a++intToChunky98 :: (P.Num a, NonNeg98.C a) => String -> Int -> Chunky98.T a intToChunky98 name =    Chunky98.fromNumber . --   NonNegW.fromNumberMsg ("Generic.Cut."++name) .@@ -250,16 +344,17 @@    drop n x = x NonNeg98.-| intToChunky98 "drop" n    {-# INLINE dropMarginRem #-}    dropMarginRem n m x =-      let (z,d,b) =-             Chunky98.minMaxDiff+      let (z,~(b,d)) =+             NonNeg98.split                 (intToChunky98 "dropMargin/n" n)                 (x NonNeg98.-| intToChunky98 "dropMargin/m" m)       in  (if b then 0 else P.fromIntegral (Chunky98.toNumber d),            x NonNeg98.-| z)    {-# INLINE splitAt #-}    splitAt n x =-      let (z,d,b) = Chunky98.minMaxDiff (intToChunky98 "splitAt" n) x-      in  (z, if b then d else Chunky98.zero)+      mapSnd+         (\ ~(b,d) -> if b then d else Chunky98.zero)+         (NonNeg98.split (intToChunky98 "splitAt" n) x)    {-# INLINE reverse #-}    reverse = Chunky98.fromChunks . List.reverse . Chunky98.toChunks
src/Synthesizer/Generic/Displacement.hs view
@@ -4,16 +4,18 @@ -} module Synthesizer.Generic.Displacement where -import qualified Algebra.Additive              as Additive- import qualified Synthesizer.Generic.Signal as SigG +import qualified Algebra.Transcendental        as Trans+import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive+ -- import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric  -{- * Mixing -}+-- * Mixing  {-| Mix two signals.     In opposition to 'zipWith' the result has the length of the longer signal. -}@@ -41,7 +43,8 @@ raise x = SigG.map ((+) x)  -{- * Distortion -}+-- * Distortion+ {- | In "Synthesizer.Basic.Distortion" you find a collection of appropriate distortion functions.@@ -49,3 +52,27 @@ distort :: (SigG.Read sig c, SigG.Transform sig v) =>    (c -> v -> v) -> sig c -> sig v -> sig v distort = SigG.zipWith+++-- * Preprocessing of control curves++{-# INLINE mapLinear #-}+mapLinear :: (Ring.C a, SigG.Transform sig a) =>+   a ->+   a ->+   sig a ->+   sig a+mapLinear depth center =+   SigG.map (\x -> center*(one+x*depth))++{-# INLINE mapExponential #-}+mapExponential :: (Trans.C a, SigG.Transform sig a) =>+   a ->+   a ->+   sig a ->+   sig a+mapExponential depth center =+   -- SigG.map ((center*) . (depth**))+   -- should be faster+   let logDepth = log depth+   in  SigG.map ((center*) . exp . (logDepth*))
src/Synthesizer/Generic/Filter/Delay.hs view
@@ -10,8 +10,8 @@ import qualified Algebra.Additive  as Additive  -- import qualified Prelude as P--- import PreludeBase-import NumericPrelude+-- import NumericPrelude.Base+import NumericPrelude.Numeric
src/Synthesizer/Generic/Filter/NonRecursive.hs view
@@ -32,8 +32,8 @@ import Data.Tuple.HT (mapSnd, mapPair, ) import Data.Maybe.HT (toMaybe, ) -import PreludeBase-import NumericPrelude as NP+import NumericPrelude.Base+import NumericPrelude.Numeric as NP   {- * Envelope application -}
src/Synthesizer/Generic/Filter/Recursive/Comb.hs view
@@ -24,8 +24,8 @@ import qualified Algebra.Additive              as Additive  import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   {- |
src/Synthesizer/Generic/Filter/Recursive/Integration.hs view
@@ -17,8 +17,8 @@ -- import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric
src/Synthesizer/Generic/Filter/Recursive/MovingAverage.hs view
@@ -30,8 +30,8 @@ -- import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric
src/Synthesizer/Generic/Interpolation.hs view
@@ -20,6 +20,7 @@  import qualified Algebra.Module    as Module import qualified Algebra.RealField as RealField+import qualified Algebra.RealRing  as RealRing -- import qualified Algebra.Field     as Field -- import qualified Algebra.Ring      as Ring import qualified Algebra.Additive  as Additive@@ -27,14 +28,14 @@ import Algebra.Additive(zero, ) import Data.Maybe (fromMaybe, ) -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   {-* Interpolation with various padding methods -}  {-# INLINE zeroPad #-}-zeroPad :: (RealField.C t, SigG.Write sig y) =>+zeroPad :: (RealRing.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 =@@ -44,7 +45,7 @@               (SigG.append x (SigG.repeat SigG.defaultLazySize z)))  {-# INLINE constantPad #-}-constantPad :: (RealField.C t, SigG.Write sig y) =>+constantPad :: (RealRing.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 =@@ -61,7 +62,7 @@ Only for finite input signals. -} {-# INLINE cyclicPad #-}-cyclicPad :: (RealField.C t, SigG.Transform sig y) =>+cyclicPad :: (RealRing.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 =@@ -73,7 +74,7 @@ The extrapolation may miss some of the first and some of the last points -} {-# INLINE extrapolationPad #-}-extrapolationPad :: (RealField.C t, SigG.Transform sig y) =>+extrapolationPad :: (RealRing.C t, SigG.Transform sig y) =>    (T t y -> t -> sig y -> a) ->    T t y -> t -> sig y -> a extrapolationPad interpolate ip phase =@@ -92,7 +93,7 @@    Interpolation.func ip phase . SigG.toState  {-# INLINE skip #-}-skip :: (RealField.C t, SigG.Transform sig y) =>+skip :: (RealRing.C t, SigG.Transform sig y) =>    T t y -> (t, sig y) -> (t, sig y) skip ip (phase0, x0) =    let (n, frac) = splitFraction phase0@@ -100,7 +101,7 @@    in  (fromIntegral m + frac, x1)  {-# INLINE single #-}-single :: (RealField.C t, SigG.Transform sig y) =>+single :: (RealRing.C t, SigG.Transform sig y) =>    T t y -> t -> sig y -> y single ip phase0 x0 =    uncurry (func ip) $ skip ip (phase0, x0)@@ -115,7 +116,7 @@ {- | All values of frequency control must be non-negative. -} {-# INLINE multiRelative #-} multiRelative ::-   (RealField.C t, SigG2.Transform sig t y) =>+   (RealRing.C t, SigG2.Transform sig t y) =>    T t y -> t -> sig y -> sig t -> sig y multiRelative ip phase0 x0 =    SigG2.crochetL@@ -127,21 +128,21 @@  {-# INLINE multiRelativeZeroPad #-} multiRelativeZeroPad ::-   (RealField.C t, SigG2.Transform sig t y, SigG.Write sig y) =>+   (RealRing.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, SigG2.Transform sig t y, SigG.Write sig y) =>+   (RealRing.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, SigG2.Transform sig t y) =>+   (RealRing.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@@ -151,7 +152,7 @@ -} {-# INLINE multiRelativeExtrapolationPad #-} multiRelativeExtrapolationPad ::-   (RealField.C t, SigG2.Transform sig t y) =>+   (RealRing.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@@ -164,14 +165,14 @@  {-# INLINE multiRelativeZeroPadConstant #-} multiRelativeZeroPadConstant ::-   (RealField.C t, Additive.C y, SigG2.Transform sig t y, SigG.Write sig y) =>+   (RealRing.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  {-# INLINE multiRelativeZeroPadLinear #-} multiRelativeZeroPadLinear ::-   (RealField.C t, Module.C t y, SigG2.Transform sig t y, SigG.Write sig y) =>+   (RealRing.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
src/Synthesizer/Generic/Loop.hs view
@@ -30,12 +30,12 @@ import qualified Algebra.Transcendental as Trans import qualified Algebra.Module         as Module import qualified Algebra.RealField      as RealField-import qualified Algebra.Real           as Real+import qualified Algebra.RealRing           as RealRing import qualified Algebra.Ring           as Ring import qualified Algebra.Additive       as Additive -import NumericPrelude-import PreludeBase+import NumericPrelude.Numeric+import NumericPrelude.Base   {- |@@ -136,5 +136,5 @@ timeControlSine :: (Trans.C a) => TimeControl a timeControlSine = TimeControl (2*pi) Wave.sine -timeControlZigZag :: (Real.C a) => TimeControl a+timeControlZigZag :: (RealRing.C a) => TimeControl a timeControlZigZag = TimeControl 4 Wave.triangle
src/Synthesizer/Generic/Noise.hs view
@@ -9,15 +9,15 @@ import qualified Synthesizer.Generic.Signal2 as SigG2 import qualified Synthesizer.State.Signal      as SigS -import qualified Algebra.Real                  as Real+import qualified Algebra.RealRing                  as RealRing import qualified Algebra.Ring                  as Ring  import System.Random (Random, RandomGen, randomR, mkStdGen, ) import qualified System.Random as Rnd  import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   {-|@@ -49,7 +49,7 @@   randomPeeks ::-   (Real.C y, Random y, SigG2.Transform sig y Bool) =>+   (RealRing.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. -}@@ -57,7 +57,7 @@    randomPeeksGen (mkStdGen 876)  randomPeeksGen ::-   (Real.C y, Random y, RandomGen g, SigG2.Transform sig y Bool) =>+   (RealRing.C y, Random y, RandomGen g, SigG2.Transform sig y Bool) =>       g    -> sig y    -> sig Bool
src/Synthesizer/Generic/Oscillator.hs view
@@ -44,10 +44,10 @@  -- import qualified Number.NonNegative       as NonNeg -import NumericPrelude+import NumericPrelude.Numeric  -- import qualified Prelude as P-import PreludeBase+import NumericPrelude.Base
src/Synthesizer/Generic/Piece.hs view
@@ -28,8 +28,8 @@ import qualified Algebra.Additive              as Additive  import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric
src/Synthesizer/Generic/Signal.hs view
@@ -34,7 +34,6 @@  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 @@ -44,7 +43,12 @@  import qualified Algebra.Module   as Module import qualified Algebra.Additive as Additive+import qualified Algebra.Monoid   as Monoid +import qualified Data.EventList.Relative.BodyTime as EventList++import qualified Numeric.NonNegative.Class as NonNeg98+ import Foreign.Storable (Storable)  import Control.Monad.Trans.State (runState, runStateT, )@@ -52,15 +56,17 @@  import Data.Function (fix, ) import qualified Data.List.HT as ListHT-import qualified Data.List as List+import qualified Data.List.Stream as List import Data.Tuple.HT (mapPair, mapFst, ) --- import NumericPrelude+-- import NumericPrelude.Numeric+import qualified Prelude as P import Prelude-   (Bool, Int, Maybe(Just), maybe, snd, (<),-    flip, uncurry, const, (.), ($), id, (++),+   (Bool, Int, Maybe(Just), maybe, snd,+    (==), (<), (>), (<=), (>=),+    flip, uncurry, const, (.), ($), (&&), id, (++),     fmap, return, error, show,-    Eq, Ord, Show, max, )+    Eq, Ord, Show, max, min, )   class Cut.Read (sig y) => Read sig y where@@ -72,12 +78,6 @@    index :: sig y -> Int -> 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@@ -110,9 +110,12 @@ newtype LazySize = LazySize Int    deriving (Eq, Ord, Show, Additive.C) +instance Monoid.C LazySize where+   idt = LazySize 0+   LazySize a <*> LazySize b = LazySize (a Additive.+ b)+ instance NonNeg.C LazySize where-   LazySize x -| LazySize y =-      LazySize (max 0 (x Additive.- y))+   split = NonNeg.splitDefault (\(LazySize n) -> n) LazySize  {- | This can be used for internal signals@@ -257,59 +260,6 @@   -instance Read SigFL.T y where-   {-# INLINE toList #-}-   toList = SigFL.toList-   {-# INLINE toState #-}-   toState = SigS.fromList . SigFL.toList-   {-# INLINE foldL #-}-   foldL = SigFL.foldL-   {-# INLINE foldR #-}-   foldR = SigFL.foldR-   {-# INLINE index #-}-   index xs n = SigFL.toList xs List.!! n--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 viewL #-}-   viewL = SigFL.viewL-   {-# INLINE viewR #-}-   viewR = SigFL.viewR--   {-# 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@@ -367,6 +317,134 @@    {-# INLINE iterateAssociative #-}    iterateAssociative _ = SigS.iterateAssociative ++instance (NonNeg98.C time, P.Integral time) =>+      Read (EventList.T time) y where+   {-# INLINE toList #-}+   toList =+      List.concatMap (uncurry (flip List.genericReplicate)) .+      EventList.toPairList+   {-# INLINE toState #-}+   toState = SigS.fromPiecewiseConstant+   {-# INLINE foldL #-}+   foldL f x = SigS.foldL f x . toState+   {-# INLINE foldR #-}+   foldR f x = SigS.foldR f x . toState+   {-# INLINE index #-}+   index sig n =+      EventList.foldrPair+         (\b t go k ->+            if k < t+              then b+              else go (t NonNeg98.-| k))+         (error $ "EventList.index: positions " ++ show n ++ " out of range")+         sig+         (P.fromIntegral n)++instance (NonNeg98.C time, P.Integral time) =>+      Transform (EventList.T time) y where+   {-# INLINE cons #-}+   cons b = EventList.cons b (P.fromInteger 1)+   {-# INLINE takeWhile #-}+   takeWhile p =+      EventList.foldrPair+         (\b t rest ->+            if p b+              then EventList.cons b t rest+              else EventList.empty)+         EventList.empty+   {-# INLINE dropWhile #-}+   dropWhile p =+      let recourse xs =+             flip (EventList.switchL EventList.empty) xs $ \b _t rest ->+             if p b+               then recourse rest+               else xs+      in  recourse+   {-# INLINE span #-}+   span p =+      let recourse xs =+             flip (EventList.switchL (EventList.empty,EventList.empty)) xs $ \b t rest ->+             if p b+               then mapFst (EventList.cons b t) $ recourse rest+               else (EventList.empty, xs)+      in  recourse++   {-# INLINE viewL #-}+   viewL xs = do+      ((b,t),ys) <- EventList.viewL xs+      if t>0+        then Just (b, if t==1 then ys else EventList.cons b (t NonNeg98.-|1) ys)+        else viewL ys+   {-# INLINE viewR #-}+   viewR =+      let dropTrailingZeros =+             EventList.foldrPair+                (\b t rest ->+                   if t==0 && EventList.null rest+                     then EventList.empty+                     else EventList.cons b t rest)+                EventList.empty+          recourse (b,t) =+             EventList.switchL+                (if t<=1+                   then EventList.empty+                   else EventList.singleton b (t NonNeg98.-| 1),+                 b)+                (\b0 t0 xs0 ->+                   mapFst (EventList.cons b t) $ recourse (b0,t0) xs0)+      in  fmap (uncurry recourse) . EventList.viewL . dropTrailingZeros++   {-# INLINE map #-}+   map = fmap+   {-# INLINE scanL #-}+   scanL f x =+      fromState (LazySize 1) . SigS.scanL f x . toState+   {-# INLINE crochetL #-}+   crochetL f x =+      fromState (LazySize 1) . SigS.crochetL f x . toState+   {-# INLINE zipWithAppend #-}+   zipWithAppend f =+      let recourse xs ys =+             flip (EventList.switchL ys) xs $ \x xn xs0 ->+             flip (EventList.switchL xs) ys $ \y yn ys0 ->+             let n = min xn yn+                 drop_ a an as0 =+                    if n>=an+                      then as0+                      else EventList.cons a (an NonNeg98.-| n) as0+             in  EventList.cons (f x y) n $+                 recourse+                    (drop_ x xn xs0)+                    (drop_ y yn ys0)+      in  recourse++++instance (NonNeg98.C time, P.Integral time) => Write (EventList.T time) y where+   {-# INLINE fromList #-}+   fromList _ =+      EventList.fromPairList .+      List.map (flip (,) (P.fromInteger 1))+   {-# INLINE repeat #-}+   repeat (LazySize n) a =+      let xs = EventList.cons a (P.fromIntegral n) xs+      in  xs+   {-# INLINE replicate #-}+   replicate size m a =+      Cut.take m (repeat size a)+   {-# INLINE iterate #-}+   iterate size f =+      fromState size . SigS.iterate f+   {-# INLINE unfoldR #-}+   unfoldR _size f =+      let recourse =+             maybe EventList.empty+                (\(x,s) -> EventList.cons x+                   (P.fromInteger 1) (recourse s)) . f+      in  recourse+   {-# INLINE iterateAssociative #-}+   iterateAssociative size f x = iterate size (f x) x   {-# INLINE switchL #-}
src/Synthesizer/Generic/Signal2.hs view
@@ -13,9 +13,6 @@ 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@@ -25,13 +22,21 @@  import Foreign.Storable (Storable) +import qualified Data.EventList.Relative.BodyTime as EventList++import qualified Numeric.NonNegative.Class as NonNeg98++import qualified Algebra.Module   as Module+-- import qualified Algebra.Additive as Additive+ 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,+   (Integral,+    Bool, Int, Maybe(Just), maybe, fst, snd,     flip, ($), (.),     return, ) @@ -68,6 +73,23 @@    scanL = SigS.scanL    {-# INLINE crochetL #-}    crochetL = SigS.crochetL+++instance (NonNeg98.C time, Integral time) =>+      Transform (EventList.T time) y0 y1 where+   {-# INLINE map #-}+   map = EventList.mapBody+   {-# INLINE scanL #-}+   scanL f x =+      SigG.fromState (SigG.LazySize 1) .+      SigS.scanL f x .+      SigG.toState+   {-# INLINE crochetL #-}+   crochetL f x =+      SigG.fromState (SigG.LazySize 1) .+      SigS.crochetL f x .+      SigG.toState+   {-# INLINE zipWith #-}
src/Synthesizer/Generic/Tutorial.hs view
@@ -35,8 +35,8 @@ import qualified Synthesizer.State.Oscillator as OsciS  import System.Exit (ExitCode, )-import NumericPrelude-import PreludeBase+import NumericPrelude.Numeric+import NumericPrelude.Base import Prelude ()
src/Synthesizer/Generic/Wave.hs view
@@ -7,23 +7,24 @@  import qualified Synthesizer.Interpolation as Interpolation -import qualified Algebra.RealField             as RealField+import qualified Algebra.RealField            as RealField+import qualified Algebra.RealRing             as RealRing  -- import Data.Tuple.HT (swap, ) -import NumericPrelude-import PreludeBase+import NumericPrelude.Numeric+import NumericPrelude.Base import Prelude ()   sample ::-   (RealField.C a, SigG.Transform sig v) =>+   (RealRing.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)+           let (n,q) = RealRing.splitFraction (phase * fromIntegral len)            in  Interpolation.func ip q $                SigG.toState $                SigG.drop n cycleWave
src/Synthesizer/Interpolation.hs view
@@ -8,8 +8,8 @@ import Data.Monoid (Sum(Sum), ) import Control.Applicative (Applicative(pure, (<*>)), (<$>), liftA2, ) -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric
src/Synthesizer/Interpolation/Class.hs view
@@ -16,11 +16,11 @@ import qualified Number.Ratio as Ratio import qualified Number.Complex as Complex -import Control.Applicative (Applicative(pure, (<*>)), )+import Control.Applicative (Applicative(pure, (<*>)), liftA2, ) import Data.Tuple.HT (mapPair, mapSnd, fst3, snd3, thd3, ) -import NumericPrelude hiding (zero, )-import PreludeBase+import NumericPrelude.Numeric hiding (zero, )+import NumericPrelude.Base import Prelude ()  {- |@@ -150,6 +150,31 @@ scaleAndAccumulateModule (a,x) =    let ax = a *> x    in  (ax, (ax+))+++{-# INLINE scaleAndAccumulateApplicative #-}+scaleAndAccumulateApplicative ::+   (C a v, Applicative f) =>+   (a, f v) -> (f v, f v -> f v)+scaleAndAccumulateApplicative (a,x) =+   let ax = fmap (curry scaleAndAccumulate a) x+   in  (fmap fst ax, (fmap snd ax <*>))++{-# INLINE scaleAndAccumulateRingApplicative #-}+scaleAndAccumulateRingApplicative ::+   (Ring.C a, Applicative f) =>+   (a, f a) -> (f a, f a -> f a)+scaleAndAccumulateRingApplicative (a,x) =+   let ax = fmap (a*) x+   in  (ax, liftA2 (+) ax)++{-# INLINE scaleAndAccumulateModuleApplicative #-}+scaleAndAccumulateModuleApplicative ::+   (Module.C a v, Applicative f) =>+   (a, f v) -> (f v, f v -> f v)+scaleAndAccumulateModuleApplicative (a,x) =+   let ax = fmap (a*>) x+   in  (ax, liftA2 (+) ax)   {- |
src/Synthesizer/Interpolation/Custom.hs view
@@ -32,8 +32,8 @@ import Control.Applicative (liftA2, ) import Synthesizer.ApplicativeUtility (liftA4, ) -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric
src/Synthesizer/Interpolation/Module.hs view
@@ -35,8 +35,8 @@ import Synthesizer.ApplicativeUtility (liftA4, ) import Synthesizer.Utility (affineComb, ) -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   {-| Consider the signal to be piecewise linear. -}
src/Synthesizer/Plain/Analysis.hs view
@@ -12,7 +12,8 @@ import qualified Algebra.Algebraic             as Algebraic import qualified Algebra.RealField             as RealField import qualified Algebra.Field                 as Field-import qualified Algebra.Real                  as Real+import qualified Algebra.RealRing              as RealRing+import qualified Algebra.Absolute              as Absolute import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive @@ -30,8 +31,8 @@ import Data.List (foldl', )  import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   {- * Notions of volume -}@@ -39,7 +40,7 @@ {- | Volume based on Manhattan norm. -}-volumeMaximum :: (Real.C y) => Sig.T y -> y+volumeMaximum :: (RealRing.C y) => Sig.T y -> y volumeMaximum =    foldl max zero . rectify --   maximum . rectify@@ -58,7 +59,7 @@ {- | Volume based on Sum norm. -}-volumeSum :: (Field.C y, Real.C y) => Sig.T y -> y+volumeSum :: (Absolute.C y, Field.C y) => Sig.T y -> y volumeSum = average . rectify  @@ -269,7 +270,7 @@ average x =    sum x / fromIntegral (length x) -rectify :: Real.C y => Sig.T y -> Sig.T y+rectify :: Absolute.C y => Sig.T y -> Sig.T y rectify = map abs  {- |@@ -328,7 +329,8 @@    in  map (scalarProduct xs) powerPowers  -binarySign :: Real.C y => Sig.T y -> Sig.T BinaryLevel+binarySign ::+   (Ord y, Additive.C y) => Sig.T y -> Sig.T BinaryLevel binarySign =    map (binaryLevelFromBool . (zero <=)) @@ -336,7 +338,8 @@ The output type could be different from the input type but then we would need a conversion from output to input for feedback. -}-deltaSigmaModulation :: Real.C y => Sig.T y -> Sig.T BinaryLevel+deltaSigmaModulation ::+   RealRing.C y => Sig.T y -> Sig.T BinaryLevel deltaSigmaModulation x =    let y = binarySign (Integration.runInit zero (x - map binaryLevelToNumber y))    in  y
src/Synthesizer/Plain/Builder.hs view
@@ -12,8 +12,8 @@  import qualified Prelude as P98 -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric
src/Synthesizer/Plain/Control.hs view
@@ -9,7 +9,7 @@  import qualified Algebra.Module                as Module import qualified Algebra.Transcendental        as Trans-import qualified Algebra.RealField             as RealField+import qualified Algebra.RealRing              as RealRing import qualified Algebra.Field                 as Field import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive@@ -22,8 +22,8 @@ import Data.List.HT (iterateAssociative, )  import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   {- * Control curve generation -}@@ -406,7 +406,7 @@ y0 |# ((d,c,y1), xs)  =  ControlPiece c y0 y1 d : xs  -piecewise :: (Trans.C y, RealField.C y) =>+piecewise :: (Trans.C y, RealRing.C y) =>    [ControlPiece y] -> Sig.T y piecewise xs =    let ts = scanl (\(_,fr) d -> splitFraction (fr+d))
src/Synthesizer/Plain/Cut.hs view
@@ -23,22 +23,22 @@ import qualified Data.EventList.Relative.TimeBody as EventList  import qualified MathObj.LaurentPolynomial as Laurent-import qualified Algebra.Real     as Real+import qualified Algebra.RealRing     as RealRing import qualified Algebra.Additive as Additive  import Data.Array (Array, Ix, (!))  import qualified Number.NonNegative as NonNeg -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric    {- | Take signal until it falls short of a certain amplitude for a given time. -}-takeUntilPause :: (Real.C a) => a -> Int -> Sig.T a -> Sig.T a+takeUntilPause :: (RealRing.C a) => a -> Int -> Sig.T a -> Sig.T a takeUntilPause y =    takeUntilInterval ((<=y) . abs) @@ -57,7 +57,7 @@   --- Better use zipWithMatch from NumericPrelude?+-- Better use zipWithMatch from NumericPrelude.Numeric? 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))
src/Synthesizer/Plain/Displacement.hs view
@@ -9,8 +9,8 @@ import qualified Synthesizer.Plain.Signal as Sig  -- import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   {- * Mixing -}
src/Synthesizer/Plain/Effect.hs view
@@ -13,10 +13,8 @@ import Synthesizer.Plain.Control(exponential2) import Synthesizer.Plain.Instrument import Synthesizer.Plain.Effect.Glass(glass)+ import qualified Synthesizer.Plain.File as File-import Synthesizer.Filter.Example(guitarRaw, flangedSaw)---import Interpolation(interpolate,interpolateConstant)---import System.Random import System.Exit(ExitCode) import System.Cmd(rawSystem) @@ -29,8 +27,7 @@           rawSystem "play" ["test.aiff"]  -soundE, soundD,-   soundC, soundB, soundA,+soundE, soundB, soundA,    sound9, sound8, sound7,    sound6, sound5, sound4,    sound3, sound2, sound1,@@ -38,9 +35,10 @@  soundE = glass +{- moved to synthesizer-filter soundD = flangedSaw- soundC _ = guitarRaw+-}  cFreq :: Double cFreq = 521.3417849066773
src/Synthesizer/Plain/Effect/Fly.hs view
@@ -13,8 +13,8 @@  import qualified Algebra.NormedSpace.Euclidean as Euc -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   {-
src/Synthesizer/Plain/Effect/Glass.hs view
@@ -18,8 +18,8 @@  import System.Random(randomRs, mkStdGen) -import PreludeBase-import NumericPrelude as NP+import NumericPrelude.Base+import NumericPrelude.Numeric as NP   {- | We try to simulate the sound of broken glass
src/Synthesizer/Plain/File.hs view
@@ -24,13 +24,13 @@ import Data.Monoid (mconcat, )  import qualified Algebra.ToInteger          as ToInteger-import qualified Algebra.RealField          as RealField+import qualified Algebra.RealRing           as RealRing import qualified Algebra.Field              as Field  import qualified System.FilePath as FilePath -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   @@ -39,22 +39,22 @@ -} render ::    (Storable int, Frame.C int, ToInteger.C int, Bounded int,-    RealField.C a, BinSmp.C v) =>+    RealRing.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) =>+renderToInt16 :: (RealRing.C a, BinSmp.C v) =>    FilePath -> a -> (a -> [v]) -> IO ExitCode renderToInt16 fileName sampleRate renderer =    writeToInt16 fileName sampleRate (renderer sampleRate) -renderMonoToInt16 :: (RealField.C a) =>+renderMonoToInt16 :: (RealRing.C a) =>    FilePath -> a -> (a -> [a]) -> IO ExitCode renderMonoToInt16 fileName sampleRate renderer =    writeMonoToInt16 fileName sampleRate (renderer sampleRate) -renderStereoToInt16 :: (RealField.C a) =>+renderStereoToInt16 :: (RealRing.C a) =>    FilePath -> a -> (a -> [(a,a)]) -> IO ExitCode renderStereoToInt16 fileName sampleRate renderer =    writeStereoToInt16 fileName sampleRate (renderer sampleRate)@@ -72,7 +72,7 @@ -} write ::    (Storable int, Frame.C int, ToInteger.C int, Bounded int,-    RealField.C a, BinSmp.C v) =>+    RealRing.C a, BinSmp.C v) =>    Builder.Put int -> FilePath -> a -> [v] -> IO ExitCode write put fileName sampleRate signal =    writeRaw@@ -82,24 +82,24 @@       (Builder.run . mconcat . map (BinSmp.outputFromCanonical put) $        signal) -writeToInt16 :: (RealField.C a, BinSmp.C v) =>+writeToInt16 :: (RealRing.C a, BinSmp.C v) =>    FilePath -> a -> [v] -> IO ExitCode writeToInt16 =    write (Builder.put :: Builder.Put Int16) -writeMonoToInt16 :: (RealField.C a) =>+writeMonoToInt16 :: (RealRing.C a) =>    FilePath -> a -> [a] -> IO ExitCode writeMonoToInt16 fileName sampleRate signal =    writeRaw SoxOpt.none fileName sampleRate       (map BinSmp.int16FromCanonical signal) -writeStereoToInt16 :: (RealField.C a) =>+writeStereoToInt16 :: (RealRing.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) =>+writeRaw :: (RealRing.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@@ -110,7 +110,7 @@ extension for 'writeRaw' and SoX will do the corresponding compression for you. -}-writeRawCompressed :: (RealField.C a, Frame.C v, Storable v) =>+writeRawCompressed :: (RealRing.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@@ -118,7 +118,7 @@   {-# 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) =>+rawToAIFF :: (RealRing.C a) =>    FilePath -> SoxOpt.T -> a -> Int -> IO ExitCode rawToAIFF fileName soxOptions sampleRate numChannels =    let fileNameRaw  = fileName ++ ".sw"@@ -146,7 +146,7 @@ after all system calls to Sox are performed. Aren't the calls serialized? -readAIFFMono :: (RealField.C a, Floating a) => FilePath -> IO [a]+readAIFFMono :: (RealRing.C a, Floating a) => FilePath -> IO [a] readAIFFMono file =    do putStrLn ("sox "++file++" /tmp/sample.sw")       system ("sox "++file++" /tmp/sample.sw")
src/Synthesizer/Plain/Filter/Delay.hs view
@@ -18,8 +18,8 @@ import qualified Synthesizer.Plain.Filter.Delay.Block as DelayBlock  import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   phaser :: (Module.C a v, RealField.C a) => a -> [a] -> [v] -> [v]
src/Synthesizer/Plain/Filter/Delay/Block.hs view
@@ -19,8 +19,8 @@ import Test.QuickCheck ((==>), Property)  import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   modulatedCore :: (RealField.C a, Additive.C v) =>
src/Synthesizer/Plain/Filter/Delay/List.hs view
@@ -9,8 +9,8 @@ import Data.List(tails)  import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   {- |
src/Synthesizer/Plain/Filter/Delay/ST.hs view
@@ -14,8 +14,8 @@ import Data.Array.ST  import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   {-
src/Synthesizer/Plain/Filter/LinearPredictive.hs view
@@ -8,8 +8,8 @@ import qualified Data.List.Match as ListMatch import qualified Data.List as List -import NumericPrelude-import PreludeBase+import NumericPrelude.Numeric+import NumericPrelude.Base import Prelude ()
src/Synthesizer/Plain/Filter/NonRecursive.hs view
@@ -31,8 +31,8 @@ -- import Control.Monad.Trans.State (StateT) -- import Control.Monad.Trans.Writer (WriterT) -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   {- * Envelope application -}
src/Synthesizer/Plain/Filter/Recursive.hs view
@@ -21,8 +21,8 @@ import Algebra.Module((*>))  import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   {- * Various Filters -}
src/Synthesizer/Plain/Filter/Recursive/Allpass.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {- |-Copyright   :  (c) Henning Thielemann 2008+Copyright   :  (c) Henning Thielemann 2008-2010 License     :  GPL  Maintainer  :  synthesizer@henning-thielemann.de@@ -14,8 +14,15 @@ 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 Control.Applicative as App+import qualified Data.Foldable as Fold+import qualified Data.Traversable as Trav +import qualified Foreign.Storable.Newtype as Store+import Foreign.Storable (Storable(sizeOf, alignment, peek, poke))+ import qualified Algebra.Module                as Module import qualified Algebra.RealTranscendental    as RealTrans import qualified Algebra.Transcendental        as Trans@@ -25,17 +32,16 @@  import Algebra.Module((*>)) -import Number.Complex ((+:)) import qualified Number.Complex as Complex import Data.Tuple.HT (mapSnd, ) import Data.Function.HT (nest, ) import Data.List.HT (mapAdjacent, switchR, ) -import Control.Monad.Trans.State (State, state, runState, evalState, )+import qualified Control.Monad.Trans.State as MS  import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   @@ -43,26 +49,36 @@    Parameter {getParameter :: a}  {- ^ Feedback factor. -}    deriving Show +instance Functor Parameter where+   {-# INLINE fmap #-}+   fmap f (Parameter k) = Parameter (f k) +instance App.Applicative Parameter where+   {-# INLINE pure #-}+   pure x = Parameter x+   {-# INLINE (<*>) #-}+   Parameter f <*> Parameter k =+      Parameter (f k)++instance Fold.Foldable Parameter where+   {-# INLINE foldMap #-}+   foldMap = Trav.foldMapDefault++instance Trav.Traversable Parameter where+   {-# INLINE sequenceA #-}+   sequenceA (Parameter k) =+      fmap Parameter k+ instance Interpol.C a v => Interpol.C a (Parameter v) where    {-# INLINE scaleAndAccumulate #-}    scaleAndAccumulate = Interpol.makeMac Parameter getParameter +instance Storable a => Storable (Parameter a) where+   sizeOf = Store.sizeOf getParameter+   alignment = Store.alignment getParameter+   peek = Store.peek Parameter+   poke = Store.poke 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 =>-     a    {- ^ The phase shift to be achieved for the given frequency in radians. -}-  -> a    {- ^ The frequency we specified the phase shift for. -}-  -> Parameter a-parameter phase frequency =-   let omega = frequency * 2 * pi-       k = (cos phase - cos omega) / (1 - cos (phase - omega))-   in  Parameter k  {- cos phi = (1-r^2)/(1+r^2)@@ -76,20 +92,54 @@ k = (s^2-r^2) / (r-s)^2 k = (s+r) / (s-r) -}+{- |+Compute the filter parameter+such that a given phase shift is achieved at a certain frequency.++Both frequency and phase are with respect to unit 1.+This is conform to Phase definition+and allows to avoid Transcendental constraint in some cases+since we need no factor @2*pi@.+See for instance 'parameterApprox'.+However, it is intended that the phase parameter is not of type Phase,+because for the 'cascadeParameter' we divide by the cascade order+and then there is a difference between phase pi and 3*pi.+-}+{-# INLINE parameter #-}+parameter :: Trans.C a =>+     a    {- ^ The phase shift to be achieved for the given frequency. -}+  -> a    {- ^ The frequency we specified the phase shift for. -}+  -> Parameter a+parameter phase frequency =+   let s = tan (pi*frequency)+       r = tan (pi*phase)+   in  Parameter $ (s+r) / (s-r)+++{- |+This is the same as 'parameter',+but for @phase = frequency@+it has a division of a zero by a zero of multiplicity 2,+whereas 'parameter' has a division  of a non-zero number by zero.+Thus 'parameter' suffers less from cancellation+if @phase@ is close to @frequency@.+-} {-# INLINE parameterAlt #-} parameterAlt :: Trans.C a =>      a    {- ^ The phase shift to be achieved for the given frequency. -}   -> a    {- ^ The frequency we specified the phase shift for. -}   -> Parameter a parameterAlt phase frequency =-   let s = tan (frequency * pi)-       r = tan (phase/2)-   in  Parameter $ (s+r) / (s-r)+   let omega = 2*pi * frequency+       phi   = 2*pi * phase+       k = (cos phi - cos omega) / (1 - cos (phi - omega))+   in  Parameter k + {- | An approximation to 'parameter' for small phase and frequency values.-It needs only field operations,-however it also needs 'pi', thus the transcendental constraint.+It needs only field operations+due to our choice of the unit 1 for the phase parameter. -} {-# INLINE parameterApprox #-} parameterApprox :: Trans.C a =>@@ -97,22 +147,22 @@   -> a    {- ^ The frequency we specified the phase shift for. -}   -> Parameter a parameterApprox phase frequency =-   let omega = frequency * 2 * pi-       k = (omega + phase) / (omega - phase)-   in  Parameter k+   Parameter $ (frequency + phase) / (frequency - phase)   -- * atomic first order allpass +type State v = (v,v)+ {-# INLINE firstOrderStep #-} firstOrderStep :: (Ring.C a, Module.C a v) =>-   Parameter a -> v -> State (v,v) v+   Parameter a -> v -> MS.State (State v) v firstOrderStep (Parameter k) u0 =-   state (\(u1,y1) -> let y0 = u1 + k *> (u0-y1) in (y0,(u0,y0)))+   MS.state (\(u1,y1) -> let y0 = u1 + k *> (u0-y1) in (y0,(u0,y0)))  {-# INLINE firstOrderModifier #-} firstOrderModifier :: (Ring.C a, Module.C a v) =>-   Modifier.Simple (v,v) (Parameter a) v v+   Modifier.Simple (State v) (Parameter a) v v firstOrderModifier =    Modifier.Simple (zero,zero) firstOrderStep @@ -128,11 +178,14 @@ firstOrder = Sig.modifyModulated firstOrderModifier  +{- |+Compute phase shift of an allpass at a given frequency.+-} {-# INLINE makePhase #-} makePhase :: RealTrans.C a => Parameter a -> a -> a makePhase (Parameter k) frequency =-   let omega = 2*pi * frequency-   in  2 * Complex.phase ((k+cos omega)+:(- sin omega)) + omega+   let cis = Complex.cis (- 2*pi * frequency)+   in  Complex.phase (Complex.fromReal k + cis) / pi + frequency   -- * allpass cascade with uniform control@@ -140,28 +193,15 @@ {-# INLINE cascadeParameter #-} cascadeParameter :: Trans.C a =>      Int  {- ^ The number of equally designed 1st order allpasses. -}-  -> a    {- ^ The phase shift to be achieved for the given frequency in radians. -}+  -> a    {- ^ The phase shift to be achieved for the given frequency. -}   -> a    {- ^ The frequency we specified the phase shift for. -}   -> Parameter a cascadeParameter order phase =    parameter (phase / fromIntegral order) -{-# INLINE cascadeParameterAlt #-}-cascadeParameterAlt :: Trans.C a =>-     Int  {- ^ The number of equally designed 1st order allpasses. -}-  -> a    {- ^ The phase shift to be achieved for the given frequency in radians. -}-  -> a    {- ^ The frequency we specified the phase shift for. -}-  -> Parameter a-cascadeParameterAlt order phase frequency =-   let orderFloat = fromIntegral order-       omega = frequency * 2 * pi-       phi = phase / orderFloat-       k = (cos phi - cos omega) / (1 - cos (phi - omega))-   in  Parameter k- {-# INLINE flangerPhase #-}-flangerPhase :: Trans.C a => a-flangerPhase = -2*pi+flangerPhase :: Field.C a => a+flangerPhase = -1  {-# INLINE flangerParameter #-} flangerParameter :: Trans.C a => Int -> a -> Parameter a@@ -171,7 +211,7 @@  {-# INLINE cascadeStep #-} cascadeStep :: (Ring.C a, Module.C a v) =>-   Parameter a -> v -> State [v] v+   Parameter a -> v -> MS.State [v] v cascadeStep = cascadeStepRec  {-@@ -181,7 +221,7 @@ -} {-# INLINE cascadeStepStackPairs #-} cascadeStepStackPairs :: (Ring.C a, Module.C a v) =>-   Parameter a -> v -> State [(v,v)] v+   Parameter a -> v -> MS.State [State v] v cascadeStepStackPairs k =    -- stackStatesR would work as well, but with reversed list of states    Modifier.stackStatesL (firstOrderStep k)@@ -191,11 +231,11 @@ {-# INLINE cascadeStepScanl #-} cascadeStepStack, cascadeStepRec, cascadeStepScanl ::    (Ring.C a, Module.C a v) =>-   Parameter a -> v -> State [v] v+   Parameter a -> v -> MS.State [v] v cascadeStepStack k x =-   state $+   MS.state $       mapSnd fromPairs .-      runState (cascadeStepStackPairs k x) .+      MS.runState (cascadeStepStackPairs k x) .       toPairs  {-# INLINE fromPairs #-}@@ -208,7 +248,7 @@ toPairs xs = mapAdjacent (,) xs  -cascadeStepRec (Parameter k) x = state $ \s ->+cascadeStepRec (Parameter k) x = MS.state $ \s ->    let crawl _ [] = error "Allpass.crawl needs at least one element in the list"        crawl u0 (_:[]) = u0:[]        crawl u0 (u1:y1:us) =@@ -217,10 +257,10 @@        news = crawl x s    in  (last news, news) -cascadeStepScanl k x = state $ \s ->+cascadeStepScanl k x = MS.state $ \s ->    let news =           scanl-             (evalState . firstOrderStep k)+             (MS.evalState . firstOrderStep k)              x (mapAdjacent (,) s)    in  (switchR            (error "Allpass.cascade needs at least one element in the state list")@@ -274,13 +314,13 @@ {-# INLINE cascadeDiverseStep #-} {-# INLINE cascadeDiverseStepScanl #-} cascadeDiverseStep, cascadeDiverseStepScanl :: (Ring.C a, Module.C a v) =>-   [Parameter a] -> v -> State [v] v+   [Parameter a] -> v -> MS.State [v] v cascadeDiverseStep = cascadeDiverseStepScanl -cascadeDiverseStepScanl ks x = state $ \s ->+cascadeDiverseStepScanl ks x = MS.state $ \s ->    let news =           scanl-             (\u0 (k,uy1) -> evalState (firstOrderStep k u0) uy1)+             (\u0 (k,uy1) -> MS.evalState (firstOrderStep k u0) uy1)              x (zip ks $ mapAdjacent (,) s)    in  (switchR            (error "Allpass.cascadeDiverse needs at least one element in the state list")
src/Synthesizer/Plain/Filter/Recursive/AllpassPoly.hs view
@@ -28,8 +28,8 @@ import Orthogonals(Scalar,one_ket_solution)  import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   @@ -83,7 +83,7 @@         q = (exp (2*pi*r) - 1) / (r^2 + k^2)     in  (r*q, -k*q) -{- Should be moved to NumericPrelude -}+{- Should be moved to NumericPrelude.Numeric -} integrateNum :: (Field.C a, Module.C a v) => Int -> (a,a) -> (a->v) -> v integrateNum n (lo,hi) f =     let xs = map (\k -> lo + (hi-lo) * fromIntegral k / fromIntegral n)
src/Synthesizer/Plain/Filter/Recursive/Butterworth.hs view
@@ -32,8 +32,8 @@ import Foreign.Storable (Storable)  import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   @@ -116,7 +116,7 @@ modifier ::    (Ring.C a, Module.C a v, Storable a, Storable v) =>    Int ->-   Modifier.Simple (Cascade.Status v) (Parameter a) v v+   Modifier.Simple (Cascade.State v) (Parameter a) v v modifier =    Cascade.modifier
src/Synthesizer/Plain/Filter/Recursive/Chebyshev.hs view
@@ -40,8 +40,8 @@ import Foreign.Storable (Storable)  import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   @@ -252,6 +252,10 @@  -- * use second order filter parameters for control +{-+We could prevent definition of an extra parameter type+by applying application to one of the filters using Filt2.amplify.+-} type ParameterA a = (a, Cascade.Parameter a)  {-# INLINE parameterA #-}@@ -291,7 +295,7 @@ modifierB ::    (Ring.C a, Module.C a v, Storable a, Storable v) =>    Int ->-   Modifier.Simple (Cascade.Status v) (Cascade.Parameter a) v v+   Modifier.Simple (Cascade.State v) (Cascade.Parameter a) v v modifierB =    Cascade.modifierB -}
src/Synthesizer/Plain/Filter/Recursive/Comb.hs view
@@ -28,8 +28,8 @@ import Algebra.Module((*>))  import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   {- |
src/Synthesizer/Plain/Filter/Recursive/FirstOrder.hs view
@@ -16,8 +16,17 @@ 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 Control.Applicative (pure, liftA2, )+import qualified Control.Applicative as App+import qualified Data.Foldable as Fold+import qualified Data.Traversable as Trav +import qualified Foreign.Storable.Newtype as Store+import qualified Foreign.Storable.Traversable as StoreTrav+import Foreign.Storable (Storable(sizeOf, alignment, peek, poke))+ import qualified Algebra.Module                as Module import qualified Algebra.Transcendental        as Trans -- import qualified Algebra.Field                 as Field@@ -30,8 +39,8 @@  import Control.Monad.Trans.State (State, state, ) -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   @@ -39,11 +48,37 @@    deriving Show  +instance Functor Parameter where+   {-# INLINE fmap #-}+   fmap f (Parameter k) = Parameter (f k)++instance App.Applicative Parameter where+   {-# INLINE pure #-}+   pure x = Parameter x+   {-# INLINE (<*>) #-}+   Parameter f <*> Parameter k =+      Parameter (f k)++instance Fold.Foldable Parameter where+   {-# INLINE foldMap #-}+   foldMap = Trav.foldMapDefault++instance Trav.Traversable Parameter where+   {-# INLINE sequenceA #-}+   sequenceA (Parameter k) =+      fmap Parameter k+ instance Interpol.C a v => Interpol.C a (Parameter v) where    {-# INLINE scaleAndAccumulate #-}    scaleAndAccumulate = Interpol.makeMac Parameter getParameter +instance Storable a => Storable (Parameter a) where+   sizeOf = Store.sizeOf getParameter+   alignment = Store.alignment getParameter+   peek = Store.peek Parameter+   poke = Store.poke getParameter + {-| Convert cut-off frequency to feedback factor. -} {-# INLINE parameter #-} parameter :: Trans.C a => a -> Parameter a@@ -127,24 +162,69 @@ data Result a =         Result {highpass_, lowpass_ :: !a} +instance Functor Result where+   {-# INLINE fmap #-}+   fmap f p = Result (f $ highpass_ p) (f $ lowpass_ p)++instance App.Applicative Result where+   {-# INLINE pure #-}+   pure x = Result x x+   {-# INLINE (<*>) #-}+   f <*> p = Result (highpass_ f $ highpass_ p) (lowpass_ f $ lowpass_ p)++instance Fold.Foldable Result where+   {-# INLINE foldMap #-}+   foldMap = Trav.foldMapDefault++instance Trav.Traversable Result where+   {-# INLINE sequenceA #-}+   sequenceA p = liftA2 Result (highpass_ p) (lowpass_ p)+ instance Additive.C v => Additive.C (Result v) where    {-# INLINE zero #-}    {-# INLINE (+) #-}    {-# INLINE (-) #-}    {-# INLINE negate #-}+   zero   = pure zero+   (+)    = liftA2 (+)+   (-)    = liftA2 (-)+   negate = fmap 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*>v = fmap (s*>) v+{-    s *> (Result hp lp) = Result (s *> hp) (s *> lp)+-} +instance Storable a => Storable (Result a) where+   sizeOf    = StoreTrav.sizeOf+   alignment = StoreTrav.alignment+   peek      = StoreTrav.peekApplicative+   poke      = StoreTrav.poke + {-# 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)++{-# INLINE modifierInit #-}+modifierInit :: (Ring.C a, Module.C a v) =>+   Modifier.Initialized v v (Parameter a) v v+modifierInit =+   Modifier.Initialized id lowpassStep++{-# INLINE modifier #-}+modifier :: (Ring.C a, Module.C a v) =>+   Modifier.Simple v (Parameter a) v v+modifier =+   Sig.modifierInitialize modifierInit zero+
src/Synthesizer/Plain/Filter/Recursive/FirstOrderComplex.hs view
@@ -47,12 +47,13 @@ import Control.Monad.Trans.State (State, state, )  import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   data Parameter a =         Parameter {c, amp :: !(Complex.T a)}+   deriving Show   instance Interpol.C a v => Interpol.C a (Parameter v) where
src/Synthesizer/Plain/Filter/Recursive/Hilbert.hs view
@@ -50,8 +50,8 @@  import qualified Data.List.Match as Match -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   @@ -71,8 +71,8 @@ parameter :: Trans.C a => a -> Parameter a parameter rate =    Parameter-      (map (Allpass.parameterApprox (-2/15) . (/rate)) polesCosine)-      (map (Allpass.parameterApprox (-2/15) . (/rate)) polesSine)+      (map (Allpass.parameterApprox (-1/(15*pi)) . (/rate)) polesCosine)+      (map (Allpass.parameterApprox (-1/(15*pi)) . (/rate)) polesSine)   {-# INLINE step2 #-}
src/Synthesizer/Plain/Filter/Recursive/Integration.hs view
@@ -18,8 +18,8 @@ -- import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric
src/Synthesizer/Plain/Filter/Recursive/Moog.hs view
@@ -21,6 +21,10 @@ import qualified Synthesizer.Causal.Process as Causal  import qualified Synthesizer.Interpolation.Class as Interpol+import Control.Applicative (pure, liftA2, (<*>), )+import qualified Control.Applicative as App+import qualified Data.Foldable as Fold+import qualified Data.Traversable as Trav  import qualified Algebra.Module                as Module import qualified Algebra.Transcendental        as Trans@@ -32,12 +36,12 @@  import Data.Function.HT (nest, ) -import Control.Monad.Trans.State (State, state, evalState, gets)+import qualified Control.Monad.Trans.State as MS import Control.Arrow ((&&&), (>>^), (^>>), )  import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   data Parameter a =@@ -49,13 +53,38 @@   deriving Show  +instance Functor Parameter where+   {-# INLINE fmap #-}+   fmap f p = Parameter+      (f $ feedback p) (fmap f $ lowpassParam p)++instance App.Applicative Parameter where+   {-# INLINE pure #-}+   pure x = Parameter x (Filt1.Parameter x)+   {-# INLINE (<*>) #-}+   f <*> p = Parameter+      (feedback f $ feedback p) (lowpassParam f <*> lowpassParam p)++instance Fold.Foldable Parameter where+   {-# INLINE foldMap #-}+   foldMap = Trav.foldMapDefault++instance Trav.Traversable Parameter where+   {-# INLINE sequenceA #-}+   sequenceA p =+      liftA2 Parameter+         (feedback p) (Trav.sequenceA (lowpassParam p))+ 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) =+{-+For small frequencies we get cancellations and division zero by zero.+-}+parameterInstable :: Trans.C a => Int -> Pole a -> Parameter a+parameterInstable order (Pole resonance frequency) =     let beta  = frequency * 2 * pi         alpha = (pi-beta) / fromIntegral order         k     = sin alpha / sin (alpha+beta)@@ -65,29 +94,57 @@     in  Parameter f (Filt1.Parameter k)  {-+sin (a+b)+ = sin a * cos b + cos a * sin b+ = (2*ta*(1-tb^2) + 2*tb*(1-ta^2)) / ((1+ta^2)*(1+tb^2)) where ta = tan(a/2); tb = tan(b/2)++sin (a+b) - sin a+ = 2*(ta*(1-tb^2) + tb*(1-ta^2) - ta*(1+tb^2)) / ((1+ta^2)*(1+tb^2))+ = 2*(tb*(1-ta^2) - 2*ta*tb^2) / ((1+ta^2)*(1+tb^2))+ = sin b * (1-ta^2 - 2*ta*tb) / (1+ta^2)+-}+parameter :: Trans.C a => Int -> Pole a -> Parameter a+parameter order (Pole resonance frequency) =+    let beta2  = frequency * pi+        alpha2 = (pi/2-beta2) / fromIntegral order+        tanAlpha2 = tan alpha2+        tanBeta2  = tan beta2+        k =+           tanAlpha2*(1+tanBeta2^2) /+           (tanAlpha2*(1-tanBeta2^2) + tanBeta2*(1-tanAlpha2^2))++        d = (1-tanAlpha2^2 - 2*tanAlpha2*tanBeta2) / (1+tanAlpha2^2)+        q = d ^ fromIntegral order+        f = (resonance-1) / (resonance*q+1)+    in  Parameter f (Filt1.Parameter k)+++type State = []++{- Used for lowpassState, list of internal values may be processed by Applicative.traverse. -} lowpassStepStack :: (Ring.C a, Module.C a v) =>-   Parameter a -> v -> State [v] v+   Parameter a -> v -> MS.State (State v) v lowpassStepStack (Parameter f k) x =-   do y0 <- gets head+   do y0 <- MS.gets head       y1 <- Modifier.stackStatesR (Filt1.lowpassStep k) (x - f *> y0)       return ((1+f) *> y1)  lowpassStepRev :: (Ring.C a, Module.C a v) =>-   Parameter a -> v -> State [v] v-lowpassStepRev (Parameter f k) x = state (\s ->+   Parameter a -> v -> MS.State (State v) v+lowpassStepRev (Parameter f k) x = MS.state $ \s ->     let news =            tail (scanl-              (evalState . Filt1.lowpassStep k)+              (MS.evalState . Filt1.lowpassStep k)               -- (\u0 y1 -> let Filt1.Parameter k0 = k in (1-k0) *> u0 + k0 *> y1)               (x - f *> last s) s)-    in  ((1+f) *> last news, news))+    in  ((1+f) *> last news, news)   lowpassModifier :: (Ring.C a, Module.C a v) =>-   Int -> Modifier.Simple [v] (Parameter a) v v+   Int -> Modifier.Simple (State v) (Parameter a) v v lowpassModifier order =    Modifier.Simple (replicate order zero) lowpassStepStack
src/Synthesizer/Plain/Filter/Recursive/MovingAverage.hs view
@@ -28,8 +28,8 @@ import Control.Monad.Fix (fix) import Data.List (tails) -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   @@ -60,8 +60,8 @@ It adds from @from@ (inclusively) to @to@ (exclusively), that is, it sums up @abs (to-from)@ values -}-sumFromTo :: (Additive.C v) => Int -> Int -> Sig.T v -> v-sumFromTo from to =+_sumFromTo :: (Additive.C v) => Int -> Int -> Sig.T v -> v+_sumFromTo from to =    if from <= to      then          sum . take (to-from) . drop from      else negate . sum . take (from-to) . drop to@@ -111,9 +111,9 @@    init . tails -} -sumsModulated :: (RealField.C a, Module.C a v) =>+_sumsModulated :: (RealField.C a, Module.C a v) =>    Int -> Sig.T a -> Sig.T v -> Sig.T v-sumsModulated maxDInt ds xs =+_sumsModulated maxDInt ds xs =    let maxD  = fromIntegral maxDInt        posXs = sumDiffsModulated 0 ds xs        negXs = sumDiffsModulated maxD (map (maxD-) ds) (delay maxDInt xs)
src/Synthesizer/Plain/Filter/Recursive/SecondOrder.hs view
@@ -22,6 +22,10 @@  import qualified Synthesizer.Interpolation.Class as Interpol import Synthesizer.ApplicativeUtility (liftA4, liftA5, )+import Control.Applicative (pure, )+import qualified Control.Applicative as App+import qualified Data.Foldable as Fold+import qualified Data.Traversable as Trav  import qualified Synthesizer.Causal.Process as Causal @@ -36,14 +40,14 @@  import Data.List (zipWith6) -import Control.Monad.Trans.State (State, state, )+import qualified Control.Monad.Trans.State as MS  import Foreign.Storable (Storable(..)) import qualified Foreign.Storable.Record as Store  import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   {- | Parameters for a general recursive filter of 2nd order. -}@@ -51,17 +55,29 @@    Parameter {c0, c1, c2, d1, d2 :: !a}        deriving Show -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 Functor Parameter where+   {-# INLINE fmap #-}+   fmap f p = Parameter+      (f $ c0 p) (f $ c1 p) (f $ c2 p) (f $ d1 p) (f $ d2 p) +instance App.Applicative Parameter where+   {-# INLINE pure #-}+   pure x = Parameter x x x x x+   {-# INLINE (<*>) #-}+   f <*> p = Parameter+      (c0 f $ c0 p) (c1 f $ c1 p) (c2 f $ c2 p) (d1 f $ d1 p) (d2 f $ d2 p) +instance Fold.Foldable Parameter where+   {-# INLINE foldMap #-}+   foldMap = Trav.foldMapDefault++instance Trav.Traversable Parameter where+   {-# INLINE sequenceA #-}+   sequenceA p =+      liftA5 Parameter+         (c0 p) (c1 p) (c2 p) (d1 p) (d2 p)+ instance Interpol.C a v => Interpol.C a (Parameter v) where    {-# INLINE scaleAndAccumulate #-}    scaleAndAccumulate =@@ -75,6 +91,41 @@   +data State a =+   State {u1, u2, y1, y2 :: !a}+       deriving Show++zeroState :: Additive.C a => State a+zeroState =+   State+      {u1 = zero, u2 = zero,+       y1 = zero, y2 = zero}+++instance Functor State where+   {-# INLINE fmap #-}+   fmap f p = State+      (f $ u1 p) (f $ u2 p) (f $ y1 p) (f $ y2 p)++instance App.Applicative State where+   {-# INLINE pure #-}+   pure x = State x x x x+   {-# INLINE (<*>) #-}+   f <*> p = State+      (u1 f $ u1 p) (u2 f $ u2 p) (y1 f $ y1 p) (y2 f $ y2 p)++instance Fold.Foldable State where+   {-# INLINE foldMap #-}+   foldMap = Trav.foldMapDefault++instance Trav.Traversable State where+   {-# INLINE sequenceA #-}+   sequenceA p =+      liftA4 State+         (u1 p) (u2 p) (y1 p) (y2 p)+++ instance Storable a => Storable (Parameter a) where    sizeOf    = Store.sizeOf storeParameter    alignment = Store.alignment storeParameter@@ -93,17 +144,17 @@       (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+instance Storable a => Storable (State a) where+   sizeOf    = Store.sizeOf storeState+   alignment = Store.alignment storeState+   peek      = Store.peek storeState+   poke      = Store.poke storeState -storeStatus ::-   Storable a => Store.Dictionary (Status a)-storeStatus =+storeState ::+   Storable a => Store.Dictionary (State a)+storeState =    Store.run $-   liftA4 Status+   liftA4 State       (Store.element u1)       (Store.element u2)       (Store.element y1)@@ -126,30 +177,41 @@          let p = comp (0.5-f)          in  Parameter (c0 p) (- c1 p) (c2 p) (- d1 p) (d2 p) +{- |+Change filter parameter such that result is amplified by a given factor.+-}+{-# INLINE amplify #-}+amplify :: (Ring.C a) =>+   a -> Parameter a -> Parameter a+amplify a p =+   p{c0 = a * c0 p,+     c1 = a * c1 p,+     c2 = a * c2 p}+ {-# INLINE step #-} step :: (Ring.C a, Module.C a v) =>-   Parameter a -> v -> State (Status v) v-step c u0 = state $ \s ->+   Parameter a -> v -> MS.State (State v) v+step c u0 = MS.state $ \s ->    let y0 =           c0 c *> u0   +           c1 c *> u1 s + d1 c *> y1 s +           c2 c *> u2 s + d2 c *> y2 s-   in  (y0, Status+   in  (y0, State                {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+   Modifier.Initialized (State v) (State 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.Simple (State v) (Parameter a) v v modifier =-   Sig.modifierInitialize modifierInit zeroStatus+   Sig.modifierInitialize modifierInit zeroState  {-# INLINE causal #-} causal :: (Ring.C a, Module.C a v) =>@@ -160,7 +222,7 @@  {-# INLINE runInit #-} runInit :: (Ring.C a, Module.C a v) =>-   Status v -> Sig.T (Parameter a) -> Sig.T v -> Sig.T v+   State v -> Sig.T (Parameter a) -> Sig.T v -> Sig.T v runInit sInit control input =    let u0s = input        u1s = u1 sInit : u0s@@ -179,4 +241,4 @@ run :: (Ring.C a, Module.C a v) =>    Sig.T (Parameter a) -> Sig.T v -> Sig.T v run =-   runInit zeroStatus+   runInit zeroState
src/Synthesizer/Plain/Filter/Recursive/SecondOrderCascade.hs view
@@ -36,14 +36,14 @@  -- import Algebra.Module((*>)) -import Control.Monad.Trans.State (State, )+import qualified Control.Monad.Trans.State as MS  import qualified Data.StorableVector as SV import Foreign.Storable (Storable(..))  import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   {-@@ -62,8 +62,8 @@ 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)+type State a =+   SV.Vector (Filt2.State a)   {-# INLINE checkSizes #-}@@ -94,14 +94,14 @@ {-# INLINE step #-} step ::    (Ring.C a, Module.C a v, Storable a, Storable v) =>-   Parameter a -> v -> State (Status v) v+   Parameter a -> v -> MS.State (State 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+   Modifier.Initialized (State v) (State v) (Parameter a) v v modifierInit =    Modifier.Initialized id step @@ -110,10 +110,10 @@ modifier ::    (Ring.C a, Module.C a v, Storable a, Storable v) =>    Int ->-   Modifier.Simple (Status v) (Parameter a) v v+   Modifier.Simple (State v) (Parameter a) v v modifier order =    Sig.modifierInitialize modifierInit-      (SV.replicate order Filt2.zeroStatus)+      (SV.replicate order Filt2.zeroState)  {-# INLINE causal #-} causal :: (Ring.C a, Module.C a v, Storable a, Storable v) =>
src/Synthesizer/Plain/Filter/Recursive/Test.hs view
@@ -18,8 +18,8 @@ import qualified Algebra.Transcendental      as Trans import qualified Algebra.Ring                as Ring -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   sampleRate :: Ring.C a => a
src/Synthesizer/Plain/Filter/Recursive/Universal.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {- |-Copyright   :  (c) Henning Thielemann 2008+Copyright   :  (c) Henning Thielemann 2008-2010 License     :  GPL  Maintainer  :  synthesizer@henning-thielemann.de@@ -21,6 +21,10 @@  import qualified Synthesizer.Interpolation.Class as Interpol import Synthesizer.ApplicativeUtility (liftA4, liftA6, )+import Control.Applicative (pure, liftA2, )+import qualified Control.Applicative as App+import qualified Data.Foldable as Fold+import qualified Data.Traversable as Trav  import Foreign.Storable (Storable(..)) import qualified Foreign.Storable.Record as Store@@ -33,20 +37,43 @@  import Algebra.Module((*>)) -import Control.Monad.Trans.State (State, state, )+import qualified Control.Monad.Trans.State as MS  import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   data Parameter a =         Parameter {k1, k2, ampIn, ampI1, ampI2, ampLimit :: !a} +instance Functor Parameter where+   {-# INLINE fmap #-}+   fmap f p = Parameter+      (f $ k1 p) (f $ k2 p) (f $ ampIn p) (f $ ampI1 p) (f $ ampI2 p) (f $ ampLimit p) +instance App.Applicative Parameter where+   {-# INLINE pure #-}+   pure x = Parameter x x x x x x+   {-# INLINE (<*>) #-}+   f <*> p = Parameter+      (k1 f $ k1 p) (k2 f $ k2 p) (ampIn f $ ampIn p) (ampI1 f $ ampI1 p) (ampI2 f $ ampI2 p) (ampLimit f $ ampLimit p)++instance Fold.Foldable Parameter where+   {-# INLINE foldMap #-}+   foldMap = Trav.foldMapDefault++instance Trav.Traversable Parameter where+   {-# INLINE sequenceA #-}+   sequenceA p =+      liftA6 Parameter+         (k1 p) (k2 p) (ampIn p) (ampI1 p) (ampI2 p) (ampLimit p)+ instance Interpol.C a v => Interpol.C a (Parameter v) where    {-# INLINE scaleAndAccumulate #-}    scaleAndAccumulate =+      Interpol.scaleAndAccumulateApplicative+{-       Interpol.runMac $ liftA6 Parameter          (Interpol.element k1)          (Interpol.element k2)@@ -54,6 +81,7 @@          (Interpol.element ampI1)          (Interpol.element ampI2)          (Interpol.element ampLimit)+-}  instance Storable a => Storable (Parameter a) where    sizeOf    = Store.sizeOf storeParameter@@ -77,23 +105,54 @@ data Result a =         Result {highpass, bandpass, lowpass, bandlimit :: !a} +instance Functor Result where+   {-# INLINE fmap #-}+   fmap f p = Result+      (f $ highpass p) (f $ bandpass p) (f $ lowpass p) (f $ bandlimit p)++instance App.Applicative Result where+   {-# INLINE pure #-}+   pure x = Result x x x x+   {-# INLINE (<*>) #-}+   f <*> p = Result+      (highpass f $ highpass p) (bandpass f $ bandpass p) (lowpass f $ lowpass p) (bandlimit f $ bandlimit p)++instance Fold.Foldable Result where+   {-# INLINE foldMap #-}+   foldMap = Trav.foldMapDefault++instance Trav.Traversable Result where+   {-# INLINE sequenceA #-}+   sequenceA p =+      liftA4 Result+         (highpass p) (bandpass p) (lowpass p) (bandlimit p)+ instance Additive.C v => Additive.C (Result v) where    {-# INLINE zero #-}    {-# INLINE (+) #-}    {-# INLINE (-) #-}    {-# INLINE negate #-}+   zero   = pure zero+   (+)    = liftA2 (+)+   (-)    = liftA2 (-)+   negate = fmap negate+{-    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) =+   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*>v = fmap (s*>) v+{-    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@@ -150,12 +209,14 @@            (pk1*volHP/volBP)  (pk2*volHP/volLP)            volHP  (volBP/volHP)  (volLP/volBP)  (recip resonance) +type State v = (v,v)+ {-| 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)+   Parameter a -> v -> MS.State (State v) (Result v) step p u =-   state $ \(i1,i2) ->+   MS.state $ \(i1,i2) ->       let newsum = ampIn p *> u + k1 p *> i1 - k2 p *> i2           newi1  = i1 - ampI1 p *> newsum           newi2  = i2 - ampI2 p *> newi1@@ -164,13 +225,13 @@  {-# INLINE modifierInit #-} modifierInit :: (Ring.C a, Module.C a v) =>-   Modifier.Initialized (v,v) (v,v) (Parameter a) v (Result v)+   Modifier.Initialized (State v) (v,v) (Parameter a) v (Result v) modifierInit =    Modifier.Initialized id step  {-# INLINE modifier #-} modifier :: (Ring.C a, Module.C a v) =>-   Modifier.Simple (v,v) (Parameter a) v (Result v)+   Modifier.Simple (State v) (Parameter a) v (Result v) modifier = Sig.modifierInitialize modifierInit (zero, zero)  {-# INLINE causal #-}
src/Synthesizer/Plain/IO.hs view
@@ -29,8 +29,8 @@  import qualified Prelude as P98 -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric
src/Synthesizer/Plain/Instrument.hs view
@@ -26,8 +26,8 @@ import qualified Algebra.Field          as Field import qualified Algebra.Ring           as Ring -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric
src/Synthesizer/Plain/Interpolation.hs view
@@ -29,6 +29,7 @@  import qualified Algebra.Module    as Module import qualified Algebra.RealField as RealField+import qualified Algebra.RealRing  as RealRing import qualified Algebra.Ring      as Ring import qualified Algebra.Additive  as Additive @@ -38,13 +39,13 @@  import Control.Monad (guard, ) -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   {-* Interpolation with various padding methods -} -zeroPad :: (RealField.C t) =>+zeroPad :: (RealRing.C t) =>    (T t y -> t -> Sig.T y -> a) ->    y -> T t y -> t -> Sig.T y -> a zeroPad interpolate z ip phase x =@@ -52,7 +53,7 @@    in  interpolate ip phFrac           (FiltNR.delayPad z (offset ip - phInt) (x ++ repeat z)) -constantPad :: (RealField.C t) =>+constantPad :: (RealRing.C t) =>    (T t y -> t -> Sig.T y -> a) ->    T t y -> t -> Sig.T y -> a constantPad interpolate ip phase x =@@ -68,7 +69,7 @@ {- | Only for finite input signals. -}-cyclicPad :: (RealField.C t) =>+cyclicPad :: (RealRing.C t) =>    (T t y -> t -> Sig.T y -> a) ->    T t y -> t -> Sig.T y -> a cyclicPad interpolate ip phase x =@@ -79,7 +80,7 @@ {- | The extrapolation may miss some of the first and some of the last points -}-extrapolationPad :: (RealField.C t) =>+extrapolationPad :: (RealRing.C t) =>    (T t y -> t -> Sig.T y -> a) ->    T t y -> t -> Sig.T y -> a extrapolationPad interpolate ip phase =@@ -97,14 +98,14 @@ func ip phase =    Interpolation.func ip phase . SigS.fromList -skip :: (RealField.C t) =>+skip :: (RealRing.C t) =>    T t y -> (t, Sig.T y) -> (t, Sig.T y) skip ip (phase0, x0) =    let (n, frac) = splitFraction phase0        (m, x1) = Sig.dropMarginRem (number ip) n x0    in  (fromIntegral m + frac, x1) -single :: (RealField.C t) =>+single :: (RealRing.C t) =>    T t y -> t -> Sig.T y -> y single ip phase0 x0 =    uncurry (func ip) $ skip ip (phase0, x0)@@ -129,7 +130,7 @@ {-* Interpolation of multiple values with various padding methods -}  {- | All values of frequency control must be non-negative. -}-multiRelative :: (RealField.C t) =>+multiRelative :: (RealRing.C t) =>    T t y -> t -> Sig.T y -> Sig.T t -> Sig.T y multiRelative ip phase0 x0 =    map (uncurry (func ip)) .@@ -138,17 +139,17 @@       (skip ip (phase0,x0))  -multiRelativeZeroPad :: (RealField.C t) =>+multiRelativeZeroPad :: (RealRing.C t) =>    y -> T t y -> t -> Sig.T t -> Sig.T y -> Sig.T y multiRelativeZeroPad z ip phase fs x =    zeroPad multiRelative z ip phase x fs -multiRelativeConstantPad :: (RealField.C t) =>+multiRelativeConstantPad :: (RealRing.C t) =>    T t y -> t -> Sig.T t -> Sig.T y -> Sig.T y multiRelativeConstantPad ip phase fs x =    constantPad multiRelative ip phase x fs -multiRelativeCyclicPad :: (RealField.C t) =>+multiRelativeCyclicPad :: (RealRing.C t) =>    T t y -> t -> Sig.T t -> Sig.T y -> Sig.T y multiRelativeCyclicPad ip phase fs x =    cyclicPad multiRelative ip phase x fs@@ -156,7 +157,7 @@ {- | The extrapolation may miss some of the first and some of the last points -}-multiRelativeExtrapolationPad :: (RealField.C t) =>+multiRelativeExtrapolationPad :: (RealRing.C t) =>    T t y -> t -> Sig.T t -> Sig.T y -> Sig.T y multiRelativeExtrapolationPad ip phase fs x =    extrapolationPad multiRelative ip phase x fs@@ -168,11 +169,11 @@ {-* All-in-one interpolation functions -}  multiRelativeZeroPadConstant ::-   (RealField.C t, Additive.C y) => t -> Sig.T t -> Sig.T y -> Sig.T y+   (RealRing.C t, Additive.C y) => t -> Sig.T t -> Sig.T y -> Sig.T y multiRelativeZeroPadConstant = multiRelativeZeroPad zero constant  multiRelativeZeroPadLinear ::-   (RealField.C t, Module.C t y) => t -> Sig.T t -> Sig.T y -> Sig.T y+   (RealRing.C t, Module.C t y) => t -> Sig.T t -> Sig.T y -> Sig.T y multiRelativeZeroPadLinear = multiRelativeZeroPad zero linear  multiRelativeZeroPadCubic ::
src/Synthesizer/Plain/LorenzAttractor.hs view
@@ -4,8 +4,8 @@ import qualified Algebra.Module as Module import qualified Algebra.Ring   as Ring -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   computeDerivatives :: (Ring.C y) =>
src/Synthesizer/Plain/Miscellaneous.hs view
@@ -7,8 +7,8 @@ -- import qualified Algebra.Additive              as Additive  import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   {- * Spatial effects -}
src/Synthesizer/Plain/Noise.hs view
@@ -4,7 +4,7 @@  import qualified Synthesizer.Plain.Signal as Sig -import qualified Algebra.Real                  as Real+import qualified Algebra.RealRing                  as RealRing import qualified Algebra.Ring                  as Ring  import System.Random (Random, RandomGen, randomRs, mkStdGen, )@@ -12,8 +12,8 @@ import Data.List.HT (sliceVertical, )  import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   {-|@@ -38,14 +38,14 @@    map sum . sliceVertical 3 . randomRs (-1,1)  -randomPeeks :: (Real.C y, Random y) =>+randomPeeks :: (RealRing.C y, Random y) =>       Sig.T y    {- ^ momentary densities, @p@ means that there is about one peak                       in the time range of @1\/p@ samples -}    -> Sig.T Bool {- ^ Every occurence of 'True' represents a peak. -} randomPeeks =    randomPeeksGen (mkStdGen 876) -randomPeeksGen :: (Real.C y, Random y, RandomGen g) =>+randomPeeksGen :: (RealRing.C y, Random y, RandomGen g) =>       g    -> Sig.T y    -> Sig.T Bool
src/Synthesizer/Plain/Oscillator.hs view
@@ -32,7 +32,7 @@ -} import qualified Algebra.Transcendental        as Trans import qualified Algebra.RealField             as RealField--- import qualified Algebra.Field                 as Field+import qualified Algebra.RealRing              as RealRing import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive @@ -40,10 +40,10 @@  import Data.Tuple.HT (mapFst, mapSnd, ) -import NumericPrelude+import NumericPrelude.Numeric  -- import qualified Prelude as P-import PreludeBase+import NumericPrelude.Base   type Phase a = a@@ -52,37 +52,37 @@ {- * Oscillators with arbitrary but constant waveforms -}  {- | oscillator with constant frequency -}-static :: (RealField.C a) => Wave.T a b -> (Phase a -> a -> Sig.T b)+static :: (RealRing.C a) => Wave.T a b -> (Phase a -> a -> Sig.T b) static wave phase freq =     map (Wave.apply wave)         (iterate (Phase.increment freq) (Phase.fromRepresentative phase))  {- | oscillator with modulated frequency -}-freqMod :: (RealField.C a) => Wave.T a b -> Phase a -> Sig.T a -> Sig.T b+freqMod :: (RealRing.C a) => Wave.T a b -> Phase a -> Sig.T a -> Sig.T b freqMod wave phase freqs =     map (Wave.apply wave)         (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+phaseMod :: (RealRing.C a) => Wave.T a b -> a -> Sig.T (Phase a) -> Sig.T b phaseMod wave freq phases =     map (Wave.apply wave) $     zipWith Phase.increment phases (iterate (Phase.increment freq) zero)  {- | oscillator with modulated shape -}-shapeMod :: (RealField.C a) => (c -> Wave.T a b) -> (Phase a) -> a -> Sig.T c -> Sig.T b+shapeMod :: (RealRing.C a) => (c -> Wave.T a b) -> (Phase a) -> a -> Sig.T c -> Sig.T b shapeMod wave phase freq parameters =     zipWith (Wave.apply . wave) parameters $     iterate (Phase.increment freq) (Phase.fromRepresentative phase)  {- | oscillator with both phase and frequency modulation -}-phaseFreqMod :: (RealField.C a) => Wave.T a b -> Sig.T (Phase a) -> Sig.T a -> Sig.T b+phaseFreqMod :: (RealRing.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 (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 :: (RealRing.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 $     freqsToPhases (Phase.fromRepresentative phase) freqs@@ -90,13 +90,13 @@  {- | oscillator with a sampled waveform with constant frequency      This is essentially an interpolation with cyclic padding. -}-staticSample :: RealField.C a => Interpolation.T a b -> [b] -> Phase a -> a -> Sig.T b+staticSample :: RealRing.C a => Interpolation.T a b -> [b] -> Phase a -> a -> Sig.T b staticSample ip wave phase freq =     freqModSample ip wave phase (repeat freq)  {- | oscillator with a sampled waveform with modulated frequency      Should behave homogenously for different types of interpolation. -}-freqModSample :: RealField.C a => Interpolation.T a b -> [b] -> Phase a -> Sig.T a -> Sig.T b+freqModSample :: RealRing.C a => Interpolation.T a b -> [b] -> Phase a -> Sig.T a -> Sig.T b freqModSample ip wave phase freqs =     let len = fromIntegral (length wave)     in  Interpolation.multiRelativeCyclicPad@@ -121,7 +121,7 @@ because in the wave information for 'shapeFreqModSample' shape and phase are strictly separated. -}-shapeFreqModSample :: (RealField.C c, RealField.C b) =>+shapeFreqModSample :: (RealRing.C c, RealRing.C b) =>     Interpolation.T c (Wave.T b a) -> [Wave.T b a] -> c -> Phase b -> Sig.T c -> Sig.T b -> Sig.T a shapeFreqModSample ip waves shape0 phase shapes freqs =     zipWith Wave.apply@@ -131,7 +131,7 @@ 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) =>+shapePhaseFreqModSample :: (RealRing.C c, RealRing.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@@ -215,21 +215,21 @@ {- * Oscillators with specific waveforms -}  {- | sine oscillator with static frequency -}-staticSine :: (Trans.C a, RealField.C a) => a -> a -> Sig.T a+staticSine :: (Trans.C a, RealRing.C a) => a -> a -> Sig.T a staticSine = static Wave.sine  {- | sine oscillator with modulated frequency -}-freqModSine :: (Trans.C a, RealField.C a) => a -> Sig.T a -> Sig.T a+freqModSine :: (Trans.C a, RealRing.C a) => a -> Sig.T a -> Sig.T a freqModSine = freqMod Wave.sine  {- | sine oscillator with modulated phase, useful for FM synthesis -}-phaseModSine :: (Trans.C a, RealField.C a) => a -> Sig.T a -> Sig.T a+phaseModSine :: (Trans.C a, RealRing.C a) => a -> Sig.T a -> Sig.T a phaseModSine = phaseMod Wave.sine  {- | saw tooth oscillator with modulated frequency -}-staticSaw :: RealField.C a => a -> a -> Sig.T a+staticSaw :: RealRing.C a => a -> a -> Sig.T a staticSaw = static Wave.saw  {- | saw tooth oscillator with modulated frequency -}-freqModSaw :: RealField.C a => a -> Sig.T a -> Sig.T a+freqModSaw :: RealRing.C a => a -> Sig.T a -> Sig.T a freqModSaw = freqMod Wave.saw
src/Synthesizer/Plain/Play.hs view
@@ -18,12 +18,12 @@ -- import qualified Synthesizer.Frame.Stereo as Stereo  import qualified Algebra.ToInteger as ToInteger-import qualified Algebra.RealField as RealField+import qualified Algebra.RealRing as RealRing  import System.Exit (ExitCode, ) -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   {- |@@ -31,20 +31,20 @@ -} render ::    (Storable int, Frame.C int, ToInteger.C int, Bounded int,-    RealField.C a, BinSmp.C v) =>+    RealRing.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 :: (RealRing.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 :: (RealRing.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 :: (RealRing.C a) => a -> (a -> [(a,a)]) -> IO ExitCode renderStereoToInt16 sampleRate renderer =    stereoToInt16 sampleRate (renderer sampleRate) @@ -54,7 +54,7 @@ -} auto ::    (Storable int, Frame.C int, ToInteger.C int, Bounded int,-    RealField.C a, BinSmp.C v) =>+    RealRing.C a, BinSmp.C v) =>    Builder.Put int -> a -> [v] -> IO ExitCode auto put sampleRate signal =    raw@@ -63,22 +63,22 @@       (Builder.run . mconcat . map (BinSmp.outputFromCanonical put) $        signal) -toInt16 :: (RealField.C a, BinSmp.C v) => a -> [v] -> IO ExitCode+toInt16 :: (RealRing.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 :: (RealRing.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 :: (RealRing.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) =>+raw :: (RealRing.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
src/Synthesizer/Plain/ToneModulation.hs view
@@ -60,7 +60,7 @@ -- import qualified Algebra.Transcendental        as Trans import qualified Algebra.RealField             as RealField import qualified Algebra.Field                 as Field--- import qualified Algebra.Real                  as Real+import qualified Algebra.RealRing              as RealRing import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive @@ -75,10 +75,10 @@ import Data.Ord.HT (limit, ) import Data.Tuple.HT (mapPair, mapSnd, forcePair, ) -import NumericPrelude+import NumericPrelude.Numeric  -- import qualified Prelude as P-import PreludeBase+import NumericPrelude.Base   @@ -343,7 +343,7 @@ phase is a number in the interval [0,1) freq contains the phase steps -}-freqsToPhases :: RealField.C a => Phase.T a -> Sig.T a -> Sig.T (Phase.T a)+freqsToPhases :: RealRing.C a => Phase.T a -> Sig.T a -> Sig.T (Phase.T a) freqsToPhases phase freq = scanl (flip Phase.increment) phase freq
src/Synthesizer/Plain/Tutorial.hs view
@@ -35,8 +35,8 @@ import qualified Algebra.Module as Module -- needed for Haddock  import System.Exit (ExitCode, )-import NumericPrelude-import PreludeBase+import NumericPrelude.Numeric+import NumericPrelude.Base import Prelude ()
src/Synthesizer/Plain/Wave.hs view
@@ -16,10 +16,10 @@ import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive -import NumericPrelude+import NumericPrelude.Numeric  -- import qualified Prelude as P-import PreludeBase+import NumericPrelude.Base   sample :: (RealField.C a) =>
src/Synthesizer/RandomKnuth.hs view
@@ -25,7 +25,10 @@ modulus :: Int modulus = 2147483399 -- 2^31-249 --- we have to split the 32 bit integer in order to avoid overflow on multiplication+{-+We have to split the 32 bit integer in order to avoid overflow on multiplication.+'split' must be chosen, such that 'splitRem' is below 2^16.+-} {-# INLINE split #-} split :: Int split = succ $ div modulus factor
src/Synthesizer/State/Analysis.hs view
@@ -11,7 +11,8 @@ import qualified Algebra.Algebraic             as Algebraic import qualified Algebra.RealField             as RealField import qualified Algebra.Field                 as Field-import qualified Algebra.Real                  as Real+import qualified Algebra.RealRing              as RealRing+import qualified Algebra.Absolute              as Absolute import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive @@ -29,8 +30,8 @@ -- import Data.List (foldl', )  import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   {- * Notions of volume -}@@ -39,7 +40,7 @@ Volume based on Manhattan norm. -} {-# INLINE volumeMaximum #-}-volumeMaximum :: (Real.C y) => Sig.T y -> y+volumeMaximum :: (RealRing.C y) => Sig.T y -> y volumeMaximum =    Sig.foldL max zero . rectify --   maximum . rectify@@ -61,7 +62,7 @@ Volume based on Sum norm. -} {-# INLINE volumeSum #-}-volumeSum :: (Field.C y, Real.C y) => Sig.T y -> y+volumeSum :: (Field.C y, Absolute.C y) => Sig.T y -> y volumeSum = average . rectify  @@ -218,7 +219,7 @@    Sig.viewL x  {-# INLINE withAtLeast2 #-}-withAtLeast2 :: (RealField.C y) =>+withAtLeast2 :: (RealRing.C y) =>    String ->    (Sig.T y -> (Int, Sig.T y)) ->    Sig.T y ->@@ -251,7 +252,7 @@    histogramDiscreteIntMap . quantize binsPerUnit  {-# INLINE quantize #-}-quantize :: (RealField.C y) => y -> Sig.T y -> Sig.T Int+quantize :: (RealRing.C y) => y -> Sig.T y -> Sig.T Int quantize binsPerUnit = Sig.map (floor . (binsPerUnit*))  {-# INLINE attachOne #-}@@ -326,7 +327,7 @@    Sig.sum x / fromIntegral (Sig.length x)  {-# INLINE rectify #-}-rectify :: Real.C y => Sig.T y -> Sig.T y+rectify :: Absolute.C y => Sig.T y -> Sig.T y rectify = Sig.map abs  {- |
src/Synthesizer/State/Control.hs view
@@ -19,7 +19,7 @@  import qualified Algebra.Module                as Module import qualified Algebra.Transcendental        as Trans-import qualified Algebra.RealField             as RealField+import qualified Algebra.RealRing              as RealRing import qualified Algebra.Field                 as Field import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive@@ -32,8 +32,8 @@ import Data.Ix (Ix, )  import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   {- * Control curve generation -}@@ -193,7 +193,7 @@ -- * piecewise curves  -splitDurations :: (RealField.C t) =>+splitDurations :: (RealRing.C t) =>    [t] -> [(Int, t)] splitDurations ts0 =    let (ds,ts) =@@ -203,7 +203,7 @@    in  zip (tail ds) (map (subtract 1) ts)  {-# INLINE piecewise #-}-piecewise :: (RealField.C a) =>+piecewise :: (RealRing.C a) =>    Piecewise.T a a (a -> Sig.T a) -> Sig.T a piecewise xs =    Sig.concat $ zipWith
src/Synthesizer/State/Cut.hs view
@@ -24,7 +24,7 @@ import qualified Data.EventList.Relative.TimeBody as EventList  import qualified MathObj.LaurentPolynomial as Laurent-import qualified Algebra.Real     as Real+import qualified Algebra.RealRing     as RealRing import qualified Algebra.Additive as Additive  import qualified Data.Array as Array@@ -37,8 +37,8 @@  import qualified Number.NonNegative as NonNeg -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   @@ -46,7 +46,7 @@ Take signal until it falls short of a certain amplitude for a given time. -} {-# INLINE takeUntilPause #-}-takeUntilPause :: (Real.C a) => a -> Int -> Sig.T a -> Sig.T a+takeUntilPause :: (RealRing.C a) => a -> Int -> Sig.T a -> Sig.T a takeUntilPause y =    takeUntilInterval ((<=y) . abs)
src/Synthesizer/State/Displacement.hs view
@@ -4,17 +4,17 @@ import qualified Synthesizer.State.Signal as Sig  -- import qualified Algebra.Module                as Module--- import qualified Algebra.Transcendental        as Trans+import qualified Algebra.Transcendental        as Trans -- import qualified Algebra.Field                 as Field--- import qualified Algebra.Ring                  as Ring+import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive  import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric  -{- * Mixing -}+-- * Mixing  {-| Mix two signals.@@ -39,7 +39,8 @@ raise x = Sig.map ((+) x)  -{- * Distortion -}+-- * Distortion+ {-| In "Synthesizer.Basic.Distortion" you find a collection of appropriate distortion functions.@@ -47,3 +48,27 @@ {-# INLINE distort #-} distort :: (c -> a -> a) -> Sig.T c -> Sig.T a -> Sig.T a distort = Sig.zipWith+++-- * Preprocessing of control curves++{-# INLINE mapLinear #-}+mapLinear :: (Ring.C a) =>+   a ->+   a ->+   Sig.T a ->+   Sig.T a+mapLinear depth center =+   Sig.map (\x -> center*(one+x*depth))++{-# INLINE mapExponential #-}+mapExponential :: (Trans.C a) =>+   a ->+   a ->+   Sig.T a ->+   Sig.T a+mapExponential depth center =+   -- Sig.map ((center*) . (depth**))+   -- should be faster+   let logDepth = log depth+   in  Sig.map ((center*) . exp . (logDepth*))
src/Synthesizer/State/Filter/Delay.hs view
@@ -9,8 +9,8 @@ import qualified Algebra.Additive  as Additive  -- import qualified Prelude as P--- import PreludeBase-import NumericPrelude+-- import NumericPrelude.Base+import NumericPrelude.Numeric
src/Synthesizer/State/Filter/NonRecursive.hs view
@@ -26,8 +26,8 @@ import Data.Function.HT (nest, ) import Data.Tuple.HT (mapFst, ) -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric
src/Synthesizer/State/Filter/Recursive/Comb.hs view
@@ -27,8 +27,8 @@ import Algebra.Module((*>))  import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   {- |
src/Synthesizer/State/Filter/Recursive/Integration.hs view
@@ -18,8 +18,8 @@ -- import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric
src/Synthesizer/State/Filter/Recursive/MovingAverage.hs view
@@ -25,8 +25,8 @@ -- import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric
src/Synthesizer/State/Interpolation.hs view
@@ -8,21 +8,21 @@ import qualified Synthesizer.State.Signal  as Sig  -- import qualified Algebra.Module    as Module-import qualified Algebra.RealField as RealField -- import qualified Algebra.Field     as Field+import qualified Algebra.RealRing  as RealRing import qualified Algebra.Ring      as Ring import qualified Algebra.Additive  as Additive  import Data.Maybe (fromMaybe) -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   {-* Interpolation with various padding methods -}  {-# INLINE zeroPad #-}-zeroPad :: (RealField.C t) =>+zeroPad :: (RealRing.C t) =>    (T t y -> t -> Sig.T y -> a) ->    y -> T t y -> t -> Sig.T y -> a zeroPad interpolate z ip phase x =@@ -31,7 +31,7 @@           (delayPad z (offset ip - phInt) (Sig.append x (Sig.repeat z)))  {-# INLINE constantPad #-}-constantPad :: (RealField.C t) =>+constantPad :: (RealRing.C t) =>    (T t y -> t -> Sig.T y -> a) ->    T t y -> t -> Sig.T y -> a constantPad interpolate ip phase x =@@ -47,7 +47,7 @@ Only for finite input signals. -} {-# INLINE cyclicPad #-}-cyclicPad :: (RealField.C t) =>+cyclicPad :: (RealRing.C t) =>    (T t y -> t -> Sig.T y -> a) ->    T t y -> t -> Sig.T y -> a cyclicPad interpolate ip phase x =@@ -59,7 +59,7 @@ The extrapolation may miss some of the first and some of the last points -} {-# INLINE extrapolationPad #-}-extrapolationPad :: (RealField.C t) =>+extrapolationPad :: (RealRing.C t) =>    (T t y -> t -> Sig.T y -> a) ->    T t y -> t -> Sig.T y -> a extrapolationPad interpolate ip phase =@@ -73,7 +73,7 @@ {-* Helper methods for interpolation of multiple nodes -}  {-# INLINE skip #-}-skip :: (RealField.C t) =>+skip :: (RealRing.C t) =>    T t y -> (t, Sig.T y) -> (t, Sig.T y) skip ip (phase0, x0) =    let (n, frac) = splitFraction phase0@@ -81,7 +81,7 @@    in  (fromIntegral m + frac, x1)  {-# INLINE single #-}-single :: (RealField.C t) =>+single :: (RealRing.C t) =>    T t y -> t -> Sig.T y -> y single ip phase0 x0 =    uncurry (func ip) $ skip ip (phase0, x0)
src/Synthesizer/State/Miscellaneous.hs view
@@ -11,8 +11,8 @@ -- import qualified Algebra.Additive              as Additive  -- import qualified Prelude as P--- import PreludeBase-import NumericPrelude+-- import NumericPrelude.Base+import NumericPrelude.Numeric  {- * Spatial effects -}
src/Synthesizer/State/Noise.hs view
@@ -4,15 +4,15 @@  import qualified Synthesizer.State.Signal as Sig -import qualified Algebra.Real                  as Real+import qualified Algebra.RealRing                  as RealRing import qualified Algebra.Ring                  as Ring  import System.Random (Random, RandomGen, randomR, mkStdGen, ) import qualified System.Random as Rnd  import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   {-|@@ -48,7 +48,7 @@   {-# INLINE randomPeeks #-}-randomPeeks :: (Real.C y, Random y) =>+randomPeeks :: (RealRing.C y, Random y) =>       Sig.T y    {- ^ momentary densities, @p@ means that there is about one peak                       in the time range of @1\/p@ samples -}    -> Sig.T Bool {- ^ Every occurence of 'True' represents a peak. -}@@ -56,7 +56,7 @@    randomPeeksGen (mkStdGen 876)  {-# INLINE randomPeeksGen #-}-randomPeeksGen :: (Real.C y, Random y, RandomGen g) =>+randomPeeksGen :: (RealRing.C y, Random y, RandomGen g) =>       g    -> Sig.T y    -> Sig.T Bool
src/Synthesizer/State/NoiseCustom.hs view
@@ -17,8 +17,8 @@ import qualified System.Random as Rnd  import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   {-|
src/Synthesizer/State/Oscillator.hs view
@@ -12,6 +12,7 @@ module Synthesizer.State.Oscillator where  import qualified Synthesizer.Causal.Oscillator  as Osci+import qualified Synthesizer.Causal.Oscillator.Core as OsciCore import qualified Synthesizer.Basic.WaveSmoothed as WaveSmooth import qualified Synthesizer.Basic.Wave         as Wave import qualified Synthesizer.Basic.Phase        as Phase@@ -26,10 +27,11 @@  import qualified Algebra.Transcendental        as Trans import qualified Algebra.RealField             as RealField+import qualified Algebra.RealRing              as RealRing  -- import qualified Prelude as P-import NumericPrelude (Float, Double, )--- import PreludeBase+import NumericPrelude.Numeric (Float, Double, )+-- import NumericPrelude.Base   @@ -40,56 +42,56 @@ Oscillator with constant frequency. It causes aliasing effects for sharp waveforms and high frequencies. -}-static :: (RealField.C a) => Wave.T a b -> (Phase.T a -> a -> Sig.T b)+static :: (RealRing.C a) => Wave.T a b -> (Phase.T a -> a -> Sig.T b) static wave phase freq =-    Sig.map (Wave.apply wave) (Osci.freqToPhases phase freq)+    Sig.map (Wave.apply wave) (OsciCore.static phase freq)  {-# INLINE staticAntiAlias #-} {- | Oscillator with constant frequency that suppresses aliasing effects using waveforms with controllable smoothness. -}-staticAntiAlias :: (RealField.C a) =>+staticAntiAlias :: (RealRing.C a) =>     WaveSmooth.T a b -> (Phase.T a -> a -> Sig.T b) staticAntiAlias wave phase freq =-    Sig.map (WaveSmooth.apply wave freq) (Osci.freqToPhases phase freq)+    Sig.map (WaveSmooth.apply wave freq) (OsciCore.static phase freq)  {-# INLINE phaseMod #-} {- | oscillator with modulated phase -}-phaseMod :: (RealField.C a) => Wave.T a b -> a -> Sig.T a -> Sig.T b+phaseMod :: (RealRing.C a) => Wave.T a b -> a -> Sig.T a -> Sig.T b phaseMod wave freq =     Causal.apply (Osci.phaseMod wave freq)  {-# INLINE shapeMod #-} {- | oscillator with modulated shape -}-shapeMod :: (RealField.C a) =>+shapeMod :: (RealRing.C a) =>     (c -> Wave.T a b) -> Phase.T a -> a -> Sig.T c -> Sig.T b shapeMod wave phase freq =     Causal.apply (Osci.shapeMod wave phase freq)  {-# INLINE freqMod #-} {- | oscillator with modulated frequency -}-freqMod :: (RealField.C a) => Wave.T a b -> Phase.T a -> Sig.T a -> Sig.T b+freqMod :: (RealRing.C a) => Wave.T a b -> Phase.T a -> Sig.T a -> Sig.T b freqMod wave phase =     Causal.apply (Osci.freqMod wave phase)  {-# INLINE freqModAntiAlias #-} {- | oscillator with modulated frequency -}-freqModAntiAlias :: (RealField.C a) =>+freqModAntiAlias :: (RealRing.C a) =>     WaveSmooth.T a b -> Phase.T a -> Sig.T a -> Sig.T b freqModAntiAlias wave phase =     Causal.apply (Osci.freqModAntiAlias wave phase)  {-# INLINE phaseFreqMod #-} {- | oscillator with both phase and frequency modulation -}-phaseFreqMod :: (RealField.C a) =>+phaseFreqMod :: (RealRing.C a) =>     Wave.T a b -> Sig.T a -> Sig.T a -> Sig.T b phaseFreqMod wave =     Causal.apply2 (Osci.phaseFreqMod wave)  {-# INLINE shapeFreqMod #-} {- | oscillator with both shape and frequency modulation -}-shapeFreqMod :: (RealField.C a) =>+shapeFreqMod :: (RealRing.C a) =>     (c -> Wave.T a b) -> Phase.T a -> Sig.T c -> Sig.T a -> Sig.T b shapeFreqMod wave phase =     Causal.apply2 (Osci.shapeFreqMod wave phase)@@ -98,7 +100,7 @@ {- | oscillator with a sampled waveform with constant frequency      This essentially an interpolation with cyclic padding. -} {-# INLINE staticSample #-}-staticSample :: RealField.C a =>+staticSample :: RealRing.C a =>     Interpolation.T a b -> Sig.T b -> Phase.T a -> a -> Sig.T b staticSample ip wave phase freq =     Causal.apply (Osci.freqModSample ip wave phase) (Sig.repeat freq)@@ -106,13 +108,13 @@ {- | oscillator with a sampled waveform with modulated frequency      Should behave homogenously for different types of interpolation. -} {-# INLINE freqModSample #-}-freqModSample :: RealField.C a =>+freqModSample :: RealRing.C a =>     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) =>+shapeFreqModSample :: (RealRing.C c, RealRing.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@@ -155,33 +157,33 @@ {-# SPECIALISE INLINE staticSine :: Phase.T Float -> Float -> Sig.T Float #-} {-# SPECIALISE INLINE staticSine :: Phase.T Double -> Double -> Sig.T Double #-} {- | sine oscillator with static frequency -}-staticSine :: (Trans.C a, RealField.C a) => Phase.T a -> a -> Sig.T a+staticSine :: (Trans.C a, RealRing.C a) => Phase.T a -> a -> Sig.T a staticSine = static Wave.sine  {-# INLINE freqModSine #-} {-# SPECIALISE INLINE freqModSine :: Phase.T Float -> Sig.T Float -> Sig.T Float #-} {-# SPECIALISE INLINE freqModSine :: Phase.T Double -> Sig.T Double -> Sig.T Double #-} {- | sine oscillator with modulated frequency -}-freqModSine :: (Trans.C a, RealField.C a) => Phase.T a -> Sig.T a -> Sig.T a+freqModSine :: (Trans.C a, RealRing.C a) => Phase.T a -> Sig.T a -> Sig.T a freqModSine = freqMod Wave.sine  {-# INLINE phaseModSine #-} {-# SPECIALISE INLINE phaseModSine :: Float -> Sig.T Float -> Sig.T Float #-} {-# SPECIALISE INLINE phaseModSine :: Double -> Sig.T Double -> Sig.T Double #-} {- | sine oscillator with modulated phase, useful for FM synthesis -}-phaseModSine :: (Trans.C a, RealField.C a) => a -> Sig.T a -> Sig.T a+phaseModSine :: (Trans.C a, RealRing.C a) => a -> Sig.T a -> Sig.T a phaseModSine = phaseMod Wave.sine  {-# INLINE staticSaw #-} {-# SPECIALISE INLINE staticSaw :: Phase.T Float -> Float -> Sig.T Float #-} {-# SPECIALISE INLINE staticSaw :: Phase.T Double -> Double -> Sig.T Double #-} {- | saw tooth oscillator with modulated frequency -}-staticSaw :: RealField.C a => Phase.T a -> a -> Sig.T a+staticSaw :: RealRing.C a => Phase.T a -> a -> Sig.T a staticSaw = static Wave.saw  {-# INLINE freqModSaw #-} {-# SPECIALISE INLINE freqModSaw :: Phase.T Float -> Sig.T Float -> Sig.T Float #-} {-# SPECIALISE INLINE freqModSaw :: Phase.T Double -> Sig.T Double -> Sig.T Double #-} {- | saw tooth oscillator with modulated frequency -}-freqModSaw :: RealField.C a => Phase.T a -> Sig.T a -> Sig.T a+freqModSaw :: RealRing.C a => Phase.T a -> Sig.T a -> Sig.T a freqModSaw = freqMod Wave.saw
src/Synthesizer/State/Signal.hs view
@@ -22,6 +22,10 @@  import qualified Synthesizer.Format as Format +import qualified Data.EventList.Relative.BodyTime as EventList+import qualified Numeric.NonNegative.Class as NonNeg98+import Numeric.NonNegative.Class ((-|), )+ import Control.Monad.Trans.State           (runState, StateT(StateT), runStateT, ) import Control.Monad (Monad, mplus, msum,@@ -43,10 +47,11 @@ import Data.Tuple.HT (mapFst, mapSnd, mapPair, fst3, snd3, thd3, ) import Data.Function.HT (nest, ) import Data.Maybe.HT (toMaybe, )-import NumericPrelude (Float, Double, fromInteger, )+import NumericPrelude.Numeric (Float, Double, fromInteger, )  import Text.Show (Show(showsPrec), show, showParen, showString, ) import Data.Maybe (Maybe(Just, Nothing), maybe, fromMaybe, )+import qualified Prelude as P import Prelude    ((.), ($), id, const, flip, curry, uncurry, fst, snd, error,     (>), (>=), max, Ord, (==), Eq,@@ -174,6 +179,17 @@ toStorableSignalVary size (Cons f a) =    fst $ SVL.unfoldrN size (runStateT f) a +fromPiecewiseConstant ::+   (NonNeg98.C time, P.Integral time) =>+   EventList.T time a -> T a+fromPiecewiseConstant xs0 =+   generate+      (let go ((x,n),xs) =+             if n == P.fromInteger 0+               then go =<< EventList.viewL xs+               else Just (x, ((x, n -| P.fromInteger 1), xs))+       in  go)+      ((error "if counter is zero, the sample value is invalid", P.fromInteger 0), xs0)   {-# INLINE iterate #-}
src/Synthesizer/State/ToneModulation.hs view
@@ -1,6 +1,7 @@ module Synthesizer.State.ToneModulation where  import qualified Synthesizer.Basic.ToneModulation as ToneMod+import qualified Synthesizer.Causal.Oscillator.Core as Osci  import qualified Synthesizer.Causal.Process as Causal import qualified Synthesizer.Interpolation as Interpolation@@ -14,15 +15,15 @@ -- import qualified Algebra.Transcendental        as Trans import qualified Algebra.RealField             as RealField -- import qualified Algebra.Field                 as Field--- import qualified Algebra.Real                  as Real+-- import qualified Algebra.RealRing                  as RealRing -- import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive  import Data.Ord.HT (limit, ) -import NumericPrelude+import NumericPrelude.Numeric -- import qualified Prelude as P-import PreludeBase+import NumericPrelude.Base import Prelude ()  @@ -177,7 +178,7 @@                   SigS.viewL $                   SigS.map (\(n,_) -> fromIntegral n / period) $                   shapeOffsets-           in  freqsToPhases+           in  Osci.freqMod                   (Phase.decrement s phase)  -- phase - s                `Causal.apply`                   (SigS.zipWith (-) freqs ss)@@ -209,27 +210,3 @@ {- 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
@@ -15,14 +15,14 @@ -- import Control.Monad (mapM, ) import Data.Tuple.HT (mapSnd, ) --- import qualified Algebra.Real     as Real+-- import qualified Algebra.RealRing     as RealRing import qualified Algebra.Additive as Additive import qualified Number.NonNegative as NonNeg  import Foreign.Storable (Storable) -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   {-# INLINE arrange #-}@@ -64,6 +64,11 @@            modify (Sig.mixSndPattern body))  +{- |+This function also uses the time differences as chunk sizes,+but may occasionally use smaller chunk sizes due to the chunk structure+of an input signal until the next signal starts.+-} arrangeList :: (Storable v, Additive.C v) =>        Sig.ChunkSize     -> EventList.T NonNeg.Int (Sig.T v)@@ -184,11 +189,25 @@           go (i Additive.+ SV.length c) cs    in  fmap (flip (,) future) . go start . Sig.chunks $ now -{- chunk must fit into the buffer -}+{- | chunk must fit into the buffer -}+{- This implementation will be faster as long as 'SV.foldr' is inefficient. -} {-# INLINE addChunkToBuffer #-} addChunkToBuffer :: (Storable a, Additive.C a) =>    SVST.Vector s a -> Int -> SV.Vector a -> ST s () addChunkToBuffer v start xs =+   let go i j =+          if j >= SV.length xs+            then return ()+            else+              SVST.unsafeModify v i (SV.index xs j Additive.+) >>+              go (i Additive.+ 1) (j Additive.+ 1)+   in  go start 0++{- | chunk must fit into the buffer -}+{-# INLINE addChunkToBufferFoldr #-}+addChunkToBufferFoldr :: (Storable a, Additive.C a) =>+   SVST.Vector s a -> Int -> SV.Vector a -> ST s ()+addChunkToBufferFoldr v start xs =    SV.foldr       (\x continue i ->          SVST.unsafeModify v i (x Additive.+) >>@@ -197,6 +216,7 @@       xs start  +-- most elegant solution, but slow because StorableVector.foldr is slow {-# INLINE addToBufferFoldr #-} addToBufferFoldr :: (Storable a, Additive.C a) =>    SVST.Vector s a -> Int -> Sig.T a -> ST s (Int, Sig.T a)
src/Synthesizer/Storable/Filter/NonRecursive.hs view
@@ -41,8 +41,8 @@  import qualified Numeric.NonNegative.Chunky as NonNegChunky -import PreludeBase-import NumericPrelude as NP+import NumericPrelude.Base+import NumericPrelude.Numeric as NP import qualified Prelude as P
src/Synthesizer/Storable/Oscillator.hs view
@@ -28,15 +28,14 @@ import Algebra.Module((*>)) -} import qualified Algebra.Transcendental        as Trans-import qualified Algebra.RealField             as RealField -- import qualified Algebra.Field                 as Field--- import qualified Algebra.Ring                  as Ring+import qualified Algebra.RealRing              as RealRing import qualified Algebra.Additive              as Additive -import NumericPrelude+import NumericPrelude.Numeric  import qualified Prelude as P-import PreludeBase+import NumericPrelude.Base   @@ -46,7 +45,7 @@ {- | 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, Storable a) =>+freqToPhase :: (RealRing.C a, Storable a) =>    Phase.T a -> Signal.T a -> Signal.T (Phase.T a) freqToPhase phase freq = Signal.scanL (flip Phase.increment) phase freq @@ -54,38 +53,38 @@ {-# INLINE static #-} {- disabled SPECIALISE static :: Storable b => ChunkSize -> (Double -> b) -> (Double -> Double -> Signal.T b) -} {- | oscillator with constant frequency -}-static :: (RealField.C a, Storable a, Storable b) =>+static :: (RealRing.C a, Storable a, Storable b) =>     ChunkSize -> Wave.T a b -> (Phase.T a -> a -> Signal.T b) static size wave phase freq =     Signal.map (Wave.apply wave) (Signal.iterate size (Phase.increment freq) phase)  {- | oscillator with modulated phase -}-phaseMod :: (RealField.C a, Storable a, Storable b) =>+phaseMod :: (RealRing.C a, Storable a, Storable b) =>     ChunkSize -> Wave.T a b -> a -> Signal.T a -> Signal.T b phaseMod size wave = shapeMod size (Wave.phaseOffset wave) zero  {- disabled INLINE shapeMod -} {- | oscillator with modulated shape -}-shapeMod :: (RealField.C a, Storable a, Storable b, Storable c) =>+shapeMod :: (RealRing.C a, Storable a, Storable b, Storable c) =>     ChunkSize -> (c -> Wave.T a b) -> Phase.T a -> a -> Signal.T c -> Signal.T b shapeMod size wave phase freq parameters =     Signal.zipWith (Wave.apply . wave) parameters        (Signal.iterate size (Phase.increment freq) phase)  {- | oscillator with modulated frequency -}-freqMod :: (RealField.C a, Storable a, Storable b) =>+freqMod :: (RealRing.C a, Storable a, Storable b) =>     ChunkSize -> Wave.T a b -> Phase.T a -> Signal.T a -> Signal.T b freqMod _size wave phase freqs =     Signal.map (Wave.apply wave) (freqToPhase phase freqs)  {- | oscillator with both phase and frequency modulation -}-phaseFreqMod :: (RealField.C a, Storable a, Storable b) =>+phaseFreqMod :: (RealRing.C a, Storable a, Storable b) =>     ChunkSize -> Wave.T a b -> Signal.T a -> Signal.T a -> Signal.T b phaseFreqMod size wave =     shapeFreqMod size (Wave.phaseOffset wave) zero  {- | oscillator with both shape and frequency modulation -}-shapeFreqMod :: (RealField.C a, Storable a, Storable b, Storable c) =>+shapeFreqMod :: (RealRing.C a, Storable a, Storable b, Storable c) =>     ChunkSize -> (c -> Wave.T a b) ->     Phase.T a -> Signal.T c -> Signal.T a -> Signal.T b shapeFreqMod _size wave phase parameters freqs =@@ -95,13 +94,13 @@ {- {- | oscillator with a sampled waveform with constant frequency      This essentially an interpolation with cyclic padding. -}-staticSample :: RealField.C a => Interpolation.T a b -> Signal.T b -> a -> a -> Signal.T b+staticSample :: RealRing.C a => Interpolation.T a b -> Signal.T b -> a -> a -> Signal.T b staticSample ip wave phase freq =     freqModSample ip wave phase (repeat freq)  {- | oscillator with a sampled waveform with modulated frequency      Should behave homogenously for different types of interpolation. -}-freqModSample :: RealField.C a => Interpolation.T a b -> Signal.T b -> a -> Signal.T a -> Signal.T b+freqModSample :: RealRing.C a => Interpolation.T a b -> Signal.T b -> a -> Signal.T a -> Signal.T b freqModSample ip wave phase freqs =     let len = fromIntegral (length wave)     in  Interpolation.multiRelativeCyclicPad@@ -115,35 +114,35 @@ {-# INLINE staticSine #-} {- disabled SPECIALISE staticSine :: ChunkSize -> Double -> Double -> Signal.T Double -} {- | sine oscillator with static frequency -}-staticSine :: (Trans.C a, RealField.C a, Storable a) =>+staticSine :: (Trans.C a, RealRing.C a, Storable a) =>    ChunkSize -> Phase.T a -> a -> Signal.T a staticSine size = static size Wave.sine  {-# INLINE freqModSine #-} {- disabled SPECIALISE freqModSine :: ChunkSize -> Double -> Signal.T Double -> Signal.T Double -} {- | sine oscillator with modulated frequency -}-freqModSine :: (Trans.C a, RealField.C a, Storable a) =>+freqModSine :: (Trans.C a, RealRing.C a, Storable a) =>    ChunkSize -> Phase.T a -> Signal.T a -> Signal.T a freqModSine size = freqMod size Wave.sine  {-# INLINE phaseModSine #-} {- disabled SPECIALISE phaseModSine :: ChunkSize -> Double -> Signal.T Double -> Signal.T Double -} {- | sine oscillator with modulated phase, useful for FM synthesis -}-phaseModSine :: (Trans.C a, RealField.C a, Storable a) =>+phaseModSine :: (Trans.C a, RealRing.C a, Storable a) =>    ChunkSize -> a -> Signal.T a -> Signal.T a phaseModSine size = phaseMod size Wave.sine  {-# INLINE staticSaw #-} {- disabled SPECIALISE staticSaw :: ChunkSize -> Double -> Double -> Signal.T Double -} {- | saw tooth oscillator with modulated frequency -}-staticSaw :: (RealField.C a, Storable a) =>+staticSaw :: (RealRing.C a, Storable a) =>    ChunkSize -> Phase.T a -> a -> Signal.T a staticSaw size = static size Wave.saw  {-# INLINE freqModSaw #-} {- disabled SPECIALISE freqModSaw :: ChunkSize -> Double -> Signal.T Double -> Signal.T Double -} {- | saw tooth oscillator with modulated frequency -}-freqModSaw :: (RealField.C a, Storable a) =>+freqModSaw :: (RealRing.C a, Storable a) =>    ChunkSize -> Phase.T a -> Signal.T a -> Signal.T a freqModSaw size = freqMod size Wave.saw
src/Synthesizer/Storable/Play.hs view
@@ -11,12 +11,12 @@ import qualified Synthesizer.Storable.Signal as SigSt import qualified Synthesizer.Frame.Stereo as Stereo -import qualified Algebra.RealField as RealField+import qualified Algebra.RealRing as RealRing  import System.Exit (ExitCode, ) -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   {- |@@ -25,14 +25,14 @@ See synthesizer-alsa package. -} monoToInt16 ::-   (Storable a, RealField.C a) =>+   (Storable a, RealRing.C a) =>    a -> SigSt.T a -> IO ExitCode monoToInt16 rate =    Play.simple SigSt.hPut SoxOpt.none (round rate) .    SigSt.map BinSmp.int16FromCanonical  stereoToInt16 ::-   (Storable a, RealField.C a) =>+   (Storable a, RealRing.C a) =>    a -> SigSt.T (Stereo.T a) -> IO ExitCode stereoToInt16 rate =    Play.simple SigSt.hPut SoxOpt.none (round rate) .
src/Synthesizer/Storable/Signal.hs view
@@ -1,5 +1,4 @@-{- OPTIONS_GHC -fglasgow-exts -}-{- glasgow-exts are for the rules -}+{-# OPTIONS_GHC -fenable-rewrite-rules #-} {- | Chunky signal stream build on StorableVector. @@ -31,7 +30,7 @@       -- for Dimensional.File       Vector.writeFile,       -- for Storable.Cut-      mix, mixSndPattern, mixAppend, mixSize,+      mix, mixSndPattern, mixSize,       splitAtPad,       Vector.null,       Vector.fromChunks,@@ -40,16 +39,15 @@       delay,       delayLoop,       delayLoopOverlap,-      -- for FusionTest+      -- for FusionList.Storable       Vector.empty,+      Vector.cons,       Vector.replicate,       Vector.repeat,       Vector.drop,       Vector.take,       takeCrochet,       fromList,-      appendFromFusionList,-      appendFusionList,       -- for Generic.Signal       zipWithRest,       zipWithAppend,@@ -61,14 +59,9 @@       Vector.chunks,        -- just for fun-      fromFusionList,       genericLength,    ) where --- import qualified Sound.Signal as Signal--import qualified Synthesizer.FusionList.Signal as FList- import qualified Data.List as List import qualified Data.StorableVector.Lazy.Pointer as Pointer import qualified Data.StorableVector.Lazy as Vector@@ -104,13 +97,13 @@ -- import System.IO (openBinaryFile, hClose, hPutBuf, IOMode(WriteMode), Handle)  -import NumericPrelude-import PreludeBase+import NumericPrelude.Numeric+import NumericPrelude.Base import Prelude ()   {--import NumericPrelude+import NumericPrelude.Numeric    (sum, (+), (-), divMod, fromIntegral, fromInteger, toInteger, isZero, zero, )  import Prelude hiding@@ -171,7 +164,26 @@             (y,acc') <- f x acc             return (y, (acc',xs)))       (acc0, x0)+-} +{-+Where to place this function?+So far, for applying a causal process to a storable signal+we have just used the generic crochetL method.++applyCausalChunk :: Causal.T a b -> Causal.T (Vector a) (Vector b)+applyCausalChunk = undefined+++A generalized version could be of type++Transform.C sig a b => Causal.T a b -> Causal.T (sig a) (sig b)++but we cannot implement that,+since crochetL does not return the final state.+-}++{- reduceLVector :: Storable x =>    (x -> acc -> Maybe acc) -> acc -> Vector x -> (acc, Bool) reduceLVector f acc0 x =@@ -322,56 +334,6 @@      else Cons [x]  ---{-# NOINLINE [0] crochetFusionListL #-}-crochetFusionListL :: (Storable y) =>-      ChunkSize-   -> (x -> acc -> Maybe (y, acc))-   -> acc-   -> FList.T x-   -> T y-crochetFusionListL size f =-   curry (unfoldr size (\(acc,xt) ->-      do (x,xs) <- FList.viewL xt-         (y,acc') <- f x acc-         return (y, (acc',xs))))--}--{-# NOINLINE [0] fromFusionList #-}-fromFusionList :: (Storable a) => ChunkSize -> FList.T a -> T a-fromFusionList size = fromList size . FList.toList-   -- fromFusionListCrochetL--{--{-# INLINE fromFusionListCrochetL #-}-fromFusionListCrochetL :: (Storable a) => ChunkSize -> FList.T a -> T a-fromFusionListCrochetL size =-   crochetFusionListL size (\x _ -> Just (x, ())) ()--fromFusionListUnfoldr :: (Storable a) => ChunkSize -> FList.T a -> T a-fromFusionListUnfoldr size =-   unfoldr size FList.viewL---{-# NOINLINE [0] toFusionList #-}-toFusionList :: (Storable a) => T a -> FList.T a-toFusionList = FList.Cons . List.concatMap Vector.unpack . decons---{- |-Converts from and to 'FList.T'-in order to speedup computation,-especially because it tells the optimizer about the 'Storable' constraint-and thus allows for more fusion,-where fusion would break otherwise.--}-{-# INLINE chop #-}-chop :: (Storable a) => ChunkSize -> FList.T a -> FList.T a-chop size = toFusionList . fromFusionList size--- {-# INLINE [0] reduceL #-} reduceL :: Storable x =>    (x -> acc -> Maybe acc) -> acc -> T x -> acc@@ -556,26 +518,7 @@ {-# NOINLINE [0] append #-} append :: T a -> T a -> T a append (Cons xs) (Cons ys)  =  Cons (xs List.++ ys)--} -{-# INLINE appendFromFusionList #-}-appendFromFusionList :: Storable a =>-   ChunkSize -> FList.T a -> FList.T a -> T a-appendFromFusionList size xs ys  =-   Vector.append (FList.toStorableSignal size xs) (FList.toStorableSignal size ys)--{- |-Like 'appendFromFusionList' but returns a 'FList.T'-for more flexible following processing.--}-{-# INLINE appendFusionList #-}-appendFusionList :: Storable a =>-   ChunkSize -> FList.T a -> FList.T a -> FList.T a-appendFusionList size xs ys  =-   FList.fromStorableSignal (appendFromFusionList size xs ys)---{- {-# INLINE iterate #-} iterate :: Storable a => ChunkSize -> (a -> a) -> a -> T a iterate size f = unfoldr size (\x -> Just (x, f x))@@ -697,6 +640,9 @@ This implementation generates laziness breaks whereever one of the original sequences has laziness breaks. It should be commutative in this respect.++It is more efficient than 'mixSize'+since it appends the rest of the longer signal without copying. -} {-# SPECIALISE mix :: T Double -> T Double -> T Double #-} {-# SPECIALISE mix :: T Float -> T Float -> T Float #-}@@ -709,21 +655,14 @@    T x ->    T x ->    T x-mix xs0 ys0 =-   let recourse xt@(x:_) yt@(y:_) =-          let z = V.zipWith (+) x y-              n = V.length z-          in  z : recourse-                     (Vector.chunks $ Vector.drop n $ Vector.fromChunks xt)-                     (Vector.chunks $ Vector.drop n $ Vector.fromChunks yt)-       recourse xs [] = xs-       recourse [] ys = ys-   in  Vector.fromChunks $-       recourse (Vector.chunks xs0) (Vector.chunks ys0)+mix = zipWithAppend (+)+{-+List.map V.unpack $ Vector.chunks $ mix (fromList defaultChunkSize [1,2,3,4,5::P.Double]) (fromList defaultChunkSize [1,2,3,4])+-}  {- | Mix while maintaining the pattern of the second operand.-This is closer to the behavior of Vector.zipWith.+This is closer to the behavior of Vector.zipWithLastPattern. -} {-# INLINE mixSndPattern #-} mixSndPattern :: (Additive.C x, Storable x) =>@@ -744,30 +683,35 @@        recourse xs0 (Vector.chunks ys0)  +{-# INLINE zipWithAppend #-}+zipWithAppend ::+   (Storable x) =>+   (x -> x -> x) ->+   T x -> T x -> T x+zipWithAppend f xs0 ys0 =+   let recourse xt@(x:_) yt@(y:_) =+          let z = V.zipWith f x y+              n = V.length z+          in  z : recourse+                     (Vector.chunks $ Vector.drop n $ Vector.fromChunks xt)+                     (Vector.chunks $ Vector.drop n $ Vector.fromChunks yt)+       recourse xs [] = xs+       recourse [] ys = ys+   in  Vector.fromChunks $+       recourse (Vector.chunks xs0) (Vector.chunks ys0)+ {- |-'mixAppend' is more efficient than 'mixSize'-since it appends the rest of the longer signal without copying. It also preserves the chunk structure of the second signal, which is essential if you want to limit look-ahead. -It seems that this implementation has a memory leak!--}-{-# INLINE mixAppend #-}-mixAppend :: (Additive.C x, Storable x) =>-   T x ->-   T x ->-   T x-mixAppend = zipWithAppend (+)-{--List.map V.unpack $ Vector.chunks $ mix (fromList defaultChunkSize [1,2,3,4,5::P.Double]) (fromList defaultChunkSize [1,2,3,4])+This implementation seems to have a memory leak! -}--{-# INLINE zipWithAppend #-}-zipWithAppend ::+{-# INLINE _zipWithAppendRest #-}+_zipWithAppendRest ::    (Storable x) =>    (x -> x -> x) ->    T x -> T x -> T x-zipWithAppend f xs ys =+_zipWithAppendRest f xs ys =    uncurry Vector.append $ mapSnd snd $ zipWithRest f xs ys  {-# INLINE zipWithRest #-}@@ -782,7 +726,7 @@        (prefixX,suffixX) = genericSplitAt len xs        (prefixY,suffixY) = genericSplitAt len ys        second = Vector.null suffixX-   in  (Vector.zipWith f prefixX prefixY,+   in  (Vector.zipWithLastPattern f prefixX prefixY,         (second, if second then suffixY else suffixX))  {-@@ -957,67 +901,7 @@ replicateCrochet size n = takeCrochet n . repeat size  - {--crochetFusionListLGenerate size g b f a =-        unfoldr size (\(a0,b0) ->-            do (y0,a1) <- f a0-               (z0,b1) <- g y0 b0-               Just (z0, (a1,b1))) (a,b) ;---}---{-# RULES-  "Storable.crochetFusionListL/crochetL" forall size f g a b x.-     crochetFusionListL size g b (FList.crochetL f a x) =-        crochetFusionListL size (\x0 (a0,b0) ->-            do (y0,a1) <- f x0 a0-               (z0,b1) <- g y0 b0-               Just (z0, (a1,b1))) (a,b) x ;--  "Storable.crochetFusionListL/generate" forall size f g a b.-     crochetFusionListL size g b (FList.generate f a) =-        unfoldr size (\(a0,b0) ->-            do (y0,a1) <- f a0-               (z0,b1) <- g y0 b0-               Just (z0, (a1,b1))) (a,b) ;--{--  "Storable.fromFusionList/crochetL"-     forall size f a (x :: Storable a => FList.T a) .-     fromFusionList size (FList.crochetL f a x) =-        crochetL f a (fromFusionList size x) ;--}--  "Storable.fromFusionList/generate" forall size f a.-     fromFusionList size (FList.generate f a) =-        unfoldr size f a ;--  "Storable.fromFusionList/cons" forall size x xs.-     fromFusionList size (FList.cons x xs) =-        cons x (fromFusionList size xs) ;--  "Storable.fromFusionList/empty" forall size.-     fromFusionList size (FList.empty) =-        empty ;--  "Storable.fromFusionList/append" forall size xs ys.-     fromFusionList size (FList.append xs ys) =-        append (fromFusionList size xs) (fromFusionList size ys) ;--  "Storable.fromFusionList/maybe" forall size f x y.-     fromFusionList size (maybe x f y) =-        maybe (fromFusionList size x)-           (fromFusionList size . f) y ;--  "Storable.fromFusionList/fromMaybe" forall size x y.-     fromFusionList size (fromMaybe x y) =-        maybe (fromFusionList size x) (fromFusionList size) y ;-  #-}---{- The "fromList/drop" rule is not quite accurate because the chunk borders are moved. Maybe 'ChunkSize' better is a list of chunks sizes.@@ -1221,7 +1105,7 @@   "Storable.reduceL/unfoldr" forall size f g a b.      reduceL g b (unfoldr size f a) =         snd-          (FList.recourse (\(a0,b0) ->+          (untilNothing (\(a0,b0) ->               do (y,a1) <- f a0                  b1 <- g y b0                  Just (a1, b1)) (a,b)) ;@@ -1273,7 +1157,15 @@   #-}  +-- maybe candidate for Utility, cf. FusionList.Signal.recourse +{-# INLINE untilNothing #-}+untilNothing :: (acc -> Maybe acc) -> acc -> acc+untilNothing f =+   let aux x = maybe x aux (f x)+   in  aux++ {- * Fusion tests -}  @@ -1285,22 +1177,6 @@   "Storable.fromList/map" forall size f xs.      fromList size (List.map f xs) = fromMapList size f xs ;   #-}---fromMapFusionList :: (Storable y) =>-   ChunkSize -> (x -> y) -> FList.T x -> T y-fromMapFusionList size f =-   unfoldr size (fmap (mapFst f) . FList.viewL)--{-# RULES-  "Storable.fromFusionList/map" forall size f xs.-     fromFusionList size (FList.map f xs) = fromMapFusionList size f xs ;--  "Storable.fromFusionList/replicate" forall size n x.-     fromFusionList size (FList.replicate n x) = replicate size n x ;-  #-}--   testLength :: (Storable a, Enum a) => a -> Int
src/Synthesizer/Storage.hs view
@@ -19,7 +19,7 @@ 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.+however even a single list operation is hard to perform in real-time.  How do real-time software synthesizer achieve real-time performance? They get the popular fast inner loops@@ -128,19 +128,6 @@ 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
src/Synthesizer/Utility.hs view
@@ -7,8 +7,8 @@ import System.Random (Random, RandomGen, randomRs, )  import Prelude ()-import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   {-|
src/Test/Sound/Synthesizer/Basic/ToneModulation.hs view
@@ -22,8 +22,8 @@ import qualified Algebra.Additive              as Additive  -import NumericPrelude-import PreludeBase+import NumericPrelude.Numeric+import NumericPrelude.Base import Prelude ()
src/Test/Sound/Synthesizer/Generic/ToneModulation.hs view
@@ -48,8 +48,8 @@ import qualified Data.List as List  -import NumericPrelude-import PreludeBase+import NumericPrelude.Numeric+import NumericPrelude.Base import Prelude ()
src/Test/Sound/Synthesizer/Plain/Analysis.hs view
@@ -5,7 +5,7 @@ import qualified Algebra.Algebraic             as Algebraic import qualified Algebra.RealField             as RealField import qualified Algebra.Field                 as Field--- import qualified Algebra.Real                  as Real+import qualified Algebra.RealRing              as RealRing import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive @@ -25,26 +25,26 @@ -- import qualified Algebra.Ring                  as Ring -- import qualified Algebra.Additive              as Additive -import NumericPrelude-import PreludeBase+import NumericPrelude.Numeric+import NumericPrelude.Base import Prelude ()  -volumeVectorMaximum :: (NormedMax.C y y, Ord y) => [y] -> Bool+volumeVectorMaximum :: (NormedMax.C y y, RealRing.C y) => [y] -> Bool volumeVectorMaximum xs =    Analysis.volumeVectorMaximum xs == Analysis.volumeMaximum xs -volumeVectorEuclidean :: (NormedEuc.C y y, Algebraic.C y) => y -> [y] -> Bool+volumeVectorEuclidean :: (NormedEuc.C y y, Algebraic.C y, Eq y) => y -> [y] -> Bool volumeVectorEuclidean x xs =    let ys = x:xs    in  Analysis.volumeVectorEuclidean ys == Analysis.volumeEuclidean ys -volumeVectorEuclideanSqr :: (NormedEuc.Sqr y y, Field.C y) => y -> [y] -> Bool+volumeVectorEuclideanSqr :: (NormedEuc.Sqr y y, Field.C y, Eq y) => y -> [y] -> Bool volumeVectorEuclideanSqr x xs =    let ys = x:xs    in  Analysis.volumeVectorEuclideanSqr ys == Analysis.volumeEuclideanSqr ys -volumeVectorSum :: (NormedSum.C y y, Field.C y) => y -> [y] -> Bool+volumeVectorSum :: (NormedSum.C y y, RealField.C y) => y -> [y] -> Bool volumeVectorSum x xs =    let ys = x:xs    in  Analysis.volumeVectorSum ys == Analysis.volumeSum ys
src/Test/Sound/Synthesizer/Plain/Control.hs view
@@ -10,8 +10,8 @@  import Data.List (transpose) -import NumericPrelude-import PreludeBase+import NumericPrelude.Numeric+import NumericPrelude.Base import Prelude ()
src/Test/Sound/Synthesizer/Plain/Filter.hs view
@@ -35,8 +35,8 @@  -- import Debug.Trace (trace, ) -import NumericPrelude-import PreludeBase+import NumericPrelude.Numeric+import NumericPrelude.Base import Prelude ()
src/Test/Sound/Synthesizer/Plain/Filter/Allpass.hs view
@@ -17,9 +17,17 @@  -- import Debug.Trace (trace, ) -import NumericPrelude-import PreludeBase+import NumericPrelude.Numeric+import NumericPrelude.Base import Prelude ()+++{- this will not work due to the poles+parameter :: Double -> Double -> Bool+parameter phase freq =+   approxEqual eps phase+      (Allpass.makePhase (Allpass.parameter phase freq) freq)+-}   cascadeStep :: Rational -> Rational -> (Rational, Rational, [Rational]) -> Bool
src/Test/Sound/Synthesizer/Plain/Filter/Hilbert.hs view
@@ -21,8 +21,8 @@  -- import Debug.Trace (trace, ) -import NumericPrelude-import PreludeBase+import NumericPrelude.Numeric+import NumericPrelude.Base import Prelude ()
src/Test/Sound/Synthesizer/Plain/Interpolation.hs view
@@ -26,7 +26,7 @@ import qualified Synthesizer.Storable.Filter.NonRecursive as FiltSt import qualified Synthesizer.Storable.Signal as SigSt -import Test.QuickCheck (test, Arbitrary(..), elements, {- Property, (==>), -} Testable, )+import Test.QuickCheck (quickCheck, Arbitrary(arbitrary), elements, {- Property, (==>), -} Testable, ) -- import Test.Utility  import Foreign.Storable (Storable, )@@ -35,7 +35,7 @@ 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.RealRing                  as RealRing -- import qualified Algebra.Ring                  as Ring -- import qualified Algebra.Additive              as Additive @@ -46,8 +46,8 @@ import Test.Utility (equalList, ArbChar, unpackArbString, )  -import NumericPrelude-import PreludeBase+import NumericPrelude.Numeric+import NumericPrelude.Base import Prelude ()  @@ -146,7 +146,7 @@       []  -controlAboveOne :: (Real.C t) => [t] -> [t]+controlAboveOne :: (RealRing.C t) => [t] -> [t] controlAboveOne =    map ((one+) . abs) @@ -316,12 +316,12 @@ testRational ::    (Testable t) =>    (Rational -> Rational -> t) -> IO ()-testRational = test+testRational = quickCheck  testFM ::    (Testable t, Arbitrary (sigX ArbChar), Show (sigX ArbChar)) =>    ([Rational] -> sigX ArbChar -> t) -> IO ()-testFM = test+testFM = quickCheck  tests :: [(String, IO ())] tests =@@ -333,11 +333,11 @@    ("frequencyModulationBack",    testFM frequencyModulationBack) :    ("frequencyModulationGeneric", testFM frequencyModulationGeneric) :    ("frequencyModulationStorableChunkSize",-      test (\size0 size1 xsize0 xsize1 cs xs ->+      quickCheck (\size0 size1 xsize0 xsize1 cs xs ->          frequencyModulationStorableChunkSize size0 size1 xsize0 xsize1             (cs::[Rational]) (unpackArbString xs))) :    ("frequencyModulationStorable",-      test (\size xsize cs xs ->+      quickCheck (\size xsize cs xs ->          frequencyModulationStorable size xsize             (cs::[Rational]) (unpackArbString xs))) :    []
src/Test/Sound/Synthesizer/Plain/Oscillator.hs view
@@ -20,8 +20,8 @@ import qualified Algebra.Additive              as Additive  -import NumericPrelude-import PreludeBase+import NumericPrelude.Numeric+import NumericPrelude.Base import Prelude ()
src/Test/Sound/Synthesizer/Plain/ToneModulation.hs view
@@ -20,7 +20,7 @@ import qualified Test.Sound.Synthesizer.Plain.NonEmpty as NonEmpty import qualified Test.Sound.Synthesizer.Plain.Interpolation as InterpolationTest -import Test.QuickCheck (test, Property, (==>), Arbitrary, arbitrary, )+import Test.QuickCheck (quickCheck, Property, (==>), Arbitrary, arbitrary, ) import Test.Utility (ArbChar, )  import qualified Number.NonNegative       as NonNeg@@ -40,8 +40,8 @@ import qualified Data.List as List  -import NumericPrelude-import PreludeBase+import NumericPrelude.Numeric+import NumericPrelude.Base import Prelude ()  @@ -425,25 +425,25 @@  tests :: [(String, IO ())] tests =-   ("limitMinRelativeValues", test limitMinRelativeValues) :-   ("limitMaxRelativeValues", test limitMaxRelativeValues) :+   ("limitMinRelativeValues", quickCheck limitMinRelativeValues) :+   ("limitMaxRelativeValues", quickCheck limitMaxRelativeValues) :    ("limitMaxRelativeValuesNonNeg",-                              test limitMaxRelativeValuesNonNeg) :+                              quickCheck limitMaxRelativeValuesNonNeg) :    ("limitMinRelativeValuesIdentity",-                              test limitMinRelativeValuesIdentity) :+                              quickCheck limitMinRelativeValuesIdentity) :    ("limitMaxRelativeValuesIdentity",-                              test limitMaxRelativeValuesIdentity) :+                              quickCheck limitMaxRelativeValuesIdentity) :    ("limitMaxRelativeValuesNonNegIdentity",-                              test limitMaxRelativeValuesNonNegIdentity) :+                              quickCheck limitMaxRelativeValuesNonNegIdentity) :    ("limitMaxRelativeValuesInfinity",-                              test limitMaxRelativeValuesInfinity) :+                              quickCheck limitMaxRelativeValuesInfinity) :    ("limitMaxRelativeValuesNonNegInfinity",-                              test limitMaxRelativeValuesNonNegInfinity) :-   ("dropRem",                test (dropRem :: NonNeg.Int -> [ArbChar] -> Bool)) :+                              quickCheck limitMaxRelativeValuesNonNegInfinity) :+   ("dropRem",                quickCheck (dropRem :: NonNeg.Int -> [ArbChar] -> Bool)) :    ("sampledToneSine",-      test (\period -> sampledToneSine (period :: NonNeg.Double))) :+      quickCheck (\period -> sampledToneSine (period :: NonNeg.Double))) :    ("sampledToneSineList",-      test (\period -> sampledToneSineList (period :: NonNeg.Double))) :+      quickCheck (\period -> sampledToneSineList (period :: NonNeg.Double))) :    ("sampledToneLinear",       testRationalLineIp sampledToneLinear) :    ("sampledToneStair",@@ -455,15 +455,15 @@    ("sampledToneStatic",       testRationalIp sampledToneStatic) :    ("shapeFreqModFromSampledToneLimitIdentity",-      test (\ml ms p ixs (t,ts) ->+      quickCheck (\ml ms p ixs (t,ts) ->           shapeFreqModFromSampledToneLimitIdentity ml ms p              (ixs::NonEmpty.T Rational) (t::Rational,ts))) :    ("oscillatorCoords",-      test (\periodInt period ->+      quickCheck (\periodInt period ->                oscillatorCoords                   periodInt (period :: NonNeg.Rational))) :    ("shapeFreqModFromSampledToneCoordsIdentity",-      test (\periodInt period ->+      quickCheck (\periodInt period ->                shapeFreqModFromSampledToneCoordsIdentity                   periodInt (period :: NonNeg.Rational))) :    ("shapeFreqModFromSampledTone",@@ -471,7 +471,7 @@    ("shapePhaseFreqModFromSampledTone",       testRationalIp shapePhaseFreqModFromSampledTone) :    ("oscillatorCells",-      test (\ml ms periodInt period ext ixs ->+      quickCheck (\ml ms periodInt period ext ixs ->                oscillatorCells ml ms periodInt (period :: NonNeg.Rational)                   ext (ixs :: NonEmpty.T ArbChar))) :    ("shapeFreqModFromSampledToneIdentity",
src/Test/Sound/Synthesizer/Plain/Wave.hs view
@@ -3,7 +3,7 @@ import qualified Synthesizer.Basic.Wave       as Wave import qualified Synthesizer.Basic.Phase      as Phase -import Test.QuickCheck (test, Arbitrary(..), elements, oneof, choose, {- Property, (==>), -} )+import Test.QuickCheck (quickCheck, Arbitrary(arbitrary), elements, oneof, choose, {- Property, (==>), -} ) -- import Test.Utility  import qualified Number.NonNegative       as NonNeg@@ -19,8 +19,8 @@ import System.Random (Random)  -import NumericPrelude-import PreludeBase+import NumericPrelude.Numeric+import NumericPrelude.Base import Prelude ()  @@ -75,5 +75,5 @@  tests :: [(String, IO ())] tests =-   ("zeroDCOffset",  test zeroDCOffset) :+   ("zeroDCOffset",  quickCheck zeroDCOffset) :    []
src/Test/Sound/Synthesizer/Storable/Cut.hs view
@@ -8,20 +8,20 @@  import qualified Data.EventList.Relative.TimeBody  as EventList --- import qualified Algebra.Real                  as Real+-- import qualified Algebra.RealRing                  as RealRing -- import qualified Algebra.Ring                  as Ring -- import qualified Algebra.Additive              as Additive  import qualified Number.NonNegative as NonNeg -import Test.QuickCheck (test, )+import Test.QuickCheck (quickCheck, ) import Test.Utility (equalList, )  -- import qualified Algebra.Ring                  as Ring -- import qualified Algebra.Additive              as Additive -import NumericPrelude-import PreludeBase+import NumericPrelude.Numeric+import NumericPrelude.Base import Prelude ()  @@ -39,5 +39,5 @@  tests :: [(String, IO ())] tests =-   ("arrange", test arrange) :+   ("arrange", quickCheck arrange) :    []
src/Test/Utility.hs view
@@ -1,15 +1,15 @@ {-# LANGUAGE NoImplicitPrelude #-} module Test.Utility where -import Test.QuickCheck (Arbitrary(..))+import Test.QuickCheck (Arbitrary(arbitrary)) -import qualified Algebra.Real                  as Real+import qualified Algebra.RealRing                  as RealRing import qualified Algebra.Ring                  as Ring  import qualified Data.Char as Char -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric   equalList :: Eq a => [a] -> Bool@@ -18,16 +18,16 @@    and (zipWith (==) xs (drop 1 xs))  -approxEqual :: (Real.C a) => a -> a -> a -> Bool+approxEqual :: (RealRing.C a) => a -> a -> a -> Bool approxEqual eps x y =    2 * abs (x-y) <= eps * (abs x + abs y) -approxEqualListRel :: (Real.C a) => a -> [a] -> Bool+approxEqualListRel :: (RealRing.C a) => a -> [a] -> Bool approxEqualListRel eps xs =    let n = fromIntegral $ length xs    in  approxEqualListAbs (eps * n * sum (map abs xs)) xs -approxEqualListAbs :: (Real.C a) => a -> [a] -> Bool+approxEqualListAbs :: (RealRing.C a) => a -> [a] -> Bool approxEqualListAbs eps xs =    let n = fromIntegral $ length xs        s = sum xs
synthesizer-core.cabal view
@@ -1,5 +1,5 @@ Name:           synthesizer-core-Version:        0.3.1+Version:        0.4 License:        GPL License-File:   LICENSE Author:         Henning Thielemann <haskell@henning-thielemann.de>@@ -12,7 +12,7 @@    used by the other synthesizer packages.    The routines can be 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 interface to Haskore see <http://code.haskell.org/haskore/revised/synthesizer/>.    For introductory examples see "Synthesizer.Plain.Tutorial"    and "Synthesizer.Generic.Tutorial". -- the Overview module does not really fit into one of the part packages@@ -48,7 +48,7 @@   Source-Repository this-  Tag:         0.3+  Tag:         0.4   Type:        darcs   Location:    http://code.haskell.org/synthesizer/core/ @@ -58,17 +58,19 @@  Library   Build-Depends:-    sample-frame-np >=0.0.1 && <0.0.2,-    sox >=0.2 && <0.3,+    sample-frame-np >=0.0.1 && <0.1,+    sox >=0.1 && <0.3,     transformers >=0.2 && <0.3,-    event-list >=0.0.8 && <0.1,-    non-negative >=0.0.5 && <0.1,-    numeric-prelude >=0.1.2 && <0.2,-    numeric-quest >= 0.1 && <0.2,+    event-list >=0.1 && <0.2,+    non-negative >=0.1 && <0.2,+    numeric-prelude >=0.2 && <0.3,+    numeric-quest >=0.1 && <0.2,     utility-ht >=0.0.5 && <0.1,     filepath >=1.1 && <1.2,-    bytestring >= 0.9 && <0.10,+    stream-fusion >=0.1.2 && <0.2,+    bytestring >=0.9 && <0.10,     binary >=0.1 && <1,+    deepseq >=1.1 && <1.2,     storablevector >=0.2.5 && <0.3,     storable-record >=0.0.1 && <0.1,     storable-tuple >=0.0.1 && <0.1,@@ -77,7 +79,7 @@   If flag(splitBase)     If flag(category)       Hs-Source-Dirs: src-4-      Build-Depends: base >= 4 && <5+      Build-Depends: base >= 4 && <6     Else       Hs-Source-Dirs: src-3       Build-Depends: base >= 3 && <4@@ -159,10 +161,6 @@     Synthesizer.Plain.IO     Synthesizer.Plain.File     Synthesizer.Plain.Play-    Synthesizer.FusionList.Control-    Synthesizer.FusionList.Filter.NonRecursive-    Synthesizer.FusionList.Oscillator-    Synthesizer.FusionList.Signal     Synthesizer.Storable.Cut     Synthesizer.Storable.Oscillator     Synthesizer.Storable.Play@@ -190,6 +188,7 @@     Synthesizer.Causal.Displacement     Synthesizer.Causal.Interpolation     Synthesizer.Causal.Oscillator+    Synthesizer.Causal.Oscillator.Core     Synthesizer.Causal.ToneModulation     Synthesizer.Causal.Filter.NonRecursive     Synthesizer.Causal.Filter.Recursive.Integration@@ -218,22 +217,10 @@     -- synthesizer.dimensional:Synthesizer.Dimensional.Causal.Filter import affineComb     Synthesizer.Utility -    -- for haskore-synthesizer-    Synthesizer.Filter.Example-   Other-Modules:     Synthesizer.Basic.ComplexModule -    Synthesizer.Filter.Basic-    Synthesizer.Filter.Composition-    Synthesizer.Filter.Fix-    Synthesizer.Filter.Graph-    Synthesizer.Filter.Graphic-    Synthesizer.Filter.MonadFix-    Synthesizer.Filter.OneWay-    Synthesizer.Filter.TwoWay - Executable test   If !flag(buildTests)     Buildable: False@@ -259,19 +246,6 @@     Test.Sound.Synthesizer.Generic.ToneModulation     Test.Sound.Synthesizer.Storable.Cut   Main-Is: Test/Main.hs--Executable fusiontest-  If !flag(buildProfilers)-    Buildable: False-  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)