diff --git a/src/Synthesizer/Plain/Oscillator.hs b/src/Synthesizer/Plain/Oscillator.hs --- a/src/Synthesizer/Plain/Oscillator.hs +++ b/src/Synthesizer/Plain/Oscillator.hs @@ -57,19 +57,23 @@ zipWith Phase.increment phases (iterate (Phase.increment freq) zero) {- | oscillator with modulated shape -} -shapeMod :: (RealRing.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 :: (RealRing.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 :: (RealRing.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 @@ -77,13 +81,17 @@ {- | oscillator with a sampled waveform with constant frequency This is essentially an interpolation with cyclic padding. -} -staticSample :: RealRing.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 :: RealRing.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 @@ -108,8 +116,10 @@ because in the wave information for 'shapeFreqModSample' shape and phase are strictly separated. -} -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 :: + (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 (Interpolation.multiRelativeConstantPad ip shape0 shapes waves) @@ -118,8 +128,10 @@ GNUPlot.plotList [] $ take 500 $ shapeFreqModSample Interpolation.cubic (map Wave.truncOddCosine [0..3]) (0.1::Double) (0::Double) (repeat 0.005) (repeat 0.02) -} -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 :: + (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 (Interpolation.multiRelativeConstantPad ip shape0 shapes waves) @@ -201,6 +213,21 @@ {- * Oscillators with specific waveforms -} +{- | impulse train with static frequency -} +staticImpulses :: (RealRing.C a) => a -> a -> Sig.T a +staticImpulses phase = freqModImpulses phase . repeat + +{- | impulse train with modulated frequency -} +freqModImpulses :: (RealRing.C a) => a -> Sig.T a -> Sig.T a +freqModImpulses phase = + Sig.crochetL + (\freq p0 -> Just $ + let p1 = p0+freq + in if p1>1 + then (1, fraction p1) + else (0, p1)) + (fraction phase) + {- | sine oscillator with static frequency -} staticSine :: (Trans.C a, RealRing.C a) => a -> a -> Sig.T a staticSine = static Wave.sine @@ -213,7 +240,7 @@ phaseModSine :: (Trans.C a, RealRing.C a) => a -> Sig.T a -> Sig.T a phaseModSine = phaseMod Wave.sine -{- | saw tooth oscillator with modulated frequency -} +{- | saw tooth oscillator with static frequency -} staticSaw :: RealRing.C a => a -> a -> Sig.T a staticSaw = static Wave.saw diff --git a/src/Synthesizer/Plain/Oscillator/BandLimited.hs b/src/Synthesizer/Plain/Oscillator/BandLimited.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Oscillator/BandLimited.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{- | +Tone generators with measures for band-limitation. + +They are not exactly band-limiting because this would cause infinite lag. +Instead we use only cubic interpolation polynomials. +This still incurs a small lag. + + +-} +module Synthesizer.Plain.Oscillator.BandLimited where + +import qualified Synthesizer.Plain.Signal as Sig + +import qualified Algebra.RealField as RealField + +import NumericPrelude.Numeric +import NumericPrelude.Base + + + +{- +sinc approximation, that could be used for band-limited oscillators: + +GP.plotFuncs [] (GP.linearScale 1000 (-2,2::Double)) [\x -> if x<0 then (if x< -1 then (x+1)*(x+2)*(x+2) else 1-x*x*2-x*x*x) else (if x<1 then 1-x*x*2+x*x*x else -(x-1)*(x-2)*(x-2)), \x -> if x==0 then 1 else sin (pi*x)/(pi*x)] + +Has the same tangent as sinc-pi at point 1. + +Cf. +DSP.Filter.FIR.PolyInterp +Integral Sine: gsl_sf_Si +-} + + + +{- | impulse train with static frequency -} +staticImpulses :: (RealField.C a) => a -> a -> Sig.T a +staticImpulses phase = freqModImpulses phase . repeat + +{- | impulse train with modulated frequency -} +freqModImpulses :: (RealField.C a) => a -> Sig.T a -> Sig.T a +freqModImpulses phase = + (\ ~(~(_,remaining),xs) -> xs ++ remaining) . + Sig.mapAccumL + (\freq (p0,xs0) -> + let p1 = p0+freq + (p2, xs1) = + if p1>=1 + then + let p1frac=fraction p1 + t=p1frac/freq + t_2 = t*t; y0 = t_2*(t-1) + t1_2 = (t-1)*(t-1); y3 = -t1_2*t + in (p1frac, xs0 + [y0, 1-t1_2+y3, 1-t_2+y0, y3]) + else (p1, xs0) + (x3,xs3) = + case xs1 of + [] -> (0,[]) + x2:xs2 -> (x2,xs2) + in Just $ (x3, (p2,xs3))) + (phase,[]) diff --git a/synthesizer-core.cabal b/synthesizer-core.cabal --- a/synthesizer-core.cabal +++ b/synthesizer-core.cabal @@ -1,5 +1,5 @@ Name: synthesizer-core -Version: 0.8.3 +Version: 0.8.4 License: GPL License-File: LICENSE Author: Henning Thielemann @@ -38,7 +38,7 @@ Source-Repository this - Tag: 0.8.3 + Tag: 0.8.4 Type: darcs Location: http://code.haskell.org/synthesizer/core/ @@ -55,20 +55,20 @@ semigroups >=0.1 && <1.0, event-list >=0.1 && <0.2, non-negative >=0.1 && <0.2, - explicit-exception >=0.1.6 && <0.2, + explicit-exception >=0.1.6 && <0.3, numeric-prelude >=0.4.2 && <0.5, numeric-quest >=0.1 && <0.3, utility-ht >=0.0.14 && <0.1, filepath >=1.1 && <1.5, - bytestring >=0.9 && <0.12, + bytestring >=0.9 && <0.13, binary >=0.1 && <1, - deepseq >=1.1 && <1.5, + deepseq >=1.1 && <1.6, storablevector >=0.2.5 && <0.3, storable-record >=0.0.1 && <0.1, - storable-tuple >=0.0.1 && <0.1, + storable-tuple >=0.0.1 && <0.2, QuickCheck >=1 && <3, array >=0.1 && <0.6, - containers >=0.1 && <0.7, + containers >=0.1 && <0.8, random >=1.0 && <2.0, process >=1.0 && <1.7, base >= 4 && <5 @@ -138,6 +138,7 @@ Synthesizer.Plain.Modifier Synthesizer.Plain.Noise Synthesizer.Plain.Oscillator + Synthesizer.Plain.Oscillator.BandLimited Synthesizer.Plain.ToneModulation Synthesizer.Plain.Wave Synthesizer.Plain.Instrument @@ -286,7 +287,7 @@ numeric-prelude, timeit >=1.0 && <3, storablevector >=0.2.7 && <0.3, - storable-tuple >=0.0.1 && <0.1, + storable-tuple, utility-ht >=0.0.5 && <0.1, base >=4 && <5 diff --git a/test/Test/Sound/Synthesizer/Basic/NumberTheory.hs b/test/Test/Sound/Synthesizer/Basic/NumberTheory.hs --- a/test/Test/Sound/Synthesizer/Basic/NumberTheory.hs +++ b/test/Test/Sound/Synthesizer/Basic/NumberTheory.hs @@ -6,12 +6,12 @@ import Control.Applicative ((<$>), ) +import qualified Data.List.HT as ListHT import qualified Data.Set as Set import qualified Data.Bits as Bit import qualified Test.QuickCheck as QC import Test.QuickCheck (Testable, Arbitrary, arbitrary, quickCheck, ) -import Test.Utility (equalList, ) import qualified Algebra.Absolute as Absolute @@ -157,10 +157,10 @@ QC.forAll (QC.choose (2,10::Integer)) $ \b (Positive n) -> NT.divideByMaximumPower b n == NT.divideByMaximumPowerRecursive b n) : ("numbers3Smooth", - QC.quickCheckWith singleArgs $ equalList $ map (take 10000) $ + QC.quickCheckWith singleArgs $ ListHT.allEqual $ map (take 10000) $ [NT.numbers3SmoothCorec, NT.numbers3SmoothFoldr, NT.numbers3SmoothSet]) : ("numbers5Smooth", - QC.quickCheckWith singleArgs $ equalList $ map (take 10000) $ + QC.quickCheckWith singleArgs $ ListHT.allEqual $ map (take 10000) $ [NT.numbers5SmoothCorec, NT.numbers5SmoothFoldr, NT.numbers5SmoothSet]) : ("ceiling3Smooth vs. is3Smooth", quickCheck $ \(Positive n) -> NT.is3Smooth $ NT.ceiling3Smooth n) : diff --git a/test/Test/Sound/Synthesizer/Plain/Control.hs b/test/Test/Sound/Synthesizer/Plain/Control.hs --- a/test/Test/Sound/Synthesizer/Plain/Control.hs +++ b/test/Test/Sound/Synthesizer/Plain/Control.hs @@ -3,9 +3,10 @@ import qualified Synthesizer.Plain.Control as Control import qualified Test.QuickCheck as QC -import Test.QuickCheck (Property, quickCheck, (==>), ) -import Test.Utility (equalList, approxEqualListAbs, approxEqualListRel, ) +import Test.QuickCheck (Property, quickCheck, (==>)) +import Test.Utility (approxEqualListAbs, approxEqualListRel) +import qualified Data.List.HT as ListHT import Data.List (transpose) import NumericPrelude.Numeric @@ -16,7 +17,7 @@ linearRing :: Int -> Int -> Bool linearRing d y0 = -- Control.linear d y0 == Control.linearMultiscale d y0 - all equalList $ take 100 $ transpose $ + all ListHT.allEqual $ take 100 $ transpose $ Control.linear d y0 : Control.linearMultiscale d y0 : Control.linearStable d y0 : @@ -40,7 +41,7 @@ linearExact :: Rational -> Rational -> Bool linearExact d y0 = - all equalList $ take 100 $ transpose $ + all ListHT.allEqual $ take 100 $ transpose $ Control.linear d y0 : Control.linearMean d y0 : Control.linearMultiscale d y0 : diff --git a/test/Test/Sound/Synthesizer/Plain/Filter.hs b/test/Test/Sound/Synthesizer/Plain/Filter.hs --- a/test/Test/Sound/Synthesizer/Plain/Filter.hs +++ b/test/Test/Sound/Synthesizer/Plain/Filter.hs @@ -19,7 +19,7 @@ import qualified Test.QuickCheck as QC import Test.QuickCheck (Property, arbitrary, quickCheck, ) -import Test.Utility (equalList, ArbChar, ) +import Test.Utility (ArbChar) import qualified Number.GaloisField2p32m5 as GF import qualified Number.NonNegative as NonNeg @@ -28,6 +28,7 @@ import Control.Applicative (liftA2, (<$>), ) +import qualified Data.List.HT as ListHT import qualified Data.List as List import Data.Tuple.HT (sortPair, mapPair, ) import Data.Ix (inRange, ) @@ -47,7 +48,7 @@ in -- this checks only for equal prefixes and can easily go wrong, -- if one list is empty and $ zipWith3 (\x y z -> x==y && y==z) naive rec pyramid - -- equalList $ naive : pyramid : rec : [] + -- ListHT.allEqual $ naive : pyramid : rec : [] sumRange :: Sig.T Int -> Property sumRange xs = @@ -59,7 +60,7 @@ pyrSt = FiltNRSt.pyramid (+) height (SigSt.fromList SigSt.defaultChunkSize xs) - in equalList $ + in ListHT.allEqual $ FiltNR.sumRange xs rng : FiltNR.sumRangeFromPyramid pyr rng : FiltNR.sumRangeFromPyramidRec pyr rng : @@ -85,7 +86,7 @@ getRange nrng pyr0 = let rng = sortPair $ mapPair (getSize, getSize) nrng pyr = map NonEmpty.toInfiniteList $ NonEmpty.toList pyr0 - in equalList $ + in ListHT.allEqual $ FiltNR.getRangeFromPyramid pyr rng : FiltNRG.consumeRangeFromPyramid (:) [] pyr rng : [] @@ -95,7 +96,7 @@ QC.forAll (QC.choose (0,10)) $ \height -> let ctrl = map (mapPair (getSize, getSize)) nctrl xs = NonEmpty.toInfiniteList xsc - in equalList $ + in ListHT.allEqual $ FiltNR.sumsPosModulated ctrl xs : FiltNR.sumsPosModulatedPyramid height ctrl xs : FiltNRG.sumsPosModulatedPyramid height ctrl xs : @@ -126,7 +127,7 @@ mapPair (getSize, getSize)) nctrl xs = NonEmpty.toInfiniteList xsc - in equalList $ + in ListHT.allEqual $ zipWith FiltNR.minRange (List.tails xs) ctrl : SigSt.toList (FiltNRSt.accumulateBinPosModulatedPyramid min height @@ -144,7 +145,7 @@ downSample2 :: Property downSample2 = QC.forAll genChunkyVector $ \xs -> - equalList $ + ListHT.allEqual $ FiltNRG.downsample2 SigG.defaultLazySize xs : FiltNRSt.downsample2 xs : [] @@ -152,7 +153,7 @@ sumsDownSample2 :: Property sumsDownSample2 = QC.forAll genChunkyVector $ \xs -> - equalList $ + ListHT.allEqual $ FiltNRG.sumsDownsample2 SigG.defaultLazySize xs : FiltNRSt.sumsDownsample2 xs : FiltNRSt.sumsDownsample2Alt xs : @@ -163,7 +164,7 @@ sumsDownSample2 lazySize xsc = let len = Chunky.fromChunks $ filter (0/=) lazySize xs = VP.pack len $ NonEmpty.toInfiniteList xsc - in equalList $ + in ListHT.allEqual $ FiltNRG.sumsDownsample2 SigG.defaultLazySize xs : FiltNRSt.sumsDownsample2 xs : FiltNRSt.sumsDownsample2Alt xs : @@ -180,7 +181,7 @@ maxC = maximum ctrl onegf :: GF.T onegf = one - in equalList $ + in ListHT.allEqual $ pack (FiltNR.movingAverageModulatedPyramid onegf height maxC ctrl (cycle xs)) : FiltNRG.movingAverageModulatedPyramid onegf diff --git a/test/Test/Sound/Synthesizer/Plain/Filter/Allpass.hs b/test/Test/Sound/Synthesizer/Plain/Filter/Allpass.hs --- a/test/Test/Sound/Synthesizer/Plain/Filter/Allpass.hs +++ b/test/Test/Sound/Synthesizer/Plain/Filter/Allpass.hs @@ -8,15 +8,16 @@ -- import qualified Test.Sound.Synthesizer.Plain.NonEmpty as NonEmpty import Test.QuickCheck (quickCheck, {- Property, (==>) -}) -import Test.Utility (equalList, ) +import qualified Data.List.HT as ListHT + +import Control.Monad.Trans.State (runState) + -- 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 Control.Monad.Trans.State (runState, ) - import NumericPrelude.Numeric import NumericPrelude.Base import Prelude () @@ -34,7 +35,7 @@ cascadeStep k u (s0,s1,ns) = let p = Allpass.Parameter k s = s0:s1:ns - in equalList $ + in ListHT.allEqual $ runState (Allpass.cascadeStepStack p u) s : runState (Allpass.cascadeStepRec p u) s : runState (Allpass.cascadeStepScanl p u) s : diff --git a/test/Test/Sound/Synthesizer/Plain/Filter/Hilbert.hs b/test/Test/Sound/Synthesizer/Plain/Filter/Hilbert.hs --- a/test/Test/Sound/Synthesizer/Plain/Filter/Hilbert.hs +++ b/test/Test/Sound/Synthesizer/Plain/Filter/Hilbert.hs @@ -9,7 +9,6 @@ import qualified Test.Sound.Synthesizer.Plain.NonEmpty as NonEmpty import Test.QuickCheck (quickCheck, {- Property, (==>) -}) --- import Test.Utility (equalList, ) -- import qualified Algebra.Module as Module -- import qualified Algebra.RealField as RealField diff --git a/test/Test/Sound/Synthesizer/Plain/Interpolation.hs b/test/Test/Sound/Synthesizer/Plain/Interpolation.hs --- a/test/Test/Sound/Synthesizer/Plain/Interpolation.hs +++ b/test/Test/Sound/Synthesizer/Plain/Interpolation.hs @@ -36,10 +36,11 @@ import qualified Algebra.RealRing as RealRing import qualified Data.List.Match as Match +import qualified Data.List.HT as ListHT import Data.Tuple.HT (mapSnd, ) import qualified Test.Sound.Synthesizer.Plain.NonEmpty as NonEmpty -import Test.Utility (equalList, ArbChar, unpackArbString, ) +import Test.Utility (ArbChar, unpackArbString) import NumericPrelude.Numeric @@ -104,7 +105,7 @@ (Interpol.C a v, Module.C a v, Eq v) => a -> v -> [v] -> Bool constant t x0 xs = - equalList $ map ($ (x0:xs)) $ map ($ t) $ + ListHT.allEqual $ map ($ (x0:xs)) $ map ($ t) $ Interpolation.func ExampleCustom.constant : Interpolation.func ExampleCustom.piecewiseConstant : Interpolation.func ExampleModule.constant : @@ -115,7 +116,7 @@ (Interpol.C a v, Module.C a v, Eq v) => a -> v -> v -> [v] -> Bool linear t x0 x1 xs = - equalList $ map ($ (x0:x1:xs)) $ map ($ t) $ + ListHT.allEqual $ map ($ (x0:x1:xs)) $ map ($ t) $ Interpolation.func ExampleCustom.linear : Interpolation.func ExampleCustom.piecewiseLinear : Interpolation.func ExampleModule.linear : @@ -126,7 +127,7 @@ (Interpol.C a v, VectorSpace.C a v, Eq v) => a -> v -> v -> v -> v -> [v] -> Bool cubic t x0 x1 x2 x3 xs = - equalList $ map ($ (x0:x1:x2:x3:xs)) $ map ($ t) $ + ListHT.allEqual $ map ($ (x0:x1:x2:x3:xs)) $ map ($ t) $ Interpolation.func ExampleCustom.cubic : Interpolation.func ExampleCustom.piecewiseCubic : Interpolation.func ExampleModule.cubic : diff --git a/test/Test/Sound/Synthesizer/Storable/Cut.hs b/test/Test/Sound/Synthesizer/Storable/Cut.hs --- a/test/Test/Sound/Synthesizer/Storable/Cut.hs +++ b/test/Test/Sound/Synthesizer/Storable/Cut.hs @@ -7,12 +7,12 @@ import qualified Synthesizer.Plain.Signal as Sig import qualified Data.EventList.Relative.TimeBody as EventList +import qualified Data.List.HT as ListHT import qualified Number.NonNegative as NonNeg import qualified Test.QuickCheck as QC import Test.QuickCheck (quickCheck, ) -import Test.Utility (equalList, ) import NumericPrelude.Numeric import NumericPrelude.Base @@ -26,7 +26,7 @@ arrange chunkSize = QC.forAll genEventList $ \evs -> let sevs = EventList.mapBody (SigSt.fromList chunkSize) evs - in equalList $ + in ListHT.allEqual $ SigSt.fromList chunkSize (Cut.arrange evs) : CutSt.arrangeAdaptive chunkSize sevs : CutSt.arrangeList chunkSize sevs : diff --git a/test/Test/Utility.hs b/test/Test/Utility.hs --- a/test/Test/Utility.hs +++ b/test/Test/Utility.hs @@ -15,11 +15,6 @@ import NumericPrelude.Numeric -equalList :: Eq a => [a] -> Bool -equalList xs = - and (ListHT.mapAdjacent (==) xs) - - approxEqual :: (RealRing.C a) => a -> a -> a -> Bool approxEqual eps x y = 2 * abs (x-y) <= eps * (abs x + abs y)