diff --git a/private/Synthesizer/Basic/NumberTheory.hs b/private/Synthesizer/Basic/NumberTheory.hs --- a/private/Synthesizer/Basic/NumberTheory.hs +++ b/private/Synthesizer/Basic/NumberTheory.hs @@ -20,7 +20,7 @@ g(4,2) = 1 g(2^n,2) = 3 for n>=3 ((-1) is always a square root of 1) g(2^n,2^k) = 2^k for k>=2 && k=3 and n in OEIS:A033948 + g(n,2) = 1 for n>=3 and n in http://oeis.org/A033948 sum(g(n,k), k\in\N) = phi(n) There are only a few patterns that occur as rows of g, but a row of g (i.e. g(n)) does functionally depend on @@ -69,8 +69,66 @@ thus lcm(o1,...,ok) divides the carmichael value of that ring, thus there is a primitive root of order lcm(o1,...,ok). -} -module Synthesizer.Basic.NumberTheory where +module Synthesizer.Basic.NumberTheory ( + fermatFactors, + uniquePrimeFactors, + primeFactors, + multiplicativeGenerator, + Order (Order, getOrder), + PrimitiveRoot(primitiveRootCandidates, maximumOrderOfPrimitiveRootsOfUnity), + primitiveRootsOfUnity, + lcmMulti, + primitiveRootsOfUnityFullOrbit, + primitiveRootsOfOrbit, + hasPrimitiveRootOfUnityNaive, + ordersOfPrimitiveRootsOfUnityTest, + orderOfOrbit, + hasPrimitiveRootOfUnityInteger, + ordersOfPrimitiveRootsOfUnityInteger, + ordersOfRootsOfUnityInteger, + ordersOfRootsOfUnityIntegerCondensed, + rootsOfUnityPower, + ringsWithPrimitiveRootOfUnityAndUnit, + ringsWithPrimitiveRootsOfUnityAndUnitsNaive, + ringWithPrimitiveRootsOfUnityAndUnits, + ringWithPrimitiveRootsOfUnity, + is3Smooth, + is5Smooth, + numbers3Smooth, + numbers5Smooth, + ceilingPowerOfTwo, + ceilingPower, + ceilingLog, + powerOfTwoFactors, + divideByMaximumPower, + ceiling3Smooth, + ceiling5Smooth, + isPrime, + raderWorstCases, + fastFourierRing, + -- for testing + multiplicativeGeneratorSet, + multiplicativeGeneratorDivisors, + primitiveRootsOfUnityPower, + primitiveRootsOfUnityNaive, + primitiveRootsOfUnityFullOrbitTest, + maximumOrderOfPrimitiveRootsOfUnityNaive, + maximumOrderOfPrimitiveRootsOfUnityInteger, + numbers3SmoothCorec, + numbers3SmoothFoldr, + numbers3SmoothSet, + numbers5SmoothCorec, + numbers5SmoothFoldr, + numbers5SmoothSet, + ceiling3SmoothScan, + ceiling5SmoothScan, + ceiling3SmoothNaive, + ceiling5SmoothNaive, + ceiling3SmoothTrace, + ceiling5SmoothTrace, + ) where + import qualified Synthesizer.State.Signal as SigS import qualified Data.Set as Set @@ -143,7 +201,7 @@ i.e. 2 or 3. Smallest multiplicative generators for primes: -http://oeis.org/A001918 + Especially large generators: $ filter ((>31) . snd) $ map (\n -> (n, multiplicativeGenerator n)) $ tail NumberTheory.primes @@ -437,7 +495,7 @@ {- This is the Carmichael function. -OEIS-A002322 + -} maximumOrderOfPrimitiveRootsOfUnityInteger :: Integer -> Order @@ -455,7 +513,7 @@ {- The sum of the sub-lists should equal the Euler totient function values -(OEIS-A000010). +. -} ordersOfPrimitiveRootsOfUnityInteger :: [[Int]] ordersOfPrimitiveRootsOfUnityInteger = @@ -617,7 +675,7 @@ {- | List all numbers that only contain prime factors 2 and 3 in ascending order. -OEIS:A003586 + -} numbers3Smooth :: [Integer] numbers3Smooth = numbers3SmoothCorec @@ -649,7 +707,7 @@ {- Hamming sequence -OEIS:A051037 + -} numbers5Smooth :: [Integer] numbers5Smooth = numbers5SmoothCorec @@ -701,9 +759,9 @@ last $ n : unfoldr (\m -> case divMod m b of (q,r) -> toMaybe (isZero r) (q,q)) n -divideByMaximumPowerRecursive :: +_divideByMaximumPowerRecursive :: (Integral.C a, Eq a, ZeroTestable.C a) => a -> a -> a -divideByMaximumPowerRecursive b = +_divideByMaximumPowerRecursive b = let recourse n = case divMod b n of (q,0) -> recourse q @@ -796,13 +854,13 @@ We must be careful not to skip combinations that are optimal. E.g.: -> ceiling5SmoothTraceWrong (10^70+1) +> _ceiling5SmoothTraceWrong (10^70+1) 10002658207445093206727527411583349735126415100956607165326185795158016 > ceiling5Smooth (10^70+1) 10001329015408448808646079907338649600000000000000000000000000000000000 -} -ceiling5SmoothTraceWrong :: Integer -> Integer -ceiling5SmoothTraceWrong n = +_ceiling5SmoothTraceWrong :: Integer -> Integer +_ceiling5SmoothTraceWrong n = minimum $ map (minimum . ceilingSmoothsTrace 3 5 n) $ ceilingSmoothsTrace 2 3 n $ ceilingPowerOfTwo n @@ -836,8 +894,7 @@ -} partialPrimes :: Integer -> [Integer] partialPrimes = - let primeFactorSet = - Set.fromAscList . uniquePrimeFactors + let primeFactorSet = Set.fromAscList . uniquePrimeFactors in unfoldr (fmap (\(p,set) -> @@ -910,11 +967,11 @@ Find lengths of signals that require many interim Rader transforms and end with the given length. -raderWorstCases 2 = OEIS-A061092 -raderWorstCases 5 = tail OEIS-A059411 +> raderWorstCases 2 = +> raderWorstCases 5 = tail Smallest raderWorstCase numbers are 2,5,13,17,19,31,37,41,43,61,... -This matches the definition of OEIS-A061303. +This matches the definition of . -} raderWorstCases :: Integer -> [Integer] raderWorstCases = @@ -939,7 +996,7 @@ that is used by Fourier.Element.primitiveRoot in order to compute a root with maximum order. -2. Reduce the moduli produced by 'fastFourierRingAlt' +2. Reduce the moduli produced by '_fastFourierRingAlt' by merging some orders that are passed to ringWithPrimitiveRootsOfUnityAndUnits, such that an LCM of a group of orders can still be handled. @@ -974,8 +1031,8 @@ that stores the primitive root and its order additional to the ResidueClass modulus. -} -fastFourierRingAlt :: Int -> Integer -fastFourierRingAlt n = +_fastFourierRingAlt :: Int -> Integer +_fastFourierRingAlt n = case n of 0 -> 2 1 -> 2 diff --git a/private/Synthesizer/Generic/Permutation.hs b/private/Synthesizer/Generic/Permutation.hs --- a/private/Synthesizer/Generic/Permutation.hs +++ b/private/Synthesizer/Generic/Permutation.hs @@ -3,7 +3,19 @@ Most functions are independent of the Signal framework. We could move them as well to Synthesizer.Basic. -} -module Synthesizer.Generic.Permutation where +module Synthesizer.Generic.Permutation ( + T, + apply, + size, + transposition, + skewGrid, + skewGridInv, + skewGridCRT, + skewGridCRTInv, + multiplicative, + inverse, + reverse, + ) where import qualified Synthesizer.Basic.NumberTheory as NumberTheory @@ -14,6 +26,8 @@ import qualified Data.StorableVector as SV import qualified Algebra.PrincipalIdealDomain as PID + +import Prelude hiding (reverse, ) diff --git a/speedtest/Fourier.hs b/speedtest/Fourier.hs --- a/speedtest/Fourier.hs +++ b/speedtest/Fourier.hs @@ -4,13 +4,11 @@ import qualified Synthesizer.Generic.Fourier as Fourier import qualified Synthesizer.Generic.Noise as NoiseG import qualified Synthesizer.Generic.Signal as SigG --- import qualified Synthesizer.Generic.Cut as CutG import qualified Synthesizer.State.Noise as NoiseS import qualified Synthesizer.State.Signal as SigS import qualified Data.StorableVector as SV --- import qualified Algebra.Ring as Ring import qualified Number.Complex as NPComplex import System.TimeIt (timeIt, ) diff --git a/speedtest/SpeedTest.hs b/speedtest/SpeedTest.hs --- a/speedtest/SpeedTest.hs +++ b/speedtest/SpeedTest.hs @@ -1,8 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} module Main (main) where --- import BinarySample (numToInt16) - import System.Time (getClockTime, diffClockTimes, tdSec, tdPicosec) import System.Directory (removeFile) diff --git a/speedtest/SpeedTestExp.hs b/speedtest/SpeedTestExp.hs --- a/speedtest/SpeedTestExp.hs +++ b/speedtest/SpeedTestExp.hs @@ -41,8 +41,8 @@ fromIntegral (double2Int (if x<0 then x-0.5 else x+0.5)) -doubleToInt16 :: Double -> Int16 -doubleToInt16 x = round (32767 * x) +_doubleToInt16 :: Double -> Int16 +_doubleToInt16 x = round (32767 * x) doubleToInt16' :: Double -> Int16 doubleToInt16' x = round' (32767 * x) diff --git a/src/Synthesizer/ApplicativeUtility.hs b/src/Synthesizer/ApplicativeUtility.hs --- a/src/Synthesizer/ApplicativeUtility.hs +++ b/src/Synthesizer/ApplicativeUtility.hs @@ -1,11 +1,10 @@ -- this is also used by synthesizer-dimensional and synthesizer-inference module Synthesizer.ApplicativeUtility where -import Control.Applicative (Applicative, (<*>), (<$>), liftA2, ) -import Data.Traversable (Traversable, sequenceA, ) - import Control.Arrow (Arrow, (<<<), ) import Control.Monad.Fix (fix, ) +import Control.Applicative (Applicative, (<*>), (<$>), liftA2, ) +import Data.Traversable (Traversable, sequenceA, ) {-# INLINE liftA4 #-} diff --git a/src/Synthesizer/Basic/Binary.hs b/src/Synthesizer/Basic/Binary.hs --- a/src/Synthesizer/Basic/Binary.hs +++ b/src/Synthesizer/Basic/Binary.hs @@ -1,11 +1,11 @@ {-# LANGUAGE NoImplicitPrelude #-} -module Synthesizer.Basic.Binary - (C(..), toCanonical, - fromCanonicalWith, fromCanonicalSimpleWith, - numberOfSignalChannels, - int16ToCanonical, int16FromCanonical, - int16FromFloat, int16FromDouble, - ) where +module Synthesizer.Basic.Binary ( + C(..), toCanonical, + fromCanonicalWith, fromCanonicalSimpleWith, + numberOfSignalChannels, + int16ToCanonical, int16FromCanonical, + int16FromFloat, int16FromDouble, + ) where import qualified Synthesizer.Frame.Stereo as Stereo @@ -24,11 +24,9 @@ import Data.Int (Int16, ) import GHC.Float (float2Int, double2Int, ) -import qualified Prelude as P98 - -import NumericPrelude.Base import NumericPrelude.Numeric - +import NumericPrelude.Base +import qualified Prelude as P98 diff --git a/src/Synthesizer/Basic/ComplexModule.hs b/src/Synthesizer/Basic/ComplexModule.hs --- a/src/Synthesizer/Basic/ComplexModule.hs +++ b/src/Synthesizer/Basic/ComplexModule.hs @@ -8,7 +8,6 @@ import Number.Complex ((+:), ) import NumericPrelude.Numeric --- import NumericPrelude.Base import Prelude () diff --git a/src/Synthesizer/Basic/Distortion.hs b/src/Synthesizer/Basic/Distortion.hs --- a/src/Synthesizer/Basic/Distortion.hs +++ b/src/Synthesizer/Basic/Distortion.hs @@ -19,14 +19,11 @@ import qualified Algebra.RealRing as RealRing import qualified Algebra.Ring as Ring -import Data.Ord.HT (limit, ) - import Data.List.HT (mapAdjacent, ) --- import Data.List ((!!), map, iterate, take, foldl, ) +import Data.Ord.HT (limit, ) --- import qualified Prelude as P -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base {- * Clipping -} diff --git a/src/Synthesizer/Basic/DistortionControlled.hs b/src/Synthesizer/Basic/DistortionControlled.hs --- a/src/Synthesizer/Basic/DistortionControlled.hs +++ b/src/Synthesizer/Basic/DistortionControlled.hs @@ -14,9 +14,8 @@ import Data.Ord.HT (limit, ) --- import qualified Prelude as P --- import NumericPrelude.Base import NumericPrelude.Numeric + {- * Clipping -} diff --git a/src/Synthesizer/Basic/Filter/NonRecursive.hs b/src/Synthesizer/Basic/Filter/NonRecursive.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Basic/Filter/NonRecursive.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Synthesizer.Basic.Filter.NonRecursive where + +import qualified Data.List.Match as Match +import Data.Tuple.HT (sortPair, ) + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Additive as Additive + +import NumericPrelude.Numeric +import NumericPrelude.Base + + +unitSizesFromPyramid :: [signal] -> [Int] +unitSizesFromPyramid pyr = + reverse $ Match.take pyr $ iterate (2*) 1 + +sumRangePrepare :: (Additive.C v) => + ((Int,Int) -> source -> v) -> + (source -> (Int,Int) -> v) +sumRangePrepare f pyr (l,r) = + case compare l r of + LT -> f (l,r) pyr + GT -> negate $ f (r,l) pyr + EQ -> zero + +symmetricRangePrepare :: + ((Int,Int) -> source -> v) -> + (source -> (Int,Int) -> v) +symmetricRangePrepare f pyr lr = f (sortPair lr) pyr + +{- +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@. +-} +ratioFreqToVariance :: (Trans.C a) => a -> a -> a +ratioFreqToVariance ratio freq = + sqrt (-2 * log ratio) / (2*pi*freq) + -- inverse of the fourier transformed gaussian diff --git a/src/Synthesizer/Basic/Phase.hs b/src/Synthesizer/Basic/Phase.hs --- a/src/Synthesizer/Basic/Phase.hs +++ b/src/Synthesizer/Basic/Phase.hs @@ -1,25 +1,23 @@ -module Synthesizer.Basic.Phase - (T, - fromRepresentative, - toRepresentative, - increment, - decrement, - multiply, +module Synthesizer.Basic.Phase ( + T, + fromRepresentative, + toRepresentative, + increment, + decrement, + multiply, ) where +import qualified Algebra.ToInteger as ToInteger 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(arbitrary), choose) import Foreign.Storable (Storable(..), ) import Foreign.Ptr (castPtr, ) --- import Data.Function.HT (powerAssociative, ) import Data.Tuple.HT (mapFst, ) import qualified NumericPrelude.Numeric as NP diff --git a/src/Synthesizer/Basic/ToneModulation.hs b/src/Synthesizer/Basic/ToneModulation.hs --- a/src/Synthesizer/Basic/ToneModulation.hs +++ b/src/Synthesizer/Basic/ToneModulation.hs @@ -1,5 +1,11 @@ {-# LANGUAGE NoImplicitPrelude #-} -module Synthesizer.Basic.ToneModulation where +module Synthesizer.Basic.ToneModulation ( + untangleShapePhase, untangleShapePhaseAnalytic, + flattenShapePhase, flattenShapePhaseAnalytic, + shapeLimits, + interpolationOffset, interpolationNumber, + Coords, Skip, + ) where import qualified Synthesizer.Basic.Phase as Phase diff --git a/src/Synthesizer/Basic/Wave.hs b/src/Synthesizer/Basic/Wave.hs --- a/src/Synthesizer/Basic/Wave.hs +++ b/src/Synthesizer/Basic/Wave.hs @@ -14,8 +14,69 @@ If you want to use parametrized waves with two parameters then zip your parameter signals and apply 'uncurry' to the wave function. -} -module Synthesizer.Basic.Wave where +module Synthesizer.Basic.Wave ( + T(Cons, decons), + fromFunction, + raise, + amplify, + distort, + overtone, + apply, + phaseOffset, + sine, + cosine, + helix, + fastSine2, + fastSine2Alt, + fastSine3, + fastSine3Alt, + fastSine4, + fastSine4Alt, + fastSine4LeastSquares, + fastSinePolynomials, + fastSines, + rationalHelix1, + rationalHelix1Alt, + rationalHelix, + saw, + sawCos, + sawComplex, + square, + squareCos, + squareComplex, + triangle, + truncOddCosine, + truncOddTriangle, + truncCosine, + truncTriangle, + powerNormed, + logitSaw, + logitSine, + sineSquare, + piecewiseParabolaSaw, + piecewiseSineSaw, + sineSawSmooth, + sineSawSharp, + sawGaussianHarmonics, + sawPike, + trianglePike, + trianglePikeShift, + squarePike, + squarePikeShift, + squareAsymmetric, + squareBalanced, + triangleAsymmetric, + trapezoid, + trapezoidAsymmetric, + trapezoidBalanced, + trapezoidSkew, + + Harmonic(Harmonic, harmonicPhase, harmonicAmplitude), + harmonic, + composedHarmonics, + ) where + import qualified Synthesizer.Basic.Phase as Phase import qualified Algebra.RealTranscendental as RealTrans @@ -39,7 +100,6 @@ import Data.Bool.HT (select, if', ) import NumericPrelude.Numeric --- import qualified Prelude as P import NumericPrelude.Base @@ -107,7 +167,7 @@ {- | Turn an unparametrized waveform into a parametrized one, where the parameter is a phase offset. -This way you express a phase modulated oscillator +This way you may express a phase modulated oscillator using a shape modulated oscillator. @flip phaseOffset@ could have also be named @rotateLeft@, @@ -232,9 +292,9 @@ {- | 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) -} @@ -274,7 +334,7 @@ {- | This is a helix that is distorted in phase -such that is a purely rational function. +such that it becomes 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. diff --git a/src/Synthesizer/Basic/WaveSmoothed.hs b/src/Synthesizer/Basic/WaveSmoothed.hs --- a/src/Synthesizer/Basic/WaveSmoothed.hs +++ b/src/Synthesizer/Basic/WaveSmoothed.hs @@ -38,12 +38,10 @@ import qualified Synthesizer.Basic.Wave as Wave import qualified Synthesizer.Basic.Phase as Phase --- import qualified Algebra.RealTranscendental as RealTrans import qualified Algebra.Transcendental as Trans --- import qualified Algebra.RealField as RealField import qualified Algebra.Module as Module import qualified Algebra.Field as Field -import qualified Algebra.RealRing as RealRing +import qualified Algebra.RealRing as RealRing import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive @@ -51,8 +49,6 @@ import qualified Number.Complex as Complex import NumericPrelude.Numeric - --- import qualified Prelude as P import NumericPrelude.Base diff --git a/src/Synthesizer/Causal/Analysis.hs b/src/Synthesizer/Causal/Analysis.hs --- a/src/Synthesizer/Causal/Analysis.hs +++ b/src/Synthesizer/Causal/Analysis.hs @@ -12,10 +12,13 @@ import qualified Data.Map as Map --- import qualified Prelude as P -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base + +flipFlopHysteresis :: + (Ord y) => (y,y) -> Ana.BinaryLevel -> Causal.T y Ana.BinaryLevel +flipFlopHysteresis bnds = Causal.scanL (Ana.flipFlopHysteresisStep bnds) deltaSigmaModulation :: RealRing.C y => Causal.T y Ana.BinaryLevel diff --git a/src/Synthesizer/Causal/Class.hs b/src/Synthesizer/Causal/Class.hs --- a/src/Synthesizer/Causal/Class.hs +++ b/src/Synthesizer/Causal/Class.hs @@ -11,9 +11,10 @@ import Control.Arrow (Arrow, arr, (<<<), (&&&), ) +type family ProcessOf (signal :: * -> *) :: * -> * -> * + class (Arrow process, ProcessOf (SignalOf process) ~ process) => C process where type SignalOf process :: * -> * - type ProcessOf (signal :: * -> *) :: * -> * -> * toSignal :: process () a -> SignalOf process a fromSignal :: SignalOf process b -> process a b diff --git a/src/Synthesizer/Causal/Cut.hs b/src/Synthesizer/Causal/Cut.hs --- a/src/Synthesizer/Causal/Cut.hs +++ b/src/Synthesizer/Causal/Cut.hs @@ -3,13 +3,12 @@ import qualified Synthesizer.Causal.Process as Causal -import Data.Maybe.HT (toMaybe, ) - import Control.Monad.Trans.State (StateT(StateT), ) --- import qualified Prelude as P -import NumericPrelude.Base +import Data.Maybe.HT (toMaybe, ) + import NumericPrelude.Numeric +import NumericPrelude.Base {-# INLINE take #-} diff --git a/src/Synthesizer/Causal/Displacement.hs b/src/Synthesizer/Causal/Displacement.hs --- a/src/Synthesizer/Causal/Displacement.hs +++ b/src/Synthesizer/Causal/Displacement.hs @@ -7,8 +7,8 @@ import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base -- * Mixing diff --git a/src/Synthesizer/Causal/Filter/NonRecursive.hs b/src/Synthesizer/Causal/Filter/NonRecursive.hs --- a/src/Synthesizer/Causal/Filter/NonRecursive.hs +++ b/src/Synthesizer/Causal/Filter/NonRecursive.hs @@ -6,7 +6,7 @@ import qualified Synthesizer.Generic.Filter.NonRecursive as FiltG import qualified Synthesizer.Generic.Signal as SigG -import qualified Synthesizer.Plain.Filter.NonRecursive as Filt +import qualified Synthesizer.Basic.Filter.NonRecursive as Filt import qualified Synthesizer.State.Control as CtrlS import qualified Synthesizer.State.Signal as SigS import Synthesizer.Utility (affineComb, ) @@ -16,9 +16,8 @@ import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive -import NumericPrelude.Base -import NumericPrelude.Numeric as NP --- import qualified Prelude as P +import NumericPrelude.Numeric +import NumericPrelude.Base as NP {-# INLINE amplify #-} diff --git a/src/Synthesizer/Causal/Filter/Recursive/Integration.hs b/src/Synthesizer/Causal/Filter/Recursive/Integration.hs --- a/src/Synthesizer/Causal/Filter/Recursive/Integration.hs +++ b/src/Synthesizer/Causal/Filter/Recursive/Integration.hs @@ -14,12 +14,10 @@ import qualified Synthesizer.Causal.Process as Causal import qualified Control.Monad.Trans.State as State --- import qualified Algebra.Field as Field --- import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base diff --git a/src/Synthesizer/Causal/Interpolation.hs b/src/Synthesizer/Causal/Interpolation.hs --- a/src/Synthesizer/Causal/Interpolation.hs +++ b/src/Synthesizer/Causal/Interpolation.hs @@ -25,8 +25,8 @@ import qualified Algebra.Additive as Additive -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base {-* Interpolation at multiple nodes with various padding methods -} diff --git a/src/Synthesizer/Causal/Oscillator.hs b/src/Synthesizer/Causal/Oscillator.hs --- a/src/Synthesizer/Causal/Oscillator.hs +++ b/src/Synthesizer/Causal/Oscillator.hs @@ -12,19 +12,17 @@ module Synthesizer.Causal.Oscillator where import qualified Synthesizer.Causal.Oscillator.Core as Osci +import qualified Synthesizer.Causal.Process as Causal +import qualified Synthesizer.Causal.Interpolation as InterpolationC +import qualified Synthesizer.Causal.ToneModulation as ToneMod import qualified Synthesizer.Basic.WaveSmoothed as WaveSmooth import qualified Synthesizer.Basic.Wave as Wave import qualified Synthesizer.Basic.Phase as Phase -import qualified Synthesizer.Causal.Process as Causal -import qualified Synthesizer.State.Signal as Sig - -import qualified Synthesizer.Causal.Interpolation as InterpolationC -import qualified Synthesizer.Causal.ToneModulation as ToneMod import qualified Synthesizer.Interpolation as Interpolation - import qualified Synthesizer.Generic.Signal as SigG +import qualified Synthesizer.State.Signal as Sig import qualified Algebra.Transcendental as Trans import qualified Algebra.RealField as RealField diff --git a/src/Synthesizer/Causal/Oscillator/Core.hs b/src/Synthesizer/Causal/Oscillator/Core.hs --- a/src/Synthesizer/Causal/Oscillator/Core.hs +++ b/src/Synthesizer/Causal/Oscillator/Core.hs @@ -20,9 +20,9 @@ import qualified Synthesizer.Causal.Process as Causal import qualified Synthesizer.State.Signal as Sig -import qualified Algebra.RealRing as RealRing - import Control.Arrow ((^<<), (&&&), second, returnA, ) + +import qualified Algebra.RealRing as RealRing import NumericPrelude.Numeric import NumericPrelude.Base diff --git a/src/Synthesizer/Causal/Process.hs b/src/Synthesizer/Causal/Process.hs --- a/src/Synthesizer/Causal/Process.hs +++ b/src/Synthesizer/Causal/Process.hs @@ -70,7 +70,7 @@ -- for testing applyFst', applySnd', -) where + ) where import qualified Synthesizer.State.Signal as Sig import qualified Synthesizer.Generic.Signal as SigG @@ -175,9 +175,10 @@ loop = liftKleisli loop +type instance Class.ProcessOf Sig.T = T + instance Class.C T where type SignalOf T = Sig.T - type ProcessOf Sig.T = T toSignal = flip applyConst () fromSignal sig = const () ^>> feed sig diff --git a/src/Synthesizer/Causal/Spatial.hs b/src/Synthesizer/Causal/Spatial.hs --- a/src/Synthesizer/Causal/Spatial.hs +++ b/src/Synthesizer/Causal/Spatial.hs @@ -1,13 +1,13 @@ {-# LANGUAGE NoImplicitPrelude #-} module Synthesizer.Causal.Spatial where +import Control.Arrow (Arrow, arr, ) + import qualified Algebra.NormedSpace.Euclidean as Euc import qualified Algebra.Field as Field -import Control.Arrow (Arrow, arr, ) - -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base {-| diff --git a/src/Synthesizer/Causal/ToneModulation.hs b/src/Synthesizer/Causal/ToneModulation.hs --- a/src/Synthesizer/Causal/ToneModulation.hs +++ b/src/Synthesizer/Causal/ToneModulation.hs @@ -11,10 +11,16 @@ ) where import qualified Synthesizer.Basic.ToneModulation as ToneMod +import qualified Synthesizer.Basic.Phase as Phase import qualified Synthesizer.State.ToneModulation as ToneModS import qualified Synthesizer.Interpolation as Interpolation import qualified Synthesizer.Causal.Oscillator.Core as Osci +import qualified Synthesizer.Causal.Process as Causal +import qualified Synthesizer.Generic.Signal as SigG +import Control.Arrow (first, (<<<), (<<^), (^<<), (&&&), (***), ) +import Control.Monad.Trans.State (state, ) + {- for testing in GHCi import qualified Synthesizer.Plain.ToneModulation as ToneModL import qualified Synthesizer.State.Signal as SigS @@ -22,24 +28,11 @@ -} import Data.Tuple.HT (mapFst, ) -import qualified Synthesizer.Causal.Process as Causal - -import qualified Synthesizer.Generic.Signal as SigG - -import qualified Synthesizer.Basic.Phase as Phase - --- import qualified Algebra.Transcendental as Trans import qualified Algebra.RealField as RealField --- import qualified Algebra.Field as Field --- import qualified Algebra.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.Numeric --- import qualified Prelude as P import NumericPrelude.Base import Prelude () diff --git a/src/Synthesizer/CausalIO/Gate.hs b/src/Synthesizer/CausalIO/Gate.hs --- a/src/Synthesizer/CausalIO/Gate.hs +++ b/src/Synthesizer/CausalIO/Gate.hs @@ -10,18 +10,17 @@ import qualified Synthesizer.CausalIO.Process as PIO import qualified Synthesizer.Zip as Zip -import Synthesizer.PiecewiseConstant.Signal (StrictTime, ) import qualified Synthesizer.Generic.Cut as CutG import qualified Synthesizer.Generic.Signal as SigG - -import qualified Data.StorableVector as SV +import Synthesizer.PiecewiseConstant.Signal (StrictTime, ) import qualified Control.Monad.Trans.State as MS - import Control.Arrow (Arrow, arr, (^<<), ) import Control.Monad (when, ) -import Data.Maybe.HT (toMaybe, ) + +import qualified Data.StorableVector as SV import qualified Data.Monoid as Mn +import Data.Maybe.HT (toMaybe, ) import qualified Numeric.NonNegative.Class as NonNeg import qualified Numeric.NonNegative.Wrapper as NonNegW diff --git a/src/Synthesizer/CausalIO/Process.hs b/src/Synthesizer/CausalIO/Process.hs --- a/src/Synthesizer/CausalIO/Process.hs +++ b/src/Synthesizer/CausalIO/Process.hs @@ -34,10 +34,8 @@ import Foreign.Storable (Storable, ) import qualified Control.Monad.Trans.State as MS - import qualified Control.Arrow as Arr import qualified Control.Category as Cat - import Control.Arrow ((^<<), (&&&), ) import Control.Monad (mplus, ) diff --git a/src/Synthesizer/ChunkySize/Cut.hs b/src/Synthesizer/ChunkySize/Cut.hs --- a/src/Synthesizer/ChunkySize/Cut.hs +++ b/src/Synthesizer/ChunkySize/Cut.hs @@ -5,28 +5,24 @@ module Synthesizer.ChunkySize.Cut where import qualified Synthesizer.ChunkySize as ChunkySize - import qualified Synthesizer.Generic.Cut as Cut import qualified Synthesizer.Generic.Signal as SigG - import qualified Synthesizer.State.Signal as SigS + import qualified Data.StorableVector.Lazy.Pattern as SigStV import qualified Data.StorableVector.Lazy as Vector - +import Foreign.Storable (Storable) import qualified Number.NonNegativeChunky as Chunky -import Foreign.Storable (Storable) - -import qualified Data.List as List import qualified Data.List.Match as Match +import qualified Data.List as List import Data.Tuple.HT (mapPair, ) - import Data.Monoid (Monoid, ) -import Prelude () import NumericPrelude.Numeric import NumericPrelude.Base hiding (splitAt, Read, ) +import Prelude () class Cut.Read sig => Read sig where diff --git a/src/Synthesizer/ChunkySize/Signal.hs b/src/Synthesizer/ChunkySize/Signal.hs --- a/src/Synthesizer/ChunkySize/Signal.hs +++ b/src/Synthesizer/ChunkySize/Signal.hs @@ -5,26 +5,20 @@ import qualified Synthesizer.ChunkySize.Cut as Cut import qualified Synthesizer.ChunkySize as ChunkySize --- import qualified Synthesizer.Generic.Cut as CutG import qualified Synthesizer.Generic.Signal as SigG --- import qualified Synthesizer.Plain.Signal as Sig import qualified Synthesizer.State.Signal as SigS --- import qualified Synthesizer.Storable.Signal as SigSt + import qualified Data.StorableVector.Lazy.Pattern as SigStV import qualified Data.StorableVector.Lazy as Vector - import Foreign.Storable (Storable) -import qualified Data.List.Match as Match - import Control.Monad.Trans.State (runStateT, ) +import qualified Data.List.Match as Match import qualified Data.List as List --- import NumericPrelude.Numeric -import Prelude - (Maybe(Just), fst, (.), id, ) +import Prelude (Maybe(Just), fst, (.), id, ) class (SigG.Write sig y, Cut.Transform (sig y)) => Write sig y where diff --git a/src/Synthesizer/Generic/Analysis.hs b/src/Synthesizer/Generic/Analysis.hs --- a/src/Synthesizer/Generic/Analysis.hs +++ b/src/Synthesizer/Generic/Analysis.hs @@ -3,7 +3,8 @@ {-# LANGUAGE FlexibleContexts #-} module Synthesizer.Generic.Analysis where -import qualified Synthesizer.State.Analysis as Ana +import qualified Synthesizer.Plain.Analysis as Ana +import qualified Synthesizer.State.Analysis as AnaS import qualified Synthesizer.Generic.Signal as SigG @@ -16,8 +17,8 @@ import qualified Algebra.NormedSpace.Euclidean as NormedEuc import qualified Algebra.NormedSpace.Sum as NormedSum -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base {- * Notions of volume -} @@ -27,25 +28,25 @@ -} volumeMaximum :: (RealRing.C y, SigG.Read sig y) => sig y -> y volumeMaximum = - Ana.volumeMaximum . SigG.toState + AnaS.volumeMaximum . SigG.toState {- | Volume based on Energy norm. -} volumeEuclidean :: (Algebraic.C y, SigG.Read sig y) => sig y -> y volumeEuclidean = - Ana.volumeEuclidean . SigG.toState + AnaS.volumeEuclidean . SigG.toState volumeEuclideanSqr :: (Field.C y, SigG.Read sig y) => sig y -> y volumeEuclideanSqr = - Ana.volumeEuclideanSqr . SigG.toState + AnaS.volumeEuclideanSqr . SigG.toState {- | Volume based on Sum norm. -} volumeSum :: (Field.C y, RealRing.C y, SigG.Read sig y) => sig y -> y volumeSum = - Ana.volumeSum . SigG.toState + AnaS.volumeSum . SigG.toState @@ -56,7 +57,7 @@ (NormedMax.C y yv, Ord y, SigG.Read sig yv) => sig yv -> y volumeVectorMaximum = - Ana.volumeVectorMaximum . SigG.toState + AnaS.volumeVectorMaximum . SigG.toState {- | Volume based on Energy norm. @@ -65,13 +66,13 @@ (Algebraic.C y, NormedEuc.C y yv, SigG.Read sig yv) => sig yv -> y volumeVectorEuclidean = - Ana.volumeVectorEuclidean . SigG.toState + AnaS.volumeVectorEuclidean . SigG.toState volumeVectorEuclideanSqr :: (Field.C y, NormedEuc.Sqr y yv, SigG.Read sig yv) => sig yv -> y volumeVectorEuclideanSqr = - Ana.volumeVectorEuclideanSqr . SigG.toState + AnaS.volumeVectorEuclideanSqr . SigG.toState {- | Volume based on Sum norm. @@ -80,7 +81,7 @@ (NormedSum.C y yv, Field.C y, SigG.Read sig yv) => sig yv -> y volumeVectorSum = - Ana.volumeVectorSum . SigG.toState + AnaS.volumeVectorSum . SigG.toState @@ -91,7 +92,7 @@ -} bounds :: (Ord y, SigG.Read sig y) => sig y -> (y,y) bounds = - Ana.bounds . SigG.toState + AnaS.bounds . SigG.toState @@ -221,8 +222,8 @@ spread :: (RealField.C y, SigG.Read sig y) => (y,y) -> [(Int,y)] -spread (l0,r0) = - let (l,r) = if l0<=r0 then (l0,r0) else (r0,l0) +spread lr0 = + let (l,r) = sortPair lr0 (li,lf) = splitFraction l (ri,rf) = splitFraction r k = recip (r-l) @@ -248,18 +249,18 @@ scalarProduct :: (Ring.C y, SigG.Read sig y) => sig y -> sig y -> y scalarProduct xs ys = - Ana.scalarProduct (SigG.toState xs) (SigG.toState ys) + AnaS.scalarProduct (SigG.toState xs) (SigG.toState ys) {- | 'directCurrentOffset' must be non-zero. -} centroid :: (Field.C y, SigG.Read sig y) => sig y -> y centroid = - Ana.centroid . SigG.toState + AnaS.centroid . SigG.toState average :: (Field.C y, SigG.Read sig y) => sig y -> y average = - Ana.average . SigG.toState + AnaS.average . SigG.toState rectify :: (RealRing.C y, SigG.Transform sig y) => sig y -> sig y rectify = SigG.map abs @@ -284,14 +285,10 @@ {- | Detect thresholds with a hysteresis. -} -flipFlopHysteresis :: (Ord y, SigG.Transform sig y, SigG.Transform sig Bool) => - (y,y) -> Bool -> sig y -> sig Bool -flipFlopHysteresis (lower,upper) = - SigG.scanL - (\state x -> - if state - then not(xupper) +flipFlopHysteresis :: + (Ord y, SigG.Transform sig y, SigG.Transform sig Ana.BinaryLevel) => + (y,y) -> Ana.BinaryLevel -> sig y -> sig Ana.BinaryLevel +flipFlopHysteresis bnds = SigG.scanL (Ana.flipFlopHysteresisStep bnds) {- | Almost naive implementation of the chirp transform, @@ -304,5 +301,5 @@ SigG.LazySize -> y -> sig y -> sig y chirpTransform size z = SigG.fromState size . - Ana.chirpTransform z . + AnaS.chirpTransform z . SigG.toState diff --git a/src/Synthesizer/Generic/Control.hs b/src/Synthesizer/Generic/Control.hs --- a/src/Synthesizer/Generic/Control.hs +++ b/src/Synthesizer/Generic/Control.hs @@ -1,23 +1,38 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} -module Synthesizer.Generic.Control where +module Synthesizer.Generic.Control ( + constant, + linear, + linearMultiscale, + linearMultiscaleNeutral, + line, + exponential, exponentialMultiscale, + exponentialMultiscaleNeutral, + exponential2, exponential2Multiscale, + exponential2MultiscaleNeutral, + vectorExponential, + vectorExponential2, + cosine, cosineMultiscaleLinear, + cosineMultiscale, + Ctrl.cosineWithSlope, + cubicHermite, + ) where -import qualified Synthesizer.Generic.Signal as SigG +import qualified Synthesizer.Plain.Control as Ctrl -import Synthesizer.Generic.Displacement (raise) +import qualified Synthesizer.Generic.Signal as SigG import qualified Algebra.Module as Module import qualified Algebra.Transcendental as Trans -import qualified Algebra.RealRing as RealRing import qualified Algebra.Field as Field import qualified Algebra.Additive as Additive -import Number.Complex (cis,real) import qualified Number.Complex as Complex +import Number.Complex (cis,real) -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base {- * Control curve generation -} @@ -148,10 +163,10 @@ -> y {-^ time t1 where -1 is approached -} -> sig y {-^ a cosine wave where one half wave is between t0 and t1 -} -cosine size = cosineWithSlope $ +cosine size = Ctrl.cosineWithSlope $ \d x -> SigG.map cos (linear size d x) -cosineMultiscaleLinear size = cosineWithSlope $ +cosineMultiscaleLinear size = Ctrl.cosineWithSlope $ \d x -> SigG.map cos (linearMultiscale size d x) cosineMultiscale :: @@ -162,173 +177,15 @@ -> y {-^ time t1 where -1 is approached -} -> sig y {-^ a cosine wave where one half wave is between t0 and t1 -} -cosineMultiscale size = cosineWithSlope $ +cosineMultiscale size = Ctrl.cosineWithSlope $ \d x -> SigG.map real (curveMultiscale size (*) (cis d) (cis x)) -cosineWithSlope :: (Trans.C y) => - (y -> y -> signal) - -> y - -> y - -> signal -cosineWithSlope c t0 t1 = - let inc = pi/(t1-t0) - in c inc (-t0*inc) - - cubicHermite :: (Field.C y, SigG.Write sig y) => SigG.LazySize -> (y, (y,y)) -> (y, (y,y)) -> sig y cubicHermite size node0 node1 = - SigG.map (cubicFunc node0 node1) $ linear size 1 0 - -{- | -0 16 -0 8 16 -0 4 8 12 16 -0 2 4 6 8 10 12 14 16 -0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 --} -cubicFunc :: (Field.C y) => - (y, (y,y)) -> (y, (y,y)) -> y -> y -cubicFunc (t0, (y0,dy0)) (t1, (y1,dy1)) t = - let dt = t0-t1 - dt0 = t-t0 - dt1 = t-t1 - x0 = dt1^2 - x1 = dt0^2 - in ((dy0*dt0 + y0 * (1-2/dt*dt0)) * x0 + - (dy1*dt1 + y1 * (1+2/dt*dt1)) * x1) / dt^2 -{- -cubic t0 (y0,dy0) t1 (y1,dy1) t = - let x0 = ((t-t1) / (t0-t1))^2 - x1 = ((t-t0) / (t1-t0))^2 - in y0 * x0 + y1 * x1 + - (dy0 - y0*2/(t0-t1)) * (t-t0)*x0 + - (dy1 - y1*2/(t1-t0)) * (t-t1)*x1 --} - - - -{-# DEPRECATED Control "use Synthesizer.Generic.Piece instead" #-} -{- | -The curve type of a piece of a piecewise defined control curve. --} -data Control y = - CtrlStep - | CtrlLin - | CtrlExp {ctrlExpSaturation :: y} - | CtrlCos - | CtrlCubic {ctrlCubicGradient0 :: y, - ctrlCubicGradient1 :: y} - deriving (Eq, Show) - -{- | -The full description of a control curve piece. --} -data ControlPiece y = - ControlPiece {pieceType :: Control y, - pieceY0 :: y, - pieceY1 :: y, - pieceDur :: y} - deriving (Eq, Show) - - -newtype PieceRightSingle y = PRS y -newtype PieceRightDouble y = PRD y - -type ControlDist y = (y, Control y, y) - - --- precedence and associativity like (:) -infixr 5 -|#, #|-, =|#, #|=, |#, #| - -{- | -The 6 operators simplify constructing a list of @ControlPiece a@. -The description consists of nodes (namely the curve values at nodes) -and the connecting curve types. -The naming scheme is as follows: -In the middle there is a bar @|@. -With respect to the bar, -the pad symbol @\#@ is at the side of the curve type, -at the other side there is nothing, a minus sign @-@, or an equality sign @=@. - - (1) Nothing means that here is the start or the end node of a curve. - - (2) Minus means that here is a node where left and right curve meet at the same value. - The node description is thus one value. - - (3) Equality sign means that here is a split node, - where left and right curve might have different ending and beginning values, respectively. - The node description consists of a pair of values. --} - --- the leading space is necessary for the Haddock parser - -( #|-) :: (y, Control y) -> (PieceRightSingle y, [ControlPiece y]) -> - (ControlDist y, [ControlPiece y]) -(d,c) #|- (PRS y1, xs) = ((d,c,y1), xs) - -(-|#) :: y -> (ControlDist y, [ControlPiece y]) -> - (PieceRightSingle y, [ControlPiece y]) -y0 -|# ((d,c,y1), xs) = (PRS y0, ControlPiece c y0 y1 d : xs) - -( #|=) :: (y, Control y) -> (PieceRightDouble y, [ControlPiece y]) -> - (ControlDist y, [ControlPiece y]) -(d,c) #|= (PRD y1, xs) = ((d,c,y1), xs) - -(=|#) :: (y,y) -> (ControlDist y, [ControlPiece y]) -> - (PieceRightDouble y, [ControlPiece y]) -(y01,y10) =|# ((d,c,y11), xs) = (PRD y01, ControlPiece c y10 y11 d : xs) - -( #|) :: (y, Control y) -> y -> - (ControlDist y, [ControlPiece y]) -(d,c) #| y1 = ((d,c,y1), []) - -(|#) :: y -> (ControlDist y, [ControlPiece y]) -> - [ControlPiece y] -y0 |# ((d,c,y1), xs) = ControlPiece c y0 y1 d : xs - - -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)) - (0,1) (map pieceDur xs) - in SigG.concat (zipWith3 - (\n t (ControlPiece c yi0 yi1 d) -> - piecewisePart size yi0 yi1 t d n c) - (map fst (tail ts)) (map (subtract 1 . snd) ts) - xs) - - -piecewisePart :: (Trans.C y, SigG.Write sig y) => - SigG.LazySize -> y -> y -> y -> y -> Int -> Control y -> sig y -piecewisePart size y0 y1 t0 d n ctrl = - SigG.take n - (case ctrl of - CtrlStep -> constant size y0 - CtrlLin -> let s = (y1-y0)/d in linearMultiscale size s (y0-t0*s) - CtrlExp s -> let y0' = y0-s; y1' = y1-s; yd = y0'/y1' - in raise s (exponentialMultiscale size (d / log yd) - (y0' * yd**(t0/d))) - CtrlCos -> SigG.map - (\y -> (1+y)*(y0/2)+(1-y)*(y1/2)) - (cosineMultiscaleLinear size t0 (t0+d)) - CtrlCubic yd0 yd1 -> - cubicHermite size (t0,(y0,yd0)) (t0+d,(y1,yd1))) - -{- - exp (-1/time) == yd**(-1/d) - 1/time == log yd / d - time == d / log yd --} - -{- - piecewise (0 |# (10.21, CtrlExp 1.1) #|- 1 -|# (10,CtrlExp 0.49) #|- 0.5 -|# (30, CtrlLin) #|- 0.5 -|# (20, CtrlCos) #| 0) - - piecewise (0 |# (10.21, CtrlExp 1.1) #|- 1 -|# (10,CtrlCubic (-0.1) 0) #|- 0.5 -|# (30, CtrlLin) #|- 0.5 -|# (20, CtrlCos) #| 0) --} + SigG.map (Ctrl.cubicFunc node0 node1) $ linear size 1 0 {- * Auxiliary functions -} diff --git a/src/Synthesizer/Generic/Cut.hs b/src/Synthesizer/Generic/Cut.hs --- a/src/Synthesizer/Generic/Cut.hs +++ b/src/Synthesizer/Generic/Cut.hs @@ -9,7 +9,6 @@ import qualified Synthesizer.Plain.Signal as Sig import qualified Synthesizer.State.Signal as SigS --- import qualified Synthesizer.Storable.Signal as SigSt import qualified Data.StorableVector as SV import qualified Data.StorableVector.Lazy as SVL @@ -30,11 +29,10 @@ import Control.DeepSeq (NFData, rnf, ) import qualified Data.List.HT as ListHT -import qualified Data.List.Stream as List +import qualified Data.List as List +import qualified Data.Monoid as Monoid import Data.Function (fix, ) import Data.Tuple.HT (mapPair, mapFst, mapSnd, ) - -import qualified Data.Monoid as Monoid import Data.Monoid (Monoid, mempty, ) import qualified Prelude as P diff --git a/src/Synthesizer/Generic/CutChunky.hs b/src/Synthesizer/Generic/CutChunky.hs --- a/src/Synthesizer/Generic/CutChunky.hs +++ b/src/Synthesizer/Generic/CutChunky.hs @@ -10,8 +10,8 @@ import qualified Number.NonNegativeChunky as Chunky import qualified Algebra.NonNegative as NonNeg - import qualified Algebra.ToInteger as ToInteger + class (Cut.Transform chunky, Cut.Transform (Chunk chunky)) => C chunky where diff --git a/src/Synthesizer/Generic/Displacement.hs b/src/Synthesizer/Generic/Displacement.hs --- a/src/Synthesizer/Generic/Displacement.hs +++ b/src/Synthesizer/Generic/Displacement.hs @@ -10,9 +10,8 @@ import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive --- import qualified Prelude as P -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base -- * Mixing diff --git a/src/Synthesizer/Generic/Filter/Delay.hs b/src/Synthesizer/Generic/Filter/Delay.hs --- a/src/Synthesizer/Generic/Filter/Delay.hs +++ b/src/Synthesizer/Generic/Filter/Delay.hs @@ -1,5 +1,11 @@ {-# LANGUAGE NoImplicitPrelude #-} -module Synthesizer.Generic.Filter.Delay where +module Synthesizer.Generic.Filter.Delay ( + static, + staticPad, + staticPos, + staticNeg, + modulated, + ) where import qualified Synthesizer.Generic.Filter.NonRecursive as FiltNR import qualified Synthesizer.Generic.Interpolation as Interpolation @@ -8,8 +14,6 @@ import qualified Algebra.RealField as RealField import qualified Algebra.Additive as Additive --- import qualified Prelude as P --- import NumericPrelude.Base import NumericPrelude.Numeric diff --git a/src/Synthesizer/Generic/Filter/NonRecursive.hs b/src/Synthesizer/Generic/Filter/NonRecursive.hs --- a/src/Synthesizer/Generic/Filter/NonRecursive.hs +++ b/src/Synthesizer/Generic/Filter/NonRecursive.hs @@ -8,17 +8,85 @@ Stability : provisional Portability : requires multi-parameter type classes -} -module Synthesizer.Generic.Filter.NonRecursive where +module Synthesizer.Generic.Filter.NonRecursive ( + negate, + amplify, + amplifyVector, + normalize, + envelope, + envelopeVector, + fadeInOut, + delay, + delayPad, + delayPos, + delayNeg, + delayLazySize, + delayPadLazySize, + delayPosLazySize, + binomialMask, + binomial, + binomial1, + sums, + sumsDownsample2, + downsample2, + downsample, + sumRange, + pyramid, + sumRangeFromPyramid, + sumsPosModulated, + sumsPosModulatedPyramid, + movingAverageModulatedPyramid, + inverseFrequencyModulationFloor, + differentiate, + differentiateCenter, + differentiate2, + + generic, + karatsubaFinite, + karatsubaFiniteInfinite, + karatsubaInfinite, + + Pair, + convolvePair, + sumAndConvolvePair, + Triple, + convolvePairTriple, + convolveTriple, + sumAndConvolveTriple, + sumAndConvolveTripleAlt, + Quadruple, + convolveQuadruple, + sumAndConvolveQuadruple, + sumAndConvolveQuadrupleAlt, + + -- for use in Storable.Filter.NonRecursive + maybeAccumulateRangeFromPyramid, + accumulatePosModulatedFromPyramid, + withPaddedInput, + -- for use in Generic.Fourier + addShiftedSimple, + + -- for testing + consumeRangeFromPyramid, + sumRangeFromPyramidReverse, + sumRangeFromPyramidFoldr, + ) where + import qualified Synthesizer.Generic.Signal as SigG import qualified Synthesizer.Generic.Cut as CutG import qualified Synthesizer.Generic.Control as Ctrl import qualified Synthesizer.Generic.LengthSignal as SigL -import qualified Synthesizer.State.Signal as SigS -import qualified Synthesizer.Plain.Filter.NonRecursive as Filt +import qualified Synthesizer.Basic.Filter.NonRecursive as Filt import qualified Synthesizer.State.Filter.NonRecursive as FiltS +import qualified Synthesizer.State.Signal as SigS +import Control.Monad (mplus, ) +import Data.Function.HT (nest, ) +import Data.Tuple.HT (mapSnd, mapPair, ) +import Data.Maybe.HT (toMaybe, ) + import qualified Algebra.Transcendental as Trans import qualified Algebra.Module as Module import qualified Algebra.RealField as RealField @@ -26,13 +94,9 @@ import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive -import Control.Monad (mplus, ) -import Data.Function.HT (nest, ) -import Data.Tuple.HT (mapSnd, mapPair, ) -import Data.Maybe.HT (toMaybe, ) - +import qualified NumericPrelude.Numeric as NP +import NumericPrelude.Numeric hiding (negate, ) import NumericPrelude.Base -import NumericPrelude.Numeric as NP -- * Envelope application @@ -186,7 +250,7 @@ (Trans.C a, RealField.C a, Module.C a v) => a -> a -> a -> sig v -> sig v gaussian eps ratio freq = - let var = ratioFreqToVariance ratio freq + let var = Filt.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 @@ -211,33 +275,9 @@ (Trans.C a, RealField.C a, Module.C a v, SigG.Transform sig v) => a -> a -> sig v -> sig v binomial ratio freq = - let width = ceiling (2 * ratioFreqToVariance ratio freq ^ 2) + let width = ceiling (2 * Filt.ratioFreqToVariance ratio freq ^ 2) in SigG.drop width . nest (2*width) (amplifyVector (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 (Additive.negate (2 * log ratio)) / (2*pi*freq) - -- inverse of the fourier transformed gaussian {-# INLINE binomial1 #-} binomial1 :: diff --git a/src/Synthesizer/Generic/Filter/Recursive/Comb.hs b/src/Synthesizer/Generic/Filter/Recursive/Comb.hs --- a/src/Synthesizer/Generic/Filter/Recursive/Comb.hs +++ b/src/Synthesizer/Generic/Filter/Recursive/Comb.hs @@ -28,8 +28,8 @@ import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base {- | diff --git a/src/Synthesizer/Generic/Filter/Recursive/Integration.hs b/src/Synthesizer/Generic/Filter/Recursive/Integration.hs --- a/src/Synthesizer/Generic/Filter/Recursive/Integration.hs +++ b/src/Synthesizer/Generic/Filter/Recursive/Integration.hs @@ -13,12 +13,10 @@ import qualified Synthesizer.Generic.Signal as SigG --- import qualified Algebra.Field as Field --- import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base diff --git a/src/Synthesizer/Generic/Filter/Recursive/MovingAverage.hs b/src/Synthesizer/Generic/Filter/Recursive/MovingAverage.hs --- a/src/Synthesizer/Generic/Filter/Recursive/MovingAverage.hs +++ b/src/Synthesizer/Generic/Filter/Recursive/MovingAverage.hs @@ -8,10 +8,10 @@ Portability : requires multi-parameter type classes -} -module Synthesizer.Generic.Filter.Recursive.MovingAverage - (sumsStaticInt, - modulatedFrac, - ) where +module Synthesizer.Generic.Filter.Recursive.MovingAverage ( + sumsStaticInt, + modulatedFrac, + ) where import qualified Synthesizer.Generic.Signal as SigG @@ -24,13 +24,10 @@ import qualified Algebra.Module as Module import qualified Algebra.RealField as RealField - --- import qualified Algebra.Field as Field --- import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base diff --git a/src/Synthesizer/Generic/Fourier.hs b/src/Synthesizer/Generic/Fourier.hs --- a/src/Synthesizer/Generic/Fourier.hs +++ b/src/Synthesizer/Generic/Fourier.hs @@ -50,8 +50,14 @@ import qualified Synthesizer.State.Analysis as Ana import qualified Synthesizer.State.Signal as SigS +import qualified Control.Monad.Trans.State as State +import Control.Monad (liftM2, ) +import Control.Applicative ((<$>), ) + +import qualified Data.Map as Map +import Data.Tuple.HT (mapPair, ) + import qualified Algebra.Transcendental as Trans --- import qualified Algebra.Field as Field import qualified Algebra.Ring as Ring import qualified Algebra.PrincipalIdealDomain as PID import qualified Algebra.IntegralDomain as Integral @@ -62,13 +68,6 @@ import qualified Number.Complex as Complex import Number.Complex ((+:)) -import qualified Data.Map as Map -import qualified Control.Monad.Trans.State as State -import Control.Monad (liftM2, ) -import Control.Applicative ((<$>), ) - -import Data.Tuple.HT (mapPair, ) - import NumericPrelude.Numeric import NumericPrelude.Base hiding (head, ) @@ -145,8 +144,7 @@ (Element y, SigG.Read sig y) => sig y -> ((Direction,y), (Direction,y)) directionPrimitiveRootsOfUnity x = - let (z,zInv) = - conjugatePrimitiveRootsOfUnity x + let (z,zInv) = conjugatePrimitiveRootsOfUnity x in ((Forward,z), (Backward,zInv)) transformForward :: @@ -691,8 +689,7 @@ {- | For @transformComposite z (n,m) sig@, -the parameters @n@ and @m@ must be relatively prime -and @n*m == length sig@ and @z ^ length sig == 1@. +it must hold @n*m == length sig@ and @z ^ length sig == 1@. Cooley-Tukey-algorithm -} diff --git a/src/Synthesizer/Generic/Interpolation.hs b/src/Synthesizer/Generic/Interpolation.hs --- a/src/Synthesizer/Generic/Interpolation.hs +++ b/src/Synthesizer/Generic/Interpolation.hs @@ -24,8 +24,8 @@ import Data.Maybe (fromMaybe, ) -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base {-* Interpolation with various padding methods -} diff --git a/src/Synthesizer/Generic/LengthSignal.hs b/src/Synthesizer/Generic/LengthSignal.hs --- a/src/Synthesizer/Generic/LengthSignal.hs +++ b/src/Synthesizer/Generic/LengthSignal.hs @@ -5,10 +5,10 @@ import qualified Synthesizer.Generic.Signal as SigG import qualified Synthesizer.Generic.Cut as CutG -import qualified Algebra.Additive as Additive - import Data.Monoid (Monoid, mempty, mappend, ) import Data.Tuple.HT (mapSnd, ) + +import qualified Algebra.Additive as Additive import NumericPrelude.Numeric as NP import NumericPrelude.Base hiding (length, splitAt, ) diff --git a/src/Synthesizer/Generic/Noise.hs b/src/Synthesizer/Generic/Noise.hs --- a/src/Synthesizer/Generic/Noise.hs +++ b/src/Synthesizer/Generic/Noise.hs @@ -5,16 +5,16 @@ import qualified Synthesizer.State.Noise as Noise -import qualified Synthesizer.Generic.Signal as SigG -import qualified Synthesizer.State.Signal as SigS +import qualified Synthesizer.Generic.Signal as SigG +import qualified Synthesizer.State.Signal as SigS -import qualified Algebra.RealRing as RealRing +import qualified Algebra.RealRing as RealRing import qualified Algebra.Ring as Ring import System.Random (Random, RandomGen, randomR, mkStdGen, ) -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base {-| diff --git a/src/Synthesizer/Generic/Piece.hs b/src/Synthesizer/Generic/Piece.hs --- a/src/Synthesizer/Generic/Piece.hs +++ b/src/Synthesizer/Generic/Piece.hs @@ -12,21 +12,20 @@ FlatPosition(..), ) where -import qualified Synthesizer.Generic.Control as Ctrl import qualified Synthesizer.Piecewise as Piecewise -import Synthesizer.Generic.Displacement (raise, ) +import Synthesizer.Piecewise (FlatPosition (FlatLeft, FlatRight)) +import qualified Synthesizer.Generic.Control as Ctrl import qualified Synthesizer.Generic.Cut as CutG import qualified Synthesizer.Generic.Signal as SigG --- import qualified Synthesizer.State.Signal as Sig -import Synthesizer.State.Control (splitDurations, FlatPosition(..), ) +import Synthesizer.Generic.Displacement (raise, ) import qualified Algebra.Transcendental as Trans import qualified Algebra.RealField as RealField import qualified Algebra.Field as Field -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base @@ -39,7 +38,7 @@ SigG.concat $ zipWith (\(n, t) (Piecewise.PieceData c yi0 yi1 d) -> SigG.take n $ Piecewise.computePiece c yi0 yi1 d lazySize t) - (splitDurations $ map Piecewise.pieceDur xs) + (Piecewise.splitDurations $ map Piecewise.pieceDur xs) xs diff --git a/src/Synthesizer/Generic/Signal.hs b/src/Synthesizer/Generic/Signal.hs --- a/src/Synthesizer/Generic/Signal.hs +++ b/src/Synthesizer/Generic/Signal.hs @@ -14,26 +14,26 @@ In this module we collect functions where the element type is not altered by the function. -} -module Synthesizer.Generic.Signal - (module Synthesizer.Generic.Signal, - Cut.null, - Cut.length, - Cut.empty, - Cut.cycle, - Cut.append, - Cut.concat, - Cut.take, - Cut.drop, - Cut.dropMarginRem, - Cut.splitAt, - Cut.reverse, - Cut.lengthAtLeast, - Cut.lengthAtMost, - Cut.sliceVertical, +module Synthesizer.Generic.Signal ( + module Synthesizer.Generic.Signal, + Cut.null, + Cut.length, + Cut.empty, + Cut.cycle, + Cut.append, + Cut.concat, + Cut.take, + Cut.drop, + Cut.dropMarginRem, + Cut.splitAt, + Cut.reverse, + Cut.lengthAtLeast, + Cut.lengthAtMost, + Cut.sliceVertical, ) where -import Synthesizer.Generic.Cut (append, ) import qualified Synthesizer.Generic.Cut as Cut +import Synthesizer.Generic.Cut (append, ) import qualified Synthesizer.Plain.Signal as Sig import qualified Synthesizer.State.Signal as SigS @@ -43,6 +43,16 @@ import qualified Synthesizer.Plain.Modifier as Modifier +import Foreign.Storable (Storable) + +import Control.Monad.Trans.State (runState, runStateT, ) + +import qualified Data.List.HT as ListHT +import qualified Data.List as List +import Data.Function (fix, ) +import Data.Tuple.HT (mapPair, mapFst, fst3, snd3, thd3, ) +import Data.Monoid (Monoid, mappend, mempty, ) + import qualified Algebra.ToInteger as ToInteger import qualified Algebra.ToRational as ToRational import qualified Algebra.Absolute as Absolute @@ -61,19 +71,8 @@ import qualified Numeric.NonNegative.Class as NonNeg98 -import Foreign.Storable (Storable) - -import Control.Monad.Trans.State (runState, runStateT, ) -import Data.Monoid (Monoid, mappend, mempty, ) - -import Data.Function (fix, ) -import qualified Data.List.HT as ListHT -import qualified Data.List.Stream as List -import Data.Tuple.HT (mapPair, mapFst, fst3, snd3, thd3, ) - import qualified Test.QuickCheck as QC --- import NumericPrelude.Numeric import qualified Prelude as P import Prelude (Bool, Int, Maybe(Just), maybe, fst, snd, diff --git a/src/Synthesizer/Generic/Wave.hs b/src/Synthesizer/Generic/Wave.hs --- a/src/Synthesizer/Generic/Wave.hs +++ b/src/Synthesizer/Generic/Wave.hs @@ -10,8 +10,6 @@ import qualified Algebra.RealField as RealField import qualified Algebra.RealRing as RealRing --- import Data.Tuple.HT (swap, ) - import NumericPrelude.Numeric import NumericPrelude.Base import Prelude () diff --git a/src/Synthesizer/Interpolation.hs b/src/Synthesizer/Interpolation.hs --- a/src/Synthesizer/Interpolation.hs +++ b/src/Synthesizer/Interpolation.hs @@ -1,15 +1,27 @@ {-# LANGUAGE NoImplicitPrelude #-} -module Synthesizer.Interpolation where +module Synthesizer.Interpolation ( + T(Cons, margin, func), + Margin(marginOffset, marginNumber), + cons, + number, + offset, + PrefixReader, + getNode, + fromPrefixReader, + constant, + ) where import qualified Synthesizer.State.Signal as Sig import Control.Monad.Trans.State (StateT(StateT), evalStateT, ) import Control.Monad.Trans.Writer (Writer, writer, runWriter, ) -import Data.Monoid (Sum(Sum), ) import Control.Applicative (Applicative(pure, (<*>)), (<$>), liftA2, ) +import Data.Monoid (Sum(Sum), ) -import NumericPrelude.Base +import qualified Test.QuickCheck as QC + import NumericPrelude.Numeric +import NumericPrelude.Base @@ -29,6 +41,10 @@ -- ^ interpolation requires 'offset' values before the current } deriving (Show, Eq) + +instance QC.Arbitrary Margin where + arbitrary = liftA2 Margin (abs <$> QC.arbitrary) (abs <$> QC.arbitrary) + cons :: Int -> Int -> (t -> Sig.T y -> y) -> T t y cons num off = diff --git a/src/Synthesizer/Interpolation/Core.hs b/src/Synthesizer/Interpolation/Core.hs --- a/src/Synthesizer/Interpolation/Core.hs +++ b/src/Synthesizer/Interpolation/Core.hs @@ -13,8 +13,8 @@ import Synthesizer.Utility (affineComb, ) -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base diff --git a/src/Synthesizer/Interpolation/Custom.hs b/src/Synthesizer/Interpolation/Custom.hs --- a/src/Synthesizer/Interpolation/Custom.hs +++ b/src/Synthesizer/Interpolation/Custom.hs @@ -27,11 +27,11 @@ import Synthesizer.Interpolation.Class ((+.*), ) +import Control.Applicative.HT (liftA4, ) import Control.Applicative (liftA2, ) -import Synthesizer.ApplicativeUtility (liftA4, ) -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base diff --git a/src/Synthesizer/Interpolation/Module.hs b/src/Synthesizer/Interpolation/Module.hs --- a/src/Synthesizer/Interpolation/Module.hs +++ b/src/Synthesizer/Interpolation/Module.hs @@ -28,11 +28,11 @@ import qualified Algebra.Module as Module import qualified Algebra.Field as Field +import Control.Applicative.HT (liftA4, ) import Control.Applicative (liftA2, ) -import Synthesizer.ApplicativeUtility (liftA4, ) -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base {-| Consider the signal to be piecewise linear. -} diff --git a/src/Synthesizer/Piecewise.hs b/src/Synthesizer/Piecewise.hs --- a/src/Synthesizer/Piecewise.hs +++ b/src/Synthesizer/Piecewise.hs @@ -1,8 +1,17 @@ +{-# LANGUAGE NoImplicitPrelude #-} {- | Construction of a data type that describes piecewise defined curves. -} module Synthesizer.Piecewise where +import Data.Ix (Ix, ) + +import qualified Algebra.RealRing as RealRing + +import NumericPrelude.Numeric +import NumericPrelude.Base + + {- ToDo: Make it a new data type with Monoid and Generic.Cut instances. @@ -19,8 +28,7 @@ -> t {- duration -} -> sig} -pieceFromFunction :: - (y -> y -> t -> sig) -> Piece t y sig +pieceFromFunction :: (y -> y -> t -> sig) -> Piece t y sig pieceFromFunction = Piece @@ -89,3 +97,15 @@ (|#) :: y -> (PieceDist t y sig, T t y sig) -> T t y sig y0 |# (PD d c y1, xs) = PieceData c y0 y1 d : xs + + +data FlatPosition = FlatLeft | FlatRight + deriving (Show, Eq, Ord, Ix, Enum) + +splitDurations :: (RealRing.C t) => [t] -> [(Int, t)] +splitDurations ts0 = + let (ds,ts) = + unzip $ scanl + (\(_,fr) d -> RealRing.splitFraction (fr+d)) + (0,1) ts0 + in zip (tail ds) (map (subtract 1) ts) diff --git a/src/Synthesizer/PiecewiseConstant/Signal.hs b/src/Synthesizer/PiecewiseConstant/Signal.hs --- a/src/Synthesizer/PiecewiseConstant/Signal.hs +++ b/src/Synthesizer/PiecewiseConstant/Signal.hs @@ -13,10 +13,8 @@ ) where import qualified Data.EventList.Relative.TimeTime as EventListTT --- import qualified Data.EventList.Relative.TimeMixed as EventListTM import qualified Data.EventList.Relative.MixedTime as EventListMT import qualified Data.EventList.Relative.BodyTime as EventListBT --- import qualified Data.EventList.Relative.TimeBody as EventList import qualified Numeric.NonNegative.Class as NonNeg import qualified Numeric.NonNegative.Wrapper as NonNegW diff --git a/src/Synthesizer/Plain/Analysis.hs b/src/Synthesizer/Plain/Analysis.hs --- a/src/Synthesizer/Plain/Analysis.hs +++ b/src/Synthesizer/Plain/Analysis.hs @@ -1,14 +1,55 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} -module Synthesizer.Plain.Analysis where +module Synthesizer.Plain.Analysis ( + volumeMaximum, + volumeEuclidean, + volumeEuclideanSqr, + volumeSum, + volumeVectorMaximum, + volumeVectorEuclidean, + volumeVectorEuclideanSqr, + volumeVectorSum, + bounds, + histogramDiscreteArray, + histogramLinearArray, + histogramDiscreteIntMap, + histogramLinearIntMap, + histogramIntMap, + directCurrentOffset, + scalarProduct, + centroid, + centroidAlt, + firstMoment, + average, + rectify, + zeros, + BinaryLevel(Low, High), + binaryLevelFromBool, + binaryLevelToNumber, + flipFlopHysteresis, + flipFlopHysteresisStep, + chirpTransform, + binarySign, + deltaSigmaModulation, + deltaSigmaModulationPositive, + + -- for testing + spread, + ) where + import qualified Synthesizer.Plain.Signal as Sig import qualified Synthesizer.Plain.Control as Ctrl import qualified Synthesizer.Plain.Filter.Recursive.Integration as Integration --- import qualified Algebra.Module as Module --- import qualified Algebra.Transcendental as Trans +import qualified Data.NonEmpty as NonEmpty +import qualified Data.Array as Array +import qualified Data.IntMap as IntMap +import Data.Tuple.HT (sortPair) +import Data.Array (accumArray) +import Data.List (foldl', ) + import qualified Algebra.Algebraic as Algebraic import qualified Algebra.RealField as RealField import qualified Algebra.Field as Field @@ -21,16 +62,8 @@ import qualified Algebra.NormedSpace.Euclidean as NormedEuc import qualified Algebra.NormedSpace.Sum as NormedSum -import qualified Data.NonEmpty as NonEmpty -import qualified Data.Array as Array - -import qualified Data.IntMap as IntMap - -import Data.Array (accumArray) -import Data.List (foldl', ) - -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base {- * Notions of volume -} @@ -213,8 +246,8 @@ meanValues = concatMap spread . NonEmpty.mapAdjacent (,) spread :: RealField.C y => (y,y) -> [(Int,y)] -spread (l0,r0) = - let (l,r) = if l0<=r0 then (l0,r0) else (r0,l0) +spread lr0 = + let (l,r) = sortPair lr0 (li,lf) = splitFraction l (ri,rf) = splitFraction r k = recip (r-l) @@ -296,12 +329,15 @@ -} flipFlopHysteresis :: (Ord y) => (y,y) -> BinaryLevel -> Sig.T y -> Sig.T BinaryLevel -flipFlopHysteresis (lower,upper) = - scanl - (\state x -> binaryLevelFromBool $ - case state of +flipFlopHysteresis bnds = scanl (flipFlopHysteresisStep bnds) + +flipFlopHysteresisStep :: Ord a => (a, a) -> BinaryLevel -> a -> BinaryLevel +flipFlopHysteresisStep (lower,upper) = + \state x -> + binaryLevelFromBool $ + case state of High -> not(x x>upper) + Low -> x>upper {- | Almost naive implementation of the chirp transform, diff --git a/src/Synthesizer/Plain/Builder.hs b/src/Synthesizer/Plain/Builder.hs --- a/src/Synthesizer/Plain/Builder.hs +++ b/src/Synthesizer/Plain/Builder.hs @@ -10,9 +10,9 @@ import qualified Algebra.FloatingPoint as Float import qualified Algebra.ToInteger as ToInteger -import Prelude () -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base +import Prelude () diff --git a/src/Synthesizer/Plain/Control.hs b/src/Synthesizer/Plain/Control.hs --- a/src/Synthesizer/Plain/Control.hs +++ b/src/Synthesizer/Plain/Control.hs @@ -1,25 +1,48 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} -module Synthesizer.Plain.Control where +module Synthesizer.Plain.Control ( + constant, + linear, + linearMultiscale, + linearMultiscaleNeutral, + linearStable, + linearMean, + line, + exponential, exponentialMultiscale, exponentialStable, + exponentialMultiscaleNeutral, + exponential2, exponential2Multiscale, exponential2Stable, + exponential2MultiscaleNeutral, + exponentialFromTo, exponentialFromToMultiscale, + vectorExponential, + vectorExponential2, + cosine, cosineMultiscale, cosineSubdiv, cosineStable, + cubicHermite, + cubicHermiteStable, -import Synthesizer.Plain.Displacement (raise) + -- used in Analysis + curveMultiscale, + curveMultiscaleNeutral, + -- used in Generic.Control, Interpolation.Module + cubicFunc, + cosineWithSlope, + ) where import qualified Synthesizer.Plain.Signal as Sig +import Data.List (zipWith4, tails, ) +import Data.List.HT (iterateAssociative, ) + import qualified Algebra.Module as Module import qualified Algebra.Transcendental as Trans -import qualified Algebra.RealRing as RealRing import qualified Algebra.Field as Field import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive import Number.Complex (cis,real, ) -import Data.List (zipWith4, tails, ) -import Data.List.HT (iterateAssociative, ) -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base {- * Control curve generation -} @@ -69,9 +92,9 @@ namely using a subdivision scheme. The division needed is a division by two. -0 4 8 -0 2 4 6 8 -0 1 2 3 4 5 6 7 8 +> 0 4 8 +> 0 2 4 6 8 +> 0 1 2 3 4 5 6 7 8 -} linearMean :: Field.C y => y @@ -224,11 +247,11 @@ map (cubicFunc node0 node1) (linear 1 0) {- | -0 16 -0 8 16 -0 4 8 12 16 -0 2 4 6 8 10 12 14 16 -0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 +> 0 16 +> 0 8 16 +> 0 4 8 12 16 +> 0 2 4 6 8 10 12 14 16 +> 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 -} cubicFunc :: Field.C y => (y, (y,y)) -> (y, (y,y)) -> y -> y cubicFunc (t0, (y0,dy0)) (t1, (y1,dy1)) t = @@ -322,126 +345,6 @@ -{-# DEPRECATED Control "use Synthesizer.State.Piece instead" #-} -{- | -The curve type of a piece of a piecewise defined control curve. --} -data Control y = - CtrlStep - | CtrlLin - | CtrlExp {ctrlExpSaturation :: y} - | CtrlCos - | CtrlCubic {ctrlCubicGradient0 :: y, - ctrlCubicGradient1 :: y} - deriving (Eq, Show) - -{- | -The full description of a control curve piece. --} -data ControlPiece y = - ControlPiece {pieceType :: Control y, - pieceY0 :: y, - pieceY1 :: y, - pieceDur :: y} - deriving (Eq, Show) - - -newtype PieceRightSingle y = PRS y -newtype PieceRightDouble y = PRD y - -type ControlDist y = (y, Control y, y) - - --- precedence and associativity like (:) -infixr 5 -|#, #|-, =|#, #|=, |#, #| - -{- | -The 6 operators simplify constructing a list of @ControlPiece a@. -The description consists of nodes (namely the curve values at nodes) -and the connecting curve types. -The naming scheme is as follows: -In the middle there is a bar @|@. -With respect to the bar, -the pad symbol @\#@ is at the side of the curve type, -at the other side there is nothing, a minus sign @-@, or an equality sign @=@. - - (1) Nothing means that here is the start or the end node of a curve. - - (2) Minus means that here is a node where left and right curve meet at the same value. - The node description is thus one value. - - (3) Equality sign means that here is a split node, - where left and right curve might have different ending and beginning values, respectively. - The node description consists of a pair of values. --} - --- the leading space is necessary for the Haddock parser - -( #|-) :: (y, Control y) -> (PieceRightSingle y, [ControlPiece y]) -> - (ControlDist y, [ControlPiece y]) -(d,c) #|- (PRS y1, xs) = ((d,c,y1), xs) - -(-|#) :: y -> (ControlDist y, [ControlPiece y]) -> - (PieceRightSingle y, [ControlPiece y]) -y0 -|# ((d,c,y1), xs) = (PRS y0, ControlPiece c y0 y1 d : xs) - -( #|=) :: (y, Control y) -> (PieceRightDouble y, [ControlPiece y]) -> - (ControlDist y, [ControlPiece y]) -(d,c) #|= (PRD y1, xs) = ((d,c,y1), xs) - -(=|#) :: (y,y) -> (ControlDist y, [ControlPiece y]) -> - (PieceRightDouble y, [ControlPiece y]) -(y01,y10) =|# ((d,c,y11), xs) = (PRD y01, ControlPiece c y10 y11 d : xs) - -( #|) :: (y, Control y) -> y -> - (ControlDist y, [ControlPiece y]) -(d,c) #| y1 = ((d,c,y1), []) - -(|#) :: y -> (ControlDist y, [ControlPiece y]) -> - [ControlPiece y] -y0 |# ((d,c,y1), xs) = ControlPiece c y0 y1 d : xs - - -piecewise :: (Trans.C y, RealRing.C y) => - [ControlPiece y] -> Sig.T y -piecewise xs = - let ts = scanl (\(_,fr) d -> splitFraction (fr+d)) - (0,1) (map pieceDur xs) - in concat (zipWith3 - (\n t (ControlPiece c yi0 yi1 d) -> - piecewisePart yi0 yi1 t d n c) - (map fst (tail ts)) (map (subtract 1 . snd) ts) - xs) - - -piecewisePart :: (Trans.C y) => - y -> y -> y -> y -> Int -> Control y -> Sig.T y -piecewisePart y0 y1 t0 d n ctrl = - take n - (case ctrl of - CtrlStep -> constant y0 - CtrlLin -> let s = (y1-y0)/d in linearStable s (y0-t0*s) - CtrlExp s -> let y0' = y0-s; y1' = y1-s; yd = y0'/y1' - in raise s (exponentialStable (d / log yd) - (y0' * yd**(t0/d))) - CtrlCos -> map (\y -> (1+y)*(y0/2)+(1-y)*(y1/2)) - (cosineStable t0 (t0+d)) - CtrlCubic yd0 yd1 -> - cubicHermiteStable (t0,(y0,yd0)) (t0+d,(y1,yd1))) - -{- - exp (-1/time) == yd**(-1/d) - 1/time == log yd / d - time == d / log yd --} - -{- - piecewise (0 |# (10.21, CtrlExp 1.1) #|- 1 -|# (10,CtrlExp 0.49) #|- 0.5 -|# (30, CtrlLin) #|- 0.5 -|# (20, CtrlCos) #| 0) - - piecewise (0 |# (10.21, CtrlExp 1.1) #|- 1 -|# (10,CtrlCubic (-0.1) 0) #|- 0.5 -|# (30, CtrlLin) #|- 0.5 -|# (20, CtrlCos) #| 0) --} - - {- * Auxiliary functions -} curveStable :: (Additive.C t) => @@ -476,8 +379,8 @@ subdivide _ [] = [] -concatMapPair' :: (a -> (b,b)) -> Sig.T a -> Sig.T b -concatMapPair' f = concatMap ((\(x,y) -> [x,y]) . f) +_concatMapPair :: (a -> (b,b)) -> Sig.T a -> Sig.T b +_concatMapPair f = concatMap ((\(x,y) -> [x,y]) . f) curveMultiscale :: (y -> y -> y) -> y -> y -> Sig.T y diff --git a/src/Synthesizer/Plain/Cut.hs b/src/Synthesizer/Plain/Cut.hs --- a/src/Synthesizer/Plain/Cut.hs +++ b/src/Synthesizer/Plain/Cut.hs @@ -22,16 +22,16 @@ import qualified Data.EventList.Relative.TimeBody as EventList +import Data.Array (Array, Ix, (!)) + import qualified MathObj.LaurentPolynomial as Laurent -import qualified Algebra.RealRing as RealRing +import qualified Algebra.RealRing as RealRing import qualified Algebra.Additive as Additive -import Data.Array (Array, Ix, (!)) - import qualified Number.NonNegative as NonNeg -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base diff --git a/src/Synthesizer/Plain/Displacement.hs b/src/Synthesizer/Plain/Displacement.hs --- a/src/Synthesizer/Plain/Displacement.hs +++ b/src/Synthesizer/Plain/Displacement.hs @@ -8,9 +8,8 @@ import qualified Synthesizer.Plain.Signal as Sig --- import qualified Prelude as P -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base {- * Mixing -} diff --git a/src/Synthesizer/Plain/Effect.hs b/src/Synthesizer/Plain/Effect.hs --- a/src/Synthesizer/Plain/Effect.hs +++ b/src/Synthesizer/Plain/Effect.hs @@ -3,11 +3,8 @@ import qualified Synthesizer.Plain.Noise as Noise import qualified Synthesizer.Plain.Filter.Recursive as Filter import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1 --- import qualified Synthesizer.Plain.Filter.Recursive.Allpass as Allpass --- import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter import qualified Synthesizer.Plain.Filter.Recursive.Moog as Moog import qualified Synthesizer.Plain.Filter.Recursive.Comb as Comb --- import qualified Synthesizer.Plain.Filter.Recursive.Integration as Integrate import qualified Synthesizer.Plain.Filter.Recursive.Butterworth as Butter import qualified Synthesizer.Plain.Filter.Recursive.Chebyshev as Cheby import Synthesizer.Plain.Control(exponential2) @@ -18,6 +15,7 @@ import qualified Control.Monad.Exception.Synchronous as Exc import System.Process (rawSystem, ) import System.Exit (ExitCode, ) + main :: IO ExitCode main = diff --git a/src/Synthesizer/Plain/Effect/Fly.hs b/src/Synthesizer/Plain/Effect/Fly.hs --- a/src/Synthesizer/Plain/Effect/Fly.hs +++ b/src/Synthesizer/Plain/Effect/Fly.hs @@ -16,8 +16,8 @@ import qualified Algebra.NormedSpace.Euclidean as Euc -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base {- diff --git a/src/Synthesizer/Plain/Effect/Glass.hs b/src/Synthesizer/Plain/Effect/Glass.hs --- a/src/Synthesizer/Plain/Effect/Glass.hs +++ b/src/Synthesizer/Plain/Effect/Glass.hs @@ -1,5 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} -module Synthesizer.Plain.Effect.Glass where +module Synthesizer.Plain.Effect.Glass (glass) where import qualified Data.EventList.Relative.TimeBody as EventList import qualified Number.NonNegative as NonNeg @@ -11,18 +11,18 @@ import qualified Synthesizer.Plain.Noise as Noise import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR -import qualified Algebra.Transcendental as Trans -import qualified Algebra.RealField as RealField -import qualified Algebra.Module as Module - import System.Random(randomRs, mkStdGen) import qualified Data.List.HT as ListHT -import NumericPrelude.Base -import NumericPrelude.Numeric as NP +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +import qualified Algebra.Module as Module +import NumericPrelude.Numeric +import NumericPrelude.Base as NP + {- | We try to simulate the sound of broken glass as a mixture of short percussive sounds with random pitch -} glass :: Double -> [Double] @@ -52,12 +52,12 @@ (Osci.static Wave.square 0 (freq/sampleRate)) (Ctrl.exponential2 (0.01*sampleRate) amp)) -densitySmooth, densityHeavy :: Trans.C a => a -> a -densitySmooth x = x * exp(-10*x*x) +_densitySmooth, densityHeavy :: Trans.C a => a -> a +_densitySmooth x = x * exp(-10*x*x) densityHeavy x = 0.4 * exp (-4*x) -timeDiffsAlt :: [Bool] -> [NonNeg.Int] -timeDiffsAlt = +_timeDiffs :: [Bool] -> [NonNeg.Int] +_timeDiffs = let diffs n (True : xs) = n : diffs 1 xs diffs n (False : xs) = diffs (succ n) xs diffs _ [] = [] diff --git a/src/Synthesizer/Plain/File.hs b/src/Synthesizer/Plain/File.hs --- a/src/Synthesizer/Plain/File.hs +++ b/src/Synthesizer/Plain/File.hs @@ -35,21 +35,22 @@ import Foreign.Storable (Storable, ) import Data.Int (Int16, ) -import qualified Control.Monad.Exception.Synchronous as Exc -import Control.Monad.Trans.Class (lift, ) +import qualified System.FilePath as FilePath import System.Process (rawSystem, ) import System.Exit (ExitCode, ) + +import qualified Control.Monad.Exception.Synchronous as Exc +import Control.Monad.Trans.Class (lift, ) import Control.Monad (liftM2, ) + import Data.Monoid (mconcat, ) import qualified Algebra.ToInteger as ToInteger import qualified Algebra.RealRing as RealRing import qualified Algebra.Field as Field -import qualified System.FilePath as FilePath - -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base diff --git a/src/Synthesizer/Plain/Filter/Delay.hs b/src/Synthesizer/Plain/Filter/Delay.hs --- a/src/Synthesizer/Plain/Filter/Delay.hs +++ b/src/Synthesizer/Plain/Filter/Delay.hs @@ -1,6 +1,12 @@ {-# LANGUAGE NoImplicitPrelude #-} -module Synthesizer.Plain.Filter.Delay where +module Synthesizer.Plain.Filter.Delay ( + phaser, + plane, + -- for testing + propAll, + ) where + import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR import qualified Synthesizer.Plain.Displacement as Syn import qualified Synthesizer.Plain.Control as Ctrl @@ -16,8 +22,8 @@ import qualified Synthesizer.Plain.Filter.Delay.List as DelayList import qualified Synthesizer.Plain.Filter.Delay.Block as DelayBlock -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base phaser :: (Module.C a v, RealField.C a) => a -> [a] -> [v] -> [v] diff --git a/src/Synthesizer/Plain/Filter/Delay/Block.hs b/src/Synthesizer/Plain/Filter/Delay/Block.hs --- a/src/Synthesizer/Plain/Filter/Delay/Block.hs +++ b/src/Synthesizer/Plain/Filter/Delay/Block.hs @@ -5,8 +5,13 @@ In contrast to ring buffers, block lists allow infinite look ahead. -} -module Synthesizer.Plain.Filter.Delay.Block where +module Synthesizer.Plain.Filter.Delay.Block ( + modulated, + -- for testing + propDrop, + ) where + import qualified Synthesizer.Plain.Interpolation as Interpolation import qualified Synthesizer.Plain.Signal as Sig @@ -18,8 +23,8 @@ import Test.QuickCheck ((==>), Property) -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base modulatedCore :: (RealField.C a, Additive.C v) => @@ -78,11 +83,11 @@ Drop elements from a blocked list. The offset must lie in the leading block. -} -dropSingleBlocksToList :: Int -> BlockList a -> Sig.T a -dropSingleBlocksToList number (arr:arrs) = +_dropSingleBlocksToList :: Int -> BlockList a -> Sig.T a +_dropSingleBlocksToList number (arr:arrs) = map (arr!) [number .. (snd $ bounds arr)] ++ concatMap elems arrs -dropSingleBlocksToList _ [] = [] +_dropSingleBlocksToList _ [] = [] suffixIndexes :: BlockList a -> [(Int, BlockList a)] diff --git a/src/Synthesizer/Plain/Filter/Delay/List.hs b/src/Synthesizer/Plain/Filter/Delay/List.hs --- a/src/Synthesizer/Plain/Filter/Delay/List.hs +++ b/src/Synthesizer/Plain/Filter/Delay/List.hs @@ -1,15 +1,15 @@ {-# LANGUAGE NoImplicitPrelude #-} -module Synthesizer.Plain.Filter.Delay.List where +module Synthesizer.Plain.Filter.Delay.List (modulated, modulatedRev) where import qualified Synthesizer.Plain.Interpolation as Interpolation +import Data.List(tails) + import qualified Algebra.RealField as RealField import qualified Algebra.Additive as Additive -import Data.List(tails) - -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base {- | diff --git a/src/Synthesizer/Plain/Filter/Delay/ST.hs b/src/Synthesizer/Plain/Filter/Delay/ST.hs --- a/src/Synthesizer/Plain/Filter/Delay/ST.hs +++ b/src/Synthesizer/Plain/Filter/Delay/ST.hs @@ -3,7 +3,7 @@ An implementation of a Delay using a classical circular buffer running in the State Thread monad. -} -module Synthesizer.Plain.Filter.Delay.ST where +module Synthesizer.Plain.Filter.Delay.ST (modulated) where import qualified Synthesizer.Plain.Interpolation as Interpolation @@ -13,8 +13,8 @@ import Control.Monad.ST.Lazy(runST,strictToLazyST,ST) import Data.Array.ST -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base {- diff --git a/src/Synthesizer/Plain/Filter/LinearPredictive.hs b/src/Synthesizer/Plain/Filter/LinearPredictive.hs --- a/src/Synthesizer/Plain/Filter/LinearPredictive.hs +++ b/src/Synthesizer/Plain/Filter/LinearPredictive.hs @@ -1,10 +1,11 @@ module Synthesizer.Plain.Filter.LinearPredictive where -import qualified Algebra.Field as Field import Synthesizer.Plain.Analysis (scalarProduct) import qualified Data.List.Match as ListMatch import qualified Data.List as List + +import qualified Algebra.Field as Field import NumericPrelude.Numeric import NumericPrelude.Base diff --git a/src/Synthesizer/Plain/Filter/NonRecursive.hs b/src/Synthesizer/Plain/Filter/NonRecursive.hs --- a/src/Synthesizer/Plain/Filter/NonRecursive.hs +++ b/src/Synthesizer/Plain/Filter/NonRecursive.hs @@ -7,8 +7,49 @@ Stability : provisional Portability : requires multi-parameter type classes -} -module Synthesizer.Plain.Filter.NonRecursive where +module Synthesizer.Plain.Filter.NonRecursive ( + amplify, + amplifyVector, + binomial, + binomial1, + delay, + delayPad, + differentiate, + differentiate2, + differentiateCenter, + downsample2, + envelope, + envelopeVector, + fadeInOut, + fadeInOutAlt, + gaussian, + generic, + genericAlt, + minRange, + movingAverageModulatedPyramid, + sumRange, + sumRangeFromPyramid, + sums, + sumsDownsample2, + sumsPosModulated, + sumsPosModulatedPyramid, + sumsPyramid, + -- for testing + propGeneric, + sumRangeFromPyramidFoldr, + sumRangeFromPyramidRec, + getRangeFromPyramid, + pyramid, + ) where + +import Synthesizer.Basic.Filter.NonRecursive ( + unitSizesFromPyramid, + sumRangePrepare, + symmetricRangePrepare, + ratioFreqToVariance, + ) + import qualified Synthesizer.Plain.Control as Ctrl import qualified Synthesizer.Plain.Signal as Sig @@ -22,17 +63,12 @@ import Algebra.Module(linearComb, ) import Data.Function.HT (nest, ) -import Data.Tuple.HT (mapPair, swap, ) +import Data.Tuple.HT (mapPair, ) import Data.List.HT (sliceVertical, ) import Data.List (tails, ) -import qualified Data.List.Match as Match - --- import Control.Monad.Trans.State (StateT) --- import Control.Monad.Trans.Writer (WriterT) - -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base {- * Envelope application -} @@ -153,29 +189,6 @@ let width = ceiling (2 * ratioFreqToVariance ratio freq ^ 2) in 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@. --} -ratioFreqToVariance :: (Trans.C a) => a -> a -> a -ratioFreqToVariance ratio freq = - sqrt (-2 * log ratio) / (2*pi*freq) - -- inverse of the fourier transformed gaussian - binomial1 :: (Additive.C v) => Sig.T v -> Sig.T v binomial1 xt@(x:xs) = x : (xs + xt) binomial1 [] = [] @@ -262,19 +275,6 @@ pyramid :: (Additive.C v) => Sig.T v -> [Sig.T v] pyramid = iterate sumsDownsample2 -unitSizesFromPyramid :: [signal] -> [Int] -unitSizesFromPyramid pyr = - reverse $ Match.take pyr $ iterate (2*) 1 - -sumRangePrepare :: (Additive.C v) => - ((Int,Int) -> source -> v) -> - (source -> (Int,Int) -> v) -sumRangePrepare f pyr (l,r) = - case compare l r of - LT -> f (l,r) pyr - GT -> negate $ f (r,l) pyr - EQ -> zero - {- | This function should be much faster than 'sumRange' but slower than the recursively implemented @movingAverage@. @@ -285,12 +285,6 @@ sumRangeFromPyramid = sumRangePrepare $ \lr0 pyr0 -> sum $ getRangeFromPyramid pyr0 lr0 - -symmetricRangePrepare :: - ((Int,Int) -> source -> v) -> - (source -> (Int,Int) -> v) -symmetricRangePrepare f pyr lr = - f (if uncurry (<) lr then lr else swap lr) pyr minRange :: (Ord v) => Sig.T v -> (Int,Int) -> v minRange = diff --git a/src/Synthesizer/Plain/Filter/Recursive.hs b/src/Synthesizer/Plain/Filter/Recursive.hs --- a/src/Synthesizer/Plain/Filter/Recursive.hs +++ b/src/Synthesizer/Plain/Filter/Recursive.hs @@ -14,8 +14,8 @@ import qualified Algebra.Module as Module import qualified Algebra.Additive as Additive -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base {- * Various Filters -} diff --git a/src/Synthesizer/Plain/Filter/Recursive/Allpass.hs b/src/Synthesizer/Plain/Filter/Recursive/Allpass.hs --- a/src/Synthesizer/Plain/Filter/Recursive/Allpass.hs +++ b/src/Synthesizer/Plain/Filter/Recursive/Allpass.hs @@ -9,16 +9,50 @@ Stability : provisional Portability : requires multi-parameter type classes -} -module Synthesizer.Plain.Filter.Recursive.Allpass where +module Synthesizer.Plain.Filter.Recursive.Allpass ( + Parameter(Parameter, getParameter), + State, + cascade, + cascadeCausal, + cascadeModifier, + cascadeParameter, + cascadeStep, + cascadeDiverseStep, + firstOrder, + firstOrderCausal, + firstOrderModifier, + firstOrderStep, + flangerParameter, + flangerPhase, + makePhase, + parameter, + parameterApprox, + -- for testing + parameterAlt, + cascadeState, + cascadeIterative, + cascadeStepRec, + cascadeStepScanl, + cascadeStepStack, + cascadeCausalModifier, + cascadeCausalStacked, + ) where + 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.Monad.Trans.State as MS import qualified Control.Applicative as App + import qualified Data.Foldable as Fold import qualified Data.Traversable as Trav +import Data.Tuple.HT (mapSnd, ) +import Data.Function.HT (nest, ) +import Data.List.HT (mapAdjacent, switchR, ) import qualified Foreign.Storable.Newtype as Store import Foreign.Storable (Storable(sizeOf, alignment, peek, poke)) @@ -31,14 +65,9 @@ import qualified Algebra.ZeroTestable as ZeroTestable import qualified Number.Complex as Complex -import Data.Tuple.HT (mapSnd, ) -import Data.Function.HT (nest, ) -import Data.List.HT (mapAdjacent, switchR, ) -import qualified Control.Monad.Trans.State as MS - -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base diff --git a/src/Synthesizer/Plain/Filter/Recursive/AllpassPoly.hs b/src/Synthesizer/Plain/Filter/Recursive/AllpassPoly.hs --- a/src/Synthesizer/Plain/Filter/Recursive/AllpassPoly.hs +++ b/src/Synthesizer/Plain/Filter/Recursive/AllpassPoly.hs @@ -11,9 +11,6 @@ -} module Synthesizer.Plain.Filter.Recursive.AllpassPoly where --- import qualified Synthesizer.Plain.Signal as Sig --- import qualified Synthesizer.Plain.Modifier as Modifier - import qualified Algebra.Module as Module import qualified Algebra.RealTranscendental as RealTrans import qualified Algebra.Transcendental as Trans @@ -25,8 +22,8 @@ import Orthogonals(Scalar,one_ket_solution) import qualified Prelude as P -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base diff --git a/src/Synthesizer/Plain/Filter/Recursive/Butterworth.hs b/src/Synthesizer/Plain/Filter/Recursive/Butterworth.hs --- a/src/Synthesizer/Plain/Filter/Recursive/Butterworth.hs +++ b/src/Synthesizer/Plain/Filter/Recursive/Butterworth.hs @@ -11,12 +11,27 @@ Butterworth lowpass and highpass -} -module Synthesizer.Plain.Filter.Recursive.Butterworth where +module Synthesizer.Plain.Filter.Recursive.Butterworth ( + Parameter, + causal, + causalPole, + highpassCausalPole, highpassPole, + lowpassCausalPole, lowpassPole, + modifier, + parameter, + partialParameter, + runPole, + -- used in Dimensional.Causal.FilterParameter + checkedHalf, + -- used in LLVM.Filter.Butterworth + partialRatio, + makeSines, + ) where + import Synthesizer.Plain.Filter.Recursive (Passband(Lowpass,Highpass), Pole(Pole)) import qualified Synthesizer.Plain.Filter.Recursive.SecondOrderCascade as Cascade import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2 --- import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1 import qualified Synthesizer.Plain.Signal as Sig import qualified Synthesizer.Plain.Modifier as Modifier import qualified Synthesizer.Causal.Process as Causal @@ -29,15 +44,15 @@ import qualified Data.StorableVector as SV import Foreign.Storable (Storable) -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base -sineList, sineListSlow, sineListFast :: (Trans.C a) => a -> [a] +sineList, _sineListSlow, sineListFast :: (Trans.C a) => a -> [a] sineList = sineListFast -sineListSlow x = +_sineListSlow x = map sin $ map (x*) $ iterate (2+) 1 sineListFast x = @@ -60,11 +75,11 @@ -partialLowpassParameterInstable, partialLowpassParameter :: (Trans.C a) => +_partialLowpassParameterInstable, partialLowpassParameter :: (Trans.C a) => a -> a -> a -> Filt2.Parameter a {- must handle infinite values when 'freq' approaches 0.5 -} -partialLowpassParameterInstable ratio freq sinw = +_partialLowpassParameterInstable ratio freq sinw = let wc = ratio * tan (pi*freq) sinw2 = 2 * wc * sinw wc2 = wc * wc diff --git a/src/Synthesizer/Plain/Filter/Recursive/Chebyshev.hs b/src/Synthesizer/Plain/Filter/Recursive/Chebyshev.hs --- a/src/Synthesizer/Plain/Filter/Recursive/Chebyshev.hs +++ b/src/Synthesizer/Plain/Filter/Recursive/Chebyshev.hs @@ -11,14 +11,24 @@ Chebyshev lowpass and highpass -} -module Synthesizer.Plain.Filter.Recursive.Chebyshev where +module Synthesizer.Plain.Filter.Recursive.Chebyshev ( + ParameterA, parameterA, partialParameterA, + ParameterB, parameterB, partialParameterB, + canonicalizeParameterA, + causalA, runAPole, causalAPole, + causalB, runBPole, causalBPole, + lowpassACausalPole, highpassACausalPole, + lowpassBCausalPole, highpassBCausalPole, + lowpassAPole, highpassAPole, + lowpassBPole, highpassBPole, + -- used in LLVM.Filter.Chebyshev + makeCirclePoints, + ) where import Synthesizer.Plain.Filter.Recursive (Passband(Lowpass,Highpass), Pole(Pole, poleResonance)) import qualified Synthesizer.Plain.Filter.Recursive.SecondOrderCascade as Cascade import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2 --- import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1 import qualified Synthesizer.Plain.Signal as Sig --- import qualified Synthesizer.Plain.Modifier as Modifier import qualified Synthesizer.Causal.Process as Causal import Control.Arrow ((>>>), (^>>), (&&&), ) @@ -33,19 +43,19 @@ import qualified Data.StorableVector as SV import Foreign.Storable (Storable) -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base -circleList, circleListSlow, circleListFast :: (Trans.C a) => a -> [Complex.T a] +circleList, circleListSlow, _circleListFast :: (Trans.C a) => a -> [Complex.T a] circleList = circleListSlow circleListSlow x = map cis $ map (x*) $ iterate (2+) 1 -circleListFast x = +_circleListFast x = let z1 = cis x z2 = z1^2 in iterate (z2*) z1 diff --git a/src/Synthesizer/Plain/Filter/Recursive/Comb.hs b/src/Synthesizer/Plain/Filter/Recursive/Comb.hs --- a/src/Synthesizer/Plain/Filter/Recursive/Comb.hs +++ b/src/Synthesizer/Plain/Filter/Recursive/Comb.hs @@ -14,18 +14,17 @@ -} module Synthesizer.Plain.Filter.Recursive.Comb where -import Synthesizer.Plain.Filter.NonRecursive (delay, ) import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1 -import qualified Synthesizer.Plain.Signal as Sig --- import qualified Synthesizer.Plain.Modifier as Modifier +import qualified Synthesizer.Plain.Signal as Sig import qualified Synthesizer.Plain.Control as Ctrl +import Synthesizer.Plain.Filter.NonRecursive (delay, ) import qualified Algebra.Module as Module import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base {- | diff --git a/src/Synthesizer/Plain/Filter/Recursive/FirstOrder.hs b/src/Synthesizer/Plain/Filter/Recursive/FirstOrder.hs --- a/src/Synthesizer/Plain/Filter/Recursive/FirstOrder.hs +++ b/src/Synthesizer/Plain/Filter/Recursive/FirstOrder.hs @@ -18,8 +18,11 @@ 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 Control.Monad.Trans.State (State, state, ) +import Control.Applicative (pure, liftA2, ) + import qualified Data.Foldable as Fold import qualified Data.Traversable as Trav @@ -29,14 +32,11 @@ import qualified Algebra.Module as Module import qualified Algebra.Transcendental as Trans --- import qualified Algebra.Field as Field import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive -import Control.Monad.Trans.State (State, state, ) - -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base @@ -155,8 +155,7 @@ -data Result a = - Result {highpass_, lowpass_ :: !a} +data Result a = Result {highpass_, lowpass_ :: !a} instance Functor Result where {-# INLINE fmap #-} diff --git a/src/Synthesizer/Plain/Filter/Recursive/FirstOrderComplex.hs b/src/Synthesizer/Plain/Filter/Recursive/FirstOrderComplex.hs --- a/src/Synthesizer/Plain/Filter/Recursive/FirstOrderComplex.hs +++ b/src/Synthesizer/Plain/Filter/Recursive/FirstOrderComplex.hs @@ -43,8 +43,8 @@ import Control.Monad.Trans.State (State, state, ) -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base data Parameter a = diff --git a/src/Synthesizer/Plain/Filter/Recursive/Hilbert.hs b/src/Synthesizer/Plain/Filter/Recursive/Hilbert.hs --- a/src/Synthesizer/Plain/Filter/Recursive/Hilbert.hs +++ b/src/Synthesizer/Plain/Filter/Recursive/Hilbert.hs @@ -15,25 +15,39 @@ ToDo: More parameters for controling the affected frequency range. -} -module Synthesizer.Plain.Filter.Recursive.Hilbert where +module Synthesizer.Plain.Filter.Recursive.Hilbert ( + Parameter (Parameter, parameterCosine, parameterSine), + polesCosine, polesSine, + parameter, + step2, + modifierInit2, + runInit2, run2, + cascade, + causal2, causalComplex2, + causal, causalComplex, -import qualified Synthesizer.Plain.Filter.Recursive.Allpass as Allpass + lowpassStream, + lowpassMaintainPhase, + ) where +import qualified Synthesizer.Plain.Filter.Recursive.Allpass as Allpass import qualified Synthesizer.Plain.Signal as Sig import qualified Synthesizer.Plain.Modifier as Modifier -import qualified Synthesizer.Causal.Process as Causal -import Control.Arrow ((<<<), (>>>), (&&&), (>>^), ) - import qualified Synthesizer.Plain.Oscillator as Osci +import qualified Synthesizer.Causal.Process as Causal import qualified Synthesizer.Basic.Wave as Wave +import qualified Synthesizer.Basic.ComplexModule as CM {- import qualified Synthesizer.Plain.Control as Ctrl import qualified Graphics.Gnuplot.Simple as Gnuplot -} -import qualified Synthesizer.Basic.ComplexModule as CM +import Control.Arrow ((<<<), (>>>), (&&&), (>>^), ) +import Control.Monad.Trans.State (State, state, runState, ) +import qualified Data.List.Match as Match + import qualified Algebra.Module as Module import qualified Algebra.Transcendental as Trans import qualified Algebra.RealField as RealField @@ -43,12 +57,8 @@ import qualified Number.Complex as Complex import Number.Complex ((+:), ) -import Control.Monad.Trans.State (State, state, runState, ) - -import qualified Data.List.Match as Match - -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base diff --git a/src/Synthesizer/Plain/Filter/Recursive/Integration.hs b/src/Synthesizer/Plain/Filter/Recursive/Integration.hs --- a/src/Synthesizer/Plain/Filter/Recursive/Integration.hs +++ b/src/Synthesizer/Plain/Filter/Recursive/Integration.hs @@ -12,14 +12,11 @@ module Synthesizer.Plain.Filter.Recursive.Integration where import qualified Synthesizer.Plain.Signal as Sig --- import qualified Synthesizer.Plain.Modifier as Modifier --- import qualified Algebra.Field as Field --- import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base diff --git a/src/Synthesizer/Plain/Filter/Recursive/Moog.hs b/src/Synthesizer/Plain/Filter/Recursive/Moog.hs --- a/src/Synthesizer/Plain/Filter/Recursive/Moog.hs +++ b/src/Synthesizer/Plain/Filter/Recursive/Moog.hs @@ -11,7 +11,14 @@ Moog cascade lowpass with resonance. -} -module Synthesizer.Plain.Filter.Recursive.Moog where +module Synthesizer.Plain.Filter.Recursive.Moog ( + Parameter(Parameter, feedback, lowpassParam), + parameter, + State, + lowpass, + lowpassModifier, + lowpassCausal, + ) where import Synthesizer.Plain.Filter.Recursive (Pole(..)) import Synthesizer.Plain.Filter.NonRecursive (envelopeVector) @@ -21,22 +28,22 @@ import qualified Synthesizer.Causal.Process as Causal import qualified Synthesizer.Interpolation.Class as Interpol -import Control.Applicative (pure, liftA2, (<*>), ) + +import qualified Control.Monad.Trans.State as MS import qualified Control.Applicative as App +import Control.Arrow ((&&&), (>>^), (^>>), ) +import Control.Applicative (pure, liftA2, (<*>), ) + import qualified Data.Foldable as Fold import qualified Data.Traversable as Trav +import Data.Function.HT (nest, ) import qualified Algebra.Module as Module import qualified Algebra.Transcendental as Trans import qualified Algebra.Ring as Ring -import Data.Function.HT (nest, ) - -import qualified Control.Monad.Trans.State as MS -import Control.Arrow ((&&&), (>>^), (^>>), ) - -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base data Parameter a = @@ -78,8 +85,8 @@ {- 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) = +_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) @@ -117,7 +124,7 @@ type State = [] {- -Used for lowpassState, +Used for _lowpassState, list of internal values may be processed by Applicative.traverse. -} lowpassStepStack :: (Ring.C a, Module.C a v) => @@ -127,9 +134,9 @@ y1 <- Modifier.stackStatesR (Filt1.lowpassStep k) (x - f *> y0) return ((1+f) *> y1) -lowpassStepRev :: (Ring.C a, Module.C a v) => +_lowpassStepRev :: (Ring.C a, Module.C a v) => Parameter a -> v -> MS.State (State v) v -lowpassStepRev (Parameter f k) x = MS.state $ \s -> +_lowpassStepRev (Parameter f k) x = MS.state $ \s -> let news = tail (scanl (MS.evalState . Filt1.lowpassStep k) @@ -146,8 +153,8 @@ {-# INLINE lowpassCausal #-} {-# INLINE lowpassCausalStacked #-} -{-# INLINE lowpassCausalModifier #-} -lowpassCausal, lowpassCausalStacked, lowpassCausalModifier :: +{-# INLINE _lowpassCausalModifier #-} +lowpassCausal, lowpassCausalStacked, _lowpassCausalModifier :: (Ring.C a, Module.C a v) => Int -> Causal.T (Parameter a, v) v lowpassCausal = lowpassCausalStacked @@ -160,11 +167,11 @@ (snd ^>> Causal.consInit zero) >>^ (\((Parameter f _k),y1) -> (1+f) *> y1) -lowpassCausalModifier order = +_lowpassCausalModifier order = Causal.fromSimpleModifier (lowpassModifier order) -lowpass, lowpassState, lowpassRecursive :: +lowpass, _lowpassState, lowpassRecursive :: (Ring.C a, Module.C a v) => Int -> Sig.T (Parameter a) -> Sig.T v -> Sig.T v @@ -172,7 +179,7 @@ lowpass = lowpassRecursive {-| Simulate the Moog cascade by a list of states of the partial lowpasses -} -lowpassState order = +_lowpassState order = Sig.modifyModulated (lowpassModifier order) {-| The elegant way of implementing the Moog cascade by recursion -} diff --git a/src/Synthesizer/Plain/Filter/Recursive/MovingAverage.hs b/src/Synthesizer/Plain/Filter/Recursive/MovingAverage.hs --- a/src/Synthesizer/Plain/Filter/Recursive/MovingAverage.hs +++ b/src/Synthesizer/Plain/Filter/Recursive/MovingAverage.hs @@ -7,29 +7,25 @@ Stability : provisional Portability : requires multi-parameter type classes -} -module Synthesizer.Plain.Filter.Recursive.MovingAverage - (sumsStaticInt, - modulatedFrac, - ) where +module Synthesizer.Plain.Filter.Recursive.MovingAverage ( + sumsStaticInt, + modulatedFrac, + ) where import qualified Synthesizer.Plain.Signal as Sig --- import qualified Synthesizer.Plain.Modifier as Modifier import qualified Synthesizer.Plain.Filter.Recursive.Integration as Integration import Synthesizer.Plain.Filter.NonRecursive (delay, ) 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 Control.Monad.Fix (fix) import Data.List (tails) -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base diff --git a/src/Synthesizer/Plain/Filter/Recursive/SecondOrder.hs b/src/Synthesizer/Plain/Filter/Recursive/SecondOrder.hs --- a/src/Synthesizer/Plain/Filter/Recursive/SecondOrder.hs +++ b/src/Synthesizer/Plain/Filter/Recursive/SecondOrder.hs @@ -13,17 +13,30 @@ can be decomposed into first order and second order filters with real coefficients. This follows from the Fundamental theorem of algebra. -} -module Synthesizer.Plain.Filter.Recursive.SecondOrder where +module Synthesizer.Plain.Filter.Recursive.SecondOrder ( + Parameter (Parameter, c0, c1, c2, d1, d2), + State (State, u1, u2, y1, y2), + adjustPassband, + amplify, + causal, + modifier, + modifierInit, + run, + runInit, + step, + zeroState, + ) where -import Synthesizer.Plain.Filter.Recursive (Passband(Lowpass,Highpass)) import qualified Synthesizer.Plain.Signal as Sig import qualified Synthesizer.Plain.Modifier as Modifier --- import qualified Synthesizer.Plain.Control as Ctrl +import Synthesizer.Plain.Filter.Recursive (Passband(Lowpass,Highpass)) import qualified Synthesizer.Interpolation.Class as Interpol -import Synthesizer.ApplicativeUtility (liftA4, liftA5, ) -import Control.Applicative (pure, ) + import qualified Control.Applicative as App +import Control.Applicative.HT (liftA4, liftA5, ) +import Control.Applicative (pure, ) + import qualified Data.Foldable as Fold import qualified Data.Traversable as Trav @@ -38,11 +51,11 @@ import qualified Control.Monad.Trans.State as MS -import Foreign.Storable (Storable(..)) import qualified Foreign.Storable.Record as Store +import Foreign.Storable (Storable(..)) -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base {- | Parameters for a general recursive filter of 2nd order. -} diff --git a/src/Synthesizer/Plain/Filter/Recursive/SecondOrderCascade.hs b/src/Synthesizer/Plain/Filter/Recursive/SecondOrderCascade.hs --- a/src/Synthesizer/Plain/Filter/Recursive/SecondOrderCascade.hs +++ b/src/Synthesizer/Plain/Filter/Recursive/SecondOrderCascade.hs @@ -16,13 +16,18 @@ This implements a cascade of second order filters using StorableVectors for state and filter parameters. -} -module Synthesizer.Plain.Filter.Recursive.SecondOrderCascade where +module Synthesizer.Plain.Filter.Recursive.SecondOrderCascade ( + Parameter (Parameter), + State, + step, + modifierInit, + modifier, + causal, + ) where import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2 --- import Synthesizer.Plain.Filter.Recursive (Passband(Lowpass,Highpass)) import qualified Synthesizer.Plain.Signal as Sig import qualified Synthesizer.Plain.Modifier as Modifier --- import qualified Synthesizer.Plain.Control as Ctrl import qualified Synthesizer.Interpolation.Class as Interpol import qualified Synthesizer.Causal.Process as Causal @@ -35,8 +40,8 @@ import qualified Data.StorableVector as SV import Foreign.Storable (Storable(..)) -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base {- diff --git a/src/Synthesizer/Plain/Filter/Recursive/Test.hs b/src/Synthesizer/Plain/Filter/Recursive/Test.hs --- a/src/Synthesizer/Plain/Filter/Recursive/Test.hs +++ b/src/Synthesizer/Plain/Filter/Recursive/Test.hs @@ -18,8 +18,8 @@ import qualified Algebra.Transcendental as Trans import qualified Algebra.Ring as Ring -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base sampleRate :: Ring.C a => a diff --git a/src/Synthesizer/Plain/Filter/Recursive/Universal.hs b/src/Synthesizer/Plain/Filter/Recursive/Universal.hs --- a/src/Synthesizer/Plain/Filter/Recursive/Universal.hs +++ b/src/Synthesizer/Plain/Filter/Recursive/Universal.hs @@ -12,8 +12,24 @@ State variable filter. One filter that generates lowpass, bandpass, highpass, bandlimit at once. -} -module Synthesizer.Plain.Filter.Recursive.Universal where +module Synthesizer.Plain.Filter.Recursive.Universal ( + Parameter(..), + Result(..), + State, + causal, + modifier, + modifierInit, + parameter, + parameterToSecondOrderLowpass, + run, + runInit, + step, + -- for testing + parameterAlt, + parameterOld, + ) where + import Synthesizer.Plain.Filter.Recursive (Pole(..)) import qualified Synthesizer.Plain.Signal as Sig import qualified Synthesizer.Plain.Modifier as Modifier @@ -22,9 +38,12 @@ import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as SecondOrder import qualified Synthesizer.Interpolation.Class as Interpol -import Synthesizer.ApplicativeUtility (liftA4, liftA6, ) -import Control.Applicative (pure, liftA2, ) + +import qualified Control.Monad.Trans.State as MS import qualified Control.Applicative as App +import Control.Applicative.HT (liftA4, liftA6, ) +import Control.Applicative (pure, liftA2, ) + import qualified Data.Foldable as Fold import qualified Data.Traversable as Trav @@ -36,10 +55,8 @@ import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive -import qualified Control.Monad.Trans.State as MS - -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base data Parameter a = diff --git a/src/Synthesizer/Plain/IO.hs b/src/Synthesizer/Plain/IO.hs --- a/src/Synthesizer/Plain/IO.hs +++ b/src/Synthesizer/Plain/IO.hs @@ -18,17 +18,14 @@ import Control.Exception (bracket, ) import Control.Monad (liftM, ) -import Data.Monoid (mconcat, ) - import qualified Data.ByteString.Lazy as B import qualified Data.Binary.Builder as Builder - +import Data.Monoid (mconcat, ) import Data.Char (ord, ) -import qualified Prelude as P98 - -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base +import qualified Prelude as P98 diff --git a/src/Synthesizer/Plain/Instrument.hs b/src/Synthesizer/Plain/Instrument.hs --- a/src/Synthesizer/Plain/Instrument.hs +++ b/src/Synthesizer/Plain/Instrument.hs @@ -26,8 +26,8 @@ import qualified Algebra.Field as Field import qualified Algebra.Ring as Ring -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base diff --git a/src/Synthesizer/Plain/Interpolation.hs b/src/Synthesizer/Plain/Interpolation.hs --- a/src/Synthesizer/Plain/Interpolation.hs +++ b/src/Synthesizer/Plain/Interpolation.hs @@ -14,7 +14,8 @@ Interpolation.Margin, Interpolation.margin, - singleRec, -- for testing + -- for testing + singleRec, ) where import qualified Synthesizer.Interpolation as Interpolation @@ -27,19 +28,19 @@ import qualified Synthesizer.Plain.Signal as Sig import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR +import Control.Monad (guard, ) + +import qualified Data.List.HT as ListHT +import Data.Maybe (fromMaybe) + 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 -import Data.Maybe (fromMaybe) -import qualified Data.List.HT as ListHT - -import Control.Monad (guard, ) - -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base {-* Interpolation with various padding methods -} diff --git a/src/Synthesizer/Plain/LorenzAttractor.hs b/src/Synthesizer/Plain/LorenzAttractor.hs --- a/src/Synthesizer/Plain/LorenzAttractor.hs +++ b/src/Synthesizer/Plain/LorenzAttractor.hs @@ -4,8 +4,8 @@ import qualified Algebra.Module as Module import qualified Algebra.Ring as Ring -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base computeDerivatives :: (Ring.C y) => diff --git a/src/Synthesizer/Plain/Noise.hs b/src/Synthesizer/Plain/Noise.hs --- a/src/Synthesizer/Plain/Noise.hs +++ b/src/Synthesizer/Plain/Noise.hs @@ -4,15 +4,15 @@ import qualified Synthesizer.Plain.Signal as Sig -import qualified Algebra.RealRing as RealRing +import qualified Algebra.RealRing as RealRing import qualified Algebra.Ring as Ring import System.Random (Random, RandomGen, randomRs, mkStdGen, ) import Data.List.HT (sliceVertical, ) -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base {-| diff --git a/src/Synthesizer/Plain/Play.hs b/src/Synthesizer/Plain/Play.hs --- a/src/Synthesizer/Plain/Play.hs +++ b/src/Synthesizer/Plain/Play.hs @@ -12,18 +12,15 @@ import Foreign.Storable (Storable, ) import Data.Int (Int16, ) - import Data.Monoid (mconcat, ) --- import qualified Synthesizer.Frame.Stereo as Stereo +import System.Exit (ExitCode, ) import qualified Algebra.ToInteger as ToInteger import qualified Algebra.RealRing as RealRing -import System.Exit (ExitCode, ) - -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base {- | diff --git a/src/Synthesizer/Plain/Signal.hs b/src/Synthesizer/Plain/Signal.hs --- a/src/Synthesizer/Plain/Signal.hs +++ b/src/Synthesizer/Plain/Signal.hs @@ -184,16 +184,15 @@ in (zipWith f prefixX prefixY, (second, if second then suffixY else suffixX)) -zipWithRest' :: +zipWithRestRec :: (y0 -> y0 -> y1) -> T y0 -> T y0 -> (T y1, (Bool, T y0)) -zipWithRest' f = +zipWithRestRec f = let recourse xt yt = forcePair $ case (xt,yt) of - (x:xs, y:ys) -> - mapFst (f x y :) (recourse xs ys) + (x:xs, y:ys) -> mapFst (f x y :) (recourse xs ys) ([], _) -> ([], (True, yt)) (_, []) -> ([], (False, xt)) in recourse diff --git a/src/Synthesizer/Plain/ToneModulation.hs b/src/Synthesizer/Plain/ToneModulation.hs --- a/src/Synthesizer/Plain/ToneModulation.hs +++ b/src/Synthesizer/Plain/ToneModulation.hs @@ -46,15 +46,49 @@ We have to interpolate in the parallelograms. -} -module Synthesizer.Plain.ToneModulation where +module Synthesizer.Plain.ToneModulation ( + Cell, + interpolateCell, + Prototype, + makePrototype, + sampledToneCell, + + oscillatorCells, + seekCell, + oscillatorSuffixes, + + -- this function fits better in the Oscillator module + freqsToPhases, + + -- for testing + dropFrac, + dropRem, + propDropFrac, + propDropRem, + oscillatorCoords, + integrateFractional, + limitRelativeShapes, + limitMinRelativeValues, + limitMaxRelativeValues, + limitMaxRelativeValuesNonNeg, + ) where + import qualified Synthesizer.Basic.ToneModulation as ToneMod import qualified Synthesizer.Basic.Phase as Phase import qualified Synthesizer.Plain.Signal as Sig import qualified Synthesizer.Plain.Interpolation as Interpolation import Synthesizer.Interpolation (Margin, ) + +import Control.Monad (guard, ) + +import qualified Data.List as List +import qualified Data.List.HT as ListHT +import qualified Data.List.Match as ListMatch import Data.Array (Array, (!), listArray, ) +import Data.Tuple.HT (mapPair, mapSnd, forcePair, ) +import Data.Ord.HT (limit, ) import qualified Algebra.RealField as RealField import qualified Algebra.RealRing as RealRing @@ -64,17 +98,7 @@ import qualified Number.NonNegative as NonNeg import qualified Number.NonNegativeChunky as Chunky -import Control.Monad (guard, ) - -import qualified Data.List as List -import qualified Data.List.HT as ListHT -import qualified Data.List.Match as ListMatch -import Data.Ord.HT (limit, ) -import Data.Tuple.HT (mapPair, mapSnd, forcePair, ) - import NumericPrelude.Numeric - --- import qualified Prelude as P import NumericPrelude.Base diff --git a/src/Synthesizer/Plain/Wave.hs b/src/Synthesizer/Plain/Wave.hs --- a/src/Synthesizer/Plain/Wave.hs +++ b/src/Synthesizer/Plain/Wave.hs @@ -14,7 +14,6 @@ import NumericPrelude.Numeric --- import qualified Prelude as P import NumericPrelude.Base diff --git a/src/Synthesizer/State/Analysis.hs b/src/Synthesizer/State/Analysis.hs --- a/src/Synthesizer/State/Analysis.hs +++ b/src/Synthesizer/State/Analysis.hs @@ -1,13 +1,38 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} -module Synthesizer.State.Analysis where +module Synthesizer.State.Analysis ( + volumeMaximum, + volumeEuclidean, + volumeEuclideanSqr, + volumeSum, + volumeVectorMaximum, + volumeVectorEuclidean, + volumeVectorEuclideanSqr, + volumeVectorSum, + bounds, + histogramDiscreteArray, + histogramLinearArray, + histogramDiscreteIntMap, + histogramLinearIntMap, + histogramIntMap, + directCurrentOffset, + scalarProduct, + centroid, + centroidRecompute, + firstMoment, + average, + averageRecompute, + rectify, + zeros, + flipFlopHysteresis, + chirpTransform, + ) where +import qualified Synthesizer.Plain.Analysis as Ana import qualified Synthesizer.State.Control as Ctrl import qualified Synthesizer.State.Signal as Sig --- import qualified Algebra.Module as Module --- import qualified Algebra.Transcendental as Trans import qualified Algebra.Algebraic as Algebraic import qualified Algebra.RealField as RealField import qualified Algebra.Field as Field @@ -25,8 +50,8 @@ import Data.Array (accumArray) -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base {- * Notions of volume -} @@ -256,23 +281,7 @@ {-# INLINE meanValues #-} meanValues :: RealField.C y => Sig.T y -> [(Int,y)] -meanValues x = concatMap spread (Sig.toList (Sig.mapAdjacent (,) x)) - -{-# INLINE spread #-} -spread :: RealField.C y => (y,y) -> [(Int,y)] -spread (l0,r0) = - let (l,r) = if l0<=r0 then (l0,r0) else (r0,l0) - (li,lf) = splitFraction l - (ri,rf) = splitFraction r - k = recip (r-l) - nodes = - (li,k*(1-lf)) : - zip [li+1 ..] (replicate (ri-li-1) k) ++ - (ri, k*rf) : - [] - in if li==ri - then [(li,one)] - else nodes +meanValues = concatMap Ana.spread . Sig.toList . Sig.mapAdjacent (,) {- | Requires finite length. @@ -347,13 +356,8 @@ -} {-# INLINE flipFlopHysteresis #-} flipFlopHysteresis :: (Ord y) => - (y,y) -> Bool -> Sig.T y -> Sig.T Bool -flipFlopHysteresis (lower,upper) = - Sig.scanL - (\state x -> - if state - then not(xupper) + (y,y) -> Ana.BinaryLevel -> Sig.T y -> Sig.T Ana.BinaryLevel +flipFlopHysteresis bnds = Sig.scanL (Ana.flipFlopHysteresisStep bnds) {- | Almost naive implementation of the chirp transform, diff --git a/src/Synthesizer/State/Control.hs b/src/Synthesizer/State/Control.hs --- a/src/Synthesizer/State/Control.hs +++ b/src/Synthesizer/State/Control.hs @@ -9,25 +9,35 @@ Stability : provisional Portability : requires multi-parameter type classes -} -module Synthesizer.State.Control where +module Synthesizer.State.Control ( + constant, + line, + linear, linearMultiscale, linearMultiscaleNeutral, + exponential, exponentialMultiscale, exponentialMultiscaleNeutral, + exponential2, exponential2Multiscale, exponential2MultiscaleNeutral, + exponentialFromTo, exponentialFromToMultiscale, + vectorExponential, + vectorExponential2, + cosine, + cubicHermite, + -- used in Analysis + curveMultiscale, + curveMultiscaleNeutral, + ) where + import qualified Synthesizer.Plain.Control as Ctrl -import qualified Synthesizer.Piecewise as Piecewise -import Synthesizer.State.Displacement (raise) import qualified Synthesizer.State.Signal as Sig import qualified Algebra.Module as Module import qualified Algebra.Transcendental as Trans -import qualified Algebra.RealRing as RealRing import qualified Algebra.Field as Field import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive -import Data.Ix (Ix, ) - -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base {- * Control curve generation -} @@ -181,94 +191,6 @@ 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 - - -splitDurations :: (RealRing.C t) => - [t] -> [(Int, t)] -splitDurations ts0 = - let (ds,ts) = - unzip $ scanl - (\(_,fr) d -> splitFraction (fr+d)) - (0,1) ts0 - in zip (tail ds) (map (subtract 1) ts) - -{-# INLINE piecewise #-} -piecewise :: (RealRing.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+(1-y)*y1)/2) - (cosine t0 (t0+d)) - - -data FlatPosition = - FlatLeft | FlatRight - deriving (Show, Eq, Ord, Ix, Enum) - -{- | -> Graphics.Gnuplot.Simple.plotList [] $ Sig.toList $ piecewise $ 1 |# (10.9, halfSinePiece FlatRight) #| 2 --} -{-# INLINE halfSinePiece #-} -halfSinePiece :: (Trans.C a) => FlatPosition -> Piece a -halfSinePiece FlatLeft = - Piecewise.pieceFromFunction $ \ y0 y1 d t0 -> - Sig.map - (\y -> y*y0 + (1-y)*y1) - (cosine t0 (t0+2*d)) -halfSinePiece FlatRight = - Piecewise.pieceFromFunction $ \ y0 y1 d t0 -> - Sig.map - (\y -> (1+y)*y0 - y*y1) - (cosine (t0-d) (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)) -- * auxiliary functions diff --git a/src/Synthesizer/State/Cut.hs b/src/Synthesizer/State/Cut.hs --- a/src/Synthesizer/State/Cut.hs +++ b/src/Synthesizer/State/Cut.hs @@ -34,20 +34,20 @@ import qualified Algebra.RealRing as RealRing import qualified Algebra.Additive as Additive -import qualified Data.Array as Array -import Data.Array (Array, Ix, (!), ) import Control.Applicative (Applicative, ) -import Data.Traversable (sequenceA, ) import qualified Data.List.HT as ListHT +import qualified Data.Array as Array +import Data.Traversable (sequenceA, ) import Data.Tuple.HT (mapFst, mapSnd, ) +import Data.Array (Array, Ix, (!), ) import Data.Maybe (fromMaybe, ) import qualified Synthesizer.ChunkySize as ChunkySize import qualified Number.NonNegative as NonNegW -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base diff --git a/src/Synthesizer/State/Displacement.hs b/src/Synthesizer/State/Displacement.hs --- a/src/Synthesizer/State/Displacement.hs +++ b/src/Synthesizer/State/Displacement.hs @@ -7,8 +7,8 @@ import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base -- * Mixing diff --git a/src/Synthesizer/State/Filter/Delay.hs b/src/Synthesizer/State/Filter/Delay.hs --- a/src/Synthesizer/State/Filter/Delay.hs +++ b/src/Synthesizer/State/Filter/Delay.hs @@ -1,5 +1,11 @@ {-# LANGUAGE NoImplicitPrelude #-} -module Synthesizer.State.Filter.Delay where +module Synthesizer.State.Filter.Delay ( + static, + staticPad, + staticPos, + staticNeg, + modulated, + ) where import qualified Synthesizer.Interpolation as Interpolation import qualified Synthesizer.State.Interpolation as InterpolationS @@ -8,8 +14,6 @@ import qualified Algebra.RealField as RealField import qualified Algebra.Additive as Additive --- import qualified Prelude as P --- import NumericPrelude.Base import NumericPrelude.Numeric diff --git a/src/Synthesizer/State/Filter/NonRecursive.hs b/src/Synthesizer/State/Filter/NonRecursive.hs --- a/src/Synthesizer/State/Filter/NonRecursive.hs +++ b/src/Synthesizer/State/Filter/NonRecursive.hs @@ -7,8 +7,25 @@ Stability : provisional Portability : requires multi-parameter type classes -} -module Synthesizer.State.Filter.NonRecursive where +module Synthesizer.State.Filter.NonRecursive ( + amplify, + amplifyVector, + envelope, + envelopeVector, + fadeInOut, + generic, + binomial, + binomial1, + sums, + inverseFrequencyModulationFloor, + inverseFrequencyModulationCeiling, + differentiate, + differentiateCenter, + differentiate2, + ) where +import Synthesizer.Basic.Filter.NonRecursive (ratioFreqToVariance, ) + import qualified Synthesizer.State.Signal as Sig import qualified Synthesizer.State.Filter.Delay as Delay @@ -24,8 +41,8 @@ import Data.Function.HT (nest, ) import Data.Tuple.HT (mapFst, ) -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base @@ -124,30 +141,6 @@ 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 diff --git a/src/Synthesizer/State/Filter/Recursive/Comb.hs b/src/Synthesizer/State/Filter/Recursive/Comb.hs --- a/src/Synthesizer/State/Filter/Recursive/Comb.hs +++ b/src/Synthesizer/State/Filter/Recursive/Comb.hs @@ -23,8 +23,8 @@ import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base {- | diff --git a/src/Synthesizer/State/Filter/Recursive/Integration.hs b/src/Synthesizer/State/Filter/Recursive/Integration.hs --- a/src/Synthesizer/State/Filter/Recursive/Integration.hs +++ b/src/Synthesizer/State/Filter/Recursive/Integration.hs @@ -14,12 +14,10 @@ import qualified Synthesizer.State.Signal as Sig import qualified Synthesizer.Causal.Process as Causal --- import qualified Algebra.Field as Field --- import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base diff --git a/src/Synthesizer/State/Filter/Recursive/MovingAverage.hs b/src/Synthesizer/State/Filter/Recursive/MovingAverage.hs --- a/src/Synthesizer/State/Filter/Recursive/MovingAverage.hs +++ b/src/Synthesizer/State/Filter/Recursive/MovingAverage.hs @@ -8,10 +8,10 @@ Portability : requires multi-parameter type classes -} -module Synthesizer.State.Filter.Recursive.MovingAverage - (sumsStaticInt, - modulatedFrac, - ) where +module Synthesizer.State.Filter.Recursive.MovingAverage ( + sumsStaticInt, + modulatedFrac, + ) where import qualified Synthesizer.State.Signal as Sig import qualified Synthesizer.State.Filter.Recursive.Integration as Integration @@ -20,13 +20,10 @@ import qualified Algebra.Module as Module import qualified Algebra.RealField as RealField - --- import qualified Algebra.Field as Field --- import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base diff --git a/src/Synthesizer/State/Interpolation.hs b/src/Synthesizer/State/Interpolation.hs --- a/src/Synthesizer/State/Interpolation.hs +++ b/src/Synthesizer/State/Interpolation.hs @@ -1,17 +1,27 @@ {-# LANGUAGE NoImplicitPrelude #-} -module Synthesizer.State.Interpolation where +module Synthesizer.State.Interpolation ( + zeroPad, + constantPad, + cyclicPad, + extrapolationPad, -import Synthesizer.Interpolation - (T, offset, number, func, ) + skip, + single, -import qualified Synthesizer.State.Signal as Sig + -- imported in State.Filter.Delay + delayPad, + ) where -import qualified Algebra.RealRing as RealRing +import Synthesizer.Interpolation (T, offset, number, func, ) +import qualified Synthesizer.State.Signal as Sig + import Data.Maybe (fromMaybe) -import NumericPrelude.Base +import qualified Algebra.RealRing as RealRing + import NumericPrelude.Numeric +import NumericPrelude.Base {-* Interpolation with various padding methods -} diff --git a/src/Synthesizer/State/Noise.hs b/src/Synthesizer/State/Noise.hs --- a/src/Synthesizer/State/Noise.hs +++ b/src/Synthesizer/State/Noise.hs @@ -4,14 +4,14 @@ import qualified Synthesizer.State.Signal as Sig -import qualified Algebra.RealRing as RealRing +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 NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base {-| diff --git a/src/Synthesizer/State/NoiseCustom.hs b/src/Synthesizer/State/NoiseCustom.hs --- a/src/Synthesizer/State/NoiseCustom.hs +++ b/src/Synthesizer/State/NoiseCustom.hs @@ -8,16 +8,15 @@ import qualified Synthesizer.State.Signal as Sig -import qualified Algebra.RealField as RealField -import qualified Algebra.Field as Field - import qualified Synthesizer.RandomKnuth as Knuth - -import System.Random (Random, RandomGen, ) import qualified System.Random as Rnd +import System.Random (Random, RandomGen, ) -import NumericPrelude.Base +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field + import NumericPrelude.Numeric +import NumericPrelude.Base {-| diff --git a/src/Synthesizer/State/Oscillator.hs b/src/Synthesizer/State/Oscillator.hs --- a/src/Synthesizer/State/Oscillator.hs +++ b/src/Synthesizer/State/Oscillator.hs @@ -13,25 +13,21 @@ import qualified Synthesizer.Causal.Oscillator as Osci import qualified Synthesizer.Causal.Oscillator.Core as OsciCore +import qualified Synthesizer.Causal.Process as Causal + import qualified Synthesizer.Basic.WaveSmoothed as WaveSmooth import qualified Synthesizer.Basic.Wave as Wave import qualified Synthesizer.Basic.Phase as Phase -import qualified Synthesizer.Causal.Process as Causal import qualified Synthesizer.State.Signal as Sig - import qualified Synthesizer.Generic.Signal as SigG - import qualified Synthesizer.Interpolation as Interpolation - import qualified Algebra.Transcendental as Trans import qualified Algebra.RealField as RealField import qualified Algebra.RealRing as RealRing --- import qualified Prelude as P import NumericPrelude.Numeric (Float, Double, ) --- import NumericPrelude.Base diff --git a/src/Synthesizer/State/Piece.hs b/src/Synthesizer/State/Piece.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/State/Piece.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{- | +See "Synthesizer.Generic.Piece". +-} +module Synthesizer.State.Piece ( + T, run, + step, linear, exponential, + cosine, halfSine, cubic, + FlatPosition(..), + ) where + +import qualified Synthesizer.Piecewise as Piecewise +import Synthesizer.Piecewise (FlatPosition (FlatLeft, FlatRight)) + +import qualified Synthesizer.State.Control as Ctrl +import qualified Synthesizer.State.Signal as Sig +import Synthesizer.State.Displacement (raise) + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealRing as RealRing +import qualified Algebra.Field as Field + +import NumericPrelude.Numeric +import NumericPrelude.Base + + + +{-# INLINE run #-} +run :: (RealRing.C a) => Piecewise.T a a (a -> Sig.T a) -> Sig.T a +run xs = + Sig.concat $ zipWith + (\(n, t) (Piecewise.PieceData c yi0 yi1 d) -> + Sig.take n $ Piecewise.computePiece c yi0 yi1 d t) + (Piecewise.splitDurations $ map Piecewise.pieceDur xs) + xs + + +type T a = Piecewise.Piece a a (a {- fractional start time -} -> Sig.T a) + + +{-# INLINE step #-} +step :: T a +step = + Piecewise.pieceFromFunction $ \ y0 _y1 _d _t0 -> + Ctrl.constant y0 + +{-# INLINE linear #-} +linear :: (Field.C a) => T a +linear = + Piecewise.pieceFromFunction $ \ y0 y1 d t0 -> + let s = (y1-y0)/d in Ctrl.linear s (y0-t0*s) + +{-# INLINE exponential #-} +exponential :: (Trans.C a) => a -> T a +exponential saturation = + Piecewise.pieceFromFunction $ \ y0 y1 d t0 -> + let y0' = y0-saturation + y1' = y1-saturation + yd = y0'/y1' + in raise saturation + (Ctrl.exponential (d / log yd) (y0' * yd**(t0/d))) + +{-# INLINE cosine #-} +cosine :: (Trans.C a) => T a +cosine = + Piecewise.pieceFromFunction $ \ y0 y1 d t0 -> + Sig.map + (\y -> ((1+y)*y0+(1-y)*y1)/2) + (Ctrl.cosine t0 (t0+d)) + + +{- | +> Graphics.Gnuplot.Simple.plotList [] $ Sig.toList $ Piece.run $ 1 |# (10.9, Piece.halfSine FlatRight) #| 2 +-} +{-# INLINE halfSine #-} +halfSine :: (Trans.C a) => FlatPosition -> T a +halfSine FlatLeft = + Piecewise.pieceFromFunction $ \ y0 y1 d t0 -> + Sig.map + (\y -> y*y0 + (1-y)*y1) + (Ctrl.cosine t0 (t0+2*d)) +halfSine FlatRight = + Piecewise.pieceFromFunction $ \ y0 y1 d t0 -> + Sig.map + (\y -> (1+y)*y0 - y*y1) + (Ctrl.cosine (t0-d) (t0+d)) + + +{-# INLINE cubic #-} +cubic :: (Field.C a) => a -> a -> T a +cubic yd0 yd1 = + Piecewise.pieceFromFunction $ \ y0 y1 d t0 -> + Ctrl.cubicHermite (t0,(y0,yd0)) (t0+d,(y1,yd1)) diff --git a/src/Synthesizer/State/Signal.hs b/src/Synthesizer/State/Signal.hs --- a/src/Synthesizer/State/Signal.hs +++ b/src/Synthesizer/State/Signal.hs @@ -10,15 +10,13 @@ -} module Synthesizer.State.Signal where --- import qualified Synthesizer.Plain.Signal as Sig import qualified Synthesizer.Plain.Modifier as Modifier import qualified Data.List as List import qualified Algebra.Module as Module import qualified Algebra.Additive as Additive -import Algebra.Additive (zero) - import Algebra.Module ((*>)) +import Algebra.Additive (zero) import qualified Synthesizer.Format as Format diff --git a/src/Synthesizer/State/ToneModulation.hs b/src/Synthesizer/State/ToneModulation.hs --- a/src/Synthesizer/State/ToneModulation.hs +++ b/src/Synthesizer/State/ToneModulation.hs @@ -1,5 +1,23 @@ -module Synthesizer.State.ToneModulation where +module Synthesizer.State.ToneModulation ( + Cell, + makeCell, + interpolateCell, + Prototype, + makePrototype, + sampledToneCell, + + oscillatorCells, + + -- needed in Causal.ToneModulation + checkNonNeg, + + -- for testing + oscillatorCoords, + limitRelativeShapes, + limitMinRelativeValues, + ) where + import qualified Synthesizer.Basic.ToneModulation as ToneMod import qualified Synthesizer.Causal.Oscillator.Core as Osci @@ -12,17 +30,12 @@ import qualified Synthesizer.Basic.Phase as Phase --- import qualified Algebra.Transcendental as Trans import qualified Algebra.RealField as RealField --- import qualified Algebra.Field as Field --- import qualified Algebra.RealRing as RealRing --- import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive import Data.Ord.HT (limit, ) import NumericPrelude.Numeric --- import qualified Prelude as P import NumericPrelude.Base import Prelude () diff --git a/src/Synthesizer/Storable/Cut.hs b/src/Synthesizer/Storable/Cut.hs --- a/src/Synthesizer/Storable/Cut.hs +++ b/src/Synthesizer/Storable/Cut.hs @@ -1,24 +1,33 @@ -module Synthesizer.Storable.Cut where +module Synthesizer.Storable.Cut ( + arrange, + -- for MIDI.CausalIO.Process + addChunkToBuffer, + + -- for testing + arrangeEquidist, + arrangeAdaptive, + arrangeList, + ) where + import qualified Synthesizer.Storable.Signal as Sig import qualified Data.StorableVector as SV import qualified Data.StorableVector.Lazy as SVL import qualified Data.StorableVector.ST.Strict as SVST +import Foreign.Storable (Storable) import Control.Monad.ST.Strict (ST, runST, ) +import Control.Monad.Trans.State (runState, modify, gets, put, ) import qualified Data.EventList.Relative.TimeBody as EventList import qualified Data.EventList.Relative.TimeMixed as EventListTM import qualified Data.EventList.Absolute.TimeBody as AbsEventList -import Control.Monad.Trans.State (runState, modify, gets, put, ) import Data.Tuple.HT (mapSnd, ) import qualified Algebra.Additive as Additive import qualified Number.NonNegative as NonNeg -import Foreign.Storable (Storable) - import NumericPrelude.Numeric import NumericPrelude.Base import Prelude () @@ -211,10 +220,10 @@ in go start 0 {- | chunk must fit into the buffer -} -{-# INLINE unsafeAddChunkToBufferFoldr #-} -unsafeAddChunkToBufferFoldr :: (Storable a, Additive.C a) => +{-# INLINE _unsafeAddChunkToBufferFoldr #-} +_unsafeAddChunkToBufferFoldr :: (Storable a, Additive.C a) => SVST.Vector s a -> Int -> SV.Vector a -> ST s () -unsafeAddChunkToBufferFoldr v start xs = +_unsafeAddChunkToBufferFoldr v start xs = SV.foldr (\x continue i -> SVST.unsafeModify v i (x +) >> @@ -224,10 +233,10 @@ -- most elegant solution, but slow because StorableVector.foldr is slow -{-# INLINE addToBufferFoldr #-} -addToBufferFoldr :: (Storable a, Additive.C a) => +{-# INLINE _addToBufferFoldr #-} +_addToBufferFoldr :: (Storable a, Additive.C a) => SVST.Vector s a -> Int -> Sig.T a -> ST s (Int, Sig.T a) -addToBufferFoldr v start xs = +_addToBufferFoldr v start xs = let n = SVST.length v (now,future) = Sig.splitAt (n Additive.- start) xs in Sig.foldr @@ -244,9 +253,9 @@ Using a StorableVectorPointer would be faster, but I think still slower than @foldr@. -} -addToBufferSwitchL :: (Storable a, Additive.C a) => +_addToBufferSwitchL :: (Storable a, Additive.C a) => SVST.Vector s a -> Int -> Sig.T a -> ST s (Int, Sig.T a) -addToBufferSwitchL v start = +_addToBufferSwitchL v start = let n = SVST.length v {-# INLINE go #-} go i = diff --git a/src/Synthesizer/Storable/Filter/NonRecursive.hs b/src/Synthesizer/Storable/Filter/NonRecursive.hs --- a/src/Synthesizer/Storable/Filter/NonRecursive.hs +++ b/src/Synthesizer/Storable/Filter/NonRecursive.hs @@ -8,16 +8,30 @@ Stability : provisional Portability : requires multi-parameter type classes -} -module Synthesizer.Storable.Filter.NonRecursive where +module Synthesizer.Storable.Filter.NonRecursive ( + downsample2, + sumsDownsample2, + convolveDownsample2, + inverseFrequencyModulationFloor, + sumsPosModulatedPyramid, + accumulatePosModulatedPyramid, + accumulateBinPosModulatedPyramid, + movingAverageModulatedPyramid, + movingAccumulateModulatedPyramid, + -- for testing + sumsDownsample2Alt, + pyramid, + ) where + import qualified Synthesizer.Storable.Signal as SigSt import qualified Data.StorableVector as V import qualified Data.StorableVector.Pointer as VPtr import qualified Data.StorableVector.Lazy as VL import qualified Data.StorableVector.Lazy.Pattern as VP +import qualified Synthesizer.Basic.Filter.NonRecursive as Filt import qualified Synthesizer.Generic.Filter.NonRecursive as FiltG -import qualified Synthesizer.Plain.Filter.NonRecursive as Filt import qualified Synthesizer.Generic.Signal as SigG import qualified Synthesizer.State.Signal as SigS import qualified Synthesizer.Plain.Signal as Sig @@ -31,16 +45,16 @@ import Foreign.Storable.Tuple () import Control.Monad (mplus, ) -import Data.Maybe.HT (toMaybe, ) -import Data.Maybe (fromMaybe, ) import qualified Data.List as List import Data.Tuple.HT (mapFst, mapSnd, mapPair, swap, ) +import Data.Maybe.HT (toMaybe, ) +import Data.Maybe (fromMaybe, ) import qualified Numeric.NonNegative.Chunky as NonNegChunky -import NumericPrelude.Base -import NumericPrelude.Numeric as NP +import NumericPrelude.Numeric +import NumericPrelude.Base as NP {- | @@ -186,11 +200,8 @@ SigSt.T (Int,Int) -> SigSt.T v accumulatePosModulatedPyramid accumulate (sizes,pyr0) ctrl = let blockSize = head sizes - pyrStarts = - iterate (zipWith SigSt.drop sizes) pyr0 - ctrlBlocks = - SigS.toList $ - SigG.sliceVertical blockSize ctrl + pyrStarts = iterate (zipWith SigSt.drop sizes) pyr0 + ctrlBlocks = SigS.toList $ SigG.sliceVertical blockSize ctrl in SigSt.fromChunks $ zipWith (\pyr -> @@ -206,9 +217,7 @@ sumsPosModulatedPyramid height ctrl xs = FiltG.accumulatePosModulatedFromPyramid FiltG.sumRangeFromPyramid - (let pyr0 = pyramid (+) height xs - sizes = Filt.unitSizesFromPyramid pyr0 - in (sizes, pyr0)) + (addSizes $ pyramid (+) height xs) ctrl accumulateBinPosModulatedPyramid :: @@ -220,12 +229,13 @@ (\pyr -> fromMaybe (error "accumulateBinPosModulatedPyramid: empty window") . FiltG.maybeAccumulateRangeFromPyramid acc pyr) - (let pyr0 = pyramid acc height xs - sizes = Filt.unitSizesFromPyramid pyr0 - in (sizes, pyr0)) + (addSizes $ pyramid acc height xs) ctrl +addSizes :: [signal] -> ([Int], [signal]) +addSizes pyr = (Filt.unitSizesFromPyramid pyr, pyr) + {- | The first argument is the amplification. The main reason to introduce it, @@ -233,8 +243,7 @@ This way we can also filter stereo signals. -} movingAverageModulatedPyramid :: - (Field.C a, Module.C a v, - Storable Int, Storable v) => + (Field.C a, Module.C a v, Storable Int, Storable v) => a -> Int -> Int -> SigSt.T Int -> SigSt.T v -> SigSt.T v movingAverageModulatedPyramid amp height maxC ctrl xs = SigSt.zipWith (\c x -> (amp / fromIntegral (2*c+1)) *> x) ctrl $ @@ -293,8 +302,9 @@ let {-# INLINE switch #-} {- switch :: - (Maybe s -> r) -> - ((t,v) -> (s, VPtr.Pointer v) -> r) -> + (Maybe (t, s) -> r) -> + ((t, v) -> (s, VPtr.Pointer v) -> r) -> + t -> (s, VPtr.Pointer v) -> r -} {- @@ -315,7 +325,7 @@ {- go :: (t,v) -> (s, VPtr.Pointer v) -> - Either (Maybe s) (v, ((t,v), (s, VPtr.Pointer v))) + Either (Maybe (t,s)) (v, ((t,v), (s, VPtr.Pointer v))) -} go (c,x) cxp = if c<1 diff --git a/src/Synthesizer/Storable/Oscillator.hs b/src/Synthesizer/Storable/Oscillator.hs --- a/src/Synthesizer/Storable/Oscillator.hs +++ b/src/Synthesizer/Storable/Oscillator.hs @@ -18,15 +18,6 @@ import Synthesizer.Storable.Signal (ChunkSize) import Foreign.Storable (Storable) --- import qualified Synthesizer.Plain.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.RealRing as RealRing diff --git a/src/Synthesizer/Storable/Play.hs b/src/Synthesizer/Storable/Play.hs --- a/src/Synthesizer/Storable/Play.hs +++ b/src/Synthesizer/Storable/Play.hs @@ -11,12 +11,12 @@ import qualified Synthesizer.Storable.Signal as SigSt import qualified Synthesizer.Frame.Stereo as Stereo -import qualified Algebra.RealRing as RealRing - import System.Exit (ExitCode, ) -import NumericPrelude.Base +import qualified Algebra.RealRing as RealRing + import NumericPrelude.Numeric +import NumericPrelude.Base {- | diff --git a/src/Synthesizer/Storable/Signal.hs b/src/Synthesizer/Storable/Signal.hs --- a/src/Synthesizer/Storable/Signal.hs +++ b/src/Synthesizer/Storable/Signal.hs @@ -8,58 +8,58 @@ instead of calling a function in an inner loop. -} module Synthesizer.Storable.Signal ( - T, - Vector.hPut, - ChunkSize, Vector.chunkSize, defaultChunkSize, - -- for Storable.Oscillator - scanL, - Vector.map, - Vector.iterate, - Vector.zipWith, - -- for State.Signal - Vector.append, - Vector.concat, - Vector.span, - Vector.splitAt, - Vector.viewL, - Vector.viewR, - Vector.switchL, - Vector.unfoldr, - Vector.reverse, - Vector.crochetL, - -- for Dimensional.File - Vector.writeFile, - -- for Storable.Cut - mix, mixSndPattern, mixSize, - splitAtPad, - Vector.null, - Vector.fromChunks, - Vector.foldr, - -- for Storable.Filter.Comb - delay, - delayLoop, - delayLoopOverlap, - -- for FusionList.Storable - Vector.empty, - Vector.cons, - Vector.replicate, - Vector.repeat, - Vector.drop, - Vector.take, - takeCrochet, - fromList, - -- for Generic.Signal - zipWithRest, - zipWithAppend, - -- for Storable.ALSA.MIDI - Vector.switchR, - -- for Test.Filter - toList, - -- for Storable.Filter.NonRecursive - Vector.chunks, + T, + Vector.hPut, + ChunkSize, Vector.chunkSize, defaultChunkSize, + -- for Storable.Oscillator + scanL, + Vector.map, + Vector.iterate, + Vector.zipWith, + -- for State.Signal + Vector.append, + Vector.concat, + Vector.span, + Vector.splitAt, + Vector.viewL, + Vector.viewR, + Vector.switchL, + Vector.unfoldr, + Vector.reverse, + Vector.crochetL, + -- for Dimensional.File + Vector.writeFile, + -- for Storable.Cut + mix, mixSndPattern, mixSize, + splitAtPad, + Vector.null, + Vector.fromChunks, + Vector.foldr, + -- for Storable.Filter.Comb + delay, + delayLoop, + delayLoopOverlap, + -- for FusionList.Storable + Vector.empty, + Vector.cons, + Vector.replicate, + Vector.repeat, + Vector.drop, + Vector.take, + takeCrochet, + fromList, + -- for Generic.Signal + zipWithRest, + zipWithAppend, + -- for Storable.ALSA.MIDI + Vector.switchR, + -- for Test.Filter + toList, + -- for Storable.Filter.NonRecursive + Vector.chunks, - -- just for fun - genericLength, + -- just for fun + genericLength, ) where import qualified Data.List as List @@ -68,17 +68,14 @@ import qualified Data.StorableVector as V import Data.StorableVector.Lazy (ChunkSize(..)) --- import Data.Maybe (Maybe(Just,Nothing), maybe, fromMaybe) - --- import Data.StorableVector(Vector) import Foreign.Storable (Storable, ) import Foreign.Storable.Tuple () import qualified Synthesizer.Frame.Stereo as Stereo --- import qualified Synthesizer.Format as Format --- import Control.Arrow ((***)) --- import Control.Monad (liftM, liftM2, {- guard, -} ) +import qualified Data.List.HT as ListHT +import Data.Maybe.HT (toMaybe, ) +import Data.Tuple.HT (mapFst, mapSnd, mapPair, forcePair, ) import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive @@ -86,16 +83,6 @@ import qualified Number.NonNegativeChunky as Chunky import qualified Number.NonNegative as NonNeg - -import qualified Data.List.HT as ListHT -import Data.Maybe.HT (toMaybe, ) -import Data.Tuple.HT (mapFst, mapSnd, mapPair, forcePair, ) - --- import qualified Algebra.Additive as Additive - - --- import System.IO (openBinaryFile, hClose, hPutBuf, IOMode(WriteMode), Handle) - import NumericPrelude.Numeric import NumericPrelude.Base diff --git a/src/Synthesizer/Utility.hs b/src/Synthesizer/Utility.hs --- a/src/Synthesizer/Utility.hs +++ b/src/Synthesizer/Utility.hs @@ -7,9 +7,9 @@ import System.Random (Random, RandomGen, randomRs, ) -import Prelude () -import NumericPrelude.Base import NumericPrelude.Numeric +import NumericPrelude.Base +import Prelude () {-| diff --git a/src/Synthesizer/Zip.hs b/src/Synthesizer/Zip.hs --- a/src/Synthesizer/Zip.hs +++ b/src/Synthesizer/Zip.hs @@ -2,10 +2,10 @@ import qualified Synthesizer.Generic.Cut as CutG -import Data.Monoid (Monoid, mempty, mappend, ) - import qualified Control.Arrow as Arrow import Control.Arrow (Arrow, (<<<), (^<<), (<<^), ) + +import Data.Monoid (Monoid, mempty, mappend, ) {- | 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.7.1 +Version: 0.8 License: GPL License-File: LICENSE Author: Henning Thielemann @@ -37,7 +37,7 @@ Source-Repository this - Tag: 0.7.1 + Tag: 0.8 Type: darcs Location: http://code.haskell.org/synthesizer/core/ @@ -49,16 +49,15 @@ Build-Depends: sample-frame-np >=0.0.4 && <0.1, sox >=0.1 && <0.3, - transformers >=0.2 && <0.5, - non-empty >=0.2 && <0.3, + transformers >=0.2 && <0.6, + non-empty >=0.2 && <0.4, event-list >=0.1 && <0.2, non-negative >=0.1 && <0.2, explicit-exception >=0.1.6 && <0.2, - numeric-prelude >=0.4 && <0.5, + numeric-prelude >=0.4.2 && <0.5, numeric-quest >=0.1 && <0.3, - utility-ht >=0.0.5 && <0.1, + utility-ht >=0.0.12 && <0.1, filepath >=1.1 && <1.5, - stream-fusion >=0.1.2 && <0.2, bytestring >=0.9 && <0.11, binary >=0.1 && <1, deepseq >=1.1 && <1.5, @@ -69,7 +68,7 @@ array >=0.1 && <0.6, containers >=0.1 && <0.6, random >=1.0 && <2.0, - process >=1.0 && <1.3, + process >=1.0 && <1.5, base >= 4 && <5 If impl(ghc>=7.0) @@ -167,6 +166,7 @@ Synthesizer.State.Noise Synthesizer.State.NoiseCustom Synthesizer.State.Oscillator + Synthesizer.State.Piece Synthesizer.State.Signal Synthesizer.State.ToneModulation Synthesizer.Causal.Process @@ -214,6 +214,7 @@ Synthesizer.Utility Other-Modules: + Synthesizer.Basic.Filter.NonRecursive Synthesizer.Basic.ComplexModule Synthesizer.Basic.NumberTheory Synthesizer.Generic.Permutation @@ -227,7 +228,7 @@ storablevector, storable-tuple, event-list, - non-empty >=0.2.1 && <0.3, + non-empty >=0.2.1 && <0.4, non-negative, utility-ht, numeric-prelude, 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 @@ -3,6 +3,9 @@ import Synthesizer.Basic.NumberTheory (Order(Order), ) import qualified Synthesizer.Basic.NumberTheory as NT + +import Control.Applicative ((<$>), ) + import qualified Data.Set as Set import qualified Data.Bits as Bit @@ -35,11 +38,7 @@ deriving (Show) instance Arbitrary Prime where - arbitrary = do - n <- fmap ((2+) . flip mod 10000) arbitrary - if NT.isPrime n - then return $ Prime n - else arbitrary + arbitrary = fmap Prime $ QC.suchThat (QC.choose (2,10000)) NT.isPrime newtype Big = Big Integer @@ -115,9 +114,8 @@ && NT.hasPrimitiveRootOfUnityInteger r n) : ("combine many rings with primitive roots of certain orders", - quickCheck $ \n0 ns0 -> - let ns = take 3 $ map (\n -> 1 + mod n 10) (n0:ns0) - order = NT.lcmMulti ns + quickCheck $ QC.forAll (take 3 <$> QC.listOf1 (QC.choose (1,10))) $ \ns -> + let order = NT.lcmMulti ns in take 3 (NT.ringsWithPrimitiveRootsOfUnityAndUnitsNaive (map Order ns) ns) == @@ -165,14 +163,14 @@ ("ceiling5Smooth vs. is5Smooth", quickCheck $ \(Positive n) -> NT.is5Smooth $ NT.ceiling5Smooth n) : ("ceiling3Smooth vs. numbers3Smooth", - simple $ \(Positive k) -> - let (n0:n1:_) = drop (fromInteger $ mod k 500) NT.numbers3Smooth + quickCheck $ QC.forAll (QC.choose (0,500)) $ \k -> + let (n0:n1:_) = drop k NT.numbers3Smooth in NT.ceiling3Smooth n0 == n0 && NT.ceiling3Smooth (n0+1) == n1) : ("ceiling5Smooth vs. numbers5Smooth", - simple $ \(Positive k) -> - let (n0:n1:_) = drop (fromInteger $ mod k 500) NT.numbers5Smooth + quickCheck $ QC.forAll (QC.choose (0,500)) $ \k -> + let (n0:n1:_) = drop k NT.numbers5Smooth in NT.ceiling5Smooth n0 == n0 && NT.ceiling5Smooth (n0+1) == n1) : diff --git a/test/Test/Sound/Synthesizer/Basic/ToneModulation.hs b/test/Test/Sound/Synthesizer/Basic/ToneModulation.hs --- a/test/Test/Sound/Synthesizer/Basic/ToneModulation.hs +++ b/test/Test/Sound/Synthesizer/Basic/ToneModulation.hs @@ -9,7 +9,6 @@ import qualified Test.Sound.Synthesizer.Plain.Interpolation as InterpolationTest import Test.QuickCheck (quickCheck, Property, (==>), Testable, ) --- import Test.Utility import qualified Number.NonNegative as NonNeg diff --git a/test/Test/Sound/Synthesizer/Causal/Analysis.hs b/test/Test/Sound/Synthesizer/Causal/Analysis.hs --- a/test/Test/Sound/Synthesizer/Causal/Analysis.hs +++ b/test/Test/Sound/Synthesizer/Causal/Analysis.hs @@ -11,6 +11,7 @@ import qualified Data.List.Match as Match import qualified Data.List as List +import qualified Test.QuickCheck as QC import Test.QuickCheck (quickCheck, ) import NumericPrelude.Numeric @@ -40,9 +41,9 @@ (AnaC.deltaSigmaModulationPositive <<< Causal.feedConstFst threshold) (xs::[Rational])) : ("movingMedian", - quickCheck $ \n0 xs -> - let n = mod n0 20 + 1 - in movingMedian n xs - == - Causal.apply (AnaC.movingMedian n) (xs::[Char])) : + quickCheck $ + QC.forAll (QC.choose (1,20)) $ \n xs -> + movingMedian n xs + == + Causal.apply (AnaC.movingMedian n) (xs::[Char])) : [] diff --git a/test/Test/Sound/Synthesizer/Generic/Filter.hs b/test/Test/Sound/Synthesizer/Generic/Filter.hs --- a/test/Test/Sound/Synthesizer/Generic/Filter.hs +++ b/test/Test/Sound/Synthesizer/Generic/Filter.hs @@ -11,8 +11,6 @@ import Test.QuickCheck (Testable, quickCheck, ) --- import qualified Algebra.Ring as Ring - import qualified Algebra.Laws as Law import NumericPrelude.Numeric diff --git a/test/Test/Sound/Synthesizer/Generic/FourierInteger.hs b/test/Test/Sound/Synthesizer/Generic/FourierInteger.hs --- a/test/Test/Sound/Synthesizer/Generic/FourierInteger.hs +++ b/test/Test/Sound/Synthesizer/Generic/FourierInteger.hs @@ -71,13 +71,6 @@ (SigG.toState xs) (SigG.toState ys) -{- -signal :: - Integral.C a => - Modulus a -> Sig.T a -> Sig.T (RC.T a) -signal (Modulus a) = fmap (/: a) --} - signal :: Sig.T Integer -> (Modulus Integer, Sig.T (RC.T Integer)) signal xs = diff --git a/test/Test/Sound/Synthesizer/Generic/Permutation.hs b/test/Test/Sound/Synthesizer/Generic/Permutation.hs --- a/test/Test/Sound/Synthesizer/Generic/Permutation.hs +++ b/test/Test/Sound/Synthesizer/Generic/Permutation.hs @@ -7,6 +7,7 @@ import qualified Synthesizer.Generic.Permutation as Permutation +import qualified Test.QuickCheck as QC import Test.QuickCheck (quickCheck, ) import NumericPrelude.Numeric @@ -14,29 +15,33 @@ import Prelude () +genRelPrime :: QC.Gen (Int, Int) +genRelPrime = do + (n0,m0) <- QC.arbitrary + let g = gcd n0 m0 + return $ if g==0 then (0,0) else (abs (div n0 g), abs (div m0 g)) + tests :: [(String, IO ())] tests = ("inverse transposition", - quickCheck $ \n0 m0 -> - let n = mod n0 100 - m = mod m0 100 - in Permutation.inverse (Permutation.transposition n m) - == - Permutation.transposition m n) : + quickCheck $ + QC.forAll (QC.choose (0,100)) $ \n -> + QC.forAll (QC.choose (0,100)) $ \m -> + Permutation.inverse (Permutation.transposition n m) + == + Permutation.transposition m n) : ("inverse skewGrid", - quickCheck $ \n0 m0 -> - let g = gcd n0 m0 - (n,m) = if g==0 then (0,0) else (abs (div n0 g), abs (div m0 g)) - in Permutation.inverse (Permutation.skewGrid n m) - == - Permutation.skewGridInv n m) : + quickCheck $ + QC.forAll genRelPrime $ \(n,m) -> + Permutation.inverse (Permutation.skewGrid n m) + == + Permutation.skewGridInv n m) : ("inverse skewGridCRT", - quickCheck $ \n0 m0 -> - let g = gcd n0 m0 - (n,m) = if g==0 then (0,0) else (abs (div n0 g), abs (div m0 g)) - in Permutation.inverse (Permutation.skewGridCRT n m) - == - Permutation.skewGridCRTInv n m) : + quickCheck $ + QC.forAll genRelPrime $ \(n,m) -> + Permutation.inverse (Permutation.skewGridCRT n m) + == + Permutation.skewGridCRTInv n m) : {- reverse (multiplicative (generator n) n) == diff --git a/test/Test/Sound/Synthesizer/Generic/ToneModulation.hs b/test/Test/Sound/Synthesizer/Generic/ToneModulation.hs --- a/test/Test/Sound/Synthesizer/Generic/ToneModulation.hs +++ b/test/Test/Sound/Synthesizer/Generic/ToneModulation.hs @@ -31,16 +31,15 @@ import Test.QuickCheck (quickCheck, Property, (==>), ) import Test.Utility (ArbChar, ) --- import Debug.Trace (trace, ) import qualified Number.NonNegative as NonNeg import qualified Algebra.RealField as RealField +import qualified Data.List as List import Data.List.HT (viewL, takeWhileJust, ) import Data.Tuple.HT (mapSnd, ) -import qualified Data.List as List import NumericPrelude.Numeric diff --git a/test/Test/Sound/Synthesizer/Plain/Analysis.hs b/test/Test/Sound/Synthesizer/Plain/Analysis.hs --- a/test/Test/Sound/Synthesizer/Plain/Analysis.hs +++ b/test/Test/Sound/Synthesizer/Plain/Analysis.hs @@ -16,6 +16,7 @@ import qualified Data.NonEmpty as NonEmpty import Data.List (genericLength) +import qualified Test.QuickCheck as QC import Test.QuickCheck (quickCheck, Property, (==>)) import Test.Utility (approxEqual) @@ -137,10 +138,15 @@ (Analysis.directCurrentOffset (map fromIntegral x) :: Rational) -small :: (Functor f) => f Int -> f Int -small = fmap (flip mod 1000) +genSmall :: (Functor f, QC.Arbitrary (f Int)) => QC.Gen (f Int) +genSmall = fmap (fmap (flip mod 1000)) QC.arbitrary +forAllSmall :: + (Functor f, QC.Arbitrary (f Int), Show (f Int), QC.Testable prop) => + (f Int -> prop) -> Property +forAllSmall = QC.forAll genSmall + tests :: [(String, IO ())] tests = ("volumeVectorMaximum", quickCheck (volumeVectorMaximum :: [Rational] -> Bool)) : @@ -150,11 +156,13 @@ ("volumeVectorSum", quickCheck (volumeVectorSum :: NonEmpty.T [] Rational -> Bool)) : ("bounds", quickCheck (bounds :: NonEmpty.T [] Rational -> Bool)) : ("spread", quickCheck (spread :: (Rational,Rational) -> Bool)) : - ("histogramDiscrete", quickCheck (histogramDiscrete . small)) : - ("histogramDiscreteLength", quickCheck (histogramDiscreteLength . small)) : - ("histogramDiscreteConcat", quickCheck (\x y -> histogramDiscreteConcat (small x) (small y))) : - ("histogramLinear", quickCheck (histogramLinear . small)) : - ("histogramLinearLength", quickCheck (histogramLinearLength . small)) : + ("histogramDiscrete", quickCheck (forAllSmall histogramDiscrete)) : + ("histogramDiscreteLength", quickCheck (forAllSmall histogramDiscreteLength)) : + ("histogramDiscreteConcat", + quickCheck $ forAllSmall $ \x -> forAllSmall $ \y -> + histogramDiscreteConcat x y) : + ("histogramLinear", quickCheck (forAllSmall histogramLinear)) : + ("histogramLinearLength", quickCheck (forAllSmall histogramLinearLength)) : ("centroid", quickCheck (centroid :: [Rational] -> Property)) : - ("histogramDCOffset", quickCheck (histogramDCOffset . small)) : + ("histogramDCOffset", quickCheck (forAllSmall histogramDCOffset)) : [] 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 @@ -5,9 +5,6 @@ import Test.QuickCheck (quickCheck, Property, (==>)) import Test.Utility (equalList, approxEqualListAbs, approxEqualListRel, ) --- import qualified Algebra.Ring as Ring --- import qualified Algebra.Additive as Additive - import Data.List (transpose) import NumericPrelude.Numeric 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 @@ -17,34 +17,31 @@ import qualified Test.Sound.Synthesizer.Plain.NonEmpty as NonEmpty -import Test.QuickCheck (quickCheck, {- Property, (==>) -}) +import qualified Test.QuickCheck as QC +import Test.QuickCheck (Property, arbitrary, quickCheck, ) import Test.Utility (equalList, ArbChar, ) --- 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 qualified Number.GaloisField2p32m5 as GF import qualified Number.NonNegative as NonNeg import qualified Numeric.NonNegative.Chunky as Chunky -import qualified Data.List as List -import Data.Tuple.HT (mapPair, ) +import Control.Applicative (liftA2, (<$>), ) --- import Debug.Trace (trace, ) +import qualified Data.List as List +import Data.Tuple.HT (sortPair, mapPair, ) +import Data.Ix (inRange, ) import NumericPrelude.Numeric import NumericPrelude.Base import Prelude () -sums :: NonNeg.Int -> Rational -> Sig.T Rational -> Bool -sums nn x0 xs0 = - let n = min (length xs) (1 + NonNeg.toNumber nn) - xs = x0:xs0 - naive = FiltNR.sums n xs +sums :: NonEmpty.T Rational -> Property +sums xsc = + ($ NonEmpty.toList xsc) $ \xs -> + QC.forAll (QC.choose (1, length xs)) $ \n -> + let naive = FiltNR.sums n xs pyramid = FiltNR.sumsPyramid n xs rec = drop (n-1) $ MA.sumsStaticInt n xs in -- this checks only for equal prefixes and can easily go wrong, @@ -52,11 +49,12 @@ and $ zipWith3 (\x y z -> x==y && y==z) naive rec pyramid -- equalList $ naive : pyramid : rec : [] -sumRange :: NonNeg.Int -> (NonNeg.Int, NonNeg.Int) -> Sig.T Int -> Bool -sumRange nheight (nl,nr) xs = - let wrap n = mod (NonNeg.toNumber n) (length xs + 1) - height = 1 + NonNeg.toNumber nheight - rng = (wrap nl, wrap nr) +sumRange :: Sig.T Int -> Property +sumRange xs = + QC.forAll (fmap (succ . NonNeg.toNumber) arbitrary) $ \height -> + QC.forAll (QC.choose (0, length xs)) $ \nl -> + QC.forAll (QC.choose (0, length xs)) $ \nr -> + let rng = (nl, nr) pyr = take height (FiltNR.pyramid xs) pyrSt = FiltNRSt.pyramid (+) height @@ -71,25 +69,33 @@ FiltNRG.sumRangeFromPyramidReverse pyrSt rng : [] -getRange :: (NonNeg.Int, NonNeg.Int) -> NonEmpty.T (NonEmpty.T ArbChar) -> Bool -getRange (nl,nr) pyr0 = - let l = NonNeg.toNumber nl - r = NonNeg.toNumber nr - rng = if l<=r then (l,r) else (r,l) +newtype Size = Size {getSize :: Int} + deriving (Eq, Ord, Show) + +sizeRange :: (Int, Int) +sizeRange = (0,1000) + +instance QC.Arbitrary Size where + arbitrary = fmap Size $ QC.choose sizeRange + shrink (Size n) = + map Size $ filter (inRange sizeRange) $ QC.shrink n + + +getRange :: (Size, Size) -> NonEmpty.T (NonEmpty.T ArbChar) -> Bool +getRange nrng pyr0 = + let rng = sortPair $ mapPair (getSize, getSize) nrng pyr = map NonEmpty.toInfiniteList $ NonEmpty.toList pyr0 in equalList $ FiltNR.getRangeFromPyramid pyr rng : FiltNRG.consumeRangeFromPyramid (:) [] pyr rng : [] -sumsPosModulated :: - NonNeg.Int -> Sig.T (NonNeg.Int,NonNeg.Int) -> NonEmpty.T Int -> Bool -sumsPosModulated nheight nctrl xsc = - let ctrl = map (mapPair (NonNeg.toNumber, NonNeg.toNumber)) nctrl +sumsPosModulated :: Sig.T (Size, Size) -> NonEmpty.T Int -> Property +sumsPosModulated nctrl xsc = + QC.forAll (QC.choose (0,10)) $ \height -> + let ctrl = map (mapPair (getSize, getSize)) nctrl xs = NonEmpty.toInfiniteList xsc - height = min 10 $ NonNeg.toNumber nheight - in -- trace (show (height, ctrl, xsc)) $ - equalList $ + in equalList $ FiltNR.sumsPosModulated ctrl xs : FiltNR.sumsPosModulatedPyramid height ctrl xs : FiltNRG.sumsPosModulatedPyramid height ctrl xs : @@ -110,19 +116,17 @@ ctrl : [] -minPosModulated :: - NonNeg.Int -> Sig.T (NonNeg.Int,NonNeg.Int) -> NonEmpty.T Int -> Bool -minPosModulated nheight nctrl xsc = +minPosModulated :: Sig.T (Size, Size) -> NonEmpty.T Int -> Property +minPosModulated nctrl xsc = + QC.forAll (QC.choose (0,10)) $ \height -> let ctrl = - map (\(nl,nr) -> - if nl==nr - then (NonNeg.toNumber nl, NonNeg.toNumber nr+1) - else (NonNeg.toNumber nl, NonNeg.toNumber nr)) + map + ((\(nl,nr) -> (nl, if nl==nr then nr+1 else nr)) + . + mapPair (getSize, getSize)) nctrl xs = NonEmpty.toInfiniteList xsc - height = min 10 $ NonNeg.toNumber nheight - in -- trace (show (height, ctrl, xsc)) $ - equalList $ + in equalList $ zipWith FiltNR.minRange (List.tails xs) ctrl : SigSt.toList (FiltNRSt.accumulateBinPosModulatedPyramid min height @@ -130,33 +134,35 @@ (SigSt.fromList SigSt.defaultChunkSize xs)) : [] -downSample2 :: - [Int] -> (Int, Sig.T Int) -> Bool -downSample2 lazySize xsc = - let len = Chunky.fromChunks $ map (VP.chunkSize . succ . abs) lazySize - xs = VP.pack len $ cycle $ uncurry (:) xsc - in equalList $ - FiltNRG.downsample2 SigG.defaultLazySize xs : - FiltNRSt.downsample2 xs : - [] -sumsDownSample2 :: - [Int] -> (Int, Sig.T Int) -> Bool -sumsDownSample2 lazySize xsc = - let len = Chunky.fromChunks $ map (VP.chunkSize . succ . abs) lazySize - xs = VP.pack len $ cycle $ uncurry (:) xsc - in equalList $ - FiltNRG.sumsDownsample2 SigG.defaultLazySize xs : - FiltNRSt.sumsDownsample2 xs : - FiltNRSt.sumsDownsample2Alt xs : - [] +genChunkyVector :: QC.Gen (VP.Vector Int) +genChunkyVector = + liftA2 VP.pack + (Chunky.fromChunks <$> arbitrary) + (NonEmpty.toInfiniteList <$> arbitrary) +downSample2 :: Property +downSample2 = + QC.forAll genChunkyVector $ \xs -> + equalList $ + FiltNRG.downsample2 SigG.defaultLazySize xs : + FiltNRSt.downsample2 xs : + [] + +sumsDownSample2 :: Property +sumsDownSample2 = + QC.forAll genChunkyVector $ \xs -> + equalList $ + FiltNRG.sumsDownsample2 SigG.defaultLazySize xs : + FiltNRSt.sumsDownsample2 xs : + FiltNRSt.sumsDownsample2Alt xs : + [] + {- -sumsDownSample2 :: - [VP.ChunkSize] -> (Int, Sig.T Int) -> Bool +sumsDownSample2 :: [VP.ChunkSize] -> NonEmpty.T Int -> Bool sumsDownSample2 lazySize xsc = let len = Chunky.fromChunks $ filter (0/=) lazySize - xs = VP.pack len $ cycle $ uncurry (:) xsc + xs = VP.pack len $ NonEmpty.toInfiniteList xsc in equalList $ FiltNRG.sumsDownsample2 SigG.defaultLazySize xs : FiltNRSt.sumsDownsample2 xs : @@ -165,18 +171,16 @@ -} movingAverageModulatedPyramid :: - NonNeg.Int -> Sig.T NonNeg.Int -> - (Stereo.T GF.T, Sig.T (Stereo.T GF.T)) -> Bool -movingAverageModulatedPyramid nheight nctrl xsc = - let ctrl = map NonNeg.toNumber nctrl - xs = uncurry (:) xsc + Sig.T Size -> NonEmpty.T (Stereo.T GF.T) -> Property +movingAverageModulatedPyramid nctrl xsc = + QC.forAll (QC.choose (0,10)) $ \height -> + let ctrl = map getSize nctrl + xs = NonEmpty.toList xsc pack ys = SigSt.fromList SigSt.defaultChunkSize ys maxC = maximum ctrl - height = min 10 $ NonNeg.toNumber nheight onegf :: GF.T onegf = one - in -- trace (show (height, ctrl, xsc)) $ - equalList $ + in equalList $ 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 @@ -15,8 +15,6 @@ import Control.Monad.Trans.State (runState, ) --- import Debug.Trace (trace, ) - import NumericPrelude.Numeric import NumericPrelude.Base import Prelude () 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 @@ -19,8 +19,6 @@ import Data.Tuple.HT (mapPair, ) --- import Debug.Trace (trace, ) - import NumericPrelude.Numeric import NumericPrelude.Base import Prelude () 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 @@ -14,7 +14,6 @@ import qualified Synthesizer.Interpolation.Class as Interpol import qualified Synthesizer.Interpolation.Custom as ExampleCustom import qualified Synthesizer.Interpolation.Module as ExampleModule -import qualified Synthesizer.Interpolation as InterpolationCore import qualified Synthesizer.Causal.Interpolation as InterpolC import qualified Synthesizer.Causal.Process as Causal @@ -26,8 +25,7 @@ import qualified Synthesizer.Storable.Filter.NonRecursive as FiltSt import qualified Synthesizer.Storable.Signal as SigSt -import Test.QuickCheck (quickCheck, Arbitrary(arbitrary), elements, {- Property, (==>), -} Testable, ) --- import Test.Utility +import Test.QuickCheck (quickCheck, Arbitrary(arbitrary), elements, Testable, ) import Foreign.Storable (Storable, ) @@ -35,14 +33,12 @@ 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 qualified Algebra.RealRing as RealRing -import qualified Test.Sound.Synthesizer.Plain.NonEmpty as NonEmpty import qualified Data.List.Match as Match -import Control.Monad (liftM2, ) +import Data.Tuple.HT (mapSnd, ) +import qualified Test.Sound.Synthesizer.Plain.NonEmpty as NonEmpty import Test.Utility (equalList, ArbChar, unpackArbString, ) @@ -52,13 +48,6 @@ -instance Arbitrary InterpolationCore.Margin where - arbitrary = - liftM2 InterpolationCore.Margin - (fmap abs arbitrary) - (fmap abs arbitrary) - - use :: (Interpolation.T a v -> x) -> (T a v -> x) @@ -246,10 +235,6 @@ SigG.defaultLazySize cs xs -makeChunkSize :: Int -> SigSt.ChunkSize -makeChunkSize size = - SigSt.chunkSize (1 + abs size) - {- makeExactFraction :: (Int,Int) -> Double makeExactFraction (n,d) = @@ -258,58 +243,45 @@ frequencyModulationStorableChunkSize :: (Storable v, RealField.C t, Eq v) => - Int -> Int -> - Int -> Int -> + SigSt.ChunkSize -> SigSt.ChunkSize -> + SigSt.ChunkSize -> SigSt.ChunkSize -> [t] -> [v] -> Bool frequencyModulationStorableChunkSize size0 size1 xsize0 xsize1 cs xs = - FiltSt.inverseFrequencyModulationFloor - (makeChunkSize size0) cs - (SigSt.fromList (makeChunkSize xsize0) xs) - == - FiltSt.inverseFrequencyModulationFloor - (makeChunkSize size1) cs - (SigSt.fromList (makeChunkSize xsize1) xs) + uncurry (==) $ + frequencyModulationStorableChunkSizeCompare size0 size1 xsize0 xsize1 cs xs frequencyModulationStorableChunkSizeCompare :: (Storable v, RealField.C t, Eq v) => - Int -> Int -> - Int -> Int -> + SigSt.ChunkSize -> SigSt.ChunkSize -> + SigSt.ChunkSize -> SigSt.ChunkSize -> [t] -> [v] -> (SigSt.T v, SigSt.T v) frequencyModulationStorableChunkSizeCompare size0 size1 xsize0 xsize1 cs xs = - (FiltSt.inverseFrequencyModulationFloor - (makeChunkSize size0) cs - (SigSt.fromList (makeChunkSize xsize0) xs), - FiltSt.inverseFrequencyModulationFloor - (makeChunkSize size1) cs - (SigSt.fromList (makeChunkSize xsize1) xs)) + (FiltSt.inverseFrequencyModulationFloor size0 cs (SigSt.fromList xsize0 xs), + FiltSt.inverseFrequencyModulationFloor size1 cs (SigSt.fromList xsize1 xs)) frequencyModulationStorable :: (Storable v, RealField.C t, Eq v) => - Int -> Int -> + SigSt.ChunkSize -> SigSt.ChunkSize -> [t] -> [v] -> Bool frequencyModulationStorable size xsize cs xs = - SigSt.toList - (FiltSt.inverseFrequencyModulationFloor (makeChunkSize size) cs - (SigSt.fromList (makeChunkSize xsize) xs)) - == FiltG.inverseFrequencyModulationFloor - SigG.defaultLazySize cs xs - + uncurry (==) $ mapSnd SigSt.toList $ + frequencyModulationStorableCompare size xsize cs xs frequencyModulationStorableCompare :: (Storable v, RealField.C t, Eq v) => - Int -> Int -> + SigSt.ChunkSize -> SigSt.ChunkSize -> [t] -> [v] -> ([v], SigSt.T v) frequencyModulationStorableCompare size xsize cs xs = (FiltG.inverseFrequencyModulationFloor SigG.defaultLazySize cs xs, - FiltSt.inverseFrequencyModulationFloor (makeChunkSize size) cs - (SigSt.fromList (makeChunkSize xsize) xs)) + FiltSt.inverseFrequencyModulationFloor size cs + (SigSt.fromList xsize xs)) diff --git a/test/Test/Sound/Synthesizer/Plain/Oscillator.hs b/test/Test/Sound/Synthesizer/Plain/Oscillator.hs --- a/test/Test/Sound/Synthesizer/Plain/Oscillator.hs +++ b/test/Test/Sound/Synthesizer/Plain/Oscillator.hs @@ -2,15 +2,12 @@ import qualified Synthesizer.Plain.Oscillator as Osci import qualified Synthesizer.Basic.Wave as Wave --- import qualified Synthesizer.Plain.Interpolation as Interpolation -import qualified Test.Sound.Synthesizer.Plain.Wave as WaveTest --- import qualified Test.Sound.Synthesizer.Plain.Interpolation as InterpolationTest +import qualified Test.Sound.Synthesizer.Plain.Wave as WaveTest -import Test.QuickCheck (quickCheck, {- Property, (==>), -} ) +import Test.QuickCheck (quickCheck, ) import qualified Algebra.RealField as RealField - import NumericPrelude.Numeric import NumericPrelude.Base diff --git a/test/Test/Sound/Synthesizer/Plain/ToneModulation.hs b/test/Test/Sound/Synthesizer/Plain/ToneModulation.hs --- a/test/Test/Sound/Synthesizer/Plain/ToneModulation.hs +++ b/test/Test/Sound/Synthesizer/Plain/ToneModulation.hs @@ -20,6 +20,7 @@ import qualified Test.Sound.Synthesizer.Plain.NonEmpty as NonEmpty import qualified Test.Sound.Synthesizer.Plain.Interpolation as InterpolationTest +import qualified Test.QuickCheck as QC import Test.QuickCheck (quickCheck, Property, (==>), ) import Test.Utility (ArbChar, ) @@ -29,6 +30,7 @@ import qualified Algebra.RealTranscendental as RealTrans 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 qualified Algebra.ZeroTestable as ZeroTestable @@ -37,7 +39,9 @@ import Data.Tuple.HT (mapPair, mapSnd, ) import qualified Data.List as List +import System.Random (Random, ) + import NumericPrelude.Numeric import NumericPrelude.Base import Prelude () @@ -117,14 +121,15 @@ in map (flip ToneModL.dropRem xs) [0 .. n + length xs] == map ((,) 0) (List.tails xs) ++ map (flip (,) []) [1..n] +ten, hundred :: (Ring.C a) => a +ten = fromInteger 10; hundred = fromInteger 100 -sampledToneSine :: (RealTrans.C a, Module.C a a) => - NonNeg.T a -> NonNeg.Int -> a -> a -> a -> Bool -sampledToneSine periodNN ext phase0 shape phase = +sampledToneSine :: (RealTrans.C a, Module.C a a, Show a, Random a) => + NonNeg.Int -> a -> a -> a -> Property +sampledToneSine ext phase0 shape phase = + QC.forAll (QC.choose (ten,hundred)) $ \period -> let ipLeap = Interpolation.cubic ipStep = Interpolation.cubic - ten = fromInteger 10 - period = ten + NonNeg.toNumber periodNN periodInt = round period len = minLength ipLeap ipStep periodInt ext tone = take len (Osci.staticSine phase0 (recip period)) @@ -132,13 +137,12 @@ head (Osci.staticSine (phase0+phase) zero)) < ten ^- (-2) -sampledToneSineList :: (RealTrans.C a, Module.C a a) => - NonNeg.T a -> NonNeg.Int -> a -> a -> [a] -> [a] -> Bool -sampledToneSineList periodNN ext origPhase phase shapes freqs = +sampledToneSineList :: (RealTrans.C a, Module.C a a, Show a, Random a) => + NonNeg.Int -> a -> a -> [a] -> [a] -> Property +sampledToneSineList ext origPhase phase shapes freqs = + QC.forAll (QC.choose (ten,hundred)) $ \period -> let ipLeap = Interpolation.cubic ipStep = Interpolation.cubic - ten = fromInteger 10 - period = ten + NonNeg.toNumber periodNN periodInt = round period len = minLength ipLeap ipStep periodInt ext tone = take len (Osci.staticSine origPhase (recip period)) @@ -440,9 +444,9 @@ quickCheck limitMaxRelativeValuesNonNegInfinity) : ("dropRem", quickCheck (dropRem :: NonNeg.Int -> [ArbChar] -> Bool)) : ("sampledToneSine", - quickCheck (\period -> sampledToneSine (period :: NonNeg.Double))) : + quickCheck (\ext phase0 -> sampledToneSine ext (phase0 :: Double))) : ("sampledToneSineList", - quickCheck (\period -> sampledToneSineList (period :: NonNeg.Double))) : + quickCheck (\ext phase0 -> sampledToneSineList ext (phase0 :: Double))) : ("sampledToneLinear", testRationalLineIp sampledToneLinear) : ("sampledToneStair", diff --git a/test/Test/Sound/Synthesizer/Plain/Wave.hs b/test/Test/Sound/Synthesizer/Plain/Wave.hs --- a/test/Test/Sound/Synthesizer/Plain/Wave.hs +++ b/test/Test/Sound/Synthesizer/Plain/Wave.hs @@ -3,10 +3,9 @@ import qualified Synthesizer.Basic.Wave as Wave import qualified Synthesizer.Basic.Phase as Phase -import Test.QuickCheck (quickCheck, Arbitrary(arbitrary), elements, oneof, choose, {- Property, (==>), -} ) --- import Test.Utility - -import qualified Number.NonNegative as NonNeg +import qualified Test.QuickCheck as QC +import Test.QuickCheck + (quickCheck, Arbitrary(arbitrary), elements, oneof, choose, ) import qualified Algebra.RealTranscendental as RealTrans import qualified Algebra.Ring as Ring @@ -60,10 +59,10 @@ [] -zeroDCOffset :: ZeroDCOffset Double -> NonNeg.Int -> Bool -zeroDCOffset w periodIntNN = - let periodInt = 100 + NonNeg.toNumber periodIntNN - period = fromIntegral periodInt +zeroDCOffset :: ZeroDCOffset Double -> QC.Property +zeroDCOffset w = + QC.forAll (QC.choose (100,600)) $ \periodInt -> + let period = fromIntegral periodInt xs = take periodInt $ map Phase.fromRepresentative $ map (/period) $ iterate (1+) 0.5 in abs (sum (map (Wave.apply (zdcWave w)) xs)) < period / fromInteger 100 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 @@ -8,12 +8,9 @@ import qualified Data.EventList.Relative.TimeBody as EventList --- 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 qualified Test.QuickCheck as QC import Test.QuickCheck (quickCheck, ) import Test.Utility (equalList, ) @@ -22,10 +19,13 @@ import Prelude () -arrange :: NonNeg.Int -> EventList.T NonNeg.Int (Sig.T Int) -> Bool -arrange nnChunkSize evs = - let chunkSize = SigSt.chunkSize $ 1 + NonNeg.toNumber nnChunkSize - sevs = EventList.mapBody (SigSt.fromList chunkSize) evs +genEventList :: QC.Gen (EventList.T NonNeg.Int (Sig.T Int)) +genEventList = fmap (EventList.mapTime (flip mod 1000)) QC.arbitrary + +arrange :: SigSt.ChunkSize -> QC.Property +arrange chunkSize = + QC.forAll genEventList $ \evs -> + let sevs = EventList.mapBody (SigSt.fromList chunkSize) evs in equalList $ SigSt.fromList chunkSize (Cut.arrange evs) : CutSt.arrangeAdaptive chunkSize sevs : diff --git a/test/Test/Utility.hs b/test/Test/Utility.hs --- a/test/Test/Utility.hs +++ b/test/Test/Utility.hs @@ -1,6 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} module Test.Utility where +import qualified Test.QuickCheck as QC import Test.QuickCheck (Arbitrary(arbitrary)) import qualified Number.Complex as Complex @@ -62,7 +63,7 @@ showsPrec n (ArbChar c) = showsPrec n c instance Arbitrary ArbChar where - arbitrary = fmap (ArbChar . Char.chr . (32+) . flip mod 96) arbitrary + arbitrary = fmap (ArbChar . Char.chr) (QC.choose (32,127)) unpackArbString :: [ArbChar] -> String unpackArbString =