packages feed

synthesizer-core 0.2.1 → 0.9.0.1

raw patch · 198 files changed

Files

+ Changes.md view
@@ -0,0 +1,32 @@+# Change log for the `synthesizer-core` package++## 0.9++* `SigG.Read` -> `SigG.Consume`++  `SigG.Write` -> `SigG.Produce`++  `SigG.LazySize` -> `ChunkySize.LazySize`++* `SigG.Produce`: Remove `LazySize` parameter.+  This rules out the `instance Produce StorableVector.Lazy`.+  You only have `instance Produce StorableVector.Typed`,+  i.e. storable vectors with maximum chunk size encoded in a type parameter.+  `instance Transform StorableVector.Lazy` and+  `instance Consume StorableVector.Lazy` are still provided, though.++  The `LazySize` parameters in the `Write` class+  only had a meaning for chunky storable vectors.+  If you need to produce (chunky or monolithic) storable vectors,+  better program your signal generator with `State.Signal`+  and then render it using `State.Signal.toStrictStorableSignal`.++## 0.8.1++* `Plain.Filter.Recursive.FirstOrder.highpassInit`,+  `Plain.Filter.Recursive.FirstOrder.highpassModifierInit`+  and derived functions change the meaning of the initial parameter.+  The previous meaning was pretty unclear and useless+  such that I consider it a bug.+  We do no longer negate the initial value.+  This is consistent with `lowpassInit`.
Makefile view
@@ -1,7 +1,29 @@-MODULE_PATH = src:src-3+MODULE_PATH = src:src-4 +# HIDE_SYNTH = -hide-package synthesizer++run-test:	update-test+	runhaskell Setup configure --user --enable-test --enable-benchmarks+	runhaskell Setup build+	runhaskell Setup haddock+	./dist/build/test/test++update-test:	test-module.list+	doctest-extract-0.1 -i src/ -o test/ --module-prefix DocTest --library-main=Main $$(cat test-module.list)++test-module.list:	synthesizer-core.cabal+	perl -p -e 's:( +DocTest\.(Synthesizer.+)|.*\n):\2:' $< >$@++ ghci:-	ghci -Wall -odirdist/build -hidirdist/build -hide-package synthesizer -i:$(MODULE_PATH)+	ghci -Wall -odirdist/build -hidirdist/build $(HIDE_SYNTH) -i:$(MODULE_PATH) +ghci7:+	ghci -Wall -odirdist/build -hidirdist/build $(HIDE_SYNTH) -i:$(MODULE_PATH) -XCPP -DNoImplicitPrelude=RebindableSyntax+ tutorial:-	ghci -Wall -fobject-code -fexcess-precision -O2 -fvia-C -optc-O2 -odirdist/build -hidirdist/build -hide-package synthesizer -i:$(MODULE_PATH) src/Synthesizer/Generic/Tutorial.hs+	ghci -Wall -fobject-code -fexcess-precision -O2 -fvia-C -optc-O2 -odirdist/build -hidirdist/build $(HIDE_SYNTH) -i:$(MODULE_PATH) src/Synthesizer/Generic/Tutorial.hs++# test new haddock features+haddock:+	haddock -h -o dist/doc/html/test/ src/Synthesizer/Plain/Signal.hs src/Synthesizer/Plain/Cut.hs
+ private/Synthesizer/Basic/NumberTheory.hs view
@@ -0,0 +1,1079 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-+Some of these functions might be moved to NumericPrelude.++Wikipedia: (primitive) roots of unity modulo n+   (primitive) roots must be units and all units are (primitive) roots+   maximum possible order for primitive roots - Carmichael+   all possible orders: divisor of Carmichael (proof? statement already in Carmichael-function-article)+   sum of primitive roots that vanishes+   order of primitive root is a divisor of each possible exponent+      proof with GCD and diophantine in exponent+   check for primitive root: fast exponentiation,+      primitivity: check exponents that are prime divisors+   how to find a primitive root: just try+   sum of powers of a primitive root is zero+   number of primitive roots of given order+      g(n,k) > 0 if k|lambda(n)+      g(n,k) = 0 else+      g(n,1) = 1+      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<n-1+      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+      either lambda(n) nor phi(n)+      lambda(14) = 6   nozeros(g(14)) = [1,1,2,2]   (f ~ [1,2,3,6])+      lambda(21) = 6   nozeros(g(21)) = [1,3,2,6]   (f ~ [1,4,3,12])+      phi(13) = 12   nozeros(g(13)) = [1,1,2,2,2,4]   (f ~ [1,2,3,4,6,12])+      phi(21) = 12   nozeros(g(21)) = [1,3,2,6]       (f ~ [1,4,3,12])+      However length(nozeros(f(n))) = numberofdivisors(lambda(n))+      numberofdivisors=A000005+   number of roots of given order+      easier to compute+      k|m => f(n,k) | f(n,m)+      g(n,k) = f(n,k) - sum(f(n,d), d|k and k/d prime) + ...+         inclusion-exclusion-principle+      better to write the other round:+      f(n,k) = sum(g(n,d), d|k) - this is Dirichlet convolution+      RUNM says f(n,k) is multiplicative+         list it in multiplicative function+      f(n,1) = 1 for n>=2+      f(n,lambda(n)) = phi(n)+      f(n,a·b) = f(n,a)·f(n,b) if a and b are coprime (conjecture)+      f(n,lcm(a,b)) = lcm(f(n,a),f(n,b)) (conjecture)+      If this conjecture is true, then we only need to know f(n,p^i).+      The following conjecture is wrong:+         for prime p it is   f(n,p^i) = gcd(lambda(n),p^i)+      counterexamples+         f(8,2) = 4, lambda(8)=2+         f(63,3) = 9, lambda(63)=6+         f(275,5) = 25, lambda(275)=20+         f(1247,7) = 49, lambda(1247)=84+      It seems to be:+         for prime p it is   f(n,p^i) = p^j for some j+   How to find a modulus where there is a primitive root of order o?+      just try numbers from the sequence o+1, 2*o+1, 3*o+1+      Because of [[Dirichlet's theorem on arithmetic progressions]]+      you will somewhen find a prime p,+      and its Carmichael value is p-1, which is a multiple of o.+      In this ring even 'o' is a unit.+   How to find a modulus where there are primitive roots of orders o1,..,ok?+      Just search for a modulus with roots of order lcm(o1,...,ok).+      The smallest such modulus should also be the smallest one+      that has primitive roots of orders o1,..,ok?+      Proof: If a ring has primitive roots of orders o1,..,ok+      then all orders divide the carmichael value of that ring,+      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 (+   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,+   divideByMaximumPowerRecursive,+   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+import qualified Data.Map as Map++import qualified Algebra.Ring as Ring+import qualified Algebra.Units as Units+import qualified Algebra.PrincipalIdealDomain as PID+import qualified Algebra.IntegralDomain as Integral+import qualified Algebra.ZeroTestable as ZeroTestable++import qualified Number.ResidueClass.Check as RC+import Number.ResidueClass.Check ((/:), )++import qualified Number.FixedPoint as FP+import Data.Bits (Bits, (.&.), (.|.), shiftR, )++import qualified Data.List.HT as ListHT+import Data.List (unfoldr, mapAccumL, genericDrop, genericSplitAt, )+import Data.Tuple.HT (mapFst, mapSnd, mapPair, swap, )+import Data.Maybe.HT (toMaybe, )++import Test.QuickCheck (Arbitrary(arbitrary), )++import NumericPrelude.Numeric+import NumericPrelude.Base+++{- |+The first pair member in @powerOfTwoFactors n@+is the maximum factor of @n@, that is a power of two.+-}+powerOfTwoFactors ::+   (Bits a, Integral.C a) => a -> (a, a)+powerOfTwoFactors n =+   let powerOfTwo = n .&. (-n)+   in  (powerOfTwo, div n powerOfTwo)+++{- |+List all factorizations of an odd number+where the first factor is at most the second factor+and the first factors are in descending order.+-}+fermatFactors :: Integer -> [(Integer,Integer)]+fermatFactors n =+   let root = FP.sqrt 1 n+   in  map (\(a,b) -> (b-a,b+a)) $+       mergeAndFilter+          (zip (scanl (+) n [1,3..]) [0 .. div (n-1) 2])+          (zip (scanl (+) (root*root) $ iterate (2+) (2*root+1)) [root..])++mergeAndFilter :: (Ord a) => [(a,b)] -> [(a,c)] -> [(b,c)]+mergeAndFilter ((a0,b):a0s) ((a1,c):a1s) =+   case compare a0 a1 of+      LT -> mergeAndFilter a0s ((a1,c):a1s)+      GT -> mergeAndFilter ((a0,b):a0s) a1s+      EQ -> (b,c) : mergeAndFilter a0s a1s+mergeAndFilter _ _ = []++++multiplicativeGenerator :: Integer -> Integer+multiplicativeGenerator = multiplicativeGeneratorDivisors++{- |+Argument must be a prime.+Usage of Set for efficient filtering of candidates seems to be overkill,+since the multiplicative generator seems to be small in most cases,+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+[(36721,37),(48889,34),(51361,37),(55441,38),(63361,37),(64609,35),(71761,44),(88321,34),(92401,34),(93481,35),(95471,43),(97441,37),(104711,43),(110881,69)++$ filter ((>63) . snd) $ map (\n -> (n, multiplicativeGenerator n)) $ tail NumberTheory.primes+[(110881,69),(760321,73)++A solution with medium complexity+could at least observe the least 64 numbers using a Word64.+-}+multiplicativeGeneratorSet :: Integer -> Integer+multiplicativeGeneratorSet p =+   let search candidates =+          case Set.minView candidates of+             Nothing -> error $ show p ++ " is not a prime"+             Just (x,rest) ->+                case orbitSet $ orbit p x of+                   new ->+                      -- fromIntegral (Set.size new) == p-2+                      if new == Set.fromList [1..p-1]+                        then x+                        else search (Set.difference rest new)+   in  search $ Set.fromList [1..p-1]++multiplicativeGeneratorDivisors :: Integer -> Integer+multiplicativeGeneratorDivisors p =+   head $ primitiveRootsOfUnity p (Order $ p-1)+++newtype Order = Order {getOrder :: Integer}+   deriving (Show, Eq, Ord)++instance Arbitrary Order where+   arbitrary = fmap (Order . (1+) . abs) arbitrary++instance Enum Order where+   succ (Order n) = Order (n+1)+   pred (Order n) = Order (n-1)+   fromEnum (Order n) = fromEnum n+   toEnum n = Order (toEnum n)+   enumFrom (Order from) =+      map Order $ enumFrom from+   enumFromThen (Order from) (Order thn) =+      map Order $ enumFromThen from thn+   enumFromTo (Order from) (Order to) =+      map Order $ enumFromTo from to+   enumFromThenTo (Order from) (Order thn) (Order to) =+      map Order $ enumFromThenTo from thn to++countOrder :: [a] -> Order+countOrder = foldl (\o _ -> succ o) (Order 0)++dividesOrder :: Order -> Order -> Bool+dividesOrder (Order k) (Order n) =+   divides k n+++-- class Integral.C a => PrimitiveRoot a where+class PID.C a => PrimitiveRoot a where+   primitiveRootCandidates :: a -> [a]+   maximumOrderOfPrimitiveRootsOfUnity :: a -> Order++instance PrimitiveRoot Integer where+   primitiveRootCandidates modu = [1 .. modu-1]+   maximumOrderOfPrimitiveRootsOfUnity =+      maximumOrderOfPrimitiveRootsOfUnityInteger++{-+For 'ordersOfPrimitiveRootsOfUnityInteger'+and the connection to Euler's totient function+we have chosen to have++> primitiveRootsOfUnity m 1 == [1].+-}+primitiveRootsOfUnity ::+   (PrimitiveRoot a, Eq a) => a -> Order -> [a]+primitiveRootsOfUnity =+   primitiveRootsOfUnityPower++{-+First check, that element x is a root of unity.+If x is not primitive,+this means there is a non-maximal exponent y with x^y=1.+This y must be a divisor of order.+Thus it is enough to check all possibilities of order/q as exponents,+where q is a prime divisor of order.+Computing a single power is much faster+than computing all powers up to the maximum power.++Verifying that a ring has no primitive root of the wanted order+takes a long time if we do it by exhaustive search.+In the case of a=Integer we could first check,+whether the considered residue ring has a primitive root of wanted order+using the Carmichael function.+We could certainly count the number of primitive roots+and stop searching if we reach that count.+-}+primitiveRootsOfUnityPower ::+   (PrimitiveRoot a, Eq a) => a -> Order -> [a]+primitiveRootsOfUnityPower modu (Order order) =+   let greatDivisors = map (div order) $ uniquePrimeFactors order+   in  filter+          (\n ->+             let pow y = RC.representative $ (n /: modu) ^ y+             in  PID.coprime n modu+                 &&+                 pow order == one+                 &&+                 all (\y -> pow y /= one) greatDivisors) $+       primitiveRootCandidates modu++primitiveRootsOfUnityNaive ::+   (PrimitiveRoot a, Eq a) => a -> Order -> [a]+primitiveRootsOfUnityNaive _ (Order 0) = []+primitiveRootsOfUnityNaive modu (Order expo) =+   filter+      (\n ->+         let (prefix,end:_) =+                genericSplitAt (expo-1) $ SigS.toList $ orbit modu n+         in  all (1/=) prefix && end==1) $+   primitiveRootCandidates modu++orbitSet :: Ord a => SigS.T a -> Set.Set a+orbitSet list =+   SigS.foldR+      (\new cont seen ->+         if Set.member new seen+           then seen+           else cont (Set.insert new seen))+      id list Set.empty++orbit :: (Integral.C a) => a -> a -> SigS.T a+orbit p x = SigS.iterate (\y -> mod (x*y) p) x+++{- |+Does not emit values in ascending order+and may return duplicates (e.g. primitiveRootsOfUnityFullOrbit 70000 10).+I hoped it would be faster than the other implementations+since it eliminates non-roots in large blocks.+However it seems that managing the root candidates in a Set+reduces performance significantly.++The idea:+Start with a seed that is a unit.+Compute its orbit until a one is reached.+Since it is a unit, we always encounter a one.+We do not need to check for non-unit seeds,+since (gcd modu seed) will be a divisor of all seed powers.+In the orbit all numbers are powers of each other.+Now finding the roots is a matter of solving+a Diophantine equation of the exponents.+In one such step all powers in an orbit are classified as roots or non-roots+and thus we can remove them all from the set of root candidates+and continue with the remaining candidates.+Duplicates can occur if a seed+in a later iteration is found again as power of another seed.+-}+primitiveRootsOfUnityFullOrbit ::+   (PrimitiveRoot a, Ord a) => a -> Order -> [a]+primitiveRootsOfUnityFullOrbit modu expo =+   let search candidates =+          flip fmap (Set.minView candidates) $ \(x,rest) ->+          mapSnd (Set.difference rest . Set.fromList) $+          primitiveRootsOfOrbit modu expo x+   in  concat $ unfoldr search $ Set.fromList $+       -- needed for modules with many divisors+       filter (PID.coprime modu) $+       primitiveRootCandidates modu++primitiveRootsOfUnityFullOrbitTest ::+   (PrimitiveRoot a, Ord a) => a -> Order -> [(a,[a])]+primitiveRootsOfUnityFullOrbitTest modu expo =+   let search candidates =+          flip fmap (Set.minView candidates) $ \(x,rest) ->+          mapPair ((,) x,+                   Set.difference rest . Set.fromList) $+          primitiveRootsOfOrbit modu expo x+   in  unfoldr search $ Set.fromList $+       filter (PID.coprime modu) $+       primitiveRootCandidates modu++primitiveRootsOfOrbit ::+   (PrimitiveRoot a, Ord a) => a -> Order -> a -> ([a], [a])+primitiveRootsOfOrbit modu (Order expo) x =+   let orb = (1:) $ takeWhile (1/=) $ iterate (\y -> mod (x*y) modu) x+       (Order orbitSize) = countOrder orb+   in  (if expo==0+          then []+          else+            {-+            size = length orb+            Search for m and k with 0<k and 0<m and m<size+            and expo*m = size*k+            such that for all l with 0<l and l<k+            m does not divide size*l.+            To this end we ask for every m+            for the smallest r such that size divides r*m.+            If r=expo then x^m is a primitive root of order expo.+            If r<expo then x^m has order smaller than expo.+            The searched r is div size (gcd size m).+            However expo = div size (gcd size m) implies,+            that expo is a divisor of size.+                expo = div size (gcd size m)+             => div size expo = gcd size m+                s = gcd size m+            We have to consider for m+            only the multiples of s.+            Then divide both sides of the equation by s, yielding+                1 = gcd expo m'+            -}+            case divMod orbitSize expo of+               (s,0) ->+                  map snd $ filter (PID.coprime expo . fst) $+                  zip+                     [0 .. expo-1]+                     -- (ListHT.sieve s $ orb)+                     (map head $ iterate (genericDrop s) orb)+               _ -> [],+        orb)+++hasPrimitiveRootOfUnityNaive ::+   (PrimitiveRoot a, Ord a) => a -> Order -> Bool+hasPrimitiveRootOfUnityNaive modu expo =+   any (dividesOrder expo . snd) $+   ordersOfPrimitiveRootsOfUnityTest modu++{-+This should be a maximum both with respect to magnitude and to divisibility.+-}+maximumOrderOfPrimitiveRootsOfUnityNaive ::+   (PrimitiveRoot a, Ord a) => a -> Order+maximumOrderOfPrimitiveRootsOfUnityNaive =+   foldl max (Order 1) . map snd . ordersOfPrimitiveRootsOfUnityTest++{- |+Computes a list of seeds and according maximum orders of roots of unity.+All divisors of those maximum orders are possible orders of roots of unity, too.+-}+ordersOfPrimitiveRootsOfUnityTest ::+   (PrimitiveRoot a, Ord a) => a -> [(a, Order)]+ordersOfPrimitiveRootsOfUnityTest modu =+   let search candidates =+          flip fmap (Set.minView candidates) $ \(x,rest) ->+          mapPair ((,) x,+                   Set.difference rest . Set.fromList) $+          orderOfOrbit modu x+   in  unfoldr search $ Set.fromList $+       filter (PID.coprime modu) $+       primitiveRootCandidates modu++{- |+modu and x must be coprime.+If they are not,+then none of the numbers in the orbit is a root of unity+and the function enters an infinite loop.+-}+orderOfOrbit ::+   (PrimitiveRoot a, Ord a) => a -> a -> (Order, [a])+orderOfOrbit modu x =+   let cyc = takeWhile (one/=) $ SigS.toList $ orbit modu x+   in  (succ $ countOrder cyc, cyc)+++{-+This test speeds up 'hasPrimitiveRootOfUnityNaive' considerably+by considering the prime factors of modu.+If modu is a prime, then the ring has a multiplicative generator,+i.e. a primitive root of unity of order modu-1.+That is, all primitive roots of unity are of an order that divides modu-1.+It seems that if modu is a power of a prime,+then the according ring has also multiplicative generator.+I think this is the reason for generalising the Rader transform+to signals of prime power length.+-}+hasPrimitiveRootOfUnityInteger ::+   Integer -> Order -> Bool+hasPrimitiveRootOfUnityInteger modu expo =+   dividesOrder expo $+   maximumOrderOfPrimitiveRootsOfUnityInteger modu++{-+Carmichael theorem:+If the integer residue rings with coprime moduli m0 and m1+have primitive roots of maximum order o0 and o1, respectively,+then the integer ring with modulus m0*m1+has maximum order (lcm o0 o1).+-}++{-+This is the Carmichael function.+<http://oeis.org/A002322>+-}+maximumOrderOfPrimitiveRootsOfUnityInteger ::+   Integer -> Order+maximumOrderOfPrimitiveRootsOfUnityInteger =+   Order .+   lcmMulti .+   map+      (\(e,p) ->+         if p == 2 && e > 2+           then p^(e-2)+           else p^(e-1) * (p-1)) .+   map (mapFst fromIntegral) .+   primeFactors+++{-+The sum of the sub-lists should equal the Euler totient function values+<http://oeis.org/A000010>.+-}+ordersOfPrimitiveRootsOfUnityInteger :: [[Int]]+ordersOfPrimitiveRootsOfUnityInteger =+   flip map [1..] $ \modu ->+   let maxOrder = maximumOrderOfPrimitiveRootsOfUnity (modu::Integer)+   in  map (length . primitiveRootsOfUnityPower modu) $+--       filter (flip divides maxOrder) $+       [Order 1 .. maxOrder]++ordersOfRootsOfUnityInteger :: [[Int]]+ordersOfRootsOfUnityInteger =+   flip map [1..] $ \modu ->+   map (length . rootsOfUnityPower (modu::Integer)) $+   [Order 1 ..]+{-+mapM_ print $ map (\n -> (n, maximumOrderOfPrimitiveRootsOfUnityInteger (fromIntegral n), take 30 $ ordersOfRootsOfUnityInteger !! (n-1))) [2..30]++mapM_ print $ map (\n -> (n, maximumOrderOfPrimitiveRootsOfUnityInteger (fromIntegral n), let row = ordersOfRootsOfUnityInteger !! (n-1) in map (row!!) $ map pred $ take 10 $ iterate (2*) 1)) [2..30]+-}++ordersOfRootsOfUnityIntegerCondensed :: [[Int]]+ordersOfRootsOfUnityIntegerCondensed =+   flip map [1..] $ \modu ->+   let maxOrder = maximumOrderOfPrimitiveRootsOfUnity (modu::Integer)+   in  map (length . rootsOfUnityPower modu) $+--       filter (flip divides maxOrder) $+       [Order 1 .. maxOrder]++rootsOfUnityPower ::+   (PrimitiveRoot a, Eq a) => a -> Order -> [a]+rootsOfUnityPower modu (Order expo) =+   filter+      (\n ->+         PID.coprime n modu+         &&+         RC.representative ((n /: modu) ^ expo) == one) $+   primitiveRootCandidates modu++{-+Corollary from the Carmichael function properties:+If in Z_n there is a primitive root r of unity of order o,+then for every Z_{m \cdot n} there is also a primitive root of unity+with the same order.++Collary:+If in Z_n1 you have a primitive root of order o1,+and so on for Z_{n_k} and order ok,+then Z_{lcm(n1,...,nk)} has primitive roots for every of the order o1,...,on.++Conjecture:+If Z_n has a total number of m primitive roots of unity of order o,+then Z_{k*n} has at least m primitive roots of unity of order o.++Conjecture:+Precondition: In Z_n there is a primitive root of prime order o.+Claims:+a) There are natural numbers m and k with n = m*(k*o+1) or n = m*o.+b) The smallest such n is of the form k*o+1 with k>1.++Counterexample for a) and non-prime o: o=15, n=77+Counterexample for b) and non-prime o:+   o=20, n=25; o=27, n=81; o=54, n=81; o=55, n=121++Corollary from definition of Carmichael function:+For n>1, Z_{2^{n+2}} has primitive root of unity of order 2^n.+-}++{- |+Given an order find integer residue rings+where roots of unity of this order exist.+The way they are constructed also warrants,+that 'order' is a unit (i.e. invertible) in those rings.++The list is not exhaustive+but computes suggestions quickly.+The first found modulus is often the smallest one that exist,+but not always (smallest counter-example: Order 80).+However, the first modulus is not the smallest one+among the ones that only have the wanted primitive root,+but where 'order' is not necessarily a unit.+E.g.++> ringsWithPrimitiveRootOfUnityAndUnit 840 == 2521 : 3361 : ...++but the smallest modulus is 1763.++Most of the numbers are primes.+For these the recursion property of the Carmichael function+immediately yields that there are primitive roots of unity of order 'order'.+-}+ringsWithPrimitiveRootOfUnityAndUnit :: Order -> [Integer]+ringsWithPrimitiveRootOfUnityAndUnit order@(Order k) =+   filter (flip hasPrimitiveRootOfUnityInteger order) $+   iterate (k+) 1+++ringsWithPrimitiveRootsOfUnityAndUnitsNaive :: [Order] -> [Integer] -> [Integer]+ringsWithPrimitiveRootsOfUnityAndUnitsNaive rootOrders units =+   filter+      (\n ->+         all (hasPrimitiveRootOfUnityInteger n) rootOrders &&+         all (PID.coprime n) units)+      [1..]+++{-+It would be nice to have the Omega monad here+in order to enumerate all rings.+-}+ringWithPrimitiveRootsOfUnityAndUnits :: [Order] -> [Integer] -> Integer+ringWithPrimitiveRootsOfUnityAndUnits rootOrders units =+   let p = lcmMulti units+   in  lcmMulti $+       map (head . filter (PID.coprime p) .+            ringsWithPrimitiveRootOfUnityAndUnit) $+       rootOrders++{-+Search for an appriopriate modulus+using the recursive definition of the Carmichael function.+We chose the prime factors of the Carmichael function argument+such that we get at least the prime factors in the function value that we need.++The modulus constructed this way is usually not the smallest possible+and it also does not provide that 'n' is a unit in the residue ring.+The simpler function 'ringsWithPrimitiveRootOfUnityAndUnit'+will usually produce a smaller modulus.+-}+ringWithPrimitiveRootsOfUnity :: Order -> Integer+ringWithPrimitiveRootsOfUnity (Order n) =+   case n of+      0 -> 2+      _ ->+         product $ map (uncurry ringPower) $ snd $+         mapAccumL+            (\factors (e,p) ->+               if Map.findWithDefault 0 p factors >= e+                 then (factors, (0,p))+                 else+                   if p==2+                     then+                       (factors,+                        case e of+                           0 -> (0,2)+                           1 -> (1,3)+                           2 -> (1,5)+                           _ -> (e+2, 2))+                     else+                       (Map.unionWith max factors $+                           Map.fromList $ map swap $ primeFactors $ p-1,+                        (e+1, p)))+            Map.empty $+         reverse $ primeFactors $ lcmMulti $+         n : map (subtract 1) (partialPrimes n)++lcmMulti :: (PID.C a) => [a] -> a+lcmMulti = foldl lcm one+++{- |+List all numbers that only contain prime factors 2 and 3 in ascending order.+<http://oeis.org/A003586>+-}+numbers3Smooth :: [Integer]+numbers3Smooth = numbers3SmoothCorec++numbers3SmoothCorec :: [Integer]+numbers3SmoothCorec = mergePowers 3 $ iterate (2*) 1++mergePowers :: (Ord a, Ring.C a) => a -> [a] -> [a]+mergePowers _ [] = []+mergePowers p (x:xs) =+   let ys = x : ListHT.mergeBy (<=) xs (map (p*) ys)+   in  ys++numbers3SmoothFoldr :: [Integer]+numbers3SmoothFoldr =+   foldr+      (\(x0:x1:xs) ys -> x0 : x1 : ListHT.mergeBy (<=) xs ys)+      (error "numbers3SmoothFoldr: infinite list should not have an end") $+   iterate (map (3*)) $+   iterate (2*) 1++numbers3SmoothSet :: [Integer]+numbers3SmoothSet =+   unfoldr+      (fmap (\(m,rest) -> (m, Set.union rest $ Set.fromAscList [2*m,3*m])) .+       Set.minView) $+   Set.singleton 1+++{-+Hamming sequence+<http://oeis.org/A051037>+-}+numbers5Smooth :: [Integer]+numbers5Smooth = numbers5SmoothCorec++numbers5SmoothCorec :: [Integer]+numbers5SmoothCorec =+   if False+     then -- causes permanent storage of numbers3SmoothCorec+          mergePowers 5 $ numbers3SmoothCorec+     else mergePowers 5 $ mergePowers 3 $ iterate (2*) 1++numbers5SmoothFoldr :: [Integer]+numbers5SmoothFoldr =+   foldr+      (\(x0:x1:x2:xs) ys -> x0 : x1 : x2 : ListHT.mergeBy (<=) xs ys)+      (error "numbers5SmoothFoldr: infinite list should not have an end") $+   iterate (map (5*)) $+   numbers3SmoothFoldr++numbers5SmoothSet :: [Integer]+numbers5SmoothSet =+   unfoldr+      (fmap (\(m,rest) -> (m, Set.union rest $ Set.fromAscList [2*m,3*m,5*m])) .+       Set.minView) $+   Set.singleton 1++ceilingPowerOfTwo :: (Ring.C a, Bits a) => a -> a+ceilingPowerOfTwo 0 = 1+ceilingPowerOfTwo n =+   (1+) $ fst $ head $+   dropWhile (uncurry (/=)) $+   ListHT.mapAdjacent (,) $+   scanl (\m d -> shiftR m d .|. m) (n-1) $+   iterate (2*) 1++{- |+It's not awfully efficient, but ok for our uses.+-}+ceilingPower :: (Integral.C a, Ord a) => a -> a -> a+ceilingPower base n = base ^ fromIntegral (ceilingLog base n)++ceilingLog :: (Integral.C a, Ord a) => a -> a -> Int+ceilingLog base =+   length . takeWhile (>0) . iterate (flip div base) . subtract 1++divideByMaximumPower ::+   (Integral.C a, ZeroTestable.C a) => a -> a -> a+divideByMaximumPower b n =+   last $+   n : unfoldr (\m -> case divMod m b of (q,r) -> toMaybe (isZero r) (q,q)) n++divideByMaximumPowerRecursive ::+   (Integral.C a, Eq a, ZeroTestable.C a) => a -> a -> a+divideByMaximumPowerRecursive b =+   let recourse n =+          case divMod n b of+             (q,0) -> recourse q+             _ -> n+   in  recourse++getMaximumExponent ::+   (Integral.C a, ZeroTestable.C a) =>+   a -> a -> (Int,a)+getMaximumExponent b n =+   last $ (0,n) :+   unfoldr+      (\(e,m) ->+         let (q,r) = divMod m b+             eq = (e+1,q)+         in  toMaybe (isZero r) (eq,eq))+      (0,n)++is3Smooth :: Integer -> Bool+is3Smooth =+   (1==) .+   divideByMaximumPower 3 .+   divideByMaximumPower 2++is5Smooth :: Integer -> Bool+is5Smooth =+   (1==) .+   divideByMaximumPower 5 .+   divideByMaximumPower 3 .+   divideByMaximumPower 2+++ceiling3Smooth :: Integer -> Integer+ceiling3Smooth = ceiling3SmoothTrace++ceiling5Smooth :: Integer -> Integer+ceiling5Smooth = ceiling5SmoothTrace++{- |+Compute the smallest composite of 2 and 3 that is as least as large as the input.+This can be interpreted as solving an integer linear programming problem with+min (\(a,b) -> a * log 2 + b * log 3)+over the domain {(a,b) : a>=0, b>=0, a * log 2 + b * log 3 >= log n}+-}+{-+This implementation looks stupid,+but it is drastically faster for large numbers than ceiling3SmoothNaive.+The reason is that the smooth numbers are logarithmically equally distributed.+That is, from @n@ to the next smooth number+it may be only 1% deviation from @n@,+but for huge @n@ the absolute difference @0.01*n@ is still huge.++@ceiling3Smooth (10^400+1)@ can be computed in about 0.1 seconds.+(Surprisingly, @ceiling3Smooth (10^500+1)@ needs almost 30 seconds.)+-}+ceiling3SmoothScan :: Integer -> Integer+ceiling3SmoothScan n =+   head $ dropWhile (<n) numbers3Smooth++ceiling5SmoothScan :: Integer -> Integer+ceiling5SmoothScan n =+   head $ dropWhile (<n) numbers5Smooth++ceiling3SmoothNaive :: Integer -> Integer+ceiling3SmoothNaive =+   head . dropWhile (not . is3Smooth) . iterate (1+)++ceiling5SmoothNaive :: Integer -> Integer+ceiling5SmoothNaive =+   head . dropWhile (not . is5Smooth) . iterate (1+)+++{-+Problem: We cannot just start with the ceilingPowerOfTwo+and then multiply with 3/4 until we fall below n,+since the 3/4 decreases too fast.+27/32 is closer to one,+and higher powers of 3 and 2 in the ratio make the ratio even closer to one.++This implementation is different:+It always moves and tests above @n@.+For every power of 3 it computes the least power of 2,+such that their product is above @n@.+-}+ceiling3SmoothTrace :: Integer -> Integer+ceiling3SmoothTrace n =+   minimum $ ceilingSmoothsTrace 2 3 n $ ceilingPowerOfTwo n++{-+We must be careful not to skip combinations that are optimal.++E.g.:+> _ceiling5SmoothTraceWrong (10^70+1)+10002658207445093206727527411583349735126415100956607165326185795158016+> ceiling5Smooth (10^70+1)+10001329015408448808646079907338649600000000000000000000000000000000000+-}+_ceiling5SmoothTraceWrong :: Integer -> Integer+_ceiling5SmoothTraceWrong n =+   minimum $ map (minimum . ceilingSmoothsTrace 3 5 n) $+   ceilingSmoothsTrace 2 3 n $ ceilingPowerOfTwo n++{-+For every reasonable pair of powers of 3 and 5+it computes the least power of 2,+such that their product is above @n@.+-}+ceiling5SmoothTrace :: Integer -> Integer+ceiling5SmoothTrace n =+   minimum $ map (minimum . ceilingSmoothsTrace 2 5 n) $+   ceilingSmoothsTrace 2 3 n $ ceilingPowerOfTwo n++{- |+@ceilingSmoothsTrace a b n m@+replaces successively @a@ factors in @m@ by @b@ factors+while keeping the product above @n@.+-}+ceilingSmoothsTrace :: Integer -> Integer -> Integer -> Integer -> [Integer]+ceilingSmoothsTrace a b n =+   let divMany k =+          case divMod k a of+             (q,r) -> if r==0 && q>=n then divMany q else k+       go m  =  m : if mod m a == 0 then go $ divMany $ m*b else []+   in  go+++{- |+Compute all primes that occur in the course of dividing+a Fourier transform into sub-transforms.+-}+partialPrimes :: Integer -> [Integer]+partialPrimes =+   let primeFactorSet = Set.fromAscList . uniquePrimeFactors+   in  unfoldr+         (fmap+             (\(p,set) ->+                (p, Set.union (primeFactorSet (p-1)) set)) .+          Set.maxView)+       .+       primeFactorSet++-- cf. htam:NumberTheory+uniquePrimeFactors ::+   (Integral.C a, Bits a, ZeroTestable.C a, Ord a) =>+   a -> [a]+--   map snd . primeFactors+uniquePrimeFactors n =+   let oddFactors =+          foldr+             (\p go m ->+                let (q,r) = divMod m p+                in  if r==0+                      then p : go (divideByMaximumPower p q)+                      else+                        if q >= p+                          then go m+                          else if m==1 then [] else m : [])+             (error "uniquePrimeFactors: end of infinite list")+             (iterate (2+) 3)+   in  case powerOfTwoFactors n of+          (1,m) -> oddFactors m+          (_,m) -> 2 : oddFactors m++{- |+Prime factors and their exponents in ascending order.+-}+primeFactors ::+   (PrimitiveRoot a, Ord a) => a -> [(Int, a)]+primeFactors n =+   let oddFactors =+          foldr+             (\p go m ->+                let (q0,r) = divMod m p+                in  if r==0+                      then+                        case getMaximumExponent p q0 of+                          (e,q1) -> (e+1,p) : go q1+                      else+                        if q0 >= p+                          then go m+                          else if m==1 then [] else (1,m) : [])+             (const [])+             (filter (not . Units.isUnit) $+              primitiveRootCandidates n)+   in  case getMaximumExponent 2 n of+          (0,m) -> oddFactors m+          (e,m) -> (e,2) : oddFactors m++{-+cf. htam:NumberTheory++Shall this be moved to NumericPrelude?++It should be replaced by a more sophisticated prime test.+-}+isPrime :: Integer -> Bool+isPrime n =+   case primeFactors n of+      [] -> False+      (e,m):_ -> e==1 && m==n++{- |+Find lengths of signals that require many interim Rader transforms+and end with the given length.++> raderWorstCases 2  =  <http://oeis.org/A061092>+> raderWorstCases 5  =  tail <http://oeis.org/A059411>++Smallest raderWorstCase numbers are 2,5,13,17,19,31,37,41,43,61,...+This matches the definition of <http://oeis.org/A061303>.+-}+raderWorstCases :: Integer -> [Integer]+raderWorstCases =+   iterate+      (\n ->+         head $ dropWhile (not . isPrime) $+         tail $ iterate (n+) 1)++{- |+This is usually faster than 'fastFourierRing'+since it does not need to factor large numbers.+However, the generated modulus is usually much greater.+-}+{-+I see the following opportunities for optimization:++1. Speedup 'fastFourierRing' by+   faster primality test (Miller-Rabin) and+   faster prime factorization (Pollard-Rho-method).+   These are also needed for+   maximumOrderOfPrimitiveRootsOfUnityInteger+   that is used by Fourier.Element.primitiveRoot+   in order to compute a root with maximum order.++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.+   This is a kind of knapsack problem.+   Maybe we could collect the factors in a way+   such that (lcm orderGroup + 1) is prime.++3. Avoid to compute factorizations of numbers+   where we already know the factors+   or where we do not need the factors at all.+   Use the factors returned by partialPrimes+   in order to compute a prime factorization+   of lcmMulti (map pred (partialPrimes n)).+   Call this (product ps).+   Now search for rings of moduli (1 + k * product ps),+   where there are (small) primitive roots of order (product ps).+   We only need to check whether there are small numbers+   such as 2, 3, 5, 6, 7 that have a (product ps)-th power that is 1,+   using fast exponentiation.+   If there is a power being 1 then check for primitivity+   by computing (k * product ps / p)-th powers+   for all prime factors p of (k * product ps).+   If there is no primitive root <= 7,+   there may still be a primitive root of wanted order,+   but it is then cheaper to seek for larger moduli.++   If we finally have a nice modulus+   it is still stupid to factorize (modulus-1)+   and search for a primitive root+   in each invocation of Fourier.Element.primitiveRoot.+   We could define a special datatype analogously to ResidueClass,+   that stores the primitive root and its order+   additional to the ResidueClass modulus.+-}+_fastFourierRingAlt :: Int -> Integer+_fastFourierRingAlt n =+   case n of+      0 -> 2+      1 -> 2+      _ ->+         let ni = fromIntegral n+             ps = filter (>1) (map (subtract 1) (partialPrimes ni))+         in  ringWithPrimitiveRootsOfUnityAndUnits (map Order $ ni : ps) ps++{- |+Determine an integer residue ring+in which a Fast Fourier transform of size n can be performed.+It must contain certain primitive roots.+If we choose a non-primitive root,+then some off-diagonal values in F^-1·F are non-zero.+-}+{-+When we need roots of orders o1,...,ok and according inverse elements+we can also ask for a ring, where there is a root of order lcm(o1,...,ok).+The answer to both questions is the same set of rings.+This can be proven using the statement,+that the order of any primitive root+divides the carmichael value of the modulus.++Since ringWithPrimitiveRootsOfUnityAndUnits+multiplies the moduli of rings for o1,...,ok,+it will produce large moduli.+-}+fastFourierRing :: Int -> Integer+fastFourierRing n =+   case n of+      0 -> 2+      1 -> 2+      _ ->+         let ni = fromIntegral n+         in  {-+             We cannot use ringsWithPrimitiveRootOfUnityAndUnit+             since for 359 we already get an Int overflow.+             For 719, 1439, 2879 we also get a very large value.+             -}+             head $ filter isPrime $+             (\order -> iterate (order +) 1) $+             lcmMulti $+             ni : map (subtract 1) (partialPrimes ni)
+ private/Synthesizer/Generic/Permutation.hs view
@@ -0,0 +1,165 @@+{- |+Permutations of signals as needed for Fast Fourier transforms.+Most functions are independent of the Signal framework.+We could move them as well to Synthesizer.Basic.+-}+module Synthesizer.Generic.Permutation (+   T,+   apply,+   size,+   transposition,+   skewGrid,+   skewGridInv,+   skewGridCRT,+   skewGridCRTInv,+   multiplicative,+   inverse,+   reverse,+   ) where++import qualified Synthesizer.Basic.NumberTheory as NumberTheory++import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.State.Signal as SigS++import qualified Data.StorableVector.ST.Strict as SVST+import qualified Data.StorableVector as SV++import qualified Algebra.PrincipalIdealDomain as PID++import Prelude hiding (reverse, )++++type T = SV.Vector Int++apply ::+   (SigG.Transform sig y) =>+   T -> sig y -> sig y+apply p xs =+   SigG.takeStateMatch xs $+   SigS.map (SigG.index xs) $+   SigS.fromStrictStorableSignal p+++size :: T -> Int+size = SV.length+++{- |+> inverse (transposition n m) = transposition m n+-}+transposition ::+   Int -> Int -> T+transposition n m =+   fst $ SV.unfoldrN (n*m)+      (\(i,j,k0) -> Just (i,+         case pred k0 of+            0  -> let j1 = j+1 in (j1, j1, m)+            k1 -> (i+n, j, k1)))+      (0,0,m)+++{-+In general the inverse of a skewGrid+does not look like even a generalized skewGrid.+E.g. @inverse $ skewGrid 3 4@.+-}+skewGrid ::+   Int -> Int -> T+skewGrid n m =+   let len = n*m+   in  fst $ SV.unfoldrN len+          (\(i0,k0) -> Just (i0,+             let k1 = pred k0+                 i1 = i0+n+             in  if k1==0+                   then (mod (i1+m) len, m)+                   else (mod i1 len, k1)))+          (0,m)++{- |+> inverse (skewGrid n m) == skewGridInv n m++In general the inverse of a skewGrid+cannot be expressed like skewGrid or skewGridCRT.+E.g. @inverse $ skewGrid 3 4@.+-}+skewGridInv ::+   Int -> Int -> T+skewGridInv n m =+   SV.pack $+   map (\k ->+      let Just (i,j) = PID.diophantine k n m+      in  mod i m + mod j n * m) $+   take (n*m) $ iterate (1+) 0++skewGridCRT ::+   Int -> Int -> T+skewGridCRT n m =+   let len = n*m+       (ni,mi) = snd $ PID.extendedGCD n m+   in  fst $ SV.unfoldrN len+          (\(i0,k0) -> Just (i0,+             let k1 = pred k0+                 i1 = i0+ni*n+             in  if k1==0+                   then (mod (i1+mi*m) len, m)+                   else (mod i1 len, k1)))+          (0,m)++skewGridCRTInv ::+   Int -> Int -> T+skewGridCRTInv n m =+   fst $ SV.packN (n*m) $+   map (\k -> mod k m + mod k n * m) $+   iterate (1+) 0+++{- |+Beware of 0-based indices stored in the result vector.+-}+multiplicative :: Int -> T+multiplicative ni =+   let n = fromIntegral ni+       gen = NumberTheory.multiplicativeGenerator n+   in  {-+       Since 'gen' is usually 2 or 3,+       the error should occur really only for huge signals.+       -}+       if gen * n > fromIntegral (maxBound :: Int)+         then error "signal too long for Int indexing"+         else fst $ SV.unfoldrN (ni-1)+                 (\x -> Just (x-1, mod (fromInteger gen * x) ni)) 1++{- |+We only need to compute the inverse permutation explicitly,+because not all signal structures support write to arbitrary indices,+thus Generic.Write does not support it.+For strict StorableVector it would be more efficient+to build the vector directly.++It holds:++> inverse . inverse == id+-}+inverse :: T -> T+inverse perm =+   SVST.runSTVector+      (do inv <- SVST.new_ (SV.length perm)+          SigS.sequence_ $+             SigS.zipWith (SVST.write inv)+                (SigS.fromStrictStorableSignal perm)+                (SigS.iterate (1+) 0)+          return inv)++reverse :: T -> T+reverse perm =+   fst $ SV.unfoldrN (SV.length perm)+      (\mn -> Just $+         case mn of+            Nothing -> (SV.head perm, Just $ SV.length perm)+            Just n ->+               let n1 = n-1+               in  (SV.index perm n1, Just n1))+      Nothing
+ speedtest/Fourier.hs view
@@ -0,0 +1,94 @@+module Main where++import qualified Synthesizer.Storable.Signal as SigSt+import qualified Synthesizer.Generic.Fourier as Fourier+import qualified Synthesizer.Generic.Noise as NoiseG+import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.State.Noise as NoiseS+import qualified Synthesizer.State.Signal as SigS++import qualified Data.StorableVector.Lazy.Typed as SVT+import qualified Data.StorableVector as SV++import qualified Number.Complex as NPComplex++import System.TimeIt (timeIt, )++import NumericPrelude.Numeric+import NumericPrelude.Base+import Prelude ()++++test0 :: IO ()+test0 =+   SigSt.writeFile "fouriertest.f64" $+   SigG.take 65536 $+   SVT.toVectorLazy $+   (NoiseG.white :: SVT.DefaultVector Double)++test1 :: IO ()+test1 =+   SigSt.writeFile "fouriertest.f64" $+   SigS.toStorableSignal SigSt.defaultChunkSize $+   SigS.take 65536 $+   SigS.map (NPComplex.+: 0) $+   (NoiseS.white :: SigS.T Double)++test2 :: Int -> IO ()+test2 n =+   writeFile "fouriertest.cache" $+   show $ Fourier.cacheBackward $+   (\sig ->+      SigS.toStorableSignal SigSt.defaultChunkSize sig ::+         SigSt.T (NPComplex.T Double)) $+   SigS.take n $+   SigS.map (NPComplex.+: 0) $+   NoiseS.white++test3 :: Int -> IO ()+test3 n =+   let sig :: SigSt.T (NPComplex.T Double)+       sig =+          SigS.toStorableSignal SigSt.defaultChunkSize $+          SigS.take n $+          SigS.map (NPComplex.+: 0) $+          NoiseS.white+       cache =+          Fourier.cacheBackward sig+   in  do timeIt $ writeFile "fouriertest.cache" $ show cache+          timeIt $ SigSt.writeFile "fouriertest.f64" $+             Fourier.transformWithCache cache sig++test4 :: Int -> IO ()+test4 n =+   let sig :: SV.Vector (NPComplex.T Double)+       sig =+          SigS.toStrictStorableSignal n $+          SigS.take n $+          SigS.map (NPComplex.+: 0) $+          NoiseS.white+       cache =+          Fourier.cacheBackward sig+   in  do -- timeIt $ writeFile "fouriertest.cache" $ show cache+          timeIt $ SV.writeFile "fouriertest.f64" $+             Fourier.transformWithCache cache sig+++main :: IO ()+main =+--   timeIt $ test2 (4096*3+1)+--   test4 (4096*3+1)+   sequence_ $+   timeIt test0 : timeIt test1 :+   map test4+      (16384 : (4096*3) : (4096*3+1) : 11025 :+       (3^9) : (5^6) : (7^5) :+       (6^6) : (3*5*7*11*13) :+       [])+{-+      (65536 : 65537 : 44100 :+       (3^10) : (5^7) : (7^5) :+       (6^6) : (2*3*5*7*11*13) :+       [])+-}
− speedtest/FusionTest.hs 
@@ -1,819 +0,0 @@-{-# OPTIONS_GHC -O2 #-}-module Main (main) where--import qualified Synthesizer.Storable.Signal as SigSt-import qualified Synthesizer.Storable.Oscillator as OsciSt-import qualified Synthesizer.Storable.Cut as CutSt--import qualified Synthesizer.State.Signal as SigS-import qualified Synthesizer.State.Oscillator as OsciS-import qualified Synthesizer.State.Control as CtrlS-import qualified Synthesizer.State.Filter.NonRecursive as FiltNRS-import qualified Synthesizer.State.Cut as CutS-import qualified Synthesizer.State.NoiseCustom as NoiseS-import qualified Synthesizer.State.Interpolation as InterpolationS--import qualified Synthesizer.FusionList.Signal as SigFL-import qualified Synthesizer.FusionList.Oscillator as OsciFL-import qualified Synthesizer.FusionList.Control as CtrlFL-import qualified Synthesizer.FusionList.Filter.NonRecursive as FiltNRFL--import qualified Synthesizer.Generic.Signal as SigG-import qualified Synthesizer.Generic.Filter.Delay as DelayG-import qualified Synthesizer.Generic.Interpolation as InterpolationG--import qualified Synthesizer.Interpolation.Module as InterpolationM-import qualified Synthesizer.Basic.Wave       as Wave-import qualified Synthesizer.Basic.Phase      as Phase-import qualified Synthesizer.Basic.DistortionControlled as Dist-import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter-import qualified Synthesizer.Plain.Filter.Recursive    as FiltR-import qualified Synthesizer.Plain.Control as Ctrl-import Synthesizer.Piecewise ((|#), (#|-), (-|#), (#|), )--import qualified Data.EventList.Relative.TimeBody as EventList--import Synthesizer.Basic.Binary (int16FromCanonical, int16FromDouble, )-import Data.Int (Int8, Int16, )-import Foreign.Storable (Storable, )-import qualified Data.List as List-import qualified Data.Char as Char--import GHC.Float (double2Int, int2Double)-import NumericPrelude ((^?))-import qualified NumericPrelude as NP--import qualified Algebra.Transcendental as Trans-import qualified Algebra.Field          as Field-import qualified Algebra.Ring           as Ring-import qualified Algebra.Additive       as Additive--import System.Random (mkStdGen)-import qualified Synthesizer.RandomKnuth as Knuth---{--If you increase the chunk size to 10000 the computation becomes slower.-Is this reproducable?--}-defaultChunkSize :: SigSt.ChunkSize-defaultChunkSize = SigSt.chunkSize 1000---{-# INLINE storableFromFusionList #-}-storableFromFusionList :: Storable a => SigFL.T a -> SigSt.T a-storableFromFusionList =-   SigFL.toStorableSignal defaultChunkSize---   SigSt.fromFusionList defaultChunkSize--mapTest0 :: SigSt.T Char-mapTest0 =-   SigSt.fromList defaultChunkSize-      (List.map succ (List.replicate 200000 'a'))--mapTest1 :: [Char] -> SigSt.T Char-mapTest1 =-   SigSt.fromList defaultChunkSize . List.map Char.toUpper--mapTest2 :: [Char] -> SigSt.T Char-mapTest2 xs =-   SigSt.fromList defaultChunkSize (List.map Char.toUpper xs)--mapTest3 :: SigSt.T Int8-mapTest3 =-   SigSt.fromList defaultChunkSize-      (List.map succ (List.replicate 200000 1234))--mapTest4 :: SigSt.T Int8-mapTest4 =-   SigSt.fromList defaultChunkSize-      (List.map pred (List.replicate 200000 1234))--mapTest5 :: SigSt.T Int8-mapTest5 =-   storableFromFusionList-      (SigFL.map pred (SigFL.replicate 200000 1234))--{- inlining here even reduces the application of rules - Why? -}-{- INLINE mapTest6 -}-mapTest6 :: SigSt.T Int16-mapTest6 =-   storableFromFusionList $ SigFL.take 200000 $-   SigFL.map int16FromCanonical $---   SigFL.map (^2) $-   SigFL.repeat (3::Double)---{-# INLINE zeroPhase #-}-zeroPhase :: Phase.T Double-zeroPhase = NP.zero--osciTest0 :: SigSt.T Int16-osciTest0 =-   storableFromFusionList $-   SigFL.take 200000 $-   -- int16FromCanonical is not only slow in execution but also blocks fusion - why?-   SigFL.map int16FromCanonical $-   (OsciFL.staticSaw zeroPhase 0.01 :: SigFL.T Double)--osciTest0a :: SigSt.T Int16-osciTest0a =-   storableFromFusionList $-   SigFL.take 200000 $-   SigFL.map int16FromDouble $-   OsciFL.staticSaw zeroPhase 0.01--{--{-# INLINE exponential2 #-}-exponential2 :: Trans.C a =>-      a   {-^ half life -}-   -> a   {-^ initial value -}-   -> SigFL.T a-          {-^ exponential decay -}-exponential2 halfLife =-   SigFL.iterate (((Ring.one Field./ (Ring.one Additive.+ Ring.one)) Trans.^? Field.recip halfLife) Ring.*)--}---osciTest0b :: SigSt.T Int16-osciTest0b =-   storableFromFusionList $-   SigFL.take 200000 $-   SigFL.map int16FromDouble $-   FiltNRFL.envelope-      (CtrlFL.exponential2 50000 1)-      (OsciFL.staticSaw zeroPhase 0.01)--osciTest0ba :: SigSt.T Int16-osciTest0ba =-   storableFromFusionList $-   SigFL.take 200000 $-   SigFL.map int16FromDouble $-   CtrlFL.exponential2 50000 1--osciTest0c :: SigSt.T Int16-osciTest0c =-   storableFromFusionList $-   SigFL.take 200000 $-   SigFL.map int16FromDouble $-   FiltNRFL.envelope-      (CtrlFL.exponential2 50000 0.5)-      (OsciFL.shapeMod Wave.squareBalanced zeroPhase 0.01 $-          SigFL.map (0.5*) $ OsciFL.staticSine zeroPhase 0.00002)--osciTest0d :: SigSt.T Int16-osciTest0d =-   storableFromFusionList $-   SigFL.take 200000 $-   SigFL.map int16FromDouble $-   FiltNRFL.envelope---      (exponential2 50000 0.5)-      (CtrlFL.exponential2 50000 0.5)---      (SigFL.iterate ((0.5 ^? recip 50000)*) 0.5)-      (OsciFL.freqMod Wave.square zeroPhase-          (SigFL.map (0.01+) $ SigFL.map (0.0001*) $ OsciFL.staticSine zeroPhase 0.0001))--osciTest0e :: SigSt.T Int16-osciTest0e =-   storableFromFusionList $-   SigFL.take 200000 $-   SigFL.map int16FromDouble $-   FiltNRFL.envelope-      (CtrlFL.exponential2 50000 0.5)-      (OsciFL.shapeFreqMod Wave.squareBalanced zeroPhase-          (SigFL.map (0.5*) $ OsciFL.staticSine zeroPhase 0.00002)-          (SigFL.map (0.01+) $ SigFL.map (0.0001*) $ OsciFL.staticSine zeroPhase 0.0001))--osciTest0ea :: SigSt.T Int16-osciTest0ea =-   storableFromFusionList $-   SigFL.take 200000 $-   SigFL.map int16FromDouble $-      (OsciFL.shapeFreqMod Wave.squareBalanced zeroPhase-          (OsciFL.staticSine zeroPhase 0.00002)-          (OsciFL.staticSine zeroPhase 0.0001))--osciTest0f :: SigSt.T Int16-osciTest0f =-   storableFromFusionList $-   SigFL.take 200000 $-   SigFL.map int16FromDouble $-   FiltNRFL.envelope-      (CtrlFL.exponential2 50000 1)---      (SigFL.zipWith (\x y -> (x+y)/2)---      (MiscFL.mix-      (SigFL.mix-         (OsciFL.static Wave.saw zeroPhase 0.01003)-         (OsciFL.static Wave.saw zeroPhase 0.00997))--- staticSaw blocks fusion---         (OsciFL.staticSaw zeroPhase 0.01003)---         (OsciFL.staticSaw zeroPhase 0.00997))--osciTest0fa :: SigSt.T Int16-osciTest0fa =-   storableFromFusionList $-   SigFL.take 200000 $-   SigFL.map int16FromDouble $-   FiltNRFL.envelope-      (CtrlFL.exponential2 50000 1)-      (SigFL.mix-         (SigFL.mix-            (OsciFL.staticSaw zeroPhase 0.01001)-            (OsciFL.staticSaw zeroPhase 0.00998))-         (SigFL.mix-            (OsciFL.staticSaw zeroPhase 0.01005)-            (OsciFL.staticSaw zeroPhase 0.00996)))--osciTest1 :: SigSt.T Double-osciTest1 =-   storableFromFusionList $-   SigFL.take 200000 $-   (OsciFL.staticSaw zeroPhase 0.01 :: SigFL.T Double)--osciTest2 :: SigSt.T Int16-osciTest2 =-   storableFromFusionList $-   SigFL.take 200000 $-   SigFL.iterate (200+) 0--osciTest3 :: SigSt.T Double-osciTest3 =-   SigSt.take 200000 $-   SigSt.map (\x->x*x) $-   SigSt.iterate defaultChunkSize (200+) 0--osciTest4 :: SigSt.T Int16-osciTest4 =-   SigSt.take 200000 $-   SigSt.map int16FromCanonical $  -- this is now really fast thanks to specialisation-   (SigSt.iterate defaultChunkSize (1+) 0 :: SigSt.T Double)--osciTest5 :: SigSt.T Int16-osciTest5 =-   SigSt.take 200000 $-   SigSt.map int16FromDouble $-   (SigSt.iterate defaultChunkSize (1+) 0 :: SigSt.T Double)--osciTest6 :: SigSt.T Int16-osciTest6 =-   -- takeCrochet is slow if not fused away-   SigSt.takeCrochet 200000 $-   SigSt.map int16FromDouble $-   (SigSt.iterate defaultChunkSize (1+) 0 :: SigSt.T Double)---{--waveSine :: Floating a => a -> a-waveSine x = sin (2*pi*x)--}--{--waveSine :: Trans.C a => a -> a-waveSine x = Trans.sin (NP.fromInteger 2 NP.* Trans.pi NP.* x)--incrFracDouble :: Double -> Double -> Double-incrFracDouble d x = NP.fraction (d + x)--{-# ONLINE incrFrac #-}-incrFrac :: NP.RealFrac a => a -> a -> a-incrFrac d x = NP.fraction (d NP.+ x)--fraction :: Double -> Double-fraction x =-   let second :: (Int, a) -> a-       second = snd-       f = second (properFraction x)-   in  if f>=0 then f else f+1--}--{--fraction :: Double -> Double-fraction x = x - fromIntegral (floor x :: Int)--}--{--fraction :: Double -> Double-fraction x = x - int2Double (double2Int x)--incrFracDouble :: Double -> Double -> Double-incrFracDouble d x = fraction (d + x)--}--{--incrFracDouble :: Double -> Double -> Double-incrFracDouble d x = d + x--}---osciTest7 :: SigSt.T Int16-osciTest7 =-   SigSt.take 200000 $-   SigSt.map int16FromDouble $---   SigSt.map (\x -> sin (2*pi*x)) $-   SigSt.map (Wave.apply Wave.sine) $---   SigSt.map (Wave.apply waveSine) $---   (SigSt.iterate defaultChunkSize (0.01 +) NP.zero :: SigSt.T (Phase.T Double))-   (SigSt.iterate defaultChunkSize (Phase.increment 0.01) NP.zero :: SigSt.T (Phase.T Double))---   (SigSt.iterate defaultChunkSize (incrFrac 0.01) NP.zero :: SigSt.T (Phase.T Double))---   (SigSt.iterate defaultChunkSize (incrFracDouble 0.01) NP.zero :: SigSt.T (Phase.T Double))--osciTest8 :: SigSt.T Int16-osciTest8 =-   SigSt.take 200000 $-   SigSt.map int16FromDouble $-   (OsciSt.staticSaw defaultChunkSize zeroPhase 0.01 :: SigSt.T Double)---appendTest0 :: SigSt.T Int16-appendTest0 =-   storableFromFusionList $-   SigFL.map int16FromDouble $-      let tone0 = SigFL.take 100000 $ OsciFL.static Wave.saw zeroPhase 0.010-          tone1 = SigFL.take 100000 $ OsciFL.static Wave.saw zeroPhase 0.015-      in  SigFL.append tone0 tone1--appendTest1 :: SigSt.T Int16-appendTest1 =-   let tone0 = SigFL.take 100000 $ OsciFL.static Wave.saw zeroPhase 0.010-       tone1 = SigFL.take 100000 $ OsciFL.static Wave.saw zeroPhase 0.015-   in  storableFromFusionList $-       SigFL.map int16FromDouble $-       SigFL.append tone0 tone1--appendTest2 :: SigSt.T Int16-appendTest2 =-   SigSt.map int16FromDouble $-   SigSt.appendFromFusionList defaultChunkSize-      (SigFL.take 100000 $ OsciFL.static Wave.saw zeroPhase 0.010)-      (SigFL.take 100000 $ OsciFL.static Wave.saw zeroPhase 0.015)--appendTest3 :: SigSt.T Int16-appendTest3 =-   storableFromFusionList $-   SigFL.map int16FromDouble $-   SigSt.appendFusionList defaultChunkSize-      (SigFL.take 100001 $ OsciFL.static Wave.sine zeroPhase 0.010)-      (SigFL.take 100000 $ OsciFL.static Wave.saw zeroPhase 0.015)--mixTest0 :: SigSt.T Int16-mixTest0 =-   SigSt.map int16FromDouble $-   SigSt.mixSize defaultChunkSize-      (SigSt.replicate defaultChunkSize 100000 NP.zero)-      (SigSt.replicate defaultChunkSize 100001 NP.one)--mixTest3 :: SigSt.T Int16-mixTest3 =-   SigSt.map int16FromDouble $-   SigSt.mixSize defaultChunkSize---      (storableFromFusionList $ SigFL.take 100000 $ OsciFL.static Wave.sine zeroPhase 0.010)---      (storableFromFusionList $ SigFL.take 100000 $ CtrlFL.exponential2 50000 1)-      (storableFromFusionList $ SigFL.take 100001 $ OsciFL.static Wave.saw zeroPhase 0.015)-      (SigSt.empty)--mixTest4 :: SigSt.T Int16-mixTest4 =-   SigSt.map int16FromDouble $-   SigSt.mixSize defaultChunkSize-      (SigSt.take 100002 $ OsciSt.staticSine defaultChunkSize zeroPhase 0.020) $-   SigSt.mixSize defaultChunkSize-      (SigSt.take 100001 $ OsciSt.staticSine defaultChunkSize zeroPhase 0.010)-      (SigSt.take 100000 $ OsciSt.staticSaw  defaultChunkSize zeroPhase 0.015)---mixTest5 :: SigSt.T Int16-mixTest5 =-   SigSt.map int16FromDouble $-   SigSt.take 441000 $---   SigSt.append-   SigSt.mix---   SigSt.mixSize defaultChunkSize-      (SigSt.iterate defaultChunkSize ((1-1e-6)*) 0.5)-      (SigSt.iterate defaultChunkSize (1e-6 +) 0)--mixTest6 :: SigSt.T Int16-mixTest6 =-   SigSt.map int16FromDouble $-   SigSt.take 441000 $---   SigSt.append-   SigSt.mix---   SigSt.mixSize defaultChunkSize-      (SigS.toStorableSignal defaultChunkSize $ SigS.iterate ((1-1e-6)*) 0.5)-      (SigS.toStorableSignal defaultChunkSize $ SigS.iterate (1e-6 +) 0)---stateTest0 :: SigSt.T Int16-stateTest0 =-   SigS.toStorableSignal defaultChunkSize $-   SigS.map int16FromDouble $-   SigS.take 441000 $-   SigS.zipWith (*) (SigS.iterate ((1-1e-4)*) 1) $---   SigS.map (\t -> if even (floor t :: Int) then 1 else -1) $-   SigS.map sin $-   SigS.iterate ((2*pi/100)+) (0::Double)--stateTest1 :: SigSt.T Int16-stateTest1 =-   SigS.toStorableSignal defaultChunkSize $-   SigS.map int16FromDouble $-   SigS.take 100000 $-   SigS.zipWith Dist.sine (SigS.iterate ((1-0.3e-4)*) 1) $-   SigS.map (Wave.apply Wave.sine) $-   SigS.iterate (Phase.increment 0.01) zeroPhase--stateTest2 :: SigSt.T Int16-stateTest2 =-   SigS.toStorableSignal defaultChunkSize $-   SigS.map int16FromDouble $-   SigS.take 100000 $-   SigS.map (Dist.logit 1) $-   SigS.map (Dist.sine 5) $-   SigS.zipWith (*) (SigS.iterate ((1-0.3e-4)*) 30) $-   SigS.map (Wave.apply Wave.sine) $-   SigS.iterate (Phase.increment 0.01) zeroPhase--stateOsciTest0 :: SigSt.T Int16-stateOsciTest0 =-   SigS.toStorableSignal defaultChunkSize $-   SigS.take 200000 $-   SigS.map int16FromCanonical $-   (OsciS.static Wave.saw zeroPhase 0.01 :: SigS.T Double)--stateOsciTest0a :: SigSt.T Int16-stateOsciTest0a =-   SigS.toStorableSignal defaultChunkSize $-   SigS.take 200000 $-   SigS.map int16FromDouble $-   OsciS.static Wave.saw zeroPhase 0.01--stateOsciTest0fa :: SigSt.T Int16-stateOsciTest0fa =-   SigS.toStorableSignal defaultChunkSize $-   SigS.take 200000 $-   SigS.map int16FromDouble $---   FiltNRS.envelope---      (CtrlS.exponential2 50000 1)-   SigS.map (0.5*) $-      (SigS.mix-         (SigS.mix-            (OsciS.static Wave.saw (Phase.fromRepresentative 0.1) 0.01001)-            (OsciS.static Wave.saw (Phase.fromRepresentative 0.7) 0.00998))-         (SigS.mix-            (OsciS.static Wave.saw (Phase.fromRepresentative 0.2) 0.01005)-            (OsciS.static Wave.saw (Phase.fromRepresentative 0.4) 0.00996)))--{-# INLINE chord #-}-chord :: SigS.T Double-chord =-   let freq = 0.005-       {-# INLINE tone #-}-       tone f =-          SigS.mix-             (SigS.mix-                (OsciS.static Wave.saw zeroPhase (f*1.001))-                (OsciS.static Wave.saw zeroPhase (f*0.998)))-             (SigS.mix-                (OsciS.static Wave.saw zeroPhase (f*1.005))-                (OsciS.static Wave.saw zeroPhase (f*0.996)))-   in  tone (freq*1.00) `SigS.mix`-       tone (freq*1.25) `SigS.mix`-       tone (freq*1.50)--stateOsciTestChord :: SigSt.T Int16-stateOsciTestChord =-   SigS.toStorableSignal defaultChunkSize $-   SigS.take 200000 $-   SigS.map int16FromDouble $-   SigS.map (0.2*) $-   chord--stateFilterTest :: SigSt.T Int16-stateFilterTest =-   SigS.toStorableSignal defaultChunkSize $-   SigS.take 200000 $-   SigS.map int16FromDouble $-   SigS.map (0.05*) $-   SigS.map UniFilter.lowpass $-   SigS.modifyModulated-      UniFilter.modifier-      (SigS.map UniFilter.parameter $-       SigS.zipWith FiltR.Pole-          (SigS.repeat (5::Double))-          (SigS.map (\f -> 0.02*3 ^? f) $-           OsciS.static Wave.fastSine2 (Phase.fromRepresentative 0.75) 0.000005)) $-   chord--stateAppendTest0 :: SigSt.T Int16-stateAppendTest0 =-   SigS.toStorableSignal defaultChunkSize $-   SigS.map int16FromDouble $-      let tone f =-             SigS.take 50000 $-             SigS.map (Wave.apply Wave.saw) $-             SigS.iterate (Phase.increment f) zeroPhase-      in  tone 0.010 `SigS.append`-          tone 0.015 `SigS.append`-          tone 0.020--stateAppendTest1 :: SigSt.T Int16-stateAppendTest1 =-   SigS.toStorableSignal defaultChunkSize $-   SigS.map int16FromDouble $-      let tone f =-             SigS.take 50000 $-             SigS.map (Wave.apply Wave.saw) $-             SigS.iterate (Phase.increment f) zeroPhase-      in  tone 0.010 `SigS.appendStored`-          tone 0.015 `SigS.appendStored`-          tone 0.020--stateAppendTest2 :: SigSt.T Int16-stateAppendTest2 =-   SigSt.map int16FromDouble $-      let tone f =-             SigS.toStorableSignal defaultChunkSize $-             SigS.take 50000 $-             SigS.map (Wave.apply Wave.saw) $-             SigS.iterate (Phase.increment f) zeroPhase-      in  tone 0.010 `SigSt.append`-          tone 0.015 `SigSt.append`-          tone 0.020--stateConcatTest0 :: SigSt.T Int16-stateConcatTest0 =-   SigS.toStorableSignal defaultChunkSize $-   SigS.map int16FromDouble $-      let tone f =-             SigS.take 50000 $-             SigS.map (Wave.apply Wave.saw) $-             SigS.iterate (Phase.increment f) zeroPhase-      in  SigS.concat $-             tone 0.010 :-             tone 0.015 :-             tone 0.020 :-             []--stateConcatTest1 :: SigSt.T Int16-stateConcatTest1 =-   SigS.toStorableSignal defaultChunkSize $-   SigS.map int16FromDouble $-      let tone f =-             SigS.take 50000 $-             SigS.map (Wave.apply Wave.saw) $-             SigS.iterate (Phase.increment f) zeroPhase-      in  SigS.concatStored $-             tone 0.010 :-             tone 0.015 :-             tone 0.020 :-             []--{-# NOINLINE storablePercTone #-}-storablePercTone :: Double -> SigSt.T Double-storablePercTone f =-   SigS.toStorableSignal defaultChunkSize $-   SigS.take 22000 $-   FiltNRS.envelope (CtrlS.exponential2 10000 1) $---   OsciS.static Wave.saw zero f-   SigS.map (0.5*) $-   SigS.mix-      (OsciS.static Wave.saw zeroPhase (f*0.999))-      (OsciS.static Wave.saw zeroPhase (f*1.001))--storableConcatTest :: SigSt.T Int16-storableConcatTest =-   SigSt.map int16FromDouble $-   SigSt.concat $-   take 13 $-   map storablePercTone $-   iterate (* 2^?(1/12)) 0.005--storableArrangeTest :: SigSt.T Int16-storableArrangeTest =-   SigSt.map int16FromDouble $-   SigSt.map (0.5*) $-   CutSt.arrange defaultChunkSize $-   foldr (EventList.cons 4000) (EventList.empty) $---   foldr (EventList.cons 4000) (EventList.pause 0) $-   take 25 $-   map storablePercTone $-   iterate (* 2^?(1/12)) 0.005---- This is much faster than Arrange.--- about 2 seconds-storableConcatInfTest :: SigSt.T Int16-storableConcatInfTest =-   SigSt.map int16FromDouble $-   SigSt.map (0.5*) $-   SigSt.concat $-   take 110 $-   map storablePercTone $-   iterate (* 2^?(1/12)) 0.002---- about 5-6 seconds-storableArrangeInfTest :: SigSt.T Int16-storableArrangeInfTest =-   SigSt.map int16FromDouble $-   SigSt.map (0.5*) $-   SigSt.take 440000 $-   CutSt.arrange defaultChunkSize $-   foldr (EventList.cons 4000) (EventList.empty) $-   map storablePercTone $-   iterate (* 2^?(1/12)) 0.002----statePercTone :: Double -> SigS.T Double-statePercTone f =-   SigS.take 22000 $-   FiltNRS.envelope (CtrlS.exponential2 10000 1) $---   OsciS.static Wave.saw zeroPhase f-   SigS.map (0.5*) $-   SigS.mix-      (OsciS.static Wave.saw zeroPhase (f*0.999))-      (OsciS.static Wave.saw zeroPhase (f*1.001))--stateArrangeInfTest :: SigSt.T Int16-stateArrangeInfTest =-   SigS.toStorableSignal defaultChunkSize $-   SigS.map int16FromDouble $-   SigS.map (0.5*) $-   SigS.take 440000 $-   CutS.arrange $-   foldr (EventList.cons 4000) (EventList.empty) $-   map statePercTone $-   iterate (* 2^?(1/12)) 0.002---{-# INLINE fastSine2 #-}-fastSine2 :: (Ord a, Ring.C a, Num a) => a -> a-fastSine2 x =-   if 2*x<1-     then 1 - NP.sqr (4*x-1)-     else NP.sqr (4*x-3) - 1--fastSineTest :: SigSt.T Int16-fastSineTest =-   SigS.toStorableSignal defaultChunkSize $-   SigS.map int16FromDouble $-   SigS.take 440000 $---   OsciS.static Wave.sine zeroPhase $---   OsciS.static Wave.fastSine4 zeroPhase $-   OsciS.static Wave.fastSine2 zeroPhase $---   OsciS.static fastSine2 zeroPhase $-   0.01---{-# INLINE stateBubbles #-}-stateBubbles :: SigS.T Double-stateBubbles =-   OsciS.freqMod Wave.sine zeroPhase $-   SigS.map (\p -> 0.01 * exp(-p)) $-   SigS.mix-      (SigS.map (1.5*) $ OsciS.static Wave.saw zeroPhase 0.00001)-      (SigS.map (0.5*) $ OsciS.static Wave.saw zeroPhase 0.0002)--stateBubblesTest :: SigSt.T Int16-stateBubblesTest =-   SigS.toStorableSignal defaultChunkSize $-   SigS.map int16FromDouble $-   SigS.take 440000 $-   stateBubbles--storableCombTest :: SigSt.T Int16-storableCombTest =-   SigSt.map int16FromDouble $-   SigSt.delayLoopOverlap 11000 (SigSt.map (0.5*)) $-   SigS.toStorableSignal defaultChunkSize $---   SigS.append (statePercTone 0.01) (SigS.replicate 40000 0)-   SigS.take 440000 $-   SigS.map (0.5*) $-   stateBubbles---storableTakeTest :: SigSt.T Int16-storableTakeTest =-   SigSt.take 440000 $-   SigS.toStorableSignal defaultChunkSize $-   SigS.map int16FromDouble $-   OsciS.static Wave.saw zeroPhase 0.01---stateNoiseTest :: SigSt.T Int16-stateNoiseTest =-   SigS.toStorableSignal defaultChunkSize $-   SigS.take 440000 $-   SigS.map int16FromDouble $-   SigS.map (0.3*) $-   SigS.map UniFilter.lowpass $-   SigS.modifyModulated-      UniFilter.modifier-      (SigS.map UniFilter.parameter $-       SigS.zipWith FiltR.Pole-          (SigS.repeat (10::Double))-          (SigS.map (\f -> 0.02*3 ^? f) $-           OsciS.static Wave.sine (Phase.fromRepresentative 0.75) 0.000005)) $---   NoiseS.whiteGen (mkStdGen 1)-   NoiseS.whiteGen (Knuth.cons 1)---stateADSRTest :: SigSt.T Int16-stateADSRTest =-   SigS.toStorableSignal defaultChunkSize $-   SigS.map int16FromDouble $-   FiltNRS.envelope-      (CtrlS.piecewise-          (0    |#  (5000, CtrlS.cubicPiece 0.001 0) #|--           0.5 -|# (40000, CtrlS.stepPiece) #|--           0.5 -|#  (8000, CtrlS.exponentialPiece 0) #|-           0.01)) $-   OsciS.static Wave.saw zeroPhase 0.01---phaserTest :: SigSt.T Int16-phaserTest =-   SigSt.take 440000 $-   SigSt.map int16FromDouble $-   SigSt.map (0.5*) $-   (\noise ->-       SigSt.mix-          noise-          (DelayG.modulated InterpolationM.linear (-500)-             (SigS.toStorableSignal defaultChunkSize-                (SigS.map-                   (\x -> 100*(2+x) :: Double)-                   (OsciS.static Wave.sine zeroPhase 0.00001)))-             noise)) $-   SigS.toStorableSignal defaultChunkSize $---   OsciS.static Wave.saw zeroPhase 0.01-   NoiseS.whiteGen (Knuth.cons 1)---phaserTest0 :: SigSt.T Int16-phaserTest0 =-   SigSt.take 440000 $-   SigSt.map int16FromDouble $-   DelayG.modulated InterpolationM.constant (-500)-      (SigSt.repeat defaultChunkSize (142::Double)) $-   SigSt.repeat defaultChunkSize (23::Double)---phaserTest1 :: SigSt.T Int16-phaserTest1 =-   SigSt.take 440000 $-   SigSt.map int16FromDouble $---   SigG.mapTails (maybe 0 fst . SigSt.viewL . SigSt.drop 100) $-{--   (\noise ->-       SigSt.mix-          (SigG.zipWithTails-             (\n -> maybe 0 fst . SigSt.viewL . SigSt.drop (div n 50))-             (SigG.iterate succ 0) noise)-          noise) $--}-{--   SigG.zipWithTails-      (\n -> maybe 0 fst . SigSt.viewL . SigSt.drop (div n 50))-      (SigG.iterate succ 0) $--}-   (\noise -> SigSt.mix noise noise) $-   SigS.toStorableSignal defaultChunkSize $-   NoiseS.whiteGen (Knuth.cons 1)----main :: IO ()-main =-   do SigSt.writeFile "storable-fusion.sw" phaserTest-      -- SigSt.writeFile "storable-fusion.sw" stateFilterTest-      -- SigSt.writeFile "storable-fusion.sw" osciTest4-      -- SigSt.writeFile "storable-fusion.sw" mapTest5---{--show highlighted core output--ghc-core -o dist/build/fusiontest/fusiontest -O -Wall -fexcess-precision -package synthesizer speedtest/FusionTest.hs--use installed synthesizer package--ghc -o dist/build/fusiontest/fusiontest -O -Wall -fexcess-precision -ddump-simpl-stats -package synthesizer speedtest/FusionTest.hs--ghc -o dist/build/fusiontest/fusiontest -O -Wall -fexcess-precision -ddump-simpl-stats -ddump-simpl -package synthesizer speedtest/FusionTest.hs >dist/build/fusiontest/FusionTest.log---with make and no explicit package specification:--ghc -Idist/build -o dist/build/fusiontest/fusiontest --make -Wall -O2 -fexcess-precision -ddump-simpl-stats -i -idist/build/autogen -isrc -odir dist/build/fusiontest/fusiontest-tmp -hidir dist/build/fusiontest/fusiontest-tmp src/FusionTest.hs--with make and explicit package specification:--ghc -Idist/build -o dist/build/fusiontest/fusiontest --make -Wall -O2 -fexcess-precision -hide-all-packages -i -idist/build/autogen -isrc -odir dist/build/fusiontest/fusiontest-tmp -hidir dist/build/fusiontest/fusiontest-tmp -package base-1.0 -package mtl-1.0 -package non-negative-0.0.2 -package numeric-prelude-0.0.3 -package event-list-0.0.7 -package Haskore-0.0.2 -package HTam-0.0 -package numeric-quest-0.1 -package bytestring-0.9.0.5 -package binary-0.4.1 -package storablevector-0.1 -package UniqueLogicNP-0.0 -package QuickCheck-1.0 src/FusionTest.hs--without make and with detailed simplifier report:--ghc -Idist/build -o dist/build/fusiontest/fusiontest -Wall -O2 -fexcess-precision -ddump-simpl-stats -ddump-simpl-iterations -ddump-asm -i -idist/build/autogen -isrc -idist/build/fusiontest/fusiontest-tmp -odir dist/build/fusiontest/fusiontest-tmp -hidir dist/build/fusiontest/fusiontest-tmp -package base-1.0 -package mtl-1.0 -package non-negative-0.0.2 -package numeric-prelude-0.0.3 -package event-list-0.0.7 -package Haskore-0.0.2 -package HTam-0.0 -package numeric-quest-0.1 -package bytestring-0.9.0.5 -package binary-0.4.1 -package storablevector-0.1 -package UniqueLogicNP-0.0 -package QuickCheck-1.0 dist/build/HSsynthesizer*.o src/FusionTest.hs--ghc -Idist/build -o dist/build/fusiontest/fusiontest -Wall -O2 -fexcess-precision -ddump-simpl-stats -ddump-simpl-iterations -i -idist/build/autogen -isrc -idist/build/fusiontest/fusiontest-tmp -odir dist/build/fusiontest/fusiontest-tmp -hidir dist/build/fusiontest/fusiontest-tmp -package base-1.0 -package mtl-1.0 -package non-negative-0.0.2 -package numeric-prelude-0.0.3 -package event-list-0.0.7 -package Haskore-0.0.2 -package HTam-0.0 -package numeric-quest-0.1 -package bytestring-0.9.0.5 -package binary-0.4.1 -package storablevector-0.1 -package UniqueLogicNP-0.0 -package QuickCheck-1.0 dist/build/HSsynthesizer*.o src/FusionTest.hs >src/FusionTest.log--ghc-6.8.2 -Idist/build -o dist/build/fusiontest/fusiontest -Wall -O2 -fexcess-precision -ddump-simpl-stats -ddump-simpl-iterations -i -idist/build/autogen -isrc -idist/build/fusiontest/fusiontest-tmp -odir dist/build/fusiontest/fusiontest-tmp -hidir dist/build/fusiontest/fusiontest-tmp -package base -package mtl -package non-negative -package numeric-prelude -package event-list -package Haskore -package HTam -package numeric-quest -package bytestring -package binary -package storablevector -package UniqueLogicNP -package QuickCheck dist/build/HSsynthesizer*.o src/FusionTest.hs >src/FusionTest.log--}
speedtest/SpeedTest.hs view
@@ -1,8 +1,6 @@-{-# OPTIONS -fno-implicit-prelude #-}+{-# LANGUAGE NoImplicitPrelude #-} module Main (main) where --- import BinarySample (numToInt16)- import System.Time (getClockTime, diffClockTimes, tdSec, tdPicosec) import System.Directory (removeFile) @@ -11,8 +9,7 @@ import qualified Data.Binary.Put as Bin  import Foreign (Int16, Ptr, alloca, allocaBytes, poke, pokeElemOff, sizeOf)-import System.IO (openBinaryFile, IOMode(WriteMode), hClose, Handle, hPutBuf)-import Control.Exception (bracket)+import System.IO (withBinaryFile, IOMode(WriteMode), Handle, hPutBuf)  import qualified Algebra.Transcendental as Trans import qualified Algebra.RealField      as RealField@@ -26,8 +23,8 @@ import Data.Maybe.HT (toMaybe, ) import Data.List.HT (sliceVertical, ) -import PreludeBase-import NumericPrelude+import NumericPrelude.Base+import NumericPrelude.Numeric  import qualified Prelude as P98 @@ -132,7 +129,7 @@ numToInt x = round (32767 * clip (-1) 1 x)  -- from BinarySample--- return type could be Int16, but that is not well supported by NumericPrelude+-- return type could be Int16, but that is not well supported by NumericPrelude.Numeric numToInt16 :: (RealField.C a) => a -> Int16 numToInt16 = P98.fromIntegral . numToInt @@ -143,8 +140,8 @@ doubleToInt :: Double -> Int doubleToInt x = roundDouble (32767 * clip (-1) 1 x) -doubleToInt16 :: Double -> Int16-doubleToInt16 = P98.fromIntegral . doubleToInt+_doubleToInt16 :: Double -> Int16+_doubleToInt16 = P98.fromIntegral . doubleToInt   @@ -172,7 +169,7 @@ writeSignalMonoPoke ::    FilePath -> [Int16] -> IO () writeSignalMonoPoke fileName signal =-   bracket (openBinaryFile fileName WriteMode) hClose $+   withBinaryFile fileName WriteMode $       \h -> alloca $          \p -> mapM_ (putInt h p) signal @@ -190,7 +187,7 @@ writeSignalMonoBlock ::    FilePath -> [Int16] -> IO () writeSignalMonoBlock fileName signal =-   bracket (openBinaryFile fileName WriteMode) hClose $+   withBinaryFile fileName WriteMode $       \h -> let blocks = sliceVertical maxBlockSize signal             in  allocaBytes (int16size * maxBlockSize) $                    \p -> mapM_ (putIntBlock h p) blocks@@ -200,8 +197,8 @@    do cnt <- foldM (\n x -> pokeElemOff p n x >> return (n+1)) 0 xs       hPutBuf h p (int16size * cnt) -putIntBlockSlow :: Handle -> Ptr Int16 -> [Int16] -> IO ()-putIntBlockSlow h p xs =+_putIntBlockSlow :: Handle -> Ptr Int16 -> [Int16] -> IO ()+_putIntBlockSlow h p xs =    do zipWithM_ (pokeElemOff p) [0..] xs       hPutBuf h p (int16size * length xs) @@ -214,7 +211,7 @@ writeZeroBlocks ::    FilePath -> Int -> IO () writeZeroBlocks fileName len =-   bracket (openBinaryFile fileName WriteMode) hClose $+   withBinaryFile fileName WriteMode $       \h -> allocaBytes (int16size * maxBlockSize) $          \p ->              do mapM_ (\off -> pokeElemOff p off (P98.fromInteger 0 :: Int16))@@ -309,7 +306,7 @@  main :: IO () main =-   do mapM (\(label, fileName, action) ->+   do mapM_ (\(label, fileName, action) ->               measureTime label (action fileName))            tests
speedtest/SpeedTestExp.hs view
@@ -9,13 +9,13 @@ import qualified Data.ByteString.Lazy as B import qualified Data.Binary.Put as Bin -import Data.Array.IO (IOUArray, newArray_, castIOUArray, hPutArray, writeArray)+import Data.Array.IO (IOUArray, newArray_, hPutArray, writeArray)+import Data.Array.Unsafe (castIOUArray)  import Data.Word(Word8) -import System.IO (openBinaryFile, hClose, hPutBuf, IOMode(WriteMode))+import System.IO (withBinaryFile, hPutBuf, IOMode(WriteMode)) import Foreign (Int16, pokeElemOff, allocaBytes)-import Control.Exception (bracket) import Control.Monad (zipWithM_)  import GHC.Float (double2Int)@@ -41,14 +41,14 @@    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) -doubleToInt16'' :: Double -> Int16-doubleToInt16'' x = seq x 0+_doubleToInt16' :: Double -> Int16+_doubleToInt16' x = seq x 0   exponential2 :: Double -> Double -> [Double]@@ -59,7 +59,7 @@  writeSignal :: FilePath -> Int -> [Double] -> IO () writeSignal name num signal =-   bracket (openBinaryFile name WriteMode) hClose $ \h ->+   withBinaryFile name WriteMode $ \h ->    allocaBytes (2*num) $ \buf ->       zipWithM_          (pokeElemOff buf) [0..(num-1)]@@ -68,7 +68,7 @@  writeExponentialList :: FilePath -> Int -> Double -> Double -> IO () writeExponentialList name num hl y0 =-   bracket (openBinaryFile name WriteMode) hClose $ \h ->+   withBinaryFile name WriteMode $ \h ->    allocaBytes (2*num) $ \buf ->       zipWithM_          (pokeElemOff buf) [0..(num-1)]@@ -78,7 +78,7 @@  writeExponential :: FilePath -> Int -> Double -> Double -> IO () writeExponential name num hl y0 =-   bracket (openBinaryFile name WriteMode) hClose $ \h ->+   withBinaryFile name WriteMode $ \h ->    allocaBytes (2*num) $ \buf -> {-       let k = 0.5**(1/hl)@@ -102,9 +102,10 @@  writeExponentialIOUArray :: FilePath -> Int -> Double -> Double -> IO () writeExponentialIOUArray name num hl y0 =-   bracket (openBinaryFile name WriteMode) hClose $ \h ->+   withBinaryFile name WriteMode $ \h ->    newArray_ (0,2*num-1) >>= \arr ->       let k = 0.5**(1/hl)+          loop :: Int -> Double -> IO ()           loop i y =              if i<num                then writeArray (arr :: IOUArray Int Int16)@@ -117,7 +118,7 @@  writeExponentialStorableVector :: FilePath -> Int -> Double -> Double -> IO () writeExponentialStorableVector name num hl y0 =-   bracket (openBinaryFile name WriteMode) hClose $ \h ->+   withBinaryFile name WriteMode $ \h ->       let k = 0.5**(1/hl)           (fp, _offset, _size) =              VB.toForeignPtr $ fst $
− src-3/Synthesizer/Causal/Process.hs 
@@ -1,393 +0,0 @@-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE ExistentialQuantification #-}-{- |-Processes that use only the current and past data.-Essentially this is a data type for the 'Synthesizer.State.Signal.crochetL' function.--}-{--ToDo:-Causal process usually depend on the sample rate,-so we need a phantom type parameter of T for the rate.--Include ST monad for mutable arrays,-this can be useful for delay lines.-On the other hand, couldn't we also use the StorableVector.Cursor data structure-and avoid the ST monad here?--}-module Synthesizer.Causal.Process (-   T,-   fromStateMaybe,-   fromState,-   fromSimpleModifier,--   id,-   map,-   first,-   second,-   compose,-   split,-   fanout,-   loop,--{--   We don't re-export these identifiers-   because people could abuse them for other Arrows.--   (>>>), (***), (&&&),-   (Arrow.^<<), (Arrow.^>>), (Arrow.<<^), (Arrow.>>^),--}--   apply,-   applyFst,-   applySnd,-   applyGeneric,-   applyGenericSameType,-   applyConst,-   apply2,-   apply3,--   feed,-   feedFst,-   feedSnd,-   feedGenericFst,-   feedGenericSnd,-   feedConstFst,-   feedConstSnd,--   crochetL,-   scanL,-   scanL1,-   zipWith,-   consInit,-   chainControlled,-   replicateControlled,-   feedback,-   feedbackControlled,--   -- for testing-   applyFst',-   applySnd',-) where--import qualified Synthesizer.State.Signal as Sig-import qualified Synthesizer.Generic.Signal as SigG-import qualified Synthesizer.Generic.Signal2 as SigG2--import qualified Synthesizer.Plain.Modifier as Modifier---- import qualified Control.Arrow as Arrow--import Control.Arrow-          (Arrow(..), returnA, (<<<), (^>>), {- ArrowApply(..), -} ArrowLoop(..),-           Kleisli(Kleisli), runKleisli, )-import Control.Monad.Trans.State-          (State, state, runState,-           StateT(StateT), runStateT, )-import Control.Monad (liftM, )--import Data.Tuple.HT (mapSnd, )-import Data.Function.HT (nest, )-import Prelude hiding (id, map, zipWith, )------ | Cf. StreamFusion  'Synthesizer.State.Signal.T'-data T a b =-   forall s. -- Seq s =>-      Cons !(a -> StateT s Maybe b)  -- compute next value-           !s                        -- initial state----{-# INLINE fromStateMaybe #-}-fromStateMaybe :: (a -> StateT s Maybe b) -> s -> T a b-fromStateMaybe = Cons--{-# INLINE fromState #-}-fromState :: (a -> State s b) -> s -> T a b-fromState f =-   fromStateMaybe (\x -> StateT (Just . runState (f x)))--{-# INLINE fromSimpleModifier #-}-fromSimpleModifier ::-   Modifier.Simple s ctrl a b -> T (ctrl,a) b-fromSimpleModifier (Modifier.Simple s f) =-   fromState (uncurry f) s---{--It's almost a Kleisli Arrow,-but the hidden type of the state disturbs.--}-instance Arrow T where-   {-# INLINE pure #-}-   {-# INLINE (>>>) #-}-   {-# INLINE first #-}-   {-# INLINE second #-}-   {-# INLINE (***) #-}-   {-# INLINE (&&&) #-}--   pure   = map-   (>>>)  = compose-   first  = liftKleisli first-   second = liftKleisli second-   (***)  = split-   (&&&)  = fanout---{--I think we cannot define an ArrowApply instance,-because we must extract the initial state somehow-from the inner (T a b) which is not possible.--instance ArrowApply T where---   app = Cons (runKleisli undefined) ()-   app = first (arr (flip Cons () . runKleisli)) >>> app--}---instance ArrowLoop T where-   {-# INLINE loop #-}-   loop = liftKleisli loop---{-# INLINE extendStateFstT #-}-extendStateFstT :: Monad m => StateT s m a -> StateT (t,s) m a-extendStateFstT st =-   StateT (\(t0,s0) -> liftM (mapSnd (\s1 -> (t0,s1))) (runStateT st s0))--{-# INLINE extendStateSndT #-}-extendStateSndT :: Monad m => StateT s m a -> StateT (s,t) m a-extendStateSndT st =-   StateT (\(s0,t0) -> liftM (mapSnd (\s1 -> (s1,t0))) (runStateT st s0))---{-# INLINE liftKleisli #-}-liftKleisli ::-   (forall s.-    Kleisli (StateT s Maybe) a0 a1 ->-    Kleisli (StateT s Maybe) b0 b1) ->-   T a0 a1 -> T b0 b1-liftKleisli op (Cons f s) =-   Cons (runKleisli $ op $ Kleisli f) s--{-# INLINE liftKleisli2 #-}-liftKleisli2 ::-   (forall s.-      Kleisli (StateT s Maybe) a0 a1 ->-      Kleisli (StateT s Maybe) b0 b1 ->-      Kleisli (StateT s Maybe) c0 c1) ->-   T a0 a1 -> T b0 b1 -> T c0 c1-liftKleisli2 op (Cons f s) (Cons g t) =-   Cons-      (runKleisli-         (Kleisli (extendStateSndT . f) `op`-          Kleisli (extendStateFstT . g)))-      (s,t)---{-# INLINE id #-}-id :: T a a-id = returnA--{-# INLINE map #-}-map :: (a -> b) -> T a b-map f = fromState (return . f) ()--{-# INLINE compose #-}-compose :: T a b -> T b c -> T a c-compose = liftKleisli2 (>>>)--{-# INLINE split #-}-split :: T a b -> T c d -> T (a,c) (b,d)-split = liftKleisli2 (***)--{-# INLINE fanout #-}-fanout :: T a b -> T a c -> T a (b,c)-fanout = liftKleisli2 (&&&)---{-# INLINE getNext #-}-getNext :: StateT (Sig.T a) Maybe a-getNext = StateT Sig.viewL--{-# INLINE apply #-}-apply :: T a b -> Sig.T a -> Sig.T b-apply (Cons f s) =-   Sig.crochetL (runStateT . f) s--{- |-I think this function does too much.-Better use 'feedFst' and (>>>).--}-{-# INLINE applyFst #-}-applyFst, applyFst' :: T (a,b) c -> Sig.T a -> T b c-applyFst c as =-   c <<< feedFst as--applyFst' (Cons f s) as =-   Cons (\b ->-           do a <- extendStateFstT getNext-              extendStateSndT (f (a,b)))-        (s,as)--{- |-I think this function does too much.-Better use 'feedSnd' and (>>>).--}-{-# INLINE applySnd #-}-applySnd, applySnd' :: T (a,b) c -> Sig.T b -> T a c-applySnd c as =-   c <<< feedSnd as--applySnd' (Cons f s) bs =-   Cons (\a ->-           do b <- extendStateFstT getNext-              extendStateSndT (f (a,b)))-        (s,bs)--{-# INLINE applyGeneric #-}-applyGeneric :: (SigG2.Transform sig a b) =>-   T a b -> sig a -> sig b-applyGeneric (Cons f s) =-   SigG2.crochetL (runStateT . f) s--{-# INLINE applyGenericSameType #-}-applyGenericSameType :: (SigG.Transform sig a) =>-   T a a -> sig a -> sig a-applyGenericSameType (Cons f s) =-   SigG.crochetL (runStateT . f) s---{- |-applyConst c x == apply c (repeat x)--}-{-# INLINE applyConst #-}-applyConst :: T a b -> a -> Sig.T b-applyConst (Cons f s) a =-   Sig.unfoldR (runStateT (f a)) s--{--Can be easily done by converting the result of applyConst to generic signal-{-# INLINE applyConstGeneric #-}-applyConstGeneric :: SigG.LazySize -> T a b -> a -> sig b-applyConstGeneric size (Cons f s) a =-   SigG.unfoldR size (runStateT (f a)) s--}---{-# INLINE apply2 #-}-apply2 :: T (a,b) c -> Sig.T a -> Sig.T b -> Sig.T c-apply2 f x y =-   apply (applyFst f x) y--{-# INLINE apply3 #-}-apply3 :: T (a,b,c) d -> Sig.T a -> Sig.T b -> Sig.T c -> Sig.T d-apply3 f x y z =-   apply2 (applyFst ((\(a,(b,c)) -> (a,b,c)) ^>> f) x) y z---{-# INLINE feed #-}-feed :: Sig.T a -> T () a-feed = fromStateMaybe (const getNext)--{-# INLINE feedFst #-}-feedFst :: Sig.T a -> T b (a,b)-feedFst = fromStateMaybe (\b -> fmap (flip (,) b) getNext)--{-# INLINE feedSnd #-}-feedSnd :: Sig.T a -> T b (b,a)-feedSnd = fromStateMaybe (\b -> fmap ((,) b) getNext)--{-# INLINE feedConstFst #-}-feedConstFst :: a -> T b (a,b)-feedConstFst a = map (\b -> (a,b))--{-# INLINE feedConstSnd #-}-feedConstSnd :: a -> T b (b,a)-feedConstSnd a = map (\b -> (b,a))--{-# INLINE feedGenericFst #-}-feedGenericFst :: (SigG.Read sig a) =>-   sig a -> T b (a,b)-feedGenericFst =-   feedFst . SigG.toState--{-# INLINE feedGenericSnd #-}-feedGenericSnd :: (SigG.Read sig a) =>-   sig a -> T b (b,a)-feedGenericSnd =-   feedSnd . SigG.toState------ * list like functions--{-# INLINE crochetL #-}-crochetL :: (x -> acc -> Maybe (y, acc)) -> acc -> T x y-crochetL f s = fromStateMaybe (StateT . f) s--{-# INLINE scanL #-}-scanL :: (acc -> x -> acc) -> acc -> T x acc-scanL f start =-   fromState (\x -> state $ \acc -> (acc, f acc x)) start--{-# INLINE scanL1 #-}-scanL1 :: (x -> x -> x) -> T x x-scanL1 f =-   crochetL (\x acc -> Just (x, Just $ maybe x (flip f x) acc)) Nothing--{-# INLINE zipWith #-}-zipWith :: (a -> b -> c) -> Sig.T a -> T b c-zipWith f = applyFst (map (uncurry f))--{- |-Prepend an element to a signal,-but keep the signal length,-i.e. drop the last element.--}-{-# INLINE consInit #-}-consInit :: x -> T x x-consInit =-   crochetL (\x acc -> Just (acc, x))----{-# INLINE chainControlled #-}-chainControlled :: [T (c,x) x] -> T (c,x) x-chainControlled =-   foldr-      (\p rest -> map fst &&& p  >>>  rest)-      (map snd)--{- |-If @T@ would be the function type @->@-then @replicateControlled 3 f@ computes-@\(c,x) -> f(c, f(c, f(c, x)))@.--}-{-# INLINE replicateControlled #-}-replicateControlled :: Int -> T (c,x) x -> T (c,x) x-replicateControlled n p =-   nest n-      (map fst &&& p  >>> )-      (map snd)---{-# INLINE feedback #-}-feedback :: T (a,c) b -> T b c -> T a b-feedback forth back =-   loop (forth >>>  id &&& back)--{-# INLINE feedbackControlled #-}-feedbackControlled :: T ((ctrl,a),c) b -> T (ctrl,b) c -> T (ctrl,a) b-feedbackControlled forth back =-   loop (map (fst.fst) &&& forth  >>>  map snd &&& back)--{--{-# INLINE feedbackControlled #-}-feedbackControlled :: T (ctrl, (a,c)) b -> T (ctrl,b) c -> T (ctrl,a) b-feedbackControlled forth back =-   loop ((\((ctrl,a),c) -> (ctrl, (a,c)))  ^>>-         map fst &&& forth  >>>-         map snd &&& back)--}
− src-4/Synthesizer/Causal/Process.hs 
@@ -1,398 +0,0 @@-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE ExistentialQuantification #-}-{- |-Processes that use only the current and past data.-Essentially this is a data type for the 'Synthesizer.State.Signal.crochetL' function.--}-{--ToDo:-Causal process usually depend on the sample rate,-so we need a phantom type parameter of T for the rate.--Include ST monad for mutable arrays,-this can be useful for delay lines.-On the other hand, couldn't we also use the StorableVector.Cursor data structure-and avoid the ST monad here?--}-module Synthesizer.Causal.Process (-   T,-   fromStateMaybe,-   fromState,-   fromSimpleModifier,--   id,-   map,-   first,-   second,-   compose,-   split,-   fanout,-   loop,--{--   We don't re-export these identifiers-   because people could abuse them for other Arrows.--   (>>>), (***), (&&&),-   (Arrow.^<<), (Arrow.^>>), (Arrow.<<^), (Arrow.>>^),--}--   apply,-   applyFst,-   applySnd,-   applyGeneric,-   applyGenericSameType,-   applyConst,-   apply2,-   apply3,--   feed,-   feedFst,-   feedSnd,-   feedGenericFst,-   feedGenericSnd,-   feedConstFst,-   feedConstSnd,--   crochetL,-   scanL,-   scanL1,-   zipWith,-   consInit,-   chainControlled,-   replicateControlled,-   feedback,-   feedbackControlled,--   -- for testing-   applyFst',-   applySnd',-) where--import qualified Synthesizer.State.Signal as Sig-import qualified Synthesizer.Generic.Signal as SigG-import qualified Synthesizer.Generic.Signal2 as SigG2--import qualified Synthesizer.Plain.Modifier as Modifier---- import qualified Control.Arrow as Arrow--import qualified Control.Category as Cat-import Control.Arrow-          (Arrow(..), returnA, (<<<), (>>>), (^>>), {- ArrowApply(..), -} ArrowLoop(..),-           Kleisli(Kleisli), runKleisli, )-import Control.Monad.Trans.State-          (State, state, runState,-           StateT(StateT), runStateT, )-import Control.Monad (liftM, )--import Data.Tuple.HT (mapSnd, )-import Data.Function.HT (nest, )-import Prelude hiding (id, map, zipWith, )------ | Cf. StreamFusion  'Synthesizer.State.Signal.T'-data T a b =-   forall s. -- Seq s =>-      Cons !(a -> StateT s Maybe b)  -- compute next value-           !s                        -- initial state----{-# INLINE fromStateMaybe #-}-fromStateMaybe :: (a -> StateT s Maybe b) -> s -> T a b-fromStateMaybe = Cons--{-# INLINE fromState #-}-fromState :: (a -> State s b) -> s -> T a b-fromState f =-   fromStateMaybe (\x -> StateT (Just . runState (f x)))--{-# INLINE fromSimpleModifier #-}-fromSimpleModifier ::-   Modifier.Simple s ctrl a b -> T (ctrl,a) b-fromSimpleModifier (Modifier.Simple s f) =-   fromState (uncurry f) s---{--It's almost a Kleisli Arrow,-but the hidden type of the state disturbs.--}-instance Cat.Category T where-   {-# INLINE id #-}-   {-# INLINE (.) #-}--   id  = fromState return ()-   (.) = flip compose--instance Arrow T where-   {-# INLINE arr #-}-   {-# INLINE first #-}-   {-# INLINE second #-}-   {-# INLINE (***) #-}-   {-# INLINE (&&&) #-}--   arr    = map-   first  = liftKleisli first-   second = liftKleisli second-   (***)  = split-   (&&&)  = fanout--{--I think we cannot define an ArrowApply instance,-because we must extract the initial state somehow-from the inner (T a b) which is not possible.--instance ArrowApply T where---   app = Cons (runKleisli undefined) ()-   app = first (arr (flip Cons () . runKleisli)) >>> app--}---instance ArrowLoop T where-   {-# INLINE loop #-}-   loop = liftKleisli loop---{-# INLINE extendStateFstT #-}-extendStateFstT :: Monad m => StateT s m a -> StateT (t,s) m a-extendStateFstT st =-   StateT (\(t0,s0) -> liftM (mapSnd (\s1 -> (t0,s1))) (runStateT st s0))--{-# INLINE extendStateSndT #-}-extendStateSndT :: Monad m => StateT s m a -> StateT (s,t) m a-extendStateSndT st =-   StateT (\(s0,t0) -> liftM (mapSnd (\s1 -> (s1,t0))) (runStateT st s0))---{-# INLINE liftKleisli #-}-liftKleisli ::-   (forall s.-    Kleisli (StateT s Maybe) a0 a1 ->-    Kleisli (StateT s Maybe) b0 b1) ->-   T a0 a1 -> T b0 b1-liftKleisli op (Cons f s) =-   Cons (runKleisli $ op $ Kleisli f) s--{-# INLINE liftKleisli2 #-}-liftKleisli2 ::-   (forall s.-      Kleisli (StateT s Maybe) a0 a1 ->-      Kleisli (StateT s Maybe) b0 b1 ->-      Kleisli (StateT s Maybe) c0 c1) ->-   T a0 a1 -> T b0 b1 -> T c0 c1-liftKleisli2 op (Cons f s) (Cons g t) =-   Cons-      (runKleisli-         (Kleisli (extendStateSndT . f) `op`-          Kleisli (extendStateFstT . g)))-      (s,t)---{-# INLINE id #-}-id :: T a a-id = returnA--{-# INLINE map #-}-map :: (a -> b) -> T a b-map f = fromState (return . f) ()--{-# INLINE compose #-}-compose :: T a b -> T b c -> T a c-compose = liftKleisli2 (>>>)--{-# INLINE split #-}-split :: T a b -> T c d -> T (a,c) (b,d)-split = liftKleisli2 (***)--{-# INLINE fanout #-}-fanout :: T a b -> T a c -> T a (b,c)-fanout = liftKleisli2 (&&&)---{-# INLINE getNext #-}-getNext :: StateT (Sig.T a) Maybe a-getNext = StateT Sig.viewL--{-# INLINE apply #-}-apply :: T a b -> Sig.T a -> Sig.T b-apply (Cons f s) =-   Sig.crochetL (runStateT . f) s--{- |-I think this function does too much.-Better use 'feedFst' and (>>>).--}-{-# INLINE applyFst #-}-applyFst, applyFst' :: T (a,b) c -> Sig.T a -> T b c-applyFst c as =-   c <<< feedFst as--applyFst' (Cons f s) as =-   Cons (\b ->-           do a <- extendStateFstT getNext-              extendStateSndT (f (a,b)))-        (s,as)--{- |-I think this function does too much.-Better use 'feedSnd' and (>>>).--}-{-# INLINE applySnd #-}-applySnd, applySnd' :: T (a,b) c -> Sig.T b -> T a c-applySnd c as =-   c <<< feedSnd as--applySnd' (Cons f s) bs =-   Cons (\a ->-           do b <- extendStateFstT getNext-              extendStateSndT (f (a,b)))-        (s,bs)--{-# INLINE applyGeneric #-}-applyGeneric :: (SigG2.Transform sig a b) =>-   T a b -> sig a -> sig b-applyGeneric (Cons f s) =-   SigG2.crochetL (runStateT . f) s--{-# INLINE applyGenericSameType #-}-applyGenericSameType :: (SigG.Transform sig a) =>-   T a a -> sig a -> sig a-applyGenericSameType (Cons f s) =-   SigG.crochetL (runStateT . f) s---{- |-applyConst c x == apply c (repeat x)--}-{-# INLINE applyConst #-}-applyConst :: T a b -> a -> Sig.T b-applyConst (Cons f s) a =-   Sig.unfoldR (runStateT (f a)) s--{--Can be easily done by converting the result of applyConst to generic signal-{-# INLINE applyConstGeneric #-}-applyConstGeneric :: SigG.LazySize -> T a b -> a -> sig b-applyConstGeneric size (Cons f s) a =-   SigG.unfoldR size (runStateT (f a)) s--}---{-# INLINE apply2 #-}-apply2 :: T (a,b) c -> Sig.T a -> Sig.T b -> Sig.T c-apply2 f x y =-   apply (applyFst f x) y--{-# INLINE apply3 #-}-apply3 :: T (a,b,c) d -> Sig.T a -> Sig.T b -> Sig.T c -> Sig.T d-apply3 f x y z =-   apply2 (applyFst ((\(a,(b,c)) -> (a,b,c)) ^>> f) x) y z---{-# INLINE feed #-}-feed :: Sig.T a -> T () a-feed = fromStateMaybe (const getNext)--{-# INLINE feedFst #-}-feedFst :: Sig.T a -> T b (a,b)-feedFst = fromStateMaybe (\b -> fmap (flip (,) b) getNext)--{-# INLINE feedSnd #-}-feedSnd :: Sig.T a -> T b (b,a)-feedSnd = fromStateMaybe (\b -> fmap ((,) b) getNext)--{-# INLINE feedConstFst #-}-feedConstFst :: a -> T b (a,b)-feedConstFst a = map (\b -> (a,b))--{-# INLINE feedConstSnd #-}-feedConstSnd :: a -> T b (b,a)-feedConstSnd a = map (\b -> (b,a))--{-# INLINE feedGenericFst #-}-feedGenericFst :: (SigG.Read sig a) =>-   sig a -> T b (a,b)-feedGenericFst =-   feedFst . SigG.toState--{-# INLINE feedGenericSnd #-}-feedGenericSnd :: (SigG.Read sig a) =>-   sig a -> T b (b,a)-feedGenericSnd =-   feedSnd . SigG.toState------ * list like functions--{-# INLINE crochetL #-}-crochetL :: (x -> acc -> Maybe (y, acc)) -> acc -> T x y-crochetL f s = fromStateMaybe (StateT . f) s--{-# INLINE scanL #-}-scanL :: (acc -> x -> acc) -> acc -> T x acc-scanL f start =-   fromState (\x -> state $ \acc -> (acc, f acc x)) start--{-# INLINE scanL1 #-}-scanL1 :: (x -> x -> x) -> T x x-scanL1 f =-   crochetL (\x acc -> Just (x, Just $ maybe x (flip f x) acc)) Nothing--{-# INLINE zipWith #-}-zipWith :: (a -> b -> c) -> Sig.T a -> T b c-zipWith f = applyFst (map (uncurry f))--{- |-Prepend an element to a signal,-but keep the signal length,-i.e. drop the last element.--}-{-# INLINE consInit #-}-consInit :: x -> T x x-consInit =-   crochetL (\x acc -> Just (acc, x))----{-# INLINE chainControlled #-}-chainControlled :: [T (c,x) x] -> T (c,x) x-chainControlled =-   foldr-      (\p rest -> map fst &&& p  >>>  rest)-      (map snd)--{- |-If @T@ would be the function type @->@-then @replicateControlled 3 f@ computes-@\(c,x) -> f(c, f(c, f(c, x)))@.--}-{-# INLINE replicateControlled #-}-replicateControlled :: Int -> T (c,x) x -> T (c,x) x-replicateControlled n p =-   nest n-      (map fst &&& p  >>> )-      (map snd)---{-# INLINE feedback #-}-feedback :: T (a,c) b -> T b c -> T a b-feedback forth back =-   loop (forth >>>  id &&& back)--{-# INLINE feedbackControlled #-}-feedbackControlled :: T ((ctrl,a),c) b -> T (ctrl,b) c -> T (ctrl,a) b-feedbackControlled forth back =-   loop (map (fst.fst) &&& forth  >>>  map snd &&& back)--{--{-# INLINE feedbackControlled #-}-feedbackControlled :: T (ctrl, (a,c)) b -> T (ctrl,b) c -> T (ctrl,a) b-feedbackControlled forth back =-   loop ((\((ctrl,a),c) -> (ctrl, (a,c)))  ^>>-         map fst &&& forth  >>>-         map snd &&& back)--}
− src-4/Synthesizer/Inference/DesignStudy/Applicative.hs 
@@ -1,42 +0,0 @@-{- |-  A design study about how to design signal processors-  that adapt to a common sample rate.-  I simplified "Synthesizer.Inference.DesignStudy.Arrow" to this module-  which uses only Applicative functors.--}-module Synthesizer.Inference.DesignStudy.Applicative where--import Data.List (intersect)-import Control.Applicative (Applicative(..), liftA3, )--data Rates = Rates [Int] | Any deriving Show--- it is a Reader monad with context processing-data Processor a = P Rates (Rates -> a)--intersectRates :: Rates -> Rates -> Rates-intersectRates Any y = y-intersectRates x Any = x-intersectRates (Rates xs) (Rates ys) = Rates $ intersect xs ys--instance Functor Processor where-   fmap f (P r f0) = P r (f . f0)--instance Applicative Processor where-   pure x = P Any (const x)-   (P r0 f0) <*> (P r1 f1)  =-      P (intersectRates r0 r1) (\r -> f0 r (f1 r))--runProcessor :: Processor a -> a-runProcessor (P r f) = f r---- test processors-processor1, processor2, processor3 :: Processor Rates-processor1 = P (Rates [44100, 48000]) id-processor2 = P Any                    id-processor3 = P (Rates [48000])        id--process :: Processor (Rates, Rates, Rates)-process = liftA3 (,,) processor1 processor2 processor3--test :: (Rates, Rates, Rates)-test = runProcessor process
− src-4/Synthesizer/Inference/DesignStudy/Arrow.hs 
@@ -1,50 +0,0 @@-module Synthesizer.Inference.DesignStudy.Arrow where--{--  A hint from Haskell cafe about how to design signal processors-  that adapt to a common sample rate.--}--{--Date: Fri, 12 Nov 2004 02:59:31 +0900-From: Koji Nakahara <yu-@div.club.ne.jp>-To: haskell-cafe@haskell.org--}--import Control.Category-import Control.Arrow-import Data.List (intersect)-data Rates = Rates [Int] | Any deriving Show-data Processor b c = P Rates (Rates -> b -> c)---- test Stream-type Stream = String--intersectRates :: Rates -> Rates -> Rates-intersectRates Any y = y-intersectRates x Any = x-intersectRates (Rates xs) (Rates ys) = Rates $ intersect xs ys--instance Category Processor where-  id = P Any (const Prelude.id)-  (P r1 f1) . (P r0 f0) =-	  P (intersectRates r0 r1) (\r -> f1 r Prelude.. f0 r)--instance Arrow Processor where-  arr f = P Any (const f)-  first (P r0 f) = P r0 (\r (x, s) -> (f r x, s))---runProcessor :: Processor b c -> b -> c-runProcessor (P r f) s = f r s---- test processors-process, processor1, processor2, processor3 :: Processor String String-processor1 = P (Rates [44100, 48000]) (\r -> ( ++ show r))-processor2 = P Any                    (\r -> ( ++ show r))-processor3 = P (Rates [48000])        (\r -> ( ++ show r))--process = processor1 >>> processor2 >>> processor3--test :: String-test = runProcessor process "bla"
− src-4/Synthesizer/Inference/DesignStudy/Monad.hs 
@@ -1,44 +0,0 @@-{- |-  A design study about how to design signal processors-  that adapt to a common sample rate.-  I tried to simplify "Synthesizer.Inference.DesignStudy.Arrow" to this module which uses only Monads.-  However the module is now very weird and does not really represent,-  what I intended to do.--}-module Synthesizer.Inference.DesignStudy.Monad where--import Control.Monad.Trans.Writer (Writer, execWriter, tell)-import Data.List (intersect)--data Rates = Rates [Int] | Any deriving Show--- it is a combination of Reader and Writer monad with context processing-data Processor a = P Rates (Rates -> Writer Stream a)---- test Stream-type Stream = String--intersectRates :: Rates -> Rates -> Rates-intersectRates Any y = y-intersectRates x Any = x-intersectRates (Rates xs) (Rates ys) = Rates $ intersect xs ys--instance Monad Processor where-   return x = P Any (\_ -> return x)-   -- maybe we should turn this into an Applicative instance-   (P r0 f0) >> (P r1 f1)  =-       P (intersectRates r0 r1) (\r -> f0 r >> f1 r)-   (P _ _) >>= _ = error "Is it possible to implement that?"--runProcessor :: Processor a -> Stream-runProcessor (P r f) = execWriter (f r)---- test processors-process, processor1, processor2, processor3 :: Processor ()-processor1 = P (Rates [44100, 48000]) (tell . show)-processor2 = P Any                    (tell . show)-processor3 = P (Rates [47000])        (tell . show)--process = processor1 >> processor2 >> processor3--test :: Stream-test = runProcessor process
src/Synthesizer/ApplicativeUtility.hs view
@@ -1,12 +1,12 @@ -- this is also used by synthesizer-dimensional and synthesizer-inference module Synthesizer.ApplicativeUtility where +import Control.Arrow (Arrow, (<<<), )+import Control.Monad.Fix (fix, ) import Control.Applicative (Applicative, (<*>), (<$>), liftA2, ) import Data.Traversable (Traversable, sequenceA, ) -import Control.Monad.Fix (fix, ) - {-# INLINE liftA4 #-} liftA4 :: Applicative f =>    (a -> b -> c -> d -> e) -> f a -> f b -> f c -> f d -> f e@@ -56,8 +56,9 @@ -- ($::) f arg sr = f sr (map ($sr) arg)  {-# INLINE (.:) #-}-(.:) :: (Applicative f) => f (b -> c) -> f (a -> b) -> f (a -> c)-(.:) = liftA2 (.)+(.:) :: (Applicative f, Arrow arrow) =>+   f (arrow b c) -> f (arrow a b) -> f (arrow a c)+(.:) = liftA2 (<<<) -- (.:) f g sr x = f sr (g sr x) -- (.:) f g sr x = ($:) f (flip g x) sr @@ -68,13 +69,14 @@ -- ($^) f x = pure f $: x  {-# INLINE (.^) #-}-(.^) :: (Functor f) => (b -> c) -> f (a -> b) -> f (a -> c)-(.^) f = fmap (f.)+(.^) :: (Functor f, Arrow arrow) =>+   arrow b c -> f (arrow a b) -> f (arrow a c)+(.^) f = fmap (f <<<) -- (.^) f = (.:) (pure f)  {-# INLINE ($#) #-} ($#) :: (Functor f) => f (a -> b) -> a -> f b-($#) f x = fmap ($x) f+($#) f x = fmap ($ x) f -- ($#) f x = f $: pure x  @@ -82,7 +84,8 @@ Our signal processors have types like @f (a -> b -> c)@. They could also have the type @a -> b -> f c@ or @f a -> f b -> f c@.-We did not choose the last variant for reduction of redundancy in type signatures,+We did not choose the last variant for reduction of redundancy in type signatures+and for simplifying sharing, and we did not choose the second variant for easy composition of processors. However the forms are freely convertible, and if you prefer the last one because you do not want to sprinkle '($:)' in your code,
src/Synthesizer/Basic/Binary.hs view
@@ -1,34 +1,35 @@ {-# LANGUAGE NoImplicitPrelude #-}-module Synthesizer.Basic.Binary-   (C(..), toCanonical, fromCanonicalWith,-    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  import Data.Monoid (Monoid, mappend, ) +import qualified Algebra.FloatingPoint as Float import qualified Algebra.ToInteger as ToInteger import qualified Algebra.RealField as RealField-import qualified Algebra.Real      as Real+import qualified Algebra.RealRing  as RealRing import qualified Algebra.Field     as Field import qualified Algebra.Ring      as Ring  import Data.Ord.HT (limit, )+import Data.Tuple.HT (mapFst, )  import Data.Int (Int16, ) import GHC.Float (float2Int, double2Int, ) +import NumericPrelude.Numeric+import NumericPrelude.Base import qualified Prelude as P98 -import PreludeBase-import NumericPrelude  -- class C a where    outputFromCanonical ::       (Bounded int, ToInteger.C int, Monoid out) =>@@ -77,9 +78,45 @@  {-# INLINE fromCanonicalWith #-} fromCanonicalWith ::-   (Real.C real, Bounded int, ToInteger.C int) =>+   (Float.C real, Bounded int, ToInteger.C int) =>    (real -> int) -> (real -> int) fromCanonicalWith rnd r =+   let {-+       I hope that the complicated computation of a proper upper bound+       is turned into a constant.+       -}+       s = fromIntegral (maxBound `asTypeOf` i)+       {-+       The floating point type might be less precise+       than the integer type.+       In this case the upper bound might be rounded up+       when converting from integer to float.+       Then converting back from float to integer+       may yield a negative value.+       -}+       ss = if rnd s < 0 then decreaseFloat s else s+       i = rnd (ss * limit (-1, 1) r)+   in  i++{-# INLINE decreaseFloat #-}+decreaseFloat :: Float.C a => a -> a+decreaseFloat =+   uncurry Float.encode . mapFst (subtract 1) . Float.decode+++{- |+Warning:+This may produce negative results for positive input in some cases!+The problem is that (maxBound :: Int32) cannot be represented exactly as Float,+the Float value is actually a bit larger than the Int32 value.+Thus when converting the Float back to Int32 it becomes negative.+Better use 'fromCanonicalWith'.+-}+{-# INLINE fromCanonicalSimpleWith #-}+fromCanonicalSimpleWith ::+   (RealRing.C real, Bounded int, ToInteger.C int) =>+   (real -> int) -> (real -> int)+fromCanonicalSimpleWith rnd r =    let s = fromIntegral (maxBound `asTypeOf` i)        i = rnd (s * limit (-1, 1) r)    in  i@@ -99,11 +136,16 @@ scale16 x = 32767 * limit (-1, 1) x  {-# INLINE int16FromCanonical #-}-int16FromCanonical :: (RealField.C a) => a -> Int16+int16FromCanonical :: (RealRing.C a) => a -> Int16+{-+The round procedure is complicated and usually unnecessary int16FromCanonical = (P98.fromIntegral :: Int -> Int16) . round . scale16+-} {- in GHC-6.4 inefficient, since 'round' for target Int16 is not optimized int16FromCanonical = round . scale16 -}+int16FromCanonical =+   (P98.fromIntegral :: Int -> Int16) . RealRing.roundSimple . scale16  {-# INLINE int16FromFloat #-} int16FromFloat :: Float -> Int16
+ src/Synthesizer/Basic/ComplexModule.hs view
@@ -0,0 +1,32 @@+{-+Maybe this module should be moved to NumericPrelude.+-}+module Synthesizer.Basic.ComplexModule where++import qualified Number.Complex as Complex+import qualified Algebra.Module as Module+import Number.Complex ((+:), )++import NumericPrelude.Numeric+import Prelude ()+++{-# INLINE scale #-}+scale :: (Module.C a v) =>+   Complex.T a -> v -> Complex.T v+scale s x =+   Complex.real s *> x  +:  Complex.imag s *> x++{-# INLINE mul #-}+mul :: (Module.C a v) =>+   Complex.T a -> Complex.T v -> Complex.T v+mul x y =+   (Complex.real x *> Complex.real y - Complex.imag x *> Complex.imag y)+   +:+   (Complex.real x *> Complex.imag y + Complex.imag x *> Complex.real y)++{-# INLINE project #-}+project :: (Module.C a v) =>+   Complex.T a -> Complex.T v -> v+project x y =+   Complex.real x *> Complex.real y - Complex.imag x *> Complex.imag y
src/Synthesizer/Basic/Distortion.hs view
@@ -1,22 +1,31 @@ {-# LANGUAGE NoImplicitPrelude #-}+{- |+The distortion functions have slope 1 at zero,+if they are differentiable at that point, at all.+This ensures that signals with low amplitude+are only slightly altered.+Non-differentiable distortions try to have an overall slope of 1.+-} module Synthesizer.Basic.Distortion (    clip, logit,    zigZag, sine,+   oddChebyshev, {- swing, -}    quantize,+   powerSigned,    ) where  import qualified Algebra.Transcendental        as Trans import qualified Algebra.RealField             as RealField import qualified Algebra.Field                 as Field-import qualified Algebra.Real                  as Real+import qualified Algebra.RealRing              as RealRing+import qualified Algebra.Absolute              as Absolute import qualified Algebra.Ring                  as Ring-import qualified Algebra.Additive              as Additive +import Data.List.HT (mapAdjacent, ) import Data.Ord.HT (limit, ) --- import qualified Prelude as P--- import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   {- * Clipping -}@@ -24,7 +33,7 @@ {- | limit, fuzz booster -}-clip :: (Real.C a) => a -> a+clip :: (RealRing.C a) => a -> a clip = limit (negate one, one)  {- |@@ -58,9 +67,91 @@ sine = sin  +{- |+Odd Chebyshev polynomial +@oddChebyshev n@ is an appropriately scaled Chebyshev polynomial of order @2*n+1@.+The argument @n@ must be non-negative. +> Graphics.Gnuplot.Simple.plotFuncs [Graphics.Gnuplot.Simple.YRange (-1,1)] (Graphics.Gnuplot.Simple.linearScale 1000 (-7,7::Double)) (List.map oddChebyshev [0..5])+-}+oddChebyshev :: (Trans.C a) => (Field.C a) => Int -> a -> a+oddChebyshev n xn =+   let order = 2*n+1+       {-+       slope of normal Chebyshev polynomials at zero is @order@+       which can be seen when considering slope of @x -> cos (order * arccos x)@+       -}+       x  = parityFlip n (xn / fromIntegral order)+       ys = 1 : x : mapAdjacent (\x0 x1 -> 2*x*x1 - x0) ys+   in  ys !! order++parityFlip :: Ring.C a => Int -> a -> a+parityFlip n x =+   if even n then x else -x+++{- |+A polynomial function with zeros at every integral point+weighted in order to equalize the local extreme points.++However, the weighting is difficult enough,+that it might be easier to use just a truncated Taylor series of sine.++We could compute a weighting denominator polynomial+by dividing our equidistant zeros polynomial by the sine series.++equidist / weight = sine+weight = equidist / sine++However we have to normalize the zeros,+thus powers of pi enter the scene+and then power series division becomes inexact.+-}+_swing :: (Trans.C a) => (Field.C a) => Int -> a -> a+_swing n x =+{-+   foldl (*) x+      (map+         (\ni ->+            let x2 = x^2+                n2 = ni^2+            in  (x2-n2)/sqrt(x2+n2))+         (take n (iterate (1+) 1)))+-}+   foldl (*) x+      (map+         (\ni ->+            let x2 = x^2+                n2 = ni^2+            in  (x2-n2)/(x2+n2))+         (take n (iterate (1+) 1)))+{-+   foldl (*) x+      (map (\ni -> (x/ni)^2-1)+         (take n (iterate (1+) 1)))+-}+{-+   let xu = iterate (1+) x+       xl = iterate (subtract 1) x+   in  foldl (*) x (take n (tail (zipWith (*) xu xl)))+-}+--   in  product (x : take n (tail xu) ++ take n (tail xl))+++ {- * Quantization -}  quantize :: (RealField.C a) => a -> a quantize x = fromIntegral (round x :: Int)+++{- * other -}++{- |+Power function.+Roughly the map @\p x -> x**p@ but retains the sign of @x@.+-}+{-# INLINE powerSigned #-}+powerSigned :: (Absolute.C a, Trans.C a) => a -> a -> a+powerSigned p x = signum x * abs x ** p
src/Synthesizer/Basic/DistortionControlled.hs view
@@ -10,22 +10,19 @@ import qualified Algebra.Transcendental        as Trans import qualified Algebra.RealField             as RealField import qualified Algebra.Field                 as Field-import qualified Algebra.Real                  as Real-import qualified Algebra.Ring                  as Ring-import qualified Algebra.Additive              as Additive+import qualified Algebra.RealRing              as RealRing  import Data.Ord.HT (limit, ) --- import qualified Prelude as P--- import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric + {- * Clipping -}  {- | limit, fuzz booster -}-clip :: (Real.C a) => a -> a -> a+clip :: (RealRing.C a) => a -> a -> a clip c = limit (negate c, c)  {- |
+ src/Synthesizer/Basic/Filter/NonRecursive.hs view
@@ -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
src/Synthesizer/Basic/Phase.hs view
@@ -1,28 +1,33 @@-module Synthesizer.Basic.Phase-   (T,-    fromRepresentative,-    toRepresentative,-    increment,-    decrement,-    multiply,+module Synthesizer.Basic.Phase (+   T,+   fromRepresentative,+   toRepresentative,+   increment,+   decrement,+   multiply,    ) where -import qualified Algebra.RealField             as RealField+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(..), choose)+import Test.QuickCheck (Arbitrary(arbitrary), choose)  import Foreign.Storable (Storable(..), ) import Foreign.Ptr (castPtr, )  import Data.Tuple.HT (mapFst, )-import qualified NumericPrelude as NP +import qualified NumericPrelude.Numeric as NP+import NumericPrelude.Numeric+import NumericPrelude.Base+import Prelude () +import qualified GHC.Float as GHC++ newtype T a = Cons {decons :: a}    deriving Eq @@ -45,46 +50,182 @@  instance (Ring.C a, Random a) => Random (T a) where    randomR = error "Phase.randomR makes no sense"-   random = mapFst Cons . randomR (NP.zero, NP.one)+   random = mapFst Cons . randomR (zero, one)  instance (Ring.C a, Random a) => Arbitrary (T a) where-   arbitrary = fmap Cons $ choose (NP.zero, NP.one)-   coarbitrary = error "Phase.coarbitrary not implemented"+   arbitrary = fmap Cons $ choose (zero, one)    {-# INLINE fromRepresentative #-}-fromRepresentative :: RealField.C a => a -> T a-fromRepresentative = Cons . RealField.fraction+fromRepresentative :: RealRing.C a => a -> T a+fromRepresentative = Cons . RealRing.fraction  {-# INLINE toRepresentative #-} toRepresentative :: T a -> a toRepresentative = decons +{- test, how fast the function can be, if we assume that the increment is smaller than one {-# INLINE increment #-}-increment :: RealField.C a => a -> T a -> T a+increment :: RealRing.C a => a -> T a -> T a+increment d = (+ Cons d)++{-# INLINE decrement #-}+decrement :: RealRing.C a => a -> T a -> T a+decrement d = Additive.subtract (Cons d)+-}++{-# INLINE increment #-}+increment :: RealRing.C a => a -> T a -> T a increment d = lift (d Additive.+)  {-# INLINE decrement #-}-decrement :: RealField.C a => a -> T a -> T a+decrement :: RealRing.C a => a -> T a -> T a decrement d = lift (Additive.subtract d) ++{-# INLINE add #-}+add :: (Ring.C a, Ord a) => T a -> T a -> T a+add (Cons x) (Cons y) =+   let z = x+y+   in  Cons $ if z>=one then z-one else z++{-# INLINE sub #-}+sub :: (Ring.C a, Ord a) => T a -> T a -> T a+sub (Cons x) (Cons y) =+   let z = x-y+   in  Cons $ if z<zero then z+one else z++{-# INLINE neg #-}+neg :: (Ring.C a, Ord a) => T a -> T a+neg (Cons x) =+   Cons $ if x==zero then zero else one-x+ {-# INLINE multiply #-}-multiply :: (RealField.C a, ToInteger.C b) => b -> T a -> T a-multiply n x = fromRepresentative (toRepresentative x Ring.* NP.fromIntegral n)+multiply :: (RealRing.C a, ToInteger.C b) => b -> T a -> T a+multiply n = lift (NP.fromIntegral n Ring.*) +{-+This implementation computes the fraction several times.+We hope that it can reduce cancellations,+but interim rounding errors seem to be equally bad. -instance RealField.C a => Additive.C (T a) where+It is certainly slower than 'multiply' and+it needs as many iterations as the number of bits of the multiplier.++> *Synthesizer.Basic.Phase> multiplyPrecise  (1000000::Integer) (fromRepresentative 2.3) :: T Double+> Phase.fromRepresentative 0.9999999998223643+> *Synthesizer.Basic.Phase> multiply  (1000000::Integer) (fromRepresentative 2.3) :: T Double+> Phase.fromRepresentative 0.999999999825377++{-# INLINE multiplyPrecise #-}+multiplyPrecise :: (RealRing.C a, ToInteger.C b) => b -> T a -> T a+multiplyPrecise n x =+   if n<zero+     then powerAssociative (+) zero (neg x) (fromIntegral (negate n))+     else powerAssociative (+) zero x (fromIntegral n)+-}+++instance RealRing.C a => Additive.C (T a) where    {-# INLINE zero #-}    {-# INLINE (+) #-}    {-# INLINE (-) #-}    {-# INLINE negate #-}    zero = Cons Additive.zero-   x + y = fromRepresentative (toRepresentative x Additive.+ toRepresentative y)-   x - y = fromRepresentative (toRepresentative x Additive.- toRepresentative y)+   (+) = add+   (-) = sub+   negate = neg+{-+This implementation requires fromRepresentative,+that needs to do checks on the size of numbers+in order to choose between float2Int/int2Float and Prelude.properFraction+   (+) = lift2 (Additive.+)+   (-) = lift2 (Additive.-)    negate = lift Additive.negate+-}  {-# INLINE lift #-}-lift :: RealField.C a => (a -> a) -> T a -> T a+lift :: (RealRing.C b) =>+   (a -> b) -> T a -> T b lift f =    fromRepresentative . f . toRepresentative++{-+{-# INLINE lift2 #-}+lift2 :: (RealRing.C c) =>+   (a -> b -> c) -> T a -> T b -> T c+lift2 f x y =+   fromRepresentative (f (toRepresentative x) (toRepresentative y))+-}+++{-# INLINE customFromRepresentative #-}+customFromRepresentative ::+   (Additive.C a) =>+   (a -> i) -> (i -> a) -> a -> T a+customFromRepresentative toInt fromInt x =+   Cons (x Additive.- fromInt (toInt x))++{-# INLINE customLift #-}+customLift ::+   (Additive.C b) =>+   (b -> i) -> (i -> b) ->+   (a -> b) -> T a -> T b+customLift toInt fromInt f =+   customFromRepresentative toInt fromInt . f . toRepresentative++{-+{-# INLINE customLift2 #-}+customLift2 ::+   (Additive.C c) =>+   (c -> i) -> (i -> c) ->+   (a -> b -> c) -> T a -> T b -> T c+customLift2 toInt fromInt f x y =+   customFromRepresentative toInt fromInt $+   f (toRepresentative x) (toRepresentative y)+-}++{-# INLINE customMultiply #-}+customMultiply ::+   (Ring.C a, Ord a, ToInteger.C b) =>+   (a -> i) -> (i -> a) ->+   b -> T a -> T a+customMultiply toInt fromInt n (Cons x) =+   customFromRepresentative toInt fromInt $+   if n<zero && x>zero+     then (one-x) * NP.fromIntegral (NP.negate n)+     else x * NP.fromIntegral n+++{- |+Optimization for the case,+that the integral part of the number is non-negative and fits in an Int.+This is the case for addition and integral scaling.++FIXME:+The increment and decrement routines are a bit dangerous,+because they fail if the increment value is larger than maxBound::Int.+However, we will always use increments with absolute value below one.+-}+{-# RULES++     "Phase.multiply @ Float"  multiply = customMultiply GHC.float2Int  GHC.int2Float;+     "Phase.multiply @ Double" multiply = customMultiply GHC.double2Int GHC.int2Double;++     "Phase.increment @ Float"  increment = \d -> customLift GHC.float2Int  GHC.int2Float  (+d);+     "Phase.increment @ Double" increment = \d -> customLift GHC.double2Int GHC.int2Double (+d);++     "Phase.decrement @ Float"  decrement = \d -> customLift GHC.float2Int  GHC.int2Float  (subtract d);+     "Phase.decrement @ Double" decrement = \d -> customLift GHC.double2Int GHC.int2Double (subtract d);++  #-}++{-+     "Phase.+        @ Float"  (+) = customLift2 GHC.float2Int GHC.int2Float (+);+     "Phase.-        @ Float"  (-) = customLift2 GHC.float2Int GHC.int2Float (-);++     "Phase.+        @ Double" (+) = customLift2 GHC.double2Int GHC.int2Double (+);+     "Phase.-        @ Double" (-) = customLift2 GHC.double2Int GHC.int2Double (-);++-}
src/Synthesizer/Basic/ToneModulation.hs view
@@ -1,21 +1,22 @@ {-# 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  import Synthesizer.Interpolation (Margin, marginOffset, marginNumber, ) --- import qualified Algebra.Transcendental        as Trans import qualified Algebra.RealField             as RealField import qualified Algebra.Field                 as Field--- import qualified Algebra.Real                  as Real import qualified Algebra.Ring                  as Ring-import qualified Algebra.Additive              as Additive -import NumericPrelude---- import qualified Prelude as P-import PreludeBase+import NumericPrelude.Numeric+import NumericPrelude.Base   {- |@@ -28,6 +29,7 @@ (we would only need a Ring instance), but for 'shapeLimit' it is better the way it is. -}+{-# INLINE untangleShapePhase #-} untangleShapePhase :: (Field.C a) =>    Int -> a -> (a, a) -> (a, a) untangleShapePhase periodInt period (shape,phase) =@@ -64,6 +66,7 @@ -}  +{-# INLINE flattenShapePhase #-} flattenShapePhase, flattenShapePhaseAnalytic :: RealField.C a =>       Int    -> a
src/Synthesizer/Basic/Wave.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {- |-Copyright   :  (c) Henning Thielemann 2006+Copyright   :  (c) Henning Thielemann 2006-2010 License     :  GPL  Maintainer  :  synthesizer@henning-thielemann.de@@ -14,17 +14,84 @@ 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,+   superSaw,+   multiSaw,+   square,+   squareCos,+   squareComplex,+   triangle,+   truncOddCosine,+   truncOddTriangle,+   truncCosine,+   truncTriangle,+   powerNormed,+   powerNormed2,+   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 Synthesizer.Basic.Distortion as Distort  import qualified Algebra.RealTranscendental    as RealTrans import qualified Algebra.Transcendental        as Trans+import qualified Algebra.ZeroTestable          as ZeroTestable import qualified Algebra.RealField             as RealField import qualified Algebra.Algebraic             as Algebraic import qualified Algebra.Module                as Module import qualified Algebra.Field                 as Field-import qualified Algebra.Real                  as Real+import qualified Algebra.RealRing              as RealRing+import qualified Algebra.Absolute              as Absolute import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive import qualified Algebra.ToInteger             as ToInteger@@ -32,13 +99,34 @@ import qualified MathObj.Polynomial as Poly import qualified Number.Complex     as Complex +import qualified Control.Applicative as App+ import Data.Bool.HT (select, if', )-import NumericPrelude+import NumericPrelude.Numeric --- import qualified Prelude as P-import PreludeBase+import NumericPrelude.Base  +{- $setup+>>> import qualified Synthesizer.Basic.Wave  as Wave+>>> import qualified Synthesizer.Basic.Phase as Phase+>>>+>>> import qualified Test.QuickCheck as QC+>>>+>>> import NumericPrelude.Numeric+>>> import NumericPrelude.Base+>>> import Prelude ()+>>>+>>> zeroDCOffset :: Wave.T Double Double -> QC.Property+>>> zeroDCOffset wave =+>>>    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 wave) xs))  <  period / fromInteger 100+-}++ {- * Definition and construction -}  newtype T t y = Cons {decons :: Phase.T t -> y}@@ -89,15 +177,29 @@    s *> w = distort (s*>) w  +instance Functor (T t) where+   {-# INLINE fmap #-}+   fmap = distort++instance App.Applicative (T t) where+   {-# INLINE pure #-}+   pure y = Cons (const y)+   {-# INLINE (<*>) #-}+   Cons f <*> Cons y = Cons (\t -> f t (y t))++ {- | Turn an unparametrized waveform into a parametrized one, where the parameter is a phase offset.-This way you express a phase modulated oscillator+This way you may express a phase modulated oscillator using a shape modulated oscillator.++@flip phaseOffset@ could have also be named @rotateLeft@,+since it rotates the wave to the left. -}-{-# SPECULATE phaseOffset :: (T Double b) -> (Double -> T Double b) #-}+{- disabled SPECIALISE phaseOffset :: (T Double b) -> (Double -> T Double b) -} {-# INLINE phaseOffset #-}-phaseOffset :: (RealField.C a) => T a b -> (a -> T a b)+phaseOffset :: (RealRing.C a) => T a b -> (a -> T a b) phaseOffset (Cons wave) offset =    Cons (wave . Phase.increment offset) @@ -108,13 +210,19 @@  {- ** unparameterized -} -{- | map a phase to value of a sine wave -}-{-# SPECULATE sine :: Double -> Double #-}+{- | map a phase to value of a sine wave++prop> zeroDCOffset Wave.sine+-}+{- disabled SPECIALISE sine :: Double -> Double -} {-# INLINE sine #-} sine :: Trans.C a => T a a sine = fromFunction $ \x -> sin (2*pi*x)  {-# INLINE cosine #-}+{- |+prop> zeroDCOffset Wave.cosine+-} cosine :: Trans.C a => T a a cosine = fromFunction $ \x -> cos (2*pi*x) @@ -124,21 +232,80 @@  {- | Approximation of sine by parabolas.-Surprisingly not really faster than 'sine'.+Surprisingly it is not really faster than 'sine'.+The wave results from integrating the 'triangle' wave,+thus it the @k@-th harmonic has amplitude @recip (k^3)@.++prop> zeroDCOffset Wave.fastSine2 -} {-# INLINE fastSine2 #-} fastSine2 :: (Ord a, Ring.C a) => T a a fastSine2 = fromFunction $ \x ->    if 2*x<1+     then -8*x*(2*x-1)+     else 8*(2*x-1)*(x-1)+{-+   if 2*x<1      then 1 - sqr (4*x-1)      else sqr (4*x-3) - 1+-} +{-# INLINE fastSine2Alt #-}+fastSine2Alt :: (RealRing.C a) => T a a+fastSine2Alt =+   distort (\x -> 4*x*(1-abs x)) saw+ {- |-Approximation of sine by fourth order polynomials.+Piecewise third order polynomial approximation by integrating 'fastSine2'.++prop> zeroDCOffset Wave.fastSine3 -}+{-# INLINE fastSine3 #-}+fastSine3 :: (Ord a, Ring.C a) => T a a+fastSine3 = fromFunction $ \x ->+   if' (4*x<1) (2* x   *(3 - (4* x   )^2)) $+   if' (4*x>3) (2*(x-1)*(3 - (4*(x-1))^2)) $+   (1-2*x) * (3 - (4*x-2)^2)+{-+   if' (4*x<1) ((4*x+1)^2*(1-2*x) - 1) $+   if' (4*x>3) ((4*x-3)^2*(3-2*x) - 1) $+   (1 - 2*(4*x-1)^2*(1-x))+-}++{-# INLINE fastSine3Alt #-}+fastSine3Alt :: (RealRing.C a, Field.C a) => T a a+fastSine3Alt =+   distort (\x -> 0.5*x * (3 - x^2)) triangle++{- |+Piecewise fourth order polynomial approximation by integrating 'fastSine3'.++prop> zeroDCOffset Wave.fastSine4+-} {-# INLINE fastSine4 #-}-fastSine4 :: (Ord a, Trans.C a) => T a a+fastSine4 :: (Ord a, Field.C a) => T a a fastSine4 = fromFunction $ \x ->+   let x2 = 2*x+   in  if x2<1+         then 16/5*x2*(x2-1)*(x2^2-x2-1)+         else 16/5*(2-x2)*(x2-1)*(x2^2-3*x2+1)++{-# INLINE fastSine4Alt #-}+fastSine4Alt :: (RealRing.C a, Field.C a) => T a a+fastSine4Alt =+   distort+      (\x ->+         let ax = 1 - abs x+         in  16/5*ax*x*(1+ax-ax^2))+      saw++{- |+Least squares approximation of sine by fourth order polynomials+computed with MuPad.+-}+{-# INLINE fastSine4LeastSquares #-}+fastSine4LeastSquares :: (Ord a, Trans.C a) => T a a+fastSine4LeastSquares = fromFunction $ \x ->    -- minimal least squares fit    let pi2 = pi*pi        pi3 = pi2*pi@@ -156,14 +323,100 @@ -}  {--GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (0,1::Double)) [sine, fastSine2, fastSine4]+GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (0,1::Double)) $ map (\f t -> apply f (Phase.fromRepresentative t)) [sine, fastSine2, fastSine3, fastSine4, fastSine4LeastSquares] -} +{- |+The coefficient of the highest power is the reciprocal of an element from+<http://oeis.org/A000111>+and the polynomial coefficients are+<http://oeis.org/A119879> . +> mapM_ print $ map (\p -> fmap ((round :: Rational -> Integer) . (/last(Poly.coeffs p))) p) (take 10 $ fastSinePolynomials)+-}+{-# INLINE fastSinePolynomials #-}+fastSinePolynomials :: (Field.C a) => [Poly.T a]+fastSinePolynomials =+   concatMap (\(p0,p1) -> [p0,p1]) $+   iterate+      (\(_,p1) ->+         let integrateNormalize p =+                let pint = Poly.integrate zero p+                in  fmap (/ Poly.evaluate pint one) pint+             p2 = one - integrateNormalize p1+             p3 = integrateNormalize p2+         in  (p2,p3))+      (one, Poly.fromCoeffs [zero, one])+{-+GNUPlot.plotFuncs [] (GNUPlot.linearScale 100 (-1,1::Double)) (map Poly.evaluate $ take 8 fastSinePolynomials)+-}++{-# INLINE fastSines #-}+fastSines :: (RealField.C a) => [T a a]+fastSines =+   zipWith ($)+      (cycle+         [\p ->+             {- square and (overtone 2 saw) could be generated in one go+                using splitFraction -}+             App.liftA2 (*) square $+                distort (Poly.evaluate p) $+                overtone (2::Int) saw,+          \p -> distort (Poly.evaluate p) triangle])+      fastSinePolynomials+{-+GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (-2,2::Double)) $ map (\w t -> apply w (Phase.fromRepresentative t)) (take 10 fastSines)+-}++{- |+This is a helix that is distorted in phase+such that 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.+We have chosen this scaling in order to stay with field operations.+-}+{-# INLINE rationalHelix1 #-}+rationalHelix1 :: Field.C a => a -> T a (Complex.T a)+rationalHelix1 k = fromFunction $ \t ->+   let num = k * (2*t-1)+       den = (1-t)*t+   in  negate $+       Complex.scale (recip (den^2+num^2))+          ((den^2-num^2) Complex.+: (2*den*num))+{-+GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (0,5::Double)) $ map (. apply (rationalHelix1 (recip pi)) . Phase.fromRepresentative) [Complex.real, Complex.imag]+-}++rationalHelix1Alt :: Field.C a => a -> T a (Complex.T a)+rationalHelix1Alt k = fromFunction $ \t ->+   negate $ helixFromTangent (k * (recip (1-t) - recip t))++{- |+Here we distort the rational helix in phase+using tangent approximations by a sum of 2*n reciprocal functions.+For the tangent function we obtain perfect cosine and sine,+thus for @k = recip pi@ and high @n@ we approach an undistorted complex helix.+-}+{-# INLINE rationalHelix #-}+rationalHelix :: Field.C a => Int -> a -> T a (Complex.T a)+rationalHelix n k = fromFunction $ \t ->+   negate $ helixFromTangent $ (* negate k) $ sum $ take n $+   zipWith (\d0 d1 -> recip (t + d0) + recip (t + d1))+      (tail $ iterate (subtract 1) 0)+      (iterate (1+) 0)++{-# INLINE helixFromTangent #-}+helixFromTangent :: Field.C a => a -> Complex.T a+helixFromTangent t =+   Complex.scale (recip (1+t^2)) ((1-t^2) Complex.+: (2*t))+ {- | saw tooth, it's a ramp down in order to have a positive coefficient for the first partial sine++prop> zeroDCOffset Wave.saw -}-{-# SPECULATE saw :: Double -> Double #-}+{- disabled SPECIALISE saw :: Double -> Double -} {-# INLINE saw #-} saw :: Ring.C a => T a a saw = fromFunction $ \x -> 1-2*x@@ -173,9 +426,11 @@ but the partial waves are shifted by 90 degree. That is, it is the Hilbert transform of the saw wave. The formula is derived from 'sawComplex'.++prop> zeroDCOffset Wave.sawCos -} {-# INLINE sawCos #-}-sawCos :: (Real.C a, Trans.C a) => T a a+sawCos :: (RealRing.C a, Trans.C a) => T a a sawCos = fromFunction $ \x -> log (2 * sin (pi*x)) * (-2/pi)  {- |@@ -187,11 +442,11 @@ -} {-# INLINE sawComplex #-} sawComplex ::-   (Complex.Power a, RealTrans.C a) =>+   (Complex.Power a, RealTrans.C a, ZeroTestable.C a) =>    T a (Complex.T a) sawComplex = fromFunction $ \x -> log (1 + Complex.cis (-pi*(1-2*x))) * (-2/pi) {--GNUPlot.plotFuncs [] (GNUPlot.linearScale 100 (0,1::Double)) [Complex.real . sawComplex, sawCos]+GNUPlot.plotFuncs [] (GNUPlot.linearScale 100 (0,1::Double)) [Complex.real . apply sawComplex . Phase.fromRepresentative, apply sawCos . Phase.fromRepresentative]  GNUPlot.plotFuncs [] (GNUPlot.linearScale 100 (0,1::Double)) [sawCos, composedHarmonics (take 20 $ harmonic 0 0 : map (\n -> harmonic 0.25 ((2/pi) / fromInteger n)) [1..])] -}@@ -199,7 +454,7 @@ {- Matching implementation that do not match 'saw' exactly. -sawCos :: (Real.C a, Trans.C a) => T a a+sawCos :: (RealRing.C a, Trans.C a) => T a a sawCos = fromFunction $ \x -> log (2 * abs (cos (pi*x)))  sawComplex ::@@ -209,8 +464,77 @@ -}  -{- | square -}-{-# SPECULATE square :: Double -> Double #-}+{-+sum [0..n-1] $ \k -> fraction (x+k*d)+sum [0..n-1] $ \k -> fraction (x+k*(floor d + fraction d))+sum [0..n-1] $ \k -> fraction (x+k*floor d + k*fraction d)+sum [0..n-1] $ \k -> fraction (x + k*fraction d)+sum [0..n-1] $ \k -> fraction (fraction x + k*fraction d)+X = fraction x (0<=X<1)+D = fraction d (0<=D<1)+sum [0..n-1] $ \k -> X+k*D - floor (X+k*D)+n*X + n*(n-1)/2*D - sum [0..n-1] (\k -> floor (X+k*D))++n=1: sum = 0+n=2: sum = floor(X+D)+n=3: sum = floor(X+D)(<2) + floor(X+2*D)(<3)+n=4: sum = floor(X+D) + floor(X+2*D) + floor(X+3*D)++N=n-1+special case: N*D<1   => X+N*D<2++X+(k-1)*D < 1+k-1 < (1-X)/D+k = ceiling((1-X)/D)++sum: max 0 (n - ceiling((1-X)/D))+   = n - min n (ceiling((1-X)/D))++https://math.stackexchange.com/questions/116689/counting-integral-lattice-points-in-a-triangle-that-may-not-have-integer-coordin+-}+{- |+@superSaw n d@ requires @1 <= n@ and @n*d <= 1@.+-}+superSaw, _superSaw :: (RealRing.C a, Field.C a) => Int -> a -> T a a+superSaw n =+   let nf = fromIntegral n+   in \d ->+      fmap (\y -> 1-2*y) $+      fromFunction $ \x ->+         (x + (nf-1)/2*d - 1) + min 1 (ceiling((1-x)/d) / nf)++_superSaw n d =+   fmap (\y -> 1 - 2/fromIntegral n * y) $+   fromFunction $ \x ->+      sum $ map fraction $ take n $ iterate (d+) x+++{- |+>      ///+>     /+>    /+> ///++@multiSaw 0 (-2)@ is the regular saw tooth wave.++Could also be composed by distorting an amplified saw tooth.+-}+multiSaw :: (RealRing.C a, Field.C a) => a -> a -> T a a+multiSaw depth slope =+   fromFunction $ \x ->+      let y = slope*(x-1/2) in+      if' (-1 <= y && y <= 1) y $+      signum y * ((1-depth) + fractionAtGrid depth (abs y - 1))++fractionAtGrid :: (RealRing.C a, Field.C a) => a -> a -> a+fractionAtGrid depth y = if' (depth==0) 0 (depth*fraction (y/depth))+++{- | square++prop> zeroDCOffset Wave.square+-}+{- disabled SPECIALISE square :: Double -> Double -} {-# INLINE square #-} square :: (Ord a, Ring.C a) => T a a square = fromFunction $ \x -> if 2*x<1 then 1 else -1@@ -235,7 +559,7 @@ -} {-# INLINE squareComplex #-} squareComplex ::-   (Complex.Power a, RealTrans.C a) =>+   (Complex.Power a, RealTrans.C a, ZeroTestable.C a) =>    T a (Complex.T a) squareComplex = fromFunction $ \x -> {- these formulas are equivalent but wrong@@ -256,9 +580,20 @@ GNUPlot.plotFuncs [] (GNUPlot.linearScale 100 (0,1::Double)) [squareCos, composedHarmonics (take 20 $ zipWith (\b n -> harmonic 0.25 (if b then (4/pi) / fromInteger n else 0)) (cycle [False,True]) [0..])] -} +{-+The harmonics 0,0,1,0,-1,0,1,0,-1 etc.+would lead to tangent function wave.+This can be derived from dividing+the series for sine by the series for cosine:+   [-1, _0_, 1] / [1, _0_, 1]+-} -{- | triangle -}-{-# SPECULATE triangle :: Double -> Double #-}++{- | triangle++prop> zeroDCOffset Wave.triangle+-}+{- disabled SPECIALISE triangle :: Double -> Double -} {-# INLINE triangle #-} triangle :: (Ord a, Ring.C a) => T a a triangle = fromFunction $ \x ->@@ -359,27 +694,28 @@  {- | Power function.--}+Roughly the map @\p x -> x**p@+but retains the sign of @x@ and+it should normalize the mapping over @[-1,1]@ to an L2 norm of 1,+but I got this one wrong. +The sign is flipped with respect to 'saw' and 'sine'+which is an historical artifact.+-}+{-# DEPRECATED powerNormed "Use powerNormed2 instead." #-}+{-# INLINE powerNormed #-}+powerNormed :: (Absolute.C a, Trans.C a) => a -> T a a+powerNormed p = amplify (-p-0.5) $ distort (Distort.powerSigned p) saw  {- |-Roughly the map @\x p -> x**p@+Power function.+Roughly the map @\p x -> x**p@ but retains the sign of @x@ and-normalizes the mapping over @[-1,1]@ to L2 norm of 1.+normalizes the mapping over @[0,1]@ to an L2 norm of 1. -}-{-# INLINE powerNormed #-}-powerNormed :: (Real.C a, Trans.C a) => a -> T a a-powerNormed p = fromFunction $ \x -> power01Normed p (2*x-1)---- | auxiliary-{-# INLINE power01Normed #-}-power01Normed :: (Real.C a, Trans.C a) => a -> a -> a-power01Normed p x = (p+0.5) * powerSigned p x---- | auxiliary-{-# INLINE powerSigned #-}-powerSigned :: (Real.C a, Trans.C a) => a -> a -> a-powerSigned p x = signum x * abs x ** p+{-# INLINE powerNormed2 #-}+powerNormed2 :: (Absolute.C a, Trans.C a) => a -> T a a+powerNormed2 p = amplify (sqrt (1+2*p)) $ distort (Distort.powerSigned p) saw   {- |@@ -406,11 +742,11 @@ Interpolation between 'sine' and 'square'. -} {-# INLINE sineSquare #-}-sineSquare :: (Real.C a, Trans.C a) =>+sineSquare :: (RealRing.C a, Trans.C a) =>       a {- ^ 0 for 'sine', 1 for 'square' -}    -> T a a sineSquare c =-   distort (powerSigned (1-c)) sine+   distort (Distort.powerSigned (1-c)) sine   @@ -533,6 +869,21 @@ affineComb phase (x0,x1) = (1-phase)*x0 + phase*x1  +{- |+Harmonics of a saw wave that is smoothed by a Gaussian lowpass filter.+This can also be used to interpolate between saw wave and sine.+The parameter is the cutoff-frequency+defined as the standard deviation of the Gaussian in frequency space.+That is, high values approximate a saw and need many harmonics,+whereas low values tend to a sine and need only few harmonics.+-}+sawGaussianHarmonics ::+   (RealField.C a, Trans.C a) => a -> [Harmonic a]+sawGaussianHarmonics cutoff =+   (harmonic zero 0 :) $+   map (\n -> harmonic zero (exp (-(n/cutoff)^2 / 2) * 2 / (pi*n))) $+   iterate (1+) 1+ {- {- | Smooth saw generated by a quintic polynomial function.@@ -565,7 +916,7 @@ {- | saw with space -}-{-# SPECULATE sawPike :: Double -> Double -> Double #-}+{- disabled SPECIALISE sawPike :: Double -> Double -> Double -} {-# INLINE sawPike #-} sawPike :: (Ord a, Field.C a) =>       a {- ^ pike width ranging from 0 to 1, 1 yields 'saw' -}@@ -578,9 +929,9 @@ {- | triangle with space -}-{-# SPECULATE trianglePike :: Double -> Double -> Double #-}+{- disabled SPECIALISE trianglePike :: Double -> Double -> Double -} {-# INLINE trianglePike #-}-trianglePike :: (Real.C a, Field.C a) =>+trianglePike :: (RealRing.C a, Field.C a) =>       a  {- ^ pike width ranging from 0 to 1, 1 yields 'triangle' -}    -> T a a trianglePike r = fromFunction $ \x ->@@ -591,9 +942,9 @@ {- | triangle with space and shift -}-{-# SPECULATE trianglePikeShift :: Double -> Double -> Double -> Double #-}+{- disabled SPECIALISE trianglePikeShift :: Double -> Double -> Double -> Double -} {-# INLINE trianglePikeShift #-}-trianglePikeShift :: (Real.C a, Field.C a) =>+trianglePikeShift :: (RealRing.C a, Field.C a) =>       a  {- ^ pike width ranging from 0 to 1 -}    -> a  {- ^ shift ranges from -1 to 1; 0 yields 'trianglePike' -}    -> T a a@@ -606,9 +957,9 @@ square with space, can also be generated by mixing square waves with different phases -}-{-# SPECULATE squarePike :: Double -> Double -> Double #-}+{- disabled SPECIALISE squarePike :: Double -> Double -> Double -} {-# INLINE squarePike #-}-squarePike :: (Real.C a) =>+squarePike :: (RealRing.C a) =>       a  {- ^ pike width ranging from 0 to 1, 1 yields 'square' -}    -> T a a squarePike r = fromFunction $ \x ->@@ -619,9 +970,9 @@ {- | square with space and shift -}-{-# SPECULATE squarePikeShift :: Double -> Double -> Double -> Double #-}+{- disabled SPECIALISE squarePikeShift :: Double -> Double -> Double -> Double -} {-# INLINE squarePikeShift #-}-squarePikeShift :: (Real.C a) =>+squarePikeShift :: (RealRing.C a) =>       a  {- ^ pike width ranging from 0 to 1 -}    -> a  {- ^ shift ranges from -1 to 1; 0 yields 'squarePike' -}    -> T a a@@ -634,7 +985,7 @@ {- | square with different times for high and low -}-{-# SPECULATE squareAsymmetric :: Double -> Double -> Double #-}+{- disabled SPECIALISE squareAsymmetric :: Double -> Double -> Double -} {-# INLINE squareAsymmetric #-} squareAsymmetric :: (Ord a, Ring.C a) =>       a  {- ^ value between -1 and 1 controlling the ratio of high and low time:@@ -648,8 +999,10 @@ {- | Like 'squareAsymmetric' but with zero average. It could be simulated by adding two saw oscillations with 180 degree phase difference and opposite sign.++prop> QC.forAll (QC.choose (-1,1)) $ zeroDCOffset . Wave.squareBalanced -}-{-# SPECULATE squareBalanced :: Double -> Double -> Double #-}+{- disabled SPECIALISE squareBalanced :: Double -> Double -> Double -} {-# INLINE squareBalanced #-} squareBalanced :: (Ord a, Ring.C a) => a -> T a a squareBalanced r =@@ -658,7 +1011,7 @@ {- | triangle -}-{-# SPECULATE sawPike :: Double -> Double -> Double #-}+{- disabled SPECIALISE sawPike :: Double -> Double -> Double -} {-# INLINE triangleAsymmetric #-} triangleAsymmetric :: (Ord a, Field.C a) =>       a  {- ^ asymmetry parameter ranging from -1 to 1:@@ -673,10 +1026,12 @@  {- | Mixing 'trapezoid' and 'trianglePike' you can get back a triangle wave form++prop> QC.forAll (QC.choose (0,1)) $ zeroDCOffset . Wave.trapezoid -}-{-# SPECULATE trapezoid :: Double -> Double -> Double #-}+{- disabled SPECIALISE trapezoid :: Double -> Double -> Double -} {-# INLINE trapezoid #-}-trapezoid :: (Real.C a, Field.C a) =>+trapezoid :: (RealRing.C a, Field.C a) =>       a  {- ^ width of the plateau ranging from 0 to 1:               0 yields 'triangle', 1 yields 'square' -}    -> T a a@@ -690,9 +1045,9 @@ That is the high and low trapezoids are symmetric itself, but the whole waveform is not symmetric. -}-{-# SPECULATE trapezoidAsymmetric :: Double -> Double -> Double -> Double #-}+{- disabled SPECIALISE trapezoidAsymmetric :: Double -> Double -> Double -> Double -} {-# INLINE trapezoidAsymmetric #-}-trapezoidAsymmetric :: (Real.C a, Field.C a) =>+trapezoidAsymmetric :: (RealRing.C a, Field.C a) =>       a  {- ^ sum of the plateau widths ranging from 0 to 1:               0 yields 'triangleAsymmetric',               1 yields 'squareAsymmetric' -}@@ -719,10 +1074,16 @@  {- | trapezoid with distinct high and low time and zero direct current offset++prop> :{+   QC.forAll (QC.choose (0,1)) $ \w ->+   QC.forAll (QC.choose (-1,1)) $ \r ->+   zeroDCOffset $ Wave.trapezoidBalanced w r+:} -}-{-# SPECULATE trapezoidBalanced :: Double -> Double -> Double -> Double #-}+{- disabled SPECIALISE trapezoidBalanced :: Double -> Double -> Double -> Double -} {-# INLINE trapezoidBalanced #-}-trapezoidBalanced :: (Real.C a, Field.C a) => a -> a -> T a a+trapezoidBalanced :: (RealRing.C a, Field.C a) => a -> a -> T a a trapezoidBalanced w r =    raise (-w*r) $ trapezoidAsymmetric w r @@ -744,7 +1105,14 @@  {- | This is similar to Polar coordinates,-but the range of the phase is from @0@ to @1@, @0@ to @2*pi@.+but the range of the phase is from @0@ to @1@, not @0@ to @2*pi@.++If you need to represent a harmonic by complex coefficients+instead of the polar representation,+then please build a complex valued polynomial from your coefficients+and use it to distort a 'helix'.++> distort (Poly.evaluate (Poly.fromCoeffs complexCoefficients)) helix -} data Harmonic a =    Harmonic {harmonicPhase :: Phase.T a, harmonicAmplitude :: a}
src/Synthesizer/Basic/WaveSmoothed.hs view
@@ -38,22 +38,18 @@ 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.Real                  as Real+import qualified Algebra.RealRing              as RealRing import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive  import qualified MathObj.Polynomial as Poly import qualified Number.Complex     as Complex -import NumericPrelude---- import qualified Prelude as P-import PreludeBase+import NumericPrelude.Numeric+import NumericPrelude.Base   {- * Definition and construction -}@@ -73,14 +69,14 @@ -} {-# INLINE fromWave #-} fromWave ::-   (Field.C t, Real.C t, Additive.C y) =>+   (Field.C t, RealRing.C t, Additive.C y) =>    Wave.T t y -> (T t y) fromWave wave =    fromControlledWaveAux (\f -> if abs f >= 1/2 then zero else wave)  {-# INLINE fromControlledWave #-} fromControlledWave ::-   (Field.C t, Real.C t, Additive.C y) =>+   (Field.C t, RealRing.C t, Additive.C y) =>    (t -> Wave.T t y) -> (T t y) fromControlledWave wave =    fromControlledWaveAux (\f0 ->@@ -139,11 +135,11 @@  {- | map a phase to value of a sine wave -} {-# INLINE sine #-}-sine :: (Trans.C a, Real.C a) => T a a+sine :: (Trans.C a, RealRing.C a) => T a a sine = fromWave Wave.sine  {-# INLINE cosine #-}-cosine :: (Trans.C a, Real.C a) => T a a+cosine :: (Trans.C a, RealRing.C a) => T a a cosine = fromWave Wave.cosine  @@ -151,21 +147,21 @@ it's a ramp down in order to have a positive coefficient for the first partial sine -} {-# INLINE saw #-}-saw :: (Real.C a, Field.C a) => T a a+saw :: (RealRing.C a, Field.C a) => T a a saw =    fromControlledWave (\f -> Wave.triangleAsymmetric (2*f-1))   {- | square -} {-# INLINE square #-}-square :: (Real.C a, Field.C a) => T a a+square :: (RealRing.C a, Field.C a) => T a a square =    fromControlledWave (\f -> Wave.trapezoid (1-2*f))   {- | triangle -} {-# INLINE triangle #-}-triangle :: (Real.C a, Field.C a) => T a a+triangle :: (RealRing.C a, Field.C a) => T a a triangle = fromWave Wave.triangle  @@ -179,7 +175,7 @@ using a complex exponential as argument. -} {-# INLINE composedHarmonics #-}-composedHarmonics :: (Trans.C a, Real.C a) => [Wave.Harmonic a] -> T a a+composedHarmonics :: (Trans.C a, RealRing.C a) => [Wave.Harmonic a] -> T a a composedHarmonics hs =    let c = map (\h -> Complex.fromPolar (Wave.harmonicAmplitude h)                    (2*pi * Phase.toRepresentative (Wave.harmonicPhase h))) hs
+ src/Synthesizer/Causal/Analysis.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.Causal.Analysis where++import qualified Synthesizer.Causal.Filter.Recursive.Integration as Integration++import qualified Synthesizer.Causal.Process as Causal+import qualified Synthesizer.Plain.Analysis as Ana++import qualified Algebra.RealRing              as RealRing++import Control.Arrow (second, (^<<), (<<^), )++import qualified Data.Map as Map++import NumericPrelude.Numeric+import NumericPrelude.Base+++{- $setup+>>> import qualified Synthesizer.Causal.Analysis as AnaC+>>> import qualified Synthesizer.Causal.Process as Causal+>>> import qualified Synthesizer.Plain.Analysis as Ana+>>>+>>> import Control.Arrow ((<<<))+>>>+>>> import qualified Data.NonEmpty.Class as NonEmptyC+>>> import qualified Data.NonEmpty as NonEmpty+>>> import qualified Data.List.Match as Match+>>> import qualified Data.List as List+>>>+>>> import qualified Test.QuickCheck as QC+>>>+>>> import NumericPrelude.Numeric+>>> import NumericPrelude.Base+>>> import Prelude ()+-}+++flipFlopHysteresis ::+   (Ord y) => (y,y) -> Ana.BinaryLevel -> Causal.T y Ana.BinaryLevel+flipFlopHysteresis bnds = Causal.scanL (Ana.flipFlopHysteresisStep bnds)++{- |+prop> :{+   \xs ->+      Match.take xs (Ana.deltaSigmaModulation xs)+      ==+      Causal.apply AnaC.deltaSigmaModulation (xs::[Rational])+:}+-}+deltaSigmaModulation ::+   RealRing.C y => Causal.T y Ana.BinaryLevel+deltaSigmaModulation =+   Causal.feedback+      ((Ana.binaryLevelFromBool . (zero <=)) ^<<+       Integration.run <<^+       uncurry (-))+      (Causal.consInit zero <<^ Ana.binaryLevelToNumber)++{- |+prop> :{+   \threshold xs ->+      Match.take xs (Ana.deltaSigmaModulationPositive threshold xs)+      ==+      Causal.apply+         (AnaC.deltaSigmaModulationPositive <<<+          Causal.feedConstFst threshold)+         (xs::[Rational])+:}+-}+deltaSigmaModulationPositive ::+   RealRing.C y => Causal.T (y, y) y+deltaSigmaModulationPositive =+   Causal.feedback+      ((\(threshold,xi) -> if threshold<=xi then threshold else zero) ^<<+       second Integration.run <<^+       (\((threshold,xi),cum) -> (threshold,xi-cum)))+      (Causal.consInit zero)+++{-+Abuse (Map a ()) as (Set a),+because in GHC-7.4.2 there is no Set.elemAt function.+-}+{- |+prop> :{+   let movingMedian :: (Ord a) => Int -> [a] -> [a]+       movingMedian n =+         map (\xs -> List.sort xs !! div (length xs) 2) . NonEmpty.tail .+         NonEmptyC.zipWith (drop . max 0) (NonEmptyC.iterate succ (negate n)) .+         NonEmpty.inits++   in QC.forAll (QC.choose (1,20)) $ \n xs ->+         movingMedian n xs+         ==+         Causal.apply (AnaC.movingMedian n) (xs::[Char])+:}+-}+movingMedian :: (Ord a) => Int -> Causal.T a a+movingMedian n =+   Causal.mapAccumL+      (\new (k,queue,oldSet) ->+         let set =+               Map.insert (new,k) () $+               maybe id (\old -> Map.delete (old,k)) (Map.lookup k queue) oldSet+         in  (fst $ fst $ Map.elemAt (div (Map.size set) 2) set,+              (mod (k+1) n, Map.insert k new queue, set)))+      (0, Map.empty, Map.empty)
+ src/Synthesizer/Causal/Arrow.hs view
@@ -0,0 +1,17 @@+module Synthesizer.Causal.Arrow where++import qualified Synthesizer.Causal.Process as Causal+import qualified Synthesizer.Generic.Signal as SigG+import Control.Arrow (Arrow, )+++class Arrow arrow => C arrow where+   apply ::+      (SigG.Transform sig a, SigG.Transform sig b) =>+      arrow a b -> sig a -> sig b++instance C Causal.T where+   apply = Causal.apply++instance C (->) where+   apply = SigG.map
+ src/Synthesizer/Causal/Class.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE TypeFamilies #-}+module Synthesizer.Causal.Class (+   module Synthesizer.Causal.Class,+   Util.chainControlled,+   Util.replicateControlled,+   ) where++import qualified Synthesizer.Causal.Utility as Util++import qualified Control.Category as Cat+import Control.Arrow (Arrow, arr, (<<<), (&&&), )+++type family ProcessOf (signal :: * -> *) :: * -> * -> *++class (Arrow process, ProcessOf (SignalOf process) ~ process) => C process where+   type SignalOf process :: * -> *+   toSignal :: process () a -> SignalOf process a+   fromSignal :: SignalOf process b -> process a b+++infixl 0 $<, $>, $*+-- infixr 0 $:*   -- can be used together with $++apply ::+   (C process) => process a b -> SignalOf process a -> SignalOf process b+apply proc sig =+   toSignal (proc <<< fromSignal sig)++applyFst, ($<) ::+   (C process) => process (a,b) c -> SignalOf process a -> process b c+applyFst proc sig =+   proc <<< feedFst sig++applySnd, ($>) ::+   (C process) => process (a,b) c -> SignalOf process b -> process a c+applySnd proc sig =+   proc <<< feedSnd sig++applyConst ::+   (C process) => process a b -> a -> SignalOf process b+applyConst proc a =+   toSignal (proc <<< arr (\() -> a))++applyConstFst ::+   (Arrow process) => process (a,b) c -> a -> process b c+applyConstFst proc a =+   proc <<< feedConstFst a++applyConstSnd ::+   (Arrow process) => process (a,b) c -> b -> process a c+applyConstSnd proc a =+   proc <<< feedConstSnd a+++feedFst :: (C process) => SignalOf process a -> process b (a,b)+feedFst sig =+   fromSignal sig &&& Cat.id++feedSnd :: (C process) => SignalOf process a -> process b (b,a)+feedSnd sig =+   Cat.id &&& fromSignal sig++{-# INLINE feedConstFst #-}+feedConstFst :: (Arrow process) => a -> process b (a,b)+feedConstFst a = arr (\b -> (a,b))++{-# INLINE feedConstSnd #-}+feedConstSnd :: (Arrow process) => a -> process b (b,a)+feedConstSnd a = arr (\b -> (b,a))+++($*) ::+   (C process) =>+   process a b -> SignalOf process a -> SignalOf process b+($*) = apply+($<) = applyFst+($>) = applySnd
+ src/Synthesizer/Causal/Cut.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.Causal.Cut where++import qualified Synthesizer.Causal.Process as Causal++import Control.Monad.Trans.State (StateT(StateT), )++import Data.Maybe.HT (toMaybe, )++import NumericPrelude.Numeric+import NumericPrelude.Base+++{-# INLINE take #-}+take :: Int -> Causal.T a a+take =+   Causal.fromStateMaybe (\x ->+      StateT (\i -> toMaybe (i>0) (x, pred i)))
src/Synthesizer/Causal/Displacement.hs view
@@ -1,16 +1,17 @@ {-# LANGUAGE NoImplicitPrelude #-} module Synthesizer.Causal.Displacement where -import qualified Synthesizer.Causal.Process as Causal+import qualified Control.Arrow as A +import qualified Algebra.Transcendental        as Trans+import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive -import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base  -{- * Mixing -}+-- * Mixing  {-| Mix two signals.@@ -18,8 +19,8 @@ that is the result is as long as the shorter of both inputs. -} {-# INLINE mix #-}-mix :: (Additive.C v) => Causal.T (v,v) v-mix = Causal.map (uncurry (+))+mix :: (Additive.C v, A.Arrow arrow) => arrow (v,v) v+mix = A.arr (uncurry (+))   {-|@@ -27,15 +28,36 @@ This is useful for adjusting the center of a modulation. -} {-# INLINE raise #-}-raise :: (Additive.C v) => v -> Causal.T v v-raise x = Causal.map (x+)+raise :: (Additive.C v, A.Arrow arrow) => v -> arrow v v+raise x = A.arr (x+)  -{- * Distortion -}+-- * Distortion {-| In "Synthesizer.Basic.Distortion" you find a collection of appropriate distortion functions. -} {-# INLINE distort #-}-distort :: (c -> a -> a) -> Causal.T (c,a) a-distort f = Causal.map (uncurry f)+distort :: (A.Arrow arrow) => (c -> a -> a) -> arrow (c,a) a+distort f = A.arr (uncurry f)++-- * Preprocessing of control curves++{-# INLINE mapLinear #-}+mapLinear :: (Ring.C a, A.Arrow arrow) =>+   a ->+   a ->+   arrow a a+mapLinear depth center =+   A.arr (\x -> center*(one+x*depth))++{-# INLINE mapExponential #-}+mapExponential :: (Trans.C a, A.Arrow arrow) =>+   a ->+   a ->+   arrow a a+mapExponential depth center =+   -- Sig.map ((center*) . (depth**))+   -- should be faster+   let logDepth = log depth+   in  A.arr ((center*) . exp . (logDepth*))
+ src/Synthesizer/Causal/Filter/NonRecursive.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.Causal.Filter.NonRecursive where++import qualified Synthesizer.Causal.Process as Causal+import Control.Arrow ((>>>), )++import qualified Synthesizer.Generic.Filter.NonRecursive as FiltG+import qualified Synthesizer.Generic.Signal as SigG+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, )++import qualified Algebra.Module         as Module+import qualified Algebra.Field          as Field+import qualified Algebra.Ring           as Ring+import qualified Algebra.Additive       as Additive++import NumericPrelude.Numeric+import NumericPrelude.Base as NP+++{-# INLINE amplify #-}+amplify :: (Ring.C a) => a -> Causal.T a a+amplify v = Causal.map (v*)++{-# INLINE amplifyVector #-}+amplifyVector :: (Module.C a v) => a -> Causal.T v v+amplifyVector v = Causal.map (v*>)+++{-# INLINE envelope #-}+envelope :: (Ring.C a) =>+   Causal.T (a,a) a+envelope = Causal.map (uncurry (*))++{-# INLINE envelopeVector #-}+envelopeVector :: (Module.C a v) =>+   Causal.T (a,v) v+envelopeVector = Causal.map (uncurry (*>))+++{-# INLINE crossfade #-}+crossfade :: (Field.C a, Module.C a a) => Int -> Causal.T (a,a) a+crossfade len =+   let affineCombMono :: (Module.C a a) => a -> (a,a) -> a+       affineCombMono = affineComb+   in  Causal.applyFst+          (Causal.map (uncurry affineCombMono))+          (CtrlS.line len (0, 1))+++{-# INLINE accumulatePosModulatedFromPyramid #-}+accumulatePosModulatedFromPyramid ::+   (SigG.Transform sig v) =>+   ([sig v] -> (Int,Int) -> v) ->+   [sig v] -> Causal.T (Int,Int) v+accumulatePosModulatedFromPyramid summer pyr0 =+   let sizes = Filt.unitSizesFromPyramid pyr0+       pyrStarts =+          SigS.iterate (zipWith SigG.drop sizes) pyr0+       offsets =+          SigS.take (head sizes) (SigS.iterate (1+) 0)+   in  Causal.feedFst (SigS.liftA2 (,) pyrStarts offsets) >>>+       Causal.map (\((pyr,offset), (lo,hi)) ->+          summer pyr (offset+lo, offset+hi))++{-# INLINE sumsPosModulatedFromPyramid #-}+sumsPosModulatedFromPyramid ::+   (Additive.C v, SigG.Transform sig v) =>+   [sig v] -> Causal.T (Int,Int) v+sumsPosModulatedFromPyramid =+   accumulatePosModulatedFromPyramid FiltG.sumRangeFromPyramid
+ src/Synthesizer/Causal/Filter/Recursive/Integration.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+Copyright   :  (c) Henning Thielemann 2009+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++Filter operators from calculus+-}+module Synthesizer.Causal.Filter.Recursive.Integration where++import qualified Synthesizer.Causal.Process as Causal+import qualified Control.Monad.Trans.State as State++import qualified Algebra.Additive              as Additive++import NumericPrelude.Numeric+import NumericPrelude.Base++++{- |+Integrate with initial value zero.+However the first emitted value is the value of the input signal.+It maintains the length of the signal.+-}+{-# INLINE run #-}+run :: Additive.C v => Causal.T v v+run = Causal.fromState (\x -> State.modify (x+) >> State.get) zero++{- |+Integrate with initial condition.+First emitted value is the initial condition.+The signal becomes one element longer.+-}+{-# INLINE runInit #-}+runInit :: Additive.C v => v -> Causal.T v v+runInit = Causal.fromState (\x -> State.state (\s -> (s, s+x)))++{- other quadrature methods may follow -}
src/Synthesizer/Causal/Interpolation.hs view
@@ -21,20 +21,19 @@  import qualified Algebra.Module    as Module import qualified Algebra.RealField as RealField+import qualified Algebra.RealRing  as RealRing import qualified Algebra.Additive  as Additive -import Algebra.Additive(zero) --import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   {-* Interpolation at multiple nodes with various padding methods -}  {- | All values of frequency control must be non-negative. -} {-# INLINE relative #-}-relative :: (RealField.C t) =>+relative :: (RealRing.C t) =>    Interpolation.T t y -> t -> Sig.T y -> Causal.T t y relative ip phase0 x0 =    Causal.crochetL@@ -45,19 +44,19 @@   {-# INLINE relativeZeroPad #-}-relativeZeroPad :: (RealField.C t) =>+relativeZeroPad :: (RealRing.C t) =>    y -> Interpolation.T t y -> t -> Sig.T y -> Causal.T t y relativeZeroPad z ip phase x =    InterpolationS.zeroPad relative z ip phase x  {-# INLINE relativeConstantPad #-}-relativeConstantPad :: (RealField.C t) =>+relativeConstantPad :: (RealRing.C t) =>    Interpolation.T t y -> t -> Sig.T y -> Causal.T t y relativeConstantPad ip phase x =    InterpolationS.constantPad relative ip phase x  {-# INLINE relativeCyclicPad #-}-relativeCyclicPad :: (RealField.C t) =>+relativeCyclicPad :: (RealRing.C t) =>    Interpolation.T t y -> t -> Sig.T y -> Causal.T t y relativeCyclicPad ip phase x =    InterpolationS.cyclicPad relative ip phase x@@ -66,7 +65,7 @@ The extrapolation may miss some of the first and some of the last points -} {-# INLINE relativeExtrapolationPad #-}-relativeExtrapolationPad :: (RealField.C t) =>+relativeExtrapolationPad :: (RealRing.C t) =>    Interpolation.T t y -> t -> Sig.T y -> Causal.T t y relativeExtrapolationPad ip phase x =    InterpolationS.extrapolationPad relative ip phase x@@ -79,14 +78,14 @@  {-# INLINE relativeZeroPadConstant #-} relativeZeroPadConstant ::-   (RealField.C t, Additive.C y) =>+   (RealRing.C t, Additive.C y) =>    t -> Sig.T y -> Causal.T t y relativeZeroPadConstant =    relativeZeroPad zero IpExample.constant  {-# INLINE relativeZeroPadLinear #-} relativeZeroPadLinear ::-   (RealField.C t, Module.C t y) =>+   (RealRing.C t, Module.C t y) =>    t -> Sig.T y -> Causal.T t y relativeZeroPadLinear =    relativeZeroPad zero IpExample.linear
src/Synthesizer/Causal/Oscillator.hs view
@@ -11,148 +11,129 @@ -} 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 Synthesizer.State.ToneModulation (freqsToPhases, )--{--import qualified Algebra.RealTranscendental    as RealTrans-import qualified Algebra.Field                 as Field-import qualified Algebra.Module                as Module-import qualified Algebra.VectorSpace           as VectorSpace+import qualified Synthesizer.State.Signal as Sig -import Algebra.Module((*>))--} import qualified Algebra.Transcendental        as Trans import qualified Algebra.RealField             as RealField-import qualified Algebra.Ring                  as Ring-import qualified Algebra.Additive              as Additive--import Control.Arrow ((^<<), (<<^), (<<<), (&&&), (***), second, returnA, )+import qualified Algebra.RealRing              as RealRing -import NumericPrelude+import Control.Arrow ((^<<), (<<^), (<<<), (***), ) -import qualified Prelude as P-import PreludeBase+import NumericPrelude.Numeric+import NumericPrelude.Base    {- * Oscillators with arbitrary but constant waveforms -} -{-# INLINE freqToPhases #-}-freqToPhases :: RealField.C a =>-   Phase.T a -> a -> Sig.T (Phase.T a)-freqToPhases phase freq =-   Sig.iterate (Phase.increment freq) phase-- {- {-# INLINE static #-} {- | oscillator with constant frequency -}-static :: (RealField.C a) =>-    Wave.T a b -> (Phase.T a -> a -> Sig.T b)+static :: (RealRing.C a) =>+   Wave.T a b -> (Phase.T a -> a -> Sig.T b) static wave phase freq =-    Sig.map (Wave.apply wave) (freqToPhases phase freq)+   Sig.map (Wave.apply wave) (Osci.static phase freq) -}   {-# INLINE phaseMod #-} {- | oscillator with modulated phase -}-phaseMod :: (RealField.C a) =>-    Wave.T a b -> a -> Causal.T a b-phaseMod wave = shapeMod (Wave.phaseOffset wave) zero+phaseMod :: (RealRing.C a) =>+   Wave.T a b -> a -> Causal.T a b+phaseMod wave freq =+   Wave.apply wave ^<< Osci.phaseMod freq  {-# INLINE shapeMod #-} {- | oscillator with modulated shape -}-shapeMod :: (RealField.C a) =>-    (c -> Wave.T a b) -> Phase.T a -> a -> Causal.T c b+shapeMod :: (RealRing.C a) =>+   (c -> Wave.T a b) -> Phase.T a -> a -> Causal.T c b shapeMod wave phase freq =-    Causal.applySnd-       (Causal.map (uncurry (Wave.apply . wave)))-       (freqToPhases phase freq)+   uncurry (Wave.apply . wave) ^<<+   Osci.shapeMod phase freq   {-# INLINE freqMod #-} {- | oscillator with modulated frequency -}-freqMod :: (RealField.C a) =>-    Wave.T a b -> Phase.T a -> Causal.T a b+freqMod :: (RealRing.C a) =>+   Wave.T a b -> Phase.T a -> Causal.T a b freqMod wave phase =-    Causal.map (Wave.apply wave) <<< freqsToPhases phase+   Wave.apply wave ^<< Osci.freqMod phase  {-# INLINE freqModAntiAlias #-} {- | oscillator with modulated frequency -}-freqModAntiAlias :: (RealField.C a) =>-    WaveSmooth.T a b -> Phase.T a -> Causal.T a b+freqModAntiAlias :: (RealRing.C a) =>+   WaveSmooth.T a b -> Phase.T a -> Causal.T a b freqModAntiAlias wave phase =-    Causal.map (uncurry (WaveSmooth.apply wave)) <<<-    returnA &&& freqsToPhases phase+   uncurry (WaveSmooth.apply wave) ^<<+   Osci.freqModAntiAlias phase  {-# INLINE phaseFreqMod #-} {- | oscillator with both phase and frequency modulation -}-phaseFreqMod :: (RealField.C a) =>-    Wave.T a b -> Causal.T (a,a) b-phaseFreqMod wave = shapeFreqMod (Wave.phaseOffset wave) zero+phaseFreqMod :: (RealRing.C a) =>+   Wave.T a b -> Causal.T (a,a) b+phaseFreqMod wave =+   Wave.apply wave ^<< Osci.phaseFreqMod  {-# INLINE shapeFreqMod #-} {- | oscillator with both shape and frequency modulation -}-shapeFreqMod :: (RealField.C a) =>-    (c -> Wave.T a b) -> Phase.T a -> Causal.T (c,a) b+shapeFreqMod :: (RealRing.C a) =>+   (c -> Wave.T a b) -> Phase.T a -> Causal.T (c,a) b shapeFreqMod wave phase =-    Causal.map (uncurry (Wave.apply . wave)) <<<-    second (freqsToPhases phase)+   uncurry (Wave.apply . wave) ^<<+   Osci.shapeFreqMod phase   {- {- | oscillator with a sampled waveform with constant frequency-     This essentially an interpolation with cyclic padding. -}+    This essentially an interpolation with cyclic padding. -} {-# INLINE staticSample #-}-staticSample :: RealField.C a =>-    Interpolation.T a b -> Sig.T b -> Phase.T a -> a -> Sig.T b+staticSample :: RealRing.C a =>+   Interpolation.T a b -> Sig.T b -> Phase.T a -> a -> Sig.T b staticSample ip wave phase freq =-    Causal.apply (freqModSample ip wave phase) (Sig.repeat freq)+   Causal.apply (freqModSample ip wave phase) (Sig.repeat freq) -}  {- | oscillator with a sampled waveform with modulated frequency-     Should behave homogenously for different types of interpolation. -}+    Should behave homogenously for different types of interpolation. -} {-# INLINE freqModSample #-}-freqModSample :: RealField.C a =>-    Interpolation.T a b -> Sig.T b -> Phase.T a -> Causal.T a b+freqModSample :: RealRing.C a =>+   Interpolation.T a b -> Sig.T b -> Phase.T a -> Causal.T a b freqModSample ip wave phase =-    let len = Sig.length wave-        pr  = fromIntegral len * Phase.toRepresentative phase-    in  InterpolationC.relativeCyclicPad ip pr wave-          <<< Causal.map (fromIntegral len *)+   let len = Sig.length wave+       pr  = fromIntegral len * Phase.toRepresentative phase+   in  InterpolationC.relativeCyclicPad ip pr wave+         <<< Causal.map (fromIntegral len *)   {-# INLINE shapeFreqModSample #-}-shapeFreqModSample :: (RealField.C c, RealField.C b) =>-    Interpolation.T c (Wave.T b a) -> Sig.T (Wave.T b a) ->-    c -> Phase.T b ->-    Causal.T (c, b) a+shapeFreqModSample :: (RealRing.C c, RealRing.C b) =>+   Interpolation.T c (Wave.T b a) -> Sig.T (Wave.T b a) ->+   c -> Phase.T b ->+   Causal.T (c, b) a shapeFreqModSample ip waves shape0 phase =-    uncurry Wave.apply ^<<-       (InterpolationC.relativeConstantPad ip shape0 waves ***-        freqsToPhases phase)+   uncurry Wave.apply ^<<+      (InterpolationC.relativeConstantPad ip shape0 waves ***+       Osci.freqMod phase)  {-# INLINE shapeFreqModFromSampledTone #-} shapeFreqModFromSampledTone ::-    (RealField.C t, SigG.Transform sig y) =>-    Interpolation.T t y ->-    Interpolation.T t y ->-    t -> sig y ->-    t -> Phase.T t ->-    Causal.T (t,t) y+   (RealField.C t, SigG.Transform sig y) =>+   Interpolation.T t y ->+   Interpolation.T t y ->+   t -> sig y ->+   t -> Phase.T t ->+   Causal.T (t,t) y shapeFreqModFromSampledTone       ipLeap ipStep period sampledTone shape0 phase =    uncurry (ToneMod.interpolateCell ipLeap ipStep) ^<<@@ -163,12 +144,12 @@  {-# INLINE shapePhaseFreqModFromSampledTone #-} shapePhaseFreqModFromSampledTone ::-    (RealField.C t, SigG.Transform sig y) =>-    Interpolation.T t y ->-    Interpolation.T t y ->-    t -> sig y ->-    t -> Phase.T t ->-    Causal.T (t,t,t) y+   (RealField.C t, SigG.Transform sig y) =>+   Interpolation.T t y ->+   Interpolation.T t y ->+   t -> sig y ->+   t -> Phase.T t ->+   Causal.T (t,t,t) y shapePhaseFreqModFromSampledTone       ipLeap ipStep period sampledTone shape0 phase =    let periodInt = round period@@ -199,22 +180,22 @@  {-# INLINE freqModSine #-} {- | sine oscillator with modulated frequency -}-freqModSine :: (Trans.C a, RealField.C a) => Phase.T a -> Causal.T a a+freqModSine :: (Trans.C a, RealRing.C a) => Phase.T a -> Causal.T a a freqModSine = freqMod Wave.sine  {-# INLINE phaseModSine #-} {- | sine oscillator with modulated phase, useful for FM synthesis -}-phaseModSine :: (Trans.C a, RealField.C a) => a -> Causal.T a a+phaseModSine :: (Trans.C a, RealRing.C a) => a -> Causal.T a a phaseModSine = phaseMod Wave.sine  {- {-# INLINE staticSaw #-} {- | saw tooth oscillator with modulated frequency -}-staticSaw :: RealField.C a => Phase.T a -> a -> Sig.T a+staticSaw :: RealRing.C a => Phase.T a -> a -> Sig.T a staticSaw = static Wave.saw -}  {-# INLINE freqModSaw #-} {- | saw tooth oscillator with modulated frequency -}-freqModSaw :: RealField.C a => Phase.T a -> Causal.T a a+freqModSaw :: RealRing.C a => Phase.T a -> Causal.T a a freqModSaw = freqMod Wave.saw
+ src/Synthesizer/Causal/Oscillator/Core.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+Copyright   :  (c) Henning Thielemann 2010+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++Basics for building tone generators.+They generate signals of phases+and these signals can be converted to arbitrary waveforms+by mapping them via @Wave@ objects.+This is also the fundament for dimensional oscillators.+-}+module Synthesizer.Causal.Oscillator.Core where++import qualified Synthesizer.Basic.Phase as Phase++import qualified Synthesizer.Causal.Process as Causal+import qualified Synthesizer.State.Signal as Sig++import Control.Arrow ((^<<), (&&&), second, returnA, )++import qualified Algebra.RealRing             as RealRing++import NumericPrelude.Numeric+import NumericPrelude.Base++++{-# INLINE static #-}+static :: RealRing.C a =>+   Phase.T a -> a -> Sig.T (Phase.T a)+static phase freq =+   Sig.iterate (Phase.increment freq) phase+++{-# INLINE phaseMod #-}+{- | oscillator with modulated phase -}+phaseMod :: (RealRing.C a) =>+   a -> Causal.T a (Phase.T a)+phaseMod freq =+   uncurry Phase.increment ^<<+      Causal.feedSnd (static zero freq)++{-# INLINE shapeMod #-}+{- | oscillator with modulated shape -}+shapeMod :: (RealRing.C a) =>+   Phase.T a -> a -> Causal.T c (c, Phase.T a)+shapeMod phase freq =+   Causal.feedSnd (static phase freq)++{-# INLINE freqMod #-}+{- |+Convert a list of phase steps into a list of momentum phases.+phase is a number in the interval [0,1).+freq contains the phase steps.+The last element is omitted.+-}+freqMod :: RealRing.C a =>+   Phase.T a -> Causal.T a (Phase.T a)+freqMod =+   Causal.scanL (flip Phase.increment)++{- |+Like 'freqMod' but the first element is omitted.+-}+{-# INLINE freqModSync #-}+freqModSync :: RealRing.C a =>+   Phase.T a -> Causal.T a (Phase.T a)+freqModSync =+   Causal.crochetL+      (\f p0 -> let p1 = Phase.increment f p0 in Just (p1,p1))+++{-# INLINE freqModAntiAlias #-}+{- | oscillator with modulated frequency -}+freqModAntiAlias :: (RealRing.C a) =>+   Phase.T a -> Causal.T a (a, Phase.T a)+freqModAntiAlias phase =+   returnA &&& freqMod phase++{-# INLINE phaseFreqMod #-}+{- | oscillator with both phase and frequency modulation -}+phaseFreqMod :: (RealRing.C a) =>+   Causal.T (a,a) (Phase.T a)+phaseFreqMod =+   uncurry Phase.increment ^<<+   second (freqMod zero)++{-# INLINE shapeFreqMod #-}+{- | oscillator with both shape and frequency modulation -}+shapeFreqMod :: (RealRing.C a) =>+   Phase.T a -> Causal.T (c,a) (c, Phase.T a)+shapeFreqMod phase =+   second (freqMod phase)
+ src/Synthesizer/Causal/Process.hs view
@@ -0,0 +1,496 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ExistentialQuantification #-}+{- |+Processes that use only the current and past data.+Essentially this is a data type for the 'Synthesizer.State.Signal.crochetL' function.+-}+{-+ToDo:+Causal process usually depend on the sample rate,+so we need a phantom type parameter of T for the rate.++Include ST monad for mutable arrays,+this can be useful for delay lines.+On the other hand, couldn't we also use the StorableVector.Cursor data structure+and avoid the ST monad here?+-}+module Synthesizer.Causal.Process (+   T(Cons),+   fromStateMaybe,+   fromState,+   fromSimpleModifier,+   fromInitializedModifier,++   id,+   map,+   first,+   second,+   compose,+   split,+   fanout,+   loop,++{-+   We don't re-export these identifiers+   because people could abuse them for other Arrows.++   (>>>), (***), (&&&),+   (Arrow.^<<), (Arrow.^>>), (Arrow.<<^), (Arrow.>>^),+-}++   apply,+   applyFst,+   applySnd,+   applySameType,+   applyConst,+   apply2,+   apply3,+   applyStorableChunk,++   feed,+   feedFst,+   feedSnd,+   feedGenericFst,+   feedGenericSnd,+   feedConstFst,+   feedConstSnd,++   crochetL,+   mapAccumL,+   scanL,+   scanL1,+   zipWith,+   consInit,+   chainControlled,+   replicateControlled,+   feedback,+   feedbackControlled,++   -- for testing+   applyFst',+   applySnd',+   ) where++import qualified Synthesizer.State.Signal as Sig+import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.Causal.Class as Class+import qualified Synthesizer.Causal.Utility as ArrowUtil++import qualified Synthesizer.Plain.Modifier as Modifier++import qualified Data.StorableVector as SV+import Foreign.Storable (Storable, )++import qualified Control.Category as Cat+import Control.Arrow+          (Arrow(..), returnA, (<<<), (>>>), (^>>), ArrowLoop(..),+           Kleisli(Kleisli), runKleisli, )+import Control.Monad.Trans.State+          (State, runState,+           StateT(StateT), runStateT, )+import Control.Monad (liftM, )+import Control.Applicative (Applicative, liftA2, pure, (<*>), )++import Data.Tuple.HT (mapSnd, )++import qualified Algebra.Field as Field+import qualified Algebra.Ring as Ring+import qualified Algebra.Additive as Additive++import qualified Prelude as P+import Prelude hiding (id, map, zipWith, )++++-- | Cf. StreamFusion  'Synthesizer.State.Signal.T'+data T a b =+   forall s. -- Seq s =>+      Cons !(a -> StateT s Maybe b)  -- compute next value+           !s                        -- initial state++++{-# INLINE fromStateMaybe #-}+fromStateMaybe :: (a -> StateT s Maybe b) -> s -> T a b+fromStateMaybe = Cons++{-# INLINE fromState #-}+fromState :: (a -> State s b) -> s -> T a b+fromState f =+   fromStateMaybe (\x -> StateT (Just . runState (f x)))++{-# INLINE fromSimpleModifier #-}+fromSimpleModifier ::+   Modifier.Simple s ctrl a b -> T (ctrl,a) b+fromSimpleModifier (Modifier.Simple s f) =+   fromState (uncurry f) s++{-# INLINE fromInitializedModifier #-}+fromInitializedModifier ::+   Modifier.Initialized s init ctrl a b -> init -> T (ctrl,a) b+fromInitializedModifier (Modifier.Initialized initF f) initS =+   fromState (uncurry f) (initF initS)+++{-+It's almost a Kleisli Arrow,+but the hidden type of the state disturbs.+-}+instance Cat.Category T where+   {-# INLINE id #-}+   {-# INLINE (.) #-}++   id  = fromState return ()+   (.) = flip compose++instance Arrow T where+   {-# INLINE arr #-}+   {-# INLINE first #-}+   {-# INLINE second #-}+   {-# INLINE (***) #-}+   {-# INLINE (&&&) #-}++   arr    = map+   first  = liftKleisli first+   second = liftKleisli second+   (***)  = split+   (&&&)  = fanout++{-+I think we cannot define an ArrowApply instance,+because we must extract the initial state somehow+from the inner (T a b) which is not possible.++instance ArrowApply T where+--   app = Cons (runKleisli undefined) ()+   app = first (arr (flip Cons () . runKleisli)) >>> app+-}+++instance ArrowLoop T where+   {-# INLINE loop #-}+   loop = liftKleisli loop+++type instance Class.ProcessOf Sig.T = T++instance Class.C T where+   type SignalOf T = Sig.T+   toSignal = flip applyConst ()+   fromSignal sig = const () ^>> feed sig+++instance Functor (T a) where+   fmap = ArrowUtil.map++instance Applicative (T a) where+   pure = ArrowUtil.pure+   (<*>) = ArrowUtil.apply+++instance (Additive.C b) => Additive.C (T a b) where+   zero = pure Additive.zero+   negate = fmap Additive.negate+   (+) = liftA2 (Additive.+)+   (-) = liftA2 (Additive.-)++instance (Ring.C b) => Ring.C (T a b) where+   one = pure Ring.one+   (*) = liftA2 (Ring.*)+   x^n = fmap (Ring.^ n) x+   fromInteger = pure . Ring.fromInteger++instance (Field.C b) => Field.C (T a b) where+   (/) = liftA2 (Field./)+   recip = fmap Field.recip+   fromRational' = pure . Field.fromRational'+++instance (P.Num b) => P.Num (T a b) where+   (+) = liftA2 (P.+)+   (-) = liftA2 (P.-)+   (*) = liftA2 (P.*)+   negate = fmap P.negate+   abs = fmap P.abs+   signum = fmap P.signum+   fromInteger = pure . P.fromInteger++instance (P.Fractional b) => P.Fractional (T a b) where+   (/) = liftA2 (P./)+   fromRational = pure . P.fromRational++++{-# INLINE extendStateFstT #-}+extendStateFstT :: Monad m => StateT s m a -> StateT (t,s) m a+extendStateFstT st =+   StateT (\(t0,s0) -> liftM (mapSnd (\s1 -> (t0,s1))) (runStateT st s0))++{-# INLINE extendStateSndT #-}+extendStateSndT :: Monad m => StateT s m a -> StateT (s,t) m a+extendStateSndT st =+   StateT (\(s0,t0) -> liftM (mapSnd (\s1 -> (s1,t0))) (runStateT st s0))+++{-# INLINE liftKleisli #-}+liftKleisli ::+   (forall s.+    Kleisli (StateT s Maybe) a0 a1 ->+    Kleisli (StateT s Maybe) b0 b1) ->+   T a0 a1 -> T b0 b1+liftKleisli op (Cons f s) =+   Cons (runKleisli $ op $ Kleisli f) s++{-# INLINE liftKleisli2 #-}+liftKleisli2 ::+   (forall s.+      Kleisli (StateT s Maybe) a0 a1 ->+      Kleisli (StateT s Maybe) b0 b1 ->+      Kleisli (StateT s Maybe) c0 c1) ->+   T a0 a1 -> T b0 b1 -> T c0 c1+liftKleisli2 op (Cons f s) (Cons g t) =+   Cons+      (runKleisli+         (Kleisli (extendStateSndT . f) `op`+          Kleisli (extendStateFstT . g)))+      (s,t)+++{-# INLINE id #-}+id :: T a a+id = returnA++{-# INLINE map #-}+map :: (a -> b) -> T a b+map f = fromState (return . f) ()++{-# INLINE compose #-}+compose :: T a b -> T b c -> T a c+compose = liftKleisli2 (>>>)++{-# INLINE split #-}+split :: T a b -> T c d -> T (a,c) (b,d)+split = liftKleisli2 (***)++{-# INLINE fanout #-}+fanout :: T a b -> T a c -> T a (b,c)+fanout = liftKleisli2 (&&&)+++{-# INLINE runViewL #-}+runViewL :: (SigG.Consume sig a) =>+   sig a ->+   (forall s. StateT s Maybe a -> s -> x) ->+   x+runViewL sig cont =+   SigG.runViewL sig (\f s -> cont (StateT f) s)+++{-# INLINE apply #-}+apply :: (SigG.Transform sig a, SigG.Transform sig b) =>+   T a b -> sig a -> sig b+apply (Cons f s) =+   SigG.crochetL (runStateT . f) s++{-# INLINE applySameType #-}+applySameType :: (SigG.Transform sig a) =>+   T a a -> sig a -> sig a+applySameType (Cons f s) =+   SigG.crochetL (runStateT . f) s+++{- |+I think this function does too much.+Better use 'feedFst' and (>>>).+-}+{-# INLINE applyFst #-}+applyFst, applyFst' :: (SigG.Consume sig a) =>+   T (a,b) c -> sig a -> T b c+applyFst c as =+   c <<< feedFst as++applyFst' (Cons f s) as =+   runViewL as (\getNext r ->+   Cons (\b ->+           do a <- extendStateFstT getNext+              extendStateSndT (f (a,b)))+        (s,r))++{- |+I think this function does too much.+Better use 'feedSnd' and (>>>).+-}+{-# INLINE applySnd #-}+applySnd, applySnd' :: (SigG.Consume sig b) =>+   T (a,b) c -> sig b -> T a c+applySnd c as =+   c <<< feedSnd as++applySnd' (Cons f s) bs =+   runViewL bs (\getNext r ->+   Cons (\a ->+           do b <- extendStateFstT getNext+              extendStateSndT (f (a,b)))+        (s,r))++{- |+applyConst c x == apply c (repeat x)+-}+{-# INLINE applyConst #-}+applyConst :: T a b -> a -> Sig.T b+applyConst (Cons f s) a =+   Sig.unfoldR (runStateT (f a)) s++{-+Can be easily done by converting the result of applyConst to generic signal+{-# INLINE applyConstGeneric #-}+applyConstGeneric :: SigG.LazySize -> T a b -> a -> sig b+applyConstGeneric size (Cons f s) a =+   SigG.unfoldR size (runStateT (f a)) s+-}+++{-# INLINE apply2 #-}+apply2 ::+   (SigG.Consume sig a, SigG.Transform sig b, SigG.Transform sig c) =>+   T (a,b) c -> sig a -> sig b -> sig c+apply2 f x y =+   apply (applyFst f x) y++{-# INLINE apply3 #-}+apply3 ::+   (SigG.Consume sig a, SigG.Consume sig b, SigG.Transform sig c, SigG.Transform sig d) =>+   T (a,b,c) d -> sig a -> sig b -> sig c -> sig d+apply3 f x y z =+   apply2 (applyFst ((\(a,(b,c)) -> (a,b,c)) ^>> f) x) y z+++{-+A generalized version could be of type++Transform sig a b => Causal.T a b -> Causal.T (sig a) (sig b)++but we cannot implement that,+since crochetL does not return the final state.+-}+applyStorableChunk ::+   (Storable a, Storable b) =>+   T a b -> T (SV.Vector a) (SV.Vector b)+applyStorableChunk (Cons next start) = Cons+   (\a -> StateT $ \ms ->+      flip fmap ms $ \s ->+         SV.crochetLResult (runStateT . next) s a)+   (Just start)+++{-# INLINE feed #-}+feed :: (SigG.Consume sig a) =>+   sig a -> T () a+feed proc =+   runViewL proc (\getNext ->+      fromStateMaybe (const getNext))++{-# INLINE feedFst #-}+feedFst :: (SigG.Consume sig a) =>+   sig a -> T b (a,b)+feedFst proc =+   runViewL proc (\getNext ->+      fromStateMaybe (\b -> fmap (flip (,) b) getNext))++{-# INLINE feedSnd #-}+feedSnd :: (SigG.Consume sig a) =>+   sig a -> T b (b,a)+feedSnd proc =+   runViewL proc (\getNext ->+      fromStateMaybe (\b -> fmap ((,) b) getNext))++{-# INLINE feedConstFst #-}+feedConstFst :: a -> T b (a,b)+feedConstFst a = map (\b -> (a,b))++{-# INLINE feedConstSnd #-}+feedConstSnd :: a -> T b (b,a)+feedConstSnd a = map (\b -> (b,a))++{-# INLINE feedGenericFst #-}+feedGenericFst :: (SigG.Consume sig a) =>+   sig a -> T b (a,b)+feedGenericFst =+   feedFst . SigG.toState++{-# INLINE feedGenericSnd #-}+feedGenericSnd :: (SigG.Consume sig a) =>+   sig a -> T b (b,a)+feedGenericSnd =+   feedSnd . SigG.toState++++-- * list like functions++{-# INLINE crochetL #-}+crochetL :: (x -> acc -> Maybe (y, acc)) -> acc -> T x y+crochetL f s = fromStateMaybe (StateT . f) s++{-# INLINE mapAccumL #-}+mapAccumL :: (x -> acc -> (y, acc)) -> acc -> T x y+mapAccumL next = crochetL (\a s -> Just $ next a s)++{-# INLINE scanL #-}+scanL :: (acc -> x -> acc) -> acc -> T x acc+scanL f = mapAccumL (\x acc -> (acc, f acc x))++{-# INLINE scanL1 #-}+scanL1 :: (x -> x -> x) -> T x x+scanL1 f =+   mapAccumL (\x acc -> (x, Just $ maybe x (flip f x) acc)) Nothing++{-# INLINE zipWith #-}+zipWith :: (SigG.Consume sig a) =>+   (a -> b -> c) -> sig a -> T b c+zipWith f = applyFst (map (uncurry f))++{- |+Prepend an element to a signal,+but keep the signal length,+i.e. drop the last element.+-}+{-# INLINE consInit #-}+consInit :: x -> T x x+consInit = mapAccumL (\x acc -> (acc, x))++++{-# INLINE chainControlled #-}+chainControlled :: [T (c,x) x] -> T (c,x) x+chainControlled = Class.chainControlled++{- |+If @T@ would be the function type @->@+then @replicateControlled 3 f@ computes+@\(c,x) -> f(c, f(c, f(c, x)))@.+-}+{-# INLINE replicateControlled #-}+replicateControlled :: Int -> T (c,x) x -> T (c,x) x+replicateControlled = Class.replicateControlled+++{-# INLINE feedback #-}+feedback :: T (a,c) b -> T b c -> T a b+feedback forth back =+   loop (forth >>>  id &&& back)++{-# INLINE feedbackControlled #-}+feedbackControlled :: T ((ctrl,a),c) b -> T (ctrl,b) c -> T (ctrl,a) b+feedbackControlled forth back =+   loop (map (fst.fst) &&& forth  >>>  map snd &&& back)++{-+{-# INLINE feedbackControlled #-}+feedbackControlled :: T (ctrl, (a,c)) b -> T (ctrl,b) c -> T (ctrl,a) b+feedbackControlled forth back =+   loop ((\((ctrl,a),c) -> (ctrl, (a,c)))  ^>>+         map fst &&& forth  >>>+         map snd &&& back)+-}
+ src/Synthesizer/Causal/Spatial.hs view
@@ -0,0 +1,24 @@+{-# 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 NumericPrelude.Numeric+import NumericPrelude.Base+++{-|+simulate an moving sounding object++convert the way of the object through 2D or 3D space+into a delay and attenuation information,+sonicDelay is the reciprocal of the sonic velocity+-}+moveAround ::+   (Field.C a, Euc.C a v, Arrow arrow) =>+   a -> a -> v -> arrow v (a,a)+moveAround att sonicDelay ear =+   arr ((\dist -> (sonicDelay*dist, 1/(att+dist)^2)) . Euc.norm . subtract ear)
src/Synthesizer/Causal/ToneModulation.hs view
@@ -11,10 +11,15 @@    ) 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 Synthesizer.State.ToneModulation (freqsToPhases, freqsToPhasesSync, )+import Control.Arrow (first, (<<<), (<<^), (^<<), (&&&), (***), )+import Control.Monad.Trans.State (state, )  {- for testing in GHCi import qualified Synthesizer.Plain.ToneModulation as ToneModL@@ -23,25 +28,12 @@ -} import Data.Tuple.HT (mapFst, ) -import qualified Synthesizer.Causal.Process as Causal--import qualified Synthesizer.Generic.Signal as SigG--import qualified Synthesizer.Basic.Phase as Phase---- import qualified Algebra.Transcendental        as Trans import qualified Algebra.RealField             as RealField--- import qualified Algebra.Field                 as Field--- import qualified Algebra.Real                  as Real import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive -import Control.Arrow (first, (<<<), (<<^), (^<<), (&&&), (***), )-import Control.Monad.Trans.State (state, )--import NumericPrelude--- import qualified Prelude as P-import PreludeBase+import NumericPrelude.Numeric+import NumericPrelude.Base import Prelude ()  @@ -69,11 +61,6 @@     ((t, Phase.T t), sig y) ->     ((t,t), ToneModS.Cell sig y) seekCell periodInt period =-    {--    n will be zero within the data body.-    It's only needed for extrapolation at the end.-    Is it really needed?-    -}     (\(sp,ptr) ->        let (k,q) = ToneMod.flattenShapePhase periodInt period sp        in  (q, ToneModS.makeCell periodInt $@@ -138,8 +125,7 @@    Int -> Int -> sig y -> ((Bool, Int), sig y) dropMargin margin n xs =    mapFst ((,) (SigG.lengthAtMost (margin+n) xs)) $-   SigG.dropMarginRem margin-      (ToneModS.checkNonNeg n) xs+   SigG.dropMarginRem margin (ToneModS.checkNonNeg n) xs  regroup :: (Int,t) -> Phase.T t -> ToneMod.Skip t regroup (d,s) p = (d, (s,p))@@ -161,7 +147,7 @@         -- phases :: RealField.C t => Causal.T ((Int,t), t) (Phase.T t)         phase0 = Phase.decrement (scale sf0) phase         phases =-           freqsToPhasesSync phase0+           Osci.freqModSync phase0               <<^ (\(s,f) -> f - scale s)     in  (regroup sf0 phase0,          uncurry regroup@@ -189,7 +175,7 @@         scale (n,_) = fromIntegral n / period         -- phases :: RealField.C t => Causal.T ((Int,t), t) (Phase.T t)         phases =-           freqsToPhases+           Osci.freqMod               (Phase.decrement (scale sf0) phase)               <<^ (\(s,f) -> f - scale s)     in  uncurry regroup@@ -229,7 +215,7 @@          then (x0, Causal.id)          else (xMin,                Causal.crochetL-                  (\x lim ->+                  (\x lim -> Just $                      let d = x-lim-                     in  Just $ if d>=zero+                     in  if d>=zero                            then (d,zero) else (zero, negate d)) x1)
+ src/Synthesizer/Causal/Utility.hs view
@@ -0,0 +1,37 @@+{- |+Utility functions based only on 'Arrow' class.+-}+module Synthesizer.Causal.Utility where++import Control.Arrow (Arrow, arr, (>>>), (&&&), (^<<), )++import Data.Function.HT (nest, )+++map :: (Arrow arrow) => (b -> c) -> arrow a b -> arrow a c+map = (^<<)++pure :: (Arrow arrow) => b -> arrow a b+pure x = arr (const x)++apply :: (Arrow arrow) => arrow a (b -> c) -> arrow a b -> arrow a c+apply f x = uncurry ($) ^<< f&&&x+++{-# INLINE chainControlled #-}+chainControlled ::+   (Arrow arrow) =>+   [arrow (c,x) x] -> arrow (c,x) x+chainControlled =+   foldr+      (\p rest -> arr fst &&& p  >>>  rest)+      (arr snd)++{-# INLINE replicateControlled #-}+replicateControlled ::+   (Arrow arrow) =>+   Int -> arrow (c,x) x -> arrow (c,x) x+replicateControlled n p =+   nest n+      (arr fst &&& p  >>> )+      (arr snd)
+ src/Synthesizer/CausalIO/Gate.hs view
@@ -0,0 +1,150 @@+module Synthesizer.CausalIO.Gate (+   Chunk(Chunk), chunk,+   allToStorableVector,+   toStorableVector,+   allToChunkySize,+   toChunkySize,+   shorten,+   ) where++import qualified Synthesizer.CausalIO.Process as PIO+import qualified Synthesizer.Zip as Zip++import qualified Synthesizer.Generic.Cut as CutG+import qualified Synthesizer.ChunkySize as ChunkySize+import Synthesizer.PiecewiseConstant.Signal (StrictTime, )++import qualified Control.Monad.Trans.State as MS+import Control.Arrow (Arrow, arr, (^<<), )+import Control.Monad (when, )++import qualified Data.StorableVector as SV+import qualified Data.Monoid as Mn+import qualified Data.Semigroup as Sg+import Data.Maybe.HT (toMaybe, )++import qualified Numeric.NonNegative.Class as NonNeg+import qualified Numeric.NonNegative.Wrapper as NonNegW++import NumericPrelude.Numeric+import NumericPrelude.Base+import Prelude ()+++{- |+Chunk represents a chunk of a Gate signal.++It means (Chunk chunkDuration sustainDuration).++sustainDuration means:+Just (t,a) -+   key is released at time t with attribute a,+   e.g. the note-off-velocity,+   t must be smaller than chunkDuration!+Nothing - key is in pressed or released state over the whole chunk+-}+data Chunk a = Chunk StrictTime (Maybe (StrictTime, a))+   deriving (Show)++-- | smart constructor that checks the time constraints+chunk :: StrictTime -> Maybe (StrictTime, a) -> Chunk a+chunk dur mrel =+   if maybe True (\(rel,_attr) -> rel<dur) mrel+     then Chunk dur mrel+     else error "release time must be strictly before chunk end"+++instance CutG.Consume (Chunk a) where+   null (Chunk dur _) = isZero dur+   length (Chunk dur _) = fromIntegral dur++instance CutG.NormalForm (Chunk a) where+   evaluateHead (Chunk dur rel) =+      dur `seq` rel `seq` ()++instance Sg.Semigroup (Chunk a) where+   (<>) = error "Gate.mappend cannot be defined"++instance Mn.Monoid (Chunk a) where+   mempty = error "Gate.mempty cannot be defined"++instance CutG.Transform (Chunk a) where+   take n (Chunk dur mrel) =+      let nn = NonNegW.fromNumberClip $ fromIntegral n+      in  Chunk (min nn dur) $+          mrel >>= \rel -> toMaybe (fst rel < nn) rel+   drop n (Chunk dur mrel) =+      let nn = NonNegW.fromNumberClip $ fromIntegral n+      in  Chunk (dur NonNeg.-| nn) $+          mrel >>= \(rel,attr) -> toMaybe (nn <= rel) (rel-nn, attr)+   splitAt n c = (CutG.take n c, CutG.drop n c)+   dropMarginRem = error "Gate.dropMarginRem is not defined"+   reverse = error "Gate.reverse cannot be defined"+++allToStorableVector ::+   (Arrow arrow) =>+   arrow (Chunk a) (SV.Vector ())+allToStorableVector = arr $+   (\(ChunkySize.LazySize n) -> SV.replicate n ())+   ^<<+   allToChunkySize++toStorableVector ::+   PIO.T (Chunk a) (SV.Vector ())+toStorableVector =+   (\(ChunkySize.LazySize n) -> SV.replicate n ())+   ^<<+   toChunkySize+++allToChunkySize ::+   (Arrow arrow) =>+   arrow (Chunk a) ChunkySize.LazySize+allToChunkySize = arr $+   \(Chunk time _) -> ChunkySize.LazySize (fromIntegral time)++toChunkySize ::+   PIO.T (Chunk a) ChunkySize.LazySize+toChunkySize =+   PIO.traverse True $+   \(Chunk time mRelease) -> do+      running <- MS.get+      if not running+        then return $ ChunkySize.LazySize 0+        else+          case mRelease of+             Nothing ->+                return $ ChunkySize.LazySize (fromIntegral time)+             Just (relTime, _) -> do+                MS.put False+                return $ ChunkySize.LazySize (fromIntegral relTime)+++{- |+Pass the second signal while the gate is open.++For completeness we would need a data type analogously to ChunkySize,+that measures signal duration in CausalIO processes.+'shorten' could then be written as++> shorten = Zip.second ^<< Zip.arrowFirstShort Gate.toChunkySize+-}+shorten ::+   (CutG.Transform signal) =>+   PIO.T (Zip.T (Chunk a) signal) signal+shorten =+   PIO.traverse True $+   \(Zip.Cons (Chunk time mRelease) sig) -> do+      when (NonNegW.toNumber time /= fromIntegral (CutG.length sig))+         (error "Gate.shorten: durations mismatch")+      running <- MS.get+      if not running+        then return CutG.empty+        else+          case mRelease of+             Nothing ->+                return $ sig+             Just (relTime, _) -> do+                MS.put False+                return $ CutG.take (fromIntegral relTime) sig
+ src/Synthesizer/CausalIO/Process.hs view
@@ -0,0 +1,332 @@+{-# LANGUAGE ExistentialQuantification #-}+{- |+Process chunks of data in the IO monad.+Typical inputs are strict storable vectors and piecewise constant values,+and typical outputs are strict storable vectors.+You may also combine several of these types using the Zip type constructor.++We may substitute IO by ST in the future, but I am uncertain about that.+On the one hand, the admissible IO functionality is very restricted,+only memory manipulation is allowed,+on the other hand we use ForeignPtrs that are not part of ST framework.+-}+module Synthesizer.CausalIO.Process (+   T(Cons),+   fromCausal,+   mapAccum,+   Synthesizer.CausalIO.Process.traverse,+   runCont,+   runStorableChunkyCont,+   zip,+   continue,+   continueChunk,+   ) where++import qualified Synthesizer.Causal.Process as Causal++import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.Generic.Cut as CutG+import qualified Synthesizer.Zip as Zip++import qualified Data.StorableVector.Lazy as SVL+import qualified Data.StorableVector as SV++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, )++import Data.Monoid (Monoid, mempty, mappend, )+import Data.Semigroup (Semigroup, (<>), )++import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO, )++import Prelude hiding (zip, )+++{-+Like the Causal arrow but unlike the Causal arrow from @synthesizer-llvm@,+we are not using a parameter type @p@.+In order to parameterize the process,+you simply use a plain Haskell function, i.e. @p -> T a b@.+This way, we do not need the Parameter type from @synthesizer-llvm@.+However, the internal state type can depend+on the value of parameters.+This may be an advantage or a disadvantage, I do not know.+-}+data T a b =+   forall state.+   Cons+      {-+      If the transition function returns a chunk+      that is shorter than the input,+      then this is the last chunk.+      This way we do not need a MaybeT IO.+      -}+      (a -> state -> IO (b, state))+      (IO state)+      {-+      The delete function must not do anything serious,+      e.g. close files,+      because it might not be called.+      Something like 'touchForeignPtr' is reasonable.+      -}+      (state -> IO ())+++instance Cat.Category T where+   id = Arr.arr id+   (Cons nextB createB deleteB) .+          (Cons nextA createA deleteA) = Cons+      (\a (sa0,sb0) -> do+         (b,sa1) <- nextA a sa0+         (c,sb1) <- nextB b sb0+         return (c,(sa1,sb1)))+      (do+         sa <- createA+         sb <- createB+         return (sa,sb))+      (\(sa,sb) ->+         deleteA sa >> deleteB sb)++instance Arr.Arrow T where+   arr f = Cons+      (\ a () -> return (f a, ()))+      (return ())+      (\ () -> return ())+   first (Cons next create delete) = Cons+      (\(b,d) sa0 ->+         do (c,sa1) <- next b sa0+            return ((c,d), sa1))+      create+      delete++fromCausal ::+   (Monoid b) =>+   Causal.T a b -> T a b+fromCausal (Causal.Cons next start) = Cons+   (\a s0 ->+      return $+      case MS.runStateT (next a) s0 of+         Nothing -> (mempty, s0)+         Just (b,s1) -> (b,s1))+   (return $ start)+   (\ _ -> return ())++mapAccum ::+   (a -> state -> (b, state)) ->+   state ->+   T a b+mapAccum next start =+   Cons+      (\a s -> return $ next a s)+      (return start)+      (\ _ -> return ())++{-+The parameter order is chosen this way,+because the 'next' function definition might be large+and can be separated with a ($).+-}+traverse ::+   state ->+   (a -> MS.State state b) ->+   T a b+traverse start next =+   Cons+      (\a s -> return $ MS.runState (next a) s)+      (return start)+      (\ _ -> return ())+++{- |+This function converts a process+into a function on lazy storable vectors.+To this end it must call unsafePerformIO,+that is, the effects of all functions called in the process+must not be observable.++I am not sure, we need this function at all.+-}+runCont ::+   (CutG.Transform a, CutG.Transform b) =>+   T a b -> IO (([a] -> [b]) -> [a] -> [b])+runCont (Cons next create delete) =+   return $+      \ procRest sig ->+      unsafePerformIO $ do+         let go xt s0 =+               unsafeInterleaveIO $+               case xt of+                  [] -> delete s0 >> return []+                  x:xs -> do+                     (y,s1) <- next x s0+                     (if CutG.length y > 0+                        then fmap (y:)+                        else id) $+                        (if CutG.length y < CutG.length x+                           then return $ procRest $+                                CutG.drop (CutG.length y) x : xs+                           else go xs s1)+         go sig =<< create++{- |+The same restrictions as for 'runCont' apply.+-}+runStorableChunkyCont ::+   (Storable a, Storable b) =>+   T (SV.Vector a) (SV.Vector b) ->+   IO ((SVL.Vector a -> SVL.Vector b) ->+       SVL.Vector a -> SVL.Vector b)+runStorableChunkyCont proc =+   flip fmap (runCont proc) $ \f cont ->+      SVL.fromChunks .+      f (SVL.chunks . cont . SVL.fromChunks) .+      SVL.chunks+++zip ::+   (Arr.Arrow arrow) =>+   arrow a b -> arrow a c -> arrow a (Zip.T b c)+zip ab ac =+   uncurry Zip.Cons ^<< ab &&& ac+++instance (CutG.Transform a, CutG.Consume b, Semigroup b) => Semigroup (T a b) where+   (<>) = append (<>)++{- |+@mappend@ should be used sparingly.+In a loop it will have to construct types at runtime+which is rather expensive.+-}+instance (CutG.Transform a, CutG.Consume b, Monoid b) => Monoid (T a b) where+   mempty = Cons+      (\ _a () -> return (mempty, ()))+      (return ())+      (\() -> return ())++append ::+   (CutG.Transform a, CutG.Consume b) =>+   (b -> b -> b) -> T a b -> T a b -> T a b+append app+      (Cons nextX createX deleteX)+      (Cons nextY createY deleteY) = Cons+   (\a s ->+      case s of+         Left s0 -> do+            (b1,s1) <- nextX a s0+            let lenA = CutG.length a+                lenB = CutG.length b1+            case compare lenA lenB of+               LT -> error "CausalIO.Process.mappend: output chunk is larger than input chunk"+               EQ -> return (b1, Left s1)+               GT -> do+                  deleteX s1+                  (b2,s2) <- nextY (CutG.drop lenB a) =<< createY+                  return (app b1 b2, Right s2)+         Right s0 -> do+            (b1,s1) <- nextY a s0+            return (b1, Right s1))+   (fmap Left createX)+   (either deleteX deleteY)+++data State a b =+   forall state.+   State+      (a -> state -> IO (b, state))+      (state -> IO ())+      state -- the only difference to (T a b) is the IO+++forceMaybe :: (Maybe a -> b) -> Maybe a -> b+forceMaybe f ma =+   case ma of+      Nothing -> f Nothing+      Just a -> f $ Just a++{- |+If the first process does not produce any output,+then the continuing process will not be started.+-}+continue ::+   (CutG.Transform a, SigG.Transform sig b) =>+   T a (sig b) -> (b -> T a (sig b)) -> T a (sig b)+continue (Cons nextX createX deleteX) procY = Cons+   (\a s ->+      case s of+         Left (lastB0, s0) -> do+            (b1,s1) <- nextX a s0+            let lenA = CutG.length a+                lenB = CutG.length b1+                lastB1 =+                   mplus (fmap snd $ SigG.viewR b1) lastB0+                cont lastB = (b1, Left (lastB,s1))+            case compare lenA lenB of+               LT -> error "CausalIO.Process.continue: output chunk is larger than input chunk"+               EQ -> return $ forceMaybe cont lastB1+               GT ->+                  case lastB1 of+                     Nothing -> return (mempty, Left (lastB1,s1))+                     Just lastB ->+                        case procY lastB of+                           Cons nextY createY deleteY -> do+                              deleteX s1+                              (b2,s2) <- nextY (CutG.drop lenB a) =<< createY+                              return (mappend b1 b2, Right (State nextY deleteY s2))+         Right (State nextY deleteY s0) -> do+            (b1,s1) <- nextY a s0+            return (b1, Right (State nextY deleteY s1)))+   (do+      sa <- createX+      return (Left (Nothing, sa)))+   (\s ->+      case s of+         Left (_lastB,s0) -> deleteX s0+         Right (State _ deleteY s0) -> deleteY s0)++{- |+Pass the last non-empty output chunk+as parameter to the continuing process.+This breaks the abstraction from the chunk sizes,+but we need it for implementing vectorized processing.+-}+continueChunk ::+   (CutG.Transform a, CutG.Transform b) =>+   T a b -> (b -> T a b) -> T a b+continueChunk (Cons nextX createX deleteX) procY = Cons+   (\a s ->+      case s of+         Left (lastB0, s0) -> do+            (b1,s1) <- nextX a s0+            let lenA = CutG.length a+                lenB = CutG.length b1+                cont lastB = (b1, Left (lastB,s1))+            case compare lenA lenB of+               LT -> error "CausalIO.Process.continueChunk: output chunk is larger than input chunk"+               EQ ->+                  -- force the decision on lenB, otherwise thunks will accumulate+                  return $ if lenB==0 then cont lastB0 else cont b1+               GT ->+                  if lenB==0+                    then return $ cont lastB0+                    else+                       case procY b1 of+                          Cons nextY createY deleteY -> do+                             deleteX s1+                             (b2,s2) <- nextY (CutG.drop lenB a) =<< createY+                             return (mappend b1 b2, Right (State nextY deleteY s2))+         Right (State nextY deleteY s0) -> do+            (b1,s1) <- nextY a s0+            return (b1, Right (State nextY deleteY s1)))+   (do+      sa <- createX+      return (Left (mempty, sa)))+   (\s ->+      case s of+         Left (_lastB,s0) -> deleteX s0+         Right (State _ deleteY s0) -> deleteY s0)
+ src/Synthesizer/ChunkySize.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Synthesizer.ChunkySize where++import qualified Synthesizer.Generic.Cut as Cut++import qualified Number.NonNegativeChunky as Chunky+import qualified Numeric.NonNegative.Chunky as Chunky98++import qualified Algebra.ToInteger    as ToInteger+import qualified Algebra.ToRational   as ToRational+import qualified Algebra.Absolute     as Absolute+import qualified Algebra.RealIntegral as RealIntegral+import qualified Algebra.IntegralDomain as Integral+import qualified Algebra.NonNegative  as NonNeg+import qualified Algebra.ZeroTestable as ZeroTestable+import qualified Algebra.Ring     as Ring+import qualified Algebra.Additive as Additive+import qualified Algebra.Monoid   as Monoid+import Algebra.Ring ((*), )+import Algebra.Additive ((+), (-), )++import qualified Data.StorableVector.Lazy as SigSt+import qualified Data.StorableVector.Lazy.Pattern as SigStV++import qualified Data.List as List+import Data.Monoid (Monoid, mempty, )+import Data.Semigroup (Semigroup, (<>), )++import qualified Test.QuickCheck as QC++import qualified Prelude as P+import Prelude (Eq, Ord, Show, Int, fmap, max, min, id, (.), ($), (==), )+++{- |+This type is used for specification of the maximum size of strict packets.+Packets can be smaller, can have different sizes in one signal.+In some kinds of streams, like lists and stateful generators,+the packet size is always 1.+The packet size is not just a burden caused by efficiency,+but we need control over packet size in applications with feedback.++ToDo: Make the element type of the corresponding signal a type parameter.+This helps to distinguish chunk sizes of scalar and vectorised signals.+-}+newtype LazySize = LazySize Int+   deriving (Eq, Ord, Show,+             Additive.C, Ring.C, ZeroTestable.C,+             ToInteger.C, ToRational.C, Absolute.C,+             RealIntegral.C, Integral.C)++instance Semigroup LazySize where+   LazySize a <> LazySize b = LazySize (a + b)++instance Monoid LazySize where+   mempty = LazySize 0++instance Monoid.C LazySize where+   idt = LazySize 0+   LazySize a <*> LazySize b = LazySize (a + b)++instance NonNeg.C LazySize where+   split = NonNeg.splitDefault (\(LazySize n) -> n) LazySize++instance QC.Arbitrary LazySize where+   arbitrary =+      case SigSt.defaultChunkSize of+         SigSt.ChunkSize n -> fmap LazySize (QC.choose (1, 2 * n))++instance Cut.Consume LazySize where+   null (LazySize n) = n==0+   length (LazySize n) = n++instance Cut.Transform LazySize where+   {-# INLINE take #-}+   take m (LazySize n) = LazySize $ min (max 0 m) n+   {-# INLINE drop #-}+   drop m (LazySize n) = LazySize $ max 0 $ n - max 0 m+   {-# INLINE splitAt #-}+   splitAt m x =+      let y = Cut.take m x+      in  (y, x-y)+   {-# INLINE dropMarginRem #-}+   dropMarginRem n m x@(LazySize xs) =+      let d = min m $ max 0 $ xs - n+      in  (m-d, Cut.drop d x)+   {-# INLINE reverse #-}+   reverse = id+++type T = Chunky.T LazySize+++fromStorableVectorSize ::+   SigStV.LazySize -> T+fromStorableVectorSize =+   Chunky.fromChunks .+   List.map (\(SigSt.ChunkSize size) -> (LazySize size)) .+   Chunky98.toChunks++toStorableVectorSize ::+   T -> SigStV.LazySize+toStorableVectorSize =+   Chunky98.fromChunks .+   List.map (\(LazySize size) -> (SigSt.ChunkSize size)) .+   Chunky.toChunks++toNullList :: T -> [()]+toNullList =+   List.concatMap (\(LazySize n) -> List.replicate n ()) .+   Chunky.toChunks
+ src/Synthesizer/ChunkySize/Cut.hs view
@@ -0,0 +1,217 @@+{- |+Functions for cutting signals with respect to lazy chunky time measures.+This is essential for realtime applications.+-}+module Synthesizer.ChunkySize.Cut where++import qualified Synthesizer.ChunkySize as ChunkySize+import qualified Synthesizer.Generic.Cut as Cut+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 qualified Data.List.Match as Match+import qualified Data.List as List+import Data.Tuple.HT (mapPair, )+import Data.Monoid (Monoid, )++import NumericPrelude.Numeric+import NumericPrelude.Base hiding (splitAt, )+import Prelude ()+++class Cut.Consume sig => Consume sig where+   length :: sig -> ChunkySize.T++class (Consume sig, Monoid sig) => Transform sig where+   take :: ChunkySize.T -> sig -> sig+   drop :: ChunkySize.T -> sig -> sig+   splitAt :: ChunkySize.T -> sig -> (sig, sig)+++-- instance Storable y => Consume SigSt.T y where+instance Storable y => Consume (Vector.Vector y) where+   {-# INLINE length #-}+   length = ChunkySize.fromStorableVectorSize . SigStV.length++instance Storable y => Transform (Vector.Vector y) where+   {-# INLINE take #-}+   take = SigStV.take . ChunkySize.toStorableVectorSize+   {-# INLINE drop #-}+   drop = SigStV.drop . ChunkySize.toStorableVectorSize+   {-# INLINE splitAt #-}+   splitAt = SigStV.splitAt . ChunkySize.toStorableVectorSize+++instance Consume ([] y) where+   {-# INLINE length #-}+   length xs =+      Chunky.fromChunks $ Match.replicate xs $ ChunkySize.LazySize one++instance Transform ([] y) where+   {-# INLINE take #-}+   take ns =+      Match.take (ChunkySize.toNullList ns)+   {-# INLINE drop #-}+   drop ns xs =+      -- 'drop' cannot make much use of laziness, thus 'foldl' is ok+      List.foldl+         (\x (ChunkySize.LazySize n) -> List.drop n x)+         xs (Chunky.toChunks ns)+   {-# INLINE splitAt #-}+   splitAt ns =+      Match.splitAt (ChunkySize.toNullList ns)++{-+instance Consume (SigFL.T y) where+   {-# INLINE length #-}+   length = SigFL.length++instance Transform (SigFL.T y) where+   {-# INLINE take #-}+   take = SigFL.take+   {-# INLINE drop #-}+   drop = SigFL.drop+   {-# INLINE splitAt #-}+   splitAt = SigFL.splitAt+-}++instance Consume (SigS.T y) where+   {-# INLINE length #-}+   length =+      Chunky.fromChunks . SigS.toList .+      SigS.map (const (ChunkySize.LazySize one))++instance Transform (SigS.T y) where+   {-# INLINE take #-}+   take size0 =+      SigS.crochetL+         (\x (n,ns) ->+            if n>zero+              then Just (x, (pred n, ns))+              else+                case ns of+                  ChunkySize.LazySize m : ms -> Just (x, (pred m, ms))+                  [] -> Nothing)+         (zero, Chunky.toChunks $ Chunky.normalize size0)+   {-# INLINE drop #-}+   drop ns xs =+      List.foldl+         (\x (ChunkySize.LazySize n) -> SigS.drop n x)+         xs (Chunky.toChunks ns)+   {-# INLINE splitAt #-}+   splitAt n =+      -- This implementation is slow. Better leave it unimplemented?+      mapPair (SigS.fromList, SigS.fromList) .+      splitAt n . SigS.toList+++{-+{-+useful for application of non-negative chunky numbers as gate signals+-}+instance (ToInteger.C a, NonNeg.C a) => Consume (Chunky.T a) where+   {-# INLINE length #-}+   length = sum . List.map (fromIntegral . toInteger) . Chunky.toChunks+++intToChunky :: (Ring.C a, NonNeg.C a) => String -> Int -> Chunky.T a+intToChunky name =+   Chunky.fromNumber .+-- the non-negative type is not necessarily a wrapper+--   NonNegW.fromNumberMsg ("Generic.Cut."++name) .+   fromIntegral .+   (\x ->+      if x<zero+        then error ("Generic.Cut.NonNeg.Chunky."++name++": negative argument")+        else x)+++instance (ToInteger.C a, NonNeg.C a) => Transform (Chunky.T a) where+   {-# INLINE take #-}+   take n = P.min (intToChunky "take" n)+   {-# INLINE drop #-}+   drop n x = x NonNeg.-| intToChunky "drop" n+   {-# INLINE dropMarginRem #-}+   dropMarginRem n m x =+      let (z,d,b) =+             Chunky.minMaxDiff+                (intToChunky "dropMargin/n" n)+                (x NonNeg.-| intToChunky "dropMargin/m" m)+      in  (if b then 0 else fromIntegral (Chunky.toNumber d),+           x NonNeg.-| z)+   {-# INLINE splitAt #-}+   splitAt n x =+      let (z,d,b) = Chunky.minMaxDiff (intToChunky "splitAt" n) x+      in  (z, if b then d else mempty)+   {-# INLINE reverse #-}+   reverse = Chunky.fromChunks . List.reverse . Chunky.toChunks++++instance (P.Integral a) => Consume (Chunky98.T a) where+   {-# INLINE null #-}+   null = List.null . Chunky98.toChunks+   {-# INLINE length #-}+   length = sum . List.map (P.fromIntegral . P.toInteger) . Chunky98.toChunks+++intToChunky98 :: (NonNeg98.C a) => String -> Int -> Chunky98.T a+intToChunky98 name =+   Chunky98.fromNumber .+--   NonNegW.fromNumberMsg ("Generic.Cut."++name) .+   P.fromIntegral .+   (\x ->+      if x<0+        then error ("Generic.Cut.NonNeg.Chunky98."++name++": negative argument")+        else x)++instance (P.Integral a, NonNeg98.C a) => Transform (Chunky98.T a) where+   {-# INLINE take #-}+   take n = P.min (intToChunky98 "take" n)+   {-# INLINE drop #-}+   drop n x = x NonNeg98.-| intToChunky98 "drop" n+   {-# INLINE dropMarginRem #-}+   dropMarginRem n m x =+      let (z,d,b) =+             Chunky98.minMaxDiff+                (intToChunky98 "dropMargin/n" n)+                (x NonNeg98.-| intToChunky98 "dropMargin/m" m)+      in  (if b then 0 else P.fromIntegral (Chunky98.toNumber d),+           x NonNeg98.-| z)+   {-# INLINE splitAt #-}+   splitAt n x =+      let (z,d,b) = Chunky98.minMaxDiff (intToChunky98 "splitAt" n) x+      in  (z, if b then d else Chunky98.zero)+   {-# INLINE reverse #-}+   reverse = Chunky98.fromChunks . List.reverse . Chunky98.toChunks+++{- |+Like @lengthAtLeast n xs  =  length xs >= n@,+but is more efficient, because it is more lazy.+-}+{-# INLINE lengthAtLeast #-}+lengthAtLeast :: (Transform sig) =>+   Int -> sig -> Bool+lengthAtLeast n xs =+   n<=0 || not (null (drop (pred n) xs))++{-# INLINE lengthAtMost #-}+lengthAtMost :: (Transform sig) =>+   Int -> sig -> Bool+lengthAtMost n xs =+   n>=0 && null (drop n xs)++{-# INLINE sliceVertical #-}+sliceVertical :: (Transform sig) =>+   Int -> sig -> SigS.T sig+sliceVertical n =+   SigS.map (take n) .+   SigS.takeWhile (not . null) .+   SigS.iterate (drop n)+-}
+ src/Synthesizer/ChunkySize/Signal.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+module Synthesizer.ChunkySize.Signal where++import qualified Synthesizer.ChunkySize.Cut as Cut+import qualified Synthesizer.ChunkySize as ChunkySize++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 Control.Monad.Trans.State (runStateT, )++import qualified Data.List.Match as Match+import qualified Data.List as List++import Prelude (Maybe(Just), fst, (.), id, )+++class (SigG.Transform sig y, Cut.Transform (sig y)) => Produce sig y where+   unfoldRN :: ChunkySize.T -> (s -> Maybe (y,s)) -> s -> sig y+++instance Storable y => Produce Vector.Vector y where+   {-# INLINE unfoldRN #-}+   unfoldRN size f =+      fst .+      SigStV.unfoldrN+         (ChunkySize.toStorableVectorSize size) f++instance Produce [] y where+   {-# INLINE unfoldRN #-}+   unfoldRN size f =+      Match.take (ChunkySize.toNullList size) .+      List.unfoldr f++instance Produce SigS.T y where+   {-# INLINE unfoldRN #-}+   unfoldRN size f =+      Cut.take size . SigS.unfoldR f+++{-# INLINE replicate #-}+replicate :: (Produce sig y) =>+   ChunkySize.T -> y -> sig y+replicate = iterateN id++{-# INLINE iterateN #-}+iterateN :: (Produce sig y) =>+   (y -> y) -> ChunkySize.T -> y -> sig y+iterateN f size =+   unfoldRN size (\y -> Just (y, f y))++{-# INLINE fromState #-}+fromState :: (Produce sig y) =>+   ChunkySize.T -> SigS.T y -> sig y+fromState size (SigS.Cons f x) =+   unfoldRN size (runStateT f) x
− src/Synthesizer/Filter/Basic.hs 
@@ -1,60 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-module Synthesizer.Filter.Basic where--import qualified Algebra.Transcendental as Trans-import qualified Algebra.Module         as Module-import qualified Algebra.RealField      as RealField-import qualified Number.Complex         as Complex--import NumericPrelude-import PreludeBase--{- ToDo:-    - support of data before time 0-       - the problem is that all past data has to be kept,-         the garbage collector can't flush it :-(-       - this means we will also need functions for plain lists,-         in this case we can't provide initial conditions to recursive filters-       - the question of initial conditions is especially problematic-         since for Graphs we have no explicit feed back-         where initial conditions can be plugged in-       - thus for two-way signal we must request the user-         to insert initial conditions in every loop of a Graph-         using the Past constructor-    - all of the following filter primitives in static and modulated form:-       - mask-       - integer delay-       - fractional delay-          - shall the fractional delay constructor store the interpolation type?-            (this discussion is similar to the one concerning-             initial conditions for recursive filters)-             - yes, because each delay may use a different interpolation type,-                    if no fractional delay is used,-                     no interpolation type needs to be specified-             - no, because the interpolation is only of interest for filter-                   application not for the transfer function-    - Is there a way to avoid the multi-parameter type class?-       - Can we provide a class for lists (OneWay and TwoWay)-         that help implementing filters and filter networks?-       - The 'transferFunction' obviously does not depend on the signal list type.-    - 'transferFunction' should not be restricted to complex numbers.-       - For arguments of type 'Ratio (Polynomial Rational)'-         you could compute the transfer function in terms of a rational function.--}--screw :: Trans.C a => a -> [Complex.T a]-screw w = iterate (Complex.cis w *) 1---class Filter list filter | filter -> list where-   {-| Apply a filter to a signal. -}-   apply :: (RealField.C t, Trans.C t,-             Module.C a v, Module.C a (list v)) =>-               filter t a v -> list v -> list v-   {-| Compute the complex amplification factor-       that is applied to the given frequency. -}-   transferFunction :: (Trans.C t, Module.C a t) =>-               filter t a v -> t -> Complex.T t
− src/Synthesizer/Filter/Composition.hs 
@@ -1,150 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-module Synthesizer.Filter.Composition where--import qualified Synthesizer.Filter.Basic as FilterBasic-import Synthesizer.Filter.Basic (Filter, apply, )--import qualified Algebra.Module         as Module-import qualified Algebra.Transcendental as Trans-import qualified Algebra.RealField      as RealField-import qualified Algebra.Field          as Field-import qualified Algebra.Additive       as Additive-import qualified Number.Complex         as Complex--import Algebra.Additive ((+))--import PreludeBase-import NumericPrelude--{- ToDo:-    - functions that build a FilterComposition for specific filters-        (1st order, universal, allpass, butterworth, chebyshev)-    - functions that turn physical filter parameters into-        internal ones-    - How can these function be combined?-      A function like-         [ FilterComposition v [m] ] -> FilterComposition v [[m]]-      is not satisfying, since the conversion function cannot rely-      that the structure of all FilterComposition v [m] is equal.-      If the list is empty the structure can't even be reconstructed.--}--{-|-  This describes a generic filter with one input and one main output-  that consists of non-recursive and recursive parts.-  If you use Feedback, make sure that at least-  one of the filters of a circle includes a delay,-  otherwise the recursion will fail.-  The main output is used to glue different parts together.-  Additionally the functions 'apply' and 'transferFunction'-  provide the signals at every node of the network.--}-data T filter t a v =-     Prim (filter t a v)-       {-^ a filter primitve -}-   | Serial   [T filter t a v]-       {-^ serial chain of filters -}-   | Parallel [T filter t a v]-       {-^ filters working parallel, there output is mixed together -}-   | Feedback (T filter t a v) (T filter t a v)-       {-^ filter the signal in the forward direction and-           feed back the output signal filtered by the second filter -}--{-|-  This is the data structure is used for the results-  of 'apply' and 'transferFunction'.-  Each constructor corresponds to one of 'Filter.Composition.T'.-  By choosing only some of the outputs-  the lazy evaluation will content-  with applying the necessary filter steps, only.--}-data Sockets s = Sockets {output :: s, socket :: SocketSpec s}--data SocketSpec s =-     Output-   | Multiplier [Sockets s]-   | Adder [Sockets s]-   | Loop (Sockets s) (Sockets s)--instance (Filter list filter) =>-      Filter (list) (T filter) where-{--   apply :: (Module.C a v) =>-      FilterComposition a v -> TwoWayList v -> TwoWayList v--}-   apply f x = output (applyMulti f x)-{--   transferFunction :: (Trans.C b, Module.C a (Complex.T b)) =>-      T filter a v -> b -> (Complex.T b)--}-   transferFunction f w = output (transferFunctionMulti f w)---{-| Apply a filter network to a signal and keep the output of all nodes.-    Generic function that is wrapped by 'apply'. -}-applyMulti :: (RealField.C t, Trans.C t,-      Module.C a v, Module.C a (list v), Filter list filter) =>-   T filter t a v -> list v -> Sockets (list v)-applyMulti (Prim f) x =-   Sockets (apply f x) Output-applyMulti (Serial fs) x =-   let sq = scanl (\(Sockets y _) -> flip applyMulti y) (Sockets x Output) fs-   in  Sockets (output (last sq)) (Multiplier (tail sq))-applyMulti (Parallel fs) x =-   let socks = map (flip applyMulti x) fs-       y = foldr (Additive.+) zero (map output socks)-   in  Sockets y (Adder socks)-{- the distinction between 'feed' and 'back'-   can be dropped in a more general net structure -}-applyMulti (Feedback feed back) x =-   let sockY@(Sockets y _) = applyMulti feed ((Additive.+) x z)-       sockZ@(Sockets z _) = applyMulti back y-   in  Sockets y (Loop sockY sockZ)---transferFunctionMulti ::-   (Trans.C t, Module.C a t, Filter list filter) =>-      T filter t a v -> t -> Sockets (Complex.T t)-transferFunctionMulti f w = tfAbsolutize 1 (tfRelative w f)--{-| Compute the transitivity for each part of the filter network.-    We must do this in such a relative manner to be able-    to compute feedback. -}-tfRelative ::-   (Trans.C t, Module.C a t, Filter list filter) =>-      t -> T filter t a v -> Sockets (Complex.T t)-tfRelative w (Prim f) =-   Sockets (FilterBasic.transferFunction f w) Output-tfRelative w (Serial fs) =-   let sq = map (tfRelative w) fs-   in  Sockets (product (map output sq)) (Multiplier sq)-tfRelative w (Parallel fs) =-   let sq = map (tfRelative w) fs-   in  Sockets (sum (map output sq)) (Adder sq)-tfRelative w (Feedback feed back) =-   let sockY = tfRelative w feed-       sockZ = tfRelative w back-       q = output sockY / (1 - output sockZ)-   in  Sockets q (Loop sockY sockZ)---{-| Make the results from 'tfRelative' absolute. -}-tfAbsolutize :: (Field.C a) => a -> Sockets a -> Sockets a-tfAbsolutize x (Sockets y spec) = Sockets (x*y)-   (case spec of-      (Multiplier socks) ->-         let sq = scanl (\(Sockets z _) -> tfAbsolutize z)-                        (Sockets x Output) socks-         in  Multiplier (tail sq)-      (Adder socks) ->-         let sq = map (tfAbsolutize x) socks-         in  Adder sq-      (Loop feed back) ->-         let sockY = tfAbsolutize (x / (1 - output back)) feed-             sockZ = tfAbsolutize (output sockY) back-             -- it should be  x*y == output sockY-         in  Loop sockY sockZ-      Output -> spec)
− src/Synthesizer/Filter/Example.hs 
@@ -1,243 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-module Synthesizer.Filter.Example where--import qualified Synthesizer.Filter.OneWay as OneWay-import qualified Synthesizer.Filter.TwoWay as TwoWay-import qualified Synthesizer.Filter.Composition as Composition-import qualified Synthesizer.Filter.Graph as Graph-import qualified Synthesizer.Plain.Interpolation as Interpolation--import Synthesizer.Filter.Basic (apply, )-import Synthesizer.Filter.Composition (T(..))--import qualified Synthesizer.Plain.Oscillator as Osci-import qualified Synthesizer.Basic.Wave       as Wave-import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1-import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR--import qualified Algebra.Module         as Module-import qualified Algebra.Transcendental as Trans-import qualified Algebra.RealField      as RealField-import qualified Algebra.Field          as Field-import qualified Algebra.Real           as Real--import Data.Maybe (fromMaybe)--import PreludeBase-import NumericPrelude----{-* Reconstruction of the sound of a plucked guitar string -}--guitarInit :: Field.C a => [a]-guitarInit = map (/128) (-      1 :    1 :    1 :    1 :    1 :    1 :    1 :    1 :-      1 :    2 :    2 :    2 :    2 :    2 :    2 :    2 :-      2 :    2 :    2 :    2 :    2 :    2 :    2 :    2 :-      2 :    2 :    2 :    3 :    3 :    3 :    3 :    3 :-      3 :    3 :    3 :    3 :    3 :    3 :    3 :    3 :-      3 :    3 :    3 :    4 :    4 :    4 :    4 :    4 :-      4 :    4 :    4 :    4 :    4 :    4 :    4 :    4 :-      5 :    5 :    5 :    5 :    5 :    5 :    5 :    5 :-      6 :    6 :    6 :    7 :    7 :    8 :    8 :    9 :-     10 :   11 :   12 :   13 :   14 :   15 :   15 :   16 :-     17 :   17 :   17 :   18 :   18 :   18 :   18 :   18 :-     18 :   18 :   18 :   17 :   17 :   16 :   16 :   15 :-     15 :   14 :   14 :   14 :   13 :   13 :   14 :   14 :-     15 :   16 :   17 :   18 :   19 :   20 :   22 :   23 :-     25 :   27 :   30 :   32 :   35 :   37 :   39 :   41 :-     43 :   45 :   47 :   48 :   49 :   49 :   48 :   46 :-     41 :   34 :   24 :   11 :   -6 :  -26 :  -48 :  -72 :-    -96 : -114 : -128 : -128 : -128 : -128 : -128 : -128 :-   -128 : -125 : -110 :  -93 :  -75 :  -57 :  -41 :  -27 :-    -17 :  -10 :   -6 :   -4 :   -2 :   -2 :   -2 :   -2 :-     -2 :   -3 :   -4 :   -4 :   -5 :   -6 :   -7 :   -8 :-     -9 :  -10 :  -11 :  -12 :  -12 :  -12 :  -13 :  -13 :-    -13 :  -13 :  -13 :  -13 :  -12 :  -12 :  -11 :  -10 :-     -9 :   -9 :   -8 :   -8 :   -7 :   -6 :   -6 :   -5 :-     -5 :   -5 :   -5 :   -4 :   -4 :   -4 :   -4 :   -4 :-     -4 :   -4 :   -4 :   -4 :   -4 :   -5 :   -7 :   -8 :-     -8 :   -9 :  -10 :  -11 :  -12 :  -13 :  -13 :  -14 :-    -14 :  -14 :  -13 :  -10 :   -7 :   -2 :    5 :   15 :-     26 :   37 :   49 :   61 :   73 :   83 :   92 :   99 :-    105 :  109 :  111 :  112 :  110 :  105 :   99 :   90 :-     80 :   71 :   63 :   57 :   52 :   49 :   47 :   47 :-     48 :   49 :   51 :   51 :   52 :   52 :   50 :   48 :-     42 :   34 :   22 :    7 :  -12 :  -32 :  -56 :  -78 :-    -96 : -114 : -127 : -128 : -128 : -128 : -128 : -128 :-   -128 : -118 : -102 :  -83 :  -67 :  -50 :  -37 :  -26 :-    -17 :  -12 :   -8 :   -5 :   -3 :   -3 :   -2 :   -2 :-     -2 :   -3 :   -4 :   -4 :   -6 :   -7 :   -8 :  -10 :-    -11 :  -12 :  -12 :  -13 : [])--guitarCompShort, guitarCompLong ::-   Field.C a => [a] -> Composition.T TwoWay.T Double a a-guitarCompShort past = Feedback (Prim (TwoWay.Past past)) (Parallel [-   Serial [Prim (TwoWay.Delay   1),-           Prim (TwoWay.Mask [0.6519177892575342, 0.2331904728998289])],-   Serial [Prim (TwoWay.Delay 126),-           Prim (TwoWay.Mask [0.08253506238277844,-               0.2369601607320473,   0.18367848836060044,-              -0.06422525077173147, -0.31836517142623727])]])-guitarCompLong past = Feedback (Prim (TwoWay.Past past)) (-   Serial [Prim (TwoWay.Delay 122),-           Prim (TwoWay.Mask [-              -0.23742303494466988,-               0.020278040917954415,-               0.12495333789385828,-               0.16125537461091102,-               0.1993410924766678,-               0.24673057006071691,-               0.25438881375430467,-               0.1424676847770117,-               0.03848071949084291,-              -0.016618282409355676,-              -0.04517323927531556,-              -0.0061713683480988475,-               0.11137126130878339-             ])])--{-| Reconstruct the guitar sound from the sampled initial wave-    and the analysed feedback factors.-    This sounds pretty like the sampled sound. -}-guitarRaw :: (Field.C a, Module.C a a) => [a]-guitarRaw =-   let gi = guitarInit  -- assert monomorphism-       y = TwoWay.future-              (TwoWay.delay (length gi)-                 (apply (guitarCompLong (reverse gi))-                        (TwoWay.Signal [] [])))-   in  y--{-| Reconstruct the guitar sound from the sampled initial wave-    but with simple smoothing on feedback.-    This sounds more statically. -}-guitarRawSimple :: (Field.C a, Module.C a a) => [a]-guitarRawSimple =-   let gi = guitarInit  -- assert monomorphism-       y  = gi ++ drop (length gi)-              (FiltNR.delay 128 (Filt1.lowpass-                 (repeat (Filt1.Parameter (0.4  `asTypeOf` head y))) y))-   in  y--{-| Reconstruct the guitar sound with the analysed feedback factors-    but with an synthetic initial wave.-    The sharpness of the initial wave can be controlled.-    This is used to implement various velocities. -}-guitarRawVelo :: (Real.C a, Trans.C a, Module.C a a) => a -> [a]-guitarRawVelo velo =-   let len  = 128::Int-       wave =-          map (Wave.power01Normed velo)-             (take len (iterate (+ 2 / fromIntegral len) (-1)))-       y = TwoWay.future-              (TwoWay.delay len-                 (apply (guitarCompLong wave)-                        (TwoWay.Signal [] [])))-   in  y---{-| Resample the reconstructed string sound-    so that notes can be played. -}-guitar :: (RealField.C a, Module.C a a) => a -> [a]-guitar freq =-   let srcFreq = 128 * freq-   in  Interpolation.multiRelativeZeroPadLinear 0-          (repeat (srcFreq `asTypeOf` freq)) guitarRawSimple----{-* Tests for FilterGraphs -}--type CompositionDouble =-        Composition.T TwoWay.T Double Double Double--{-| a simple lowpass used to create an exponential2 -}---expo :: (RealField.C a, Module.C a a) => TwoWay.Signal a-expo :: TwoWay.Signal Double-expo =-   let _flt1 = Feedback (Serial [Prim (OneWay.Delay ([0] `asTypeOf` past))])-                       (Serial [Prim (OneWay.Mask-                                        ([0.9] `asTypeOf` past))])-       _flt2 = (Prim (TwoWay.Mask ([0.5] `asTypeOf` past)))-                 :: CompositionDouble-       flt3 = (Feedback (Serial [])-                        (Prim (TwoWay.Delay 1)))-                 :: CompositionDouble-       TwoWay.Signal past future = apply flt3 (TwoWay.Signal [] [1])-   in  TwoWay.Signal past (take 10 future)--type GraphDouble f = Graph.T f Int Double Double Double--simpleGraph :: TwoWay.Signal Double-simpleGraph =-   let out =-          Graph.apply-             (Graph.fromList-                [(0, []),-                 (1, [(0, TwoWay.Delay (-1))]),-                 (2, [(1, TwoWay.Mask [0.95])])] ::-                    GraphDouble TwoWay.T)-             (Graph.signalFromList-                [(0, TwoWay.Signal [] [1])])-   in  fromMaybe (error "requested output of non-existing socket")-                 (Graph.lookupSignal out (2::Int))--expoGraphTwoWay :: [Double]-expoGraphTwoWay =-   let out =-          Graph.apply-             (Graph.fromList-                [(0, [(2, TwoWay.Past [1])]),-                 (1, [(0, TwoWay.Delay 1)]),-                 (2, [(1, TwoWay.Mask [0.95])])] ::-                    GraphDouble TwoWay.T)-             (Graph.signalFromList-                [(0, TwoWay.Signal [] [])])-   in  TwoWay.take 20 $ TwoWay.delay 10-          (fromMaybe (error "requested output of non-existing socket")-             (Graph.lookupSignal out (0::Int)))---expoGraph :: [Double]-expoGraph =-   let out =-          Graph.apply-             (Graph.fromList-                [(0, [(1, OneWay.Delay [0])]),-                 (1, [(0, OneWay.Mask [0.99])])] ::-                    GraphDouble OneWay.T)-             (Graph.signalFromList-                [(0, [1])])-   in  fromMaybe (error "requested output of non-existing socket")-                 (Graph.lookupSignal out (0::Int))--{-| make recursive flanger with help of the two way interpolation -}-flangedSaw :: Double -> [Double]-flangedSaw sampleRate =-   let {- The flanger's principal filter frequency will vary between-          flangeFreq * 2**flangeRange and flangeFreq / 2**flangeRange -}-       flangeFreq  = 1000-       flangeRange = 2-       sawFreq     = 440-       gain = 0.6-       vol  = 0.5--       {- 'control' contains the feedback times -}-       control  = map (\c -> sampleRate/flangeFreq * 2**(-flangeRange*c))-                      (map sin (iterate (pi/(0.5*sampleRate)+) 0))-       sawPast   = Osci.freqModSaw 0 (repeat (-sawFreq/sampleRate))-       sawFuture = Osci.freqModSaw 0 (repeat ( sawFreq/sampleRate))-       --lowNoise = amplify vol noise-       flt = Feedback-                (Prim (TwoWay.Mask [vol]))-                (Serial [Prim (TwoWay.Mask [gain]),-                         Prim (TwoWay.Past []),-                         Prim (TwoWay.ModFracDelay-                                  Interpolation.linear -                                     (TwoWay.Signal [] control))])-                :: CompositionDouble--   in  TwoWay.future-          (apply flt (TwoWay.Signal sawPast sawFuture))
− src/Synthesizer/Filter/Fix.hs 
@@ -1,38 +0,0 @@-module Synthesizer.Filter.Fix where--import qualified Synthesizer.Filter.Graph as Graph---{-|-A 'Graph.T' with numbered nodes is not very comfortable.-Better provide a 'Control.Monad.Fix.fix'-like function-which allows to enter a graph this way:--> fix $ \[v,w,y] ->-> [a·(u + d·w),->  b·(v + e·y),->  c· w]---}--type T filter t a v  =-   [Channel filter t a v] -> [[(Channel filter t a v, filter t a v)]]--type ChannelId = Int--data Channel filter t a v =-   Channel {channelId     :: ChannelId,-            channelInputs :: [(ChannelId, filter t a v)]}---fix :: T filter t a v -> [Channel filter t a v]-fix f =-   let cs = zipWith (\n inputs ->-               Channel n (map (\(c,filt) -> (channelId c, filt)) inputs))-               [0 ..] (f cs)-   in  cs---toGraph :: T filter t a v -> Graph.T filter Int t a v-toGraph =-   Graph.fromList . map (\(Channel n inputs) -> (n, inputs)) . fix
− src/Synthesizer/Filter/Graph.hs 
@@ -1,183 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE FlexibleContexts #-}-module Synthesizer.Filter.Graph where--import qualified Prelude as P-import PreludeBase-import NumericPrelude--import qualified Synthesizer.Filter.Basic as FilterBasic-import Synthesizer.Filter.Basic (Filter, apply, )-import qualified Data.Map as Map-import Data.Map(Map)-import MathObj.DiscreteMap()  {- Module.C instances for Map -}--import qualified Number.Complex         as Complex-import qualified Algebra.RealField      as RealField-import qualified Algebra.Additive       as Additive-import qualified Algebra.Transcendental as Trans-import qualified Algebra.Module         as Module-import Algebra.Module((*>))-import Orthogonals(Scalar,inverse,add_to_diagonal)---{-|-A filter network is a graph consisting-of nodes (input and output signals)-and edges (filter processes).-Output signals can be taken from every node,-inputs can be injected in some nodes-which means that the signal at this node is superposed with-the injected signal.-The same can be achieved by duplicating the network,-one duplicate per input,-and superposing the corresponding outputs.-It is also sensible to setup a graph without inputs,-e.g. a recursive filter with some initial conditions-that works independent from any input.--In opposition to electric filter networks-digital filter networks must be directed.--Test-case: leap-frog filters like-->     +-----------[d]-----------+->     v                         |->(u) -+-> [a] (v) -+-> [b] (w) -+-> [c] (y) -+->->                  ^                         |->                  +-----------[e]-----------+--@-v = a·(u + d·w)-w = b·(v + e·y)-y = c· w-@--We model the general network by a list of nodes,-where each node is an adder that holds a list of its inputs.-Each input of a node is an output-of another node that has gone through a processor.-Additionally there may be one input from outside.-In principle a processor could be a simple filter network-as defined by the structure 'Filter'.--The network is an applyable filter-whenever each circle contains a delay.-To compute the transfer function-we have to solve a system of linear equations-which we can construct quite straight forward-from the processors' input lists.--The current design can be abstractly seen-as the system of linear equations:--  y = A*y + u--where A is a matrix containing the edges hosting the filters,-y the vector of output signals,-u the vector of input signals.-In this formulation the number of inputs and outputs must match-but since you are free to ignore some of the inputs and outputs-you can use nodes for pure output, pure input or both of them.---}--newtype T filter i t a v =-   C (Map i-      [(i,          {- index of the processor whose output goes in here -}-        filter t a v  {- description of the filter -}-        )])---newtype Signal list i v = Signal (Map i (list v))---fromList :: (Ord i) => [(i, [(i, filter t a v)])] -> T filter i t a v-fromList = C . Map.fromList--toList :: T filter i t a v -> [(i, [(i, filter t a v)])]-toList (C fg) = Map.toList fg--signalFromList :: (Ord i) => [(i, list v)] -> Signal list i v-signalFromList = Signal . Map.fromList--signalToList :: Signal list i v -> [(i, list v)]-signalToList (Signal x) = Map.toList x--lookupSignal :: (Ord i) => Signal list i v -> i -> Maybe (list v)-lookupSignal (Signal x) = flip Map.lookup x---{--  These instance may help to include FilterGraphs-  in even bigger structures.--}-instance (Ord i, Additive.C (list v), Eq (list v))-            => Additive.C (Signal list i v) where-   zero                      = Signal Additive.zero-   (+) (Signal x) (Signal y) = Signal ((Additive.+) x y)-   (-) (Signal x) (Signal y) = Signal ((Additive.-) x y)-   negate (Signal x)         = Signal (Additive.negate x)--instance (Ord i, Eq a, Additive.C a, Additive.C (list v), Eq (list v),-              Module.C a v, Module.C a (list v))-                 => Module.C a (Signal list i v) where-   s *> (Signal x) = Signal (s *> x)---{--   It would be interesting to make FilterGraphs-   an instance of Filter.-   To achieve that we had to make GraphSignals an instance of Module.C-   and the transferFunction would no longer return a factor-   but a function that maps input amplitudes-   of a given frequency to output amplitudes.--instance (Ord i, Show i, Filter list filter) =>-      Filter (Signal list i) (T filter i) where--}--apply :: (Ord i, Show i, Additive.C t, Trans.C t, RealField.C t,-          Module.C a v, Module.C a (list v),-          Filter list filter) =>-   T filter i t a v -> Signal list i v -> Signal list i v-apply (C fg) (Signal inputs) =-   let getInput  i = Map.findWithDefault Additive.zero i inputs-       getOutput i = Map.findWithDefault-                         (error ("Unknown processor: "++show i)) i outputs-       output i edges =-          foldl (Additive.+) (getInput i) (map (\(j,f) ->-                   FilterBasic.apply f (getOutput j)) edges)-       outputs = Map.mapWithKey output fg-   in  Signal outputs--{-| Compute a matrix that tells how an input frequency-    is mapped to the various output nodes.--   According to the formulation given above-   we have to invert the matrix (I-A).--   Currently this is done by a QR decomposition for each frequency.-   It would be probably faster if we decompose-   the matrix containing polynomial elements.-   Then the inverted matrix would consist of some-   polynomial ratios which can be evaluated for each frequency.--}-transferFunction ::-   (Ord i, Show i, Trans.C t,-    P.Fractional (Complex.T t), Scalar (Complex.T t),-      Module.C a t, Filter list filter) =>-         T filter i t a v -> t -> [[Complex.T t]]-transferFunction (C fg) w =-   let keys = Map.keys fg-       elts = Map.elems fg-       inputsToMap procs =-          Map.mapWithKey (\_ f -> FilterBasic.transferFunction f w)-                         (Map.fromList procs)-       makeRow procs =-          map (flip (Map.findWithDefault 0) (inputsToMap procs)) keys-       matrix = map makeRow elts-   in  inverse (add_to_diagonal (-1) matrix)
− src/Synthesizer/Filter/Graphic.hs 
@@ -1,7 +0,0 @@-module Synthesizer.Filter.Graphic where--{-|-  This module should be populated with functions-  that create flowchart graphics from the filter networks-  of the 'Composition' module.--}
− src/Synthesizer/Filter/MonadFix.hs 
@@ -1,44 +0,0 @@-module Synthesizer.Filter.MonadFix where--import qualified Synthesizer.Filter.Graph as Graph-import qualified Synthesizer.Filter.Fix   as FFix--import Synthesizer.Filter.Fix (Channel(Channel), ChannelId)--import Control.Monad.Trans.State (StateT, evalStateT, get, modify, )-import Control.Monad.Trans.Writer (Writer, execWriter, tell, )-import Control.Monad.Trans (lift, )---{-|-If you find 'Filter.Fix.T' still inconvenient,-and if you don't care about portability,-you can also use the following monad with the @mdo@ notation.--> mdo->   v <- a·(u + d·w)->   w <- b·(v + e·y)->   y <- c· w---}---type T filter t a v x  =  StateT ChannelId (Writer [Channel filter t a v]) x--makeChannel ::-   [(ChannelId, filter t a v)] ->-   T filter t a v ChannelId-makeChannel inputs =-   do n <- get-      modify succ-      lift $ tell [Channel n inputs]-      return n---run :: T filter t a v x -> [Channel filter t a v]-run m = execWriter (evalStateT m 0)---toGraph :: T filter t a v x -> Graph.T filter Int t a v-toGraph =-   Graph.fromList . map (\(Channel n inputs) -> (n, inputs)) . run
− src/Synthesizer/Filter/OneWay.hs 
@@ -1,76 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-module Synthesizer.Filter.OneWay where--import Synthesizer.Filter.Basic--import qualified Synthesizer.Plain.Interpolation as Interpolation-import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR-import Number.Complex(cis)--import qualified Algebra.Module   as Module-import qualified Algebra.Ring     as Ring-import qualified Algebra.Additive as Additive--import Algebra.Module(linearComb)-import Algebra.Additive(zero)--import PreludeBase-import NumericPrelude--type Signal = []--{-| shift signal in time -}-delay :: (Additive.C v) =>-   Int -> Signal v -> Signal v-delay = FiltNR.delayPad zero--delayOnce :: (Additive.C v) =>-   Signal v -> Signal v-delayOnce = (zero:)---{-| Unmodulated non-recursive filter -}-nonRecursiveFilter :: Module.C a v =>-      [a] -> [v] -> [v]-nonRecursiveFilter = FiltNR.generic--{-| Modulated non-recursive filter. -}-nonRecursiveFilterMod :: Module.C a v =>-   [[a]] -> [v] -> [v]-nonRecursiveFilterMod ms x =-   zipWith linearComb ms (tail (scanl (flip (:)) [] x))---{-| Description of a basic filter that can be used in larger networks. -}-data T t a v =-     Mask [a]-        {-^ A static filter described by its mask -}-   | ModMask (Signal [a])-        {-^ A modulated filter described by a list of masks -}-   | FracDelay (Interpolation.T t v) t-        {-^ Delay the signal by a fractional amount of samples.-            This is achieved by interpolation. -}-   | ModFracDelay (Interpolation.T t v) (Signal t)-        {-^ Delay with varying delay times.-            The delay times sequence must monotonically decrease.-            (This includes constant parts!) -}-   | Delay [v]-        {-^ Delay the signal by prepending another one -}--instance Filter [] T where--   apply (Mask         m)     = nonRecursiveFilter m-   apply (ModMask      m)     = nonRecursiveFilterMod m-   apply (FracDelay    ip t)  = Interpolation.multiRelativeZeroPad zero-                                   ip (-t) (repeat 1)-   apply (ModFracDelay ip ts) = Interpolation.multiRelativeZeroPad zero-                                   ip (- head ts) (repeat 1 - FiltNR.differentiate ts)-   apply (Delay        x)     = (x++)--   transferFunction (Mask        m) w = linearComb m (screw (negate w))-   transferFunction (FracDelay _ t) w = cis (negate w * t)-   transferFunction (Delay       x) w = cis (negate w * fromIntegral (length x))-   transferFunction _ _ =-      error "transfer function can't be computed for modulated filters"
− src/Synthesizer/Filter/TwoWay.hs 
@@ -1,247 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-module Synthesizer.Filter.TwoWay where--import Synthesizer.Filter.Basic--import qualified Synthesizer.Plain.Signal as Sig-import qualified Synthesizer.Plain.Interpolation as Ip-import qualified Synthesizer.Plain.Interpolation as Interpolation--import Algebra.Module(linearComb,(*>))--import qualified Algebra.Module    as Module-import qualified Algebra.RealField as RealField-import qualified Algebra.Ring      as Ring-import qualified Algebra.Additive  as Additive--import Number.Complex(cis, )-import Data.Function.HT (nest, )-import qualified Data.List as List--import PreludeBase hiding (take)-import NumericPrelude---{-| A TwoWay.Signal stores values of the past and the future -}-data Signal v = Signal {past, future :: [v]}-   deriving (Show, Eq)--{-| Take n values starting from time zero.-    If you want clips from elsewhere,-    call 'take' after 'delay'. -}-take :: Int -> Signal v -> [v]-take n (Signal _ x) = List.take n x--zipSignalWith :: (a -> b -> c) -> Signal a -> Signal b -> Signal c-zipSignalWith f (Signal xPast xFuture) (Signal yPast yFuture) =-   (Signal (zipWith f xPast yPast) (zipWith f xFuture yFuture))--{-| Take the value at time zero. -}-origin :: Ring.C a => Signal a -> a-origin (Signal _ (x:_)) = x-origin _ = 0--{-| A signal that consists entirely of ones -}-ones :: Ring.C a => Signal a-ones = Signal (repeat 1) (repeat 1)--{-| shift signal in time,-    keep all values but if required pad with zeros -}-delay :: (Additive.C v) =>-   Int -> Signal v -> Signal v-delay = delayGen delayOnce--delayPad :: v -> Int -> Signal v -> Signal v-delayPad z = delayGen (delayPadOnce z)--{-| shift signal in time,-    zero values at either ends will be flushed -}-delayOpt :: (Eq v, Additive.C v) =>-   Int -> Signal v -> Signal v-delayOpt = delayGen delayOptOnce---{-| Delay by one sample. -}-delayOnce :: (Additive.C v) =>-   Signal v -> Signal v---delayOnce (Signal []     []) = ([],[])-delayOnce (Signal []     ys) = Signal [] (zero:ys)-delayOnce (Signal (x:xs) ys) = Signal xs (x:ys)--delayPadOnce :: v -> Signal v -> Signal v---delayPadOnce _ (Signal []     []) = ([],[])-delayPadOnce z (Signal []     ys) = Signal [] (z:ys)-delayPadOnce _ (Signal (x:xs) ys) = Signal xs (x:ys)--delayOptOnce :: (Eq v, Additive.C v) =>-   Signal v -> Signal v---delayOptOnce (Signal []     []) = Signal [] []-delayOptOnce (Signal []     ys) = Signal [] (zero:ys)-delayOptOnce (Signal (x:xs) []) = Signal xs (if x==zero then [] else x:[])-delayOptOnce (Signal (x:xs) ys) = Signal xs (x:ys)---{-| General routine that supports delaying and prefetching-    using a general one-sample delaying routine. -}-delayGen :: (Signal v -> Signal v) ->-               Int -> Signal v -> Signal v-{- Using this optimization applications of recursive filters-   with zero initial conditions represented by an empty list will fail.-   This is because in this case the value of the first item of the future list-   depends on the first item of the input future list,-   whereas normally the first future value depends on no input future value,-   at all.-delayGen _ _ (Signal [] []) = Signal [] []-   cf. the next example -}-delayGen delOnce t =-    if t < 0-    then reverseTwoWay . nest (negate t) delOnce . reverseTwoWay-    else nest t delOnce--reverseTwoWay :: Signal v -> Signal v-reverseTwoWay (Signal x y) = Signal y x---instance (Additive.C v) => Additive.C (Signal v) where-   zero                                = Signal zero zero-   (+)   (Signal y0 y1) (Signal x0 x1) = Signal (y0 + x0)   (y1 + x1)-   (-)   (Signal y0 y1) (Signal x0 x1) = Signal (y0 - x0)   (y1 - x1)-   negate               (Signal x0 x1) = Signal (negate x0) (negate x1)--instance (Module.C a v) => Module.C a (Signal v) where-   (*>)  s      (Signal x0 x1) = Signal (s *> x0) (s *> x1)-----{-| for a Signal this means a reversion of the elements -}-flipPair :: (a,b) -> (b,a)-flipPair (x,y) = (y,x)--{- This example simulates what happens if you call-     apply (Feedback (Serial []) (Prim (Delay 1)) []) ([],[1])-   depending on the implementation of delayGen it may work or-   loop infinitely when yFuture is computed.-   It's even before the first element of yFuture is computed.-   Note, that the equivalent-     apply (Feedback (Serial []) (Prim (Delay 1)) [0]) ([],[1])-   works! (i.e. set yPast = [0] -}-testDelayGen :: Signal Double-testDelayGen =-   let yPast = []-       x = Signal [] [1]-       y = Signal yPast yFuture-       Signal _ yFuture = delayOnce (x + y)-       -- Signal _ yFuture = delayOptOnce (add x y)-       -- Signal _ yFuture = delayGen delayOnce 1 (add x y)-   in  Signal yPast (List.take 10 yFuture)----{-| Unmodulated non-recursive filter -}-nonRecursiveFilter :: Module.C a v =>-      [a] -> Signal v -> Signal v-nonRecursiveFilter m x =-   linearComb m (iterate delayOnce x)--{-| Modulated non-recursive filter.-    The number of values before time 0 (past) or-    the filter mask lengths must be at most finite. -}-nonRecursiveFilterMod :: Module.C a v =>-   Signal [a] -> Signal v -> Signal v-nonRecursiveFilterMod (Signal mpre msuf) x =-   let (pre, suf) = unzip (map (\(Signal a b) -> (a,b)) (iterate delayOnce x))-   in  Signal (zipWith linearComb mpre pre) (zipWith linearComb msuf suf)---{-| Interpolation allowing negative frequencies,-    but requires storage of all past values. -}-interpolatePaddedZero :: (Ord a, RealField.C a) =>-   b -> Interpolation.T a b-      -> a -> Signal a -> Signal b -> Signal b-interpolatePaddedZero z ip phase fs (Signal xPast xFuture) =-   let (phInt, phFrac) = splitFraction phase-       xPadded = Signal (xPast ++ repeat z) (xFuture ++ repeat z)-   in  interpolateCore ip phFrac fs-          (delayPad z (Ip.offset ip - phInt) xPadded)--interpolatePaddedCyclic :: (Ord a, RealField.C a) =>-   Interpolation.T a b-      -> a -> Signal a -> Signal b -> Signal b-interpolatePaddedCyclic ip phase fs (Signal xPast xFuture) =-   let (phInt, phFrac) = splitFraction phase-       xCyclic = xFuture ++ reverse xPast-   in  interpolateCore ip phFrac fs-          -- mod is for efficiency, only-          (delayPad (error "interpolate: infinite signal needs no zero padding")-                    (mod (Ip.offset ip - phInt) (length xCyclic))-                    (Signal (cycle (reverse xCyclic)) (cycle xCyclic)))---- note that the extrapolation may miss some of the first and some of the last points-interpolatePaddedExtrapolation :: (Ord a, RealField.C a) =>-   Interpolation.T a b-      -> a -> Signal a -> Signal b -> Signal b-interpolatePaddedExtrapolation ip phase fs x =-   interpolateCore ip (phase - fromIntegral (Ip.offset ip)) fs x--interpolateCore :: (Ord a, Ring.C a) =>-   Interpolation.T a b -> a -> Signal a -> Signal b -> Signal b-interpolateCore ip phase (Signal freqPast freqFuture) x =-   Signal (interpolateHalfWay ip (1-phase) freqPast-             (delayPadOnce (error "interpolateCore: infinite signal needs no zero padding")-                           (reverseTwoWay x)))-          (interpolateHalfWay ip phase freqFuture x)--interpolateHalfWay :: (Ord a, Ring.C a) =>-   Interpolation.T a b -> a -> [a] -> Signal b -> [b]-interpolateHalfWay ip phase freqs (Signal xPast xFuture) =-    if phase >= 1 && Sig.lengthAtLeast (1+Ip.number ip) xFuture-    then interpolateHalfWay ip (phase-1) freqs-            (Signal (head xFuture : xPast) (tail xFuture))-    else if phase < 0 && Sig.lengthAtLeast 1 xPast-         then interpolateHalfWay ip (phase + 1) freqs-                 (Signal (tail xPast) (head xPast : xFuture))-         else Ip.func ip phase xFuture :-              interpolateHalfWay ip (phase + head freqs) (tail freqs)-                 (Signal xPast xFuture)---{-| Description of a basic filter that can be used in larger networks. -}-data T t a v =-     Mask [a]-        {-^ A static filter described by its mask -}-   | ModMask (Signal [a])-        {-^ A modulated filter described by a list of masks -}-   | FracDelay (Interpolation.T t v) t-        {-^ Delay the signal by a fractional amount of samples.-            This is achieved by interpolation. -}-   | ModFracDelay (Interpolation.T t v) (Signal t)-        {-^ Delay with varying delay times. -}-   | Delay Int-        {-^ Delay the signal by given amount of samples. -}-   | Past [v]-        {-^ Replace the past by the given one.-            This must be present in each recursive filter cycle-            to let the magic work! -}--instance Filter Signal T where--   apply (Mask         m)     = nonRecursiveFilter m-   apply (ModMask      m)     = nonRecursiveFilterMod m-   apply (FracDelay    ip t)  = interpolatePaddedZero zero-                                   ip (-t) ones-   apply (ModFracDelay ip ts) = interpolatePaddedZero zero-                                   ip (- origin ts) (ts - delay (-1) ts + ones)-   apply (Delay        t)     = delay t-   apply (Past         x)     = Signal x . future--   {- This is in principle the same as for one way filters.-      How can one merge them? -}-   transferFunction (Mask        m) w = linearComb m (screw (negate w))-   transferFunction (FracDelay _ t) w = cis (negate w * t)-   transferFunction (Delay       t) w = cis (negate w * fromIntegral t)-   transferFunction (Past        _) _ = 1-   transferFunction _ _ =-      error "transfer function can't be computed for modulated filters"
src/Synthesizer/Frame/Stereo.hs view
@@ -1,114 +1,39 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{--This data type can be used as sample type for stereo signals.--}-module Synthesizer.Frame.Stereo (T, left, right, cons, map, ) where--import qualified Sound.Sox.Frame as Frame--import qualified Synthesizer.Interpolation.Class as Interpol--import qualified Algebra.NormedSpace.Maximum   as NormedMax-import qualified Algebra.NormedSpace.Euclidean as NormedEuc-import qualified Algebra.NormedSpace.Sum       as NormedSum--import qualified Algebra.Module    as Module-import qualified Algebra.Algebraic as Algebraic-import qualified Algebra.Additive  as Additive--import Foreign.Storable (Storable (..), )-import qualified Foreign.Storable.Record as Store--import Control.Applicative (liftA2, )-import Control.Monad (liftM2, )--import Test.QuickCheck (Arbitrary(..), )--import NumericPrelude-import PreludeBase hiding (map)-import Prelude ()------ cf. Sound.Sox.Frame.Stereo-data T a = Cons {left, right :: !a}-   deriving (Eq)---instance Show a => Show (T a) where-   showsPrec p x =-      showParen (p >= 10)-         (showString "Stereo.cons " . showsPrec 11 (left x) .-          showString " " . showsPrec 11 (right x))--instance (Arbitrary a) => Arbitrary (T a) where-   arbitrary = liftM2 cons arbitrary arbitrary-   coarbitrary = error "Stereo.coarbitrary not implemented"---{-# INLINE cons #-}-cons :: a -> a -> T a-cons = Cons--{-# INLINE map #-}-map :: (a -> b) -> T a -> T b-map f (Cons l r) = Cons (f l) (f r)--instance Functor T where-   fmap = map---store :: Storable a => Store.Dictionary (T a)-store =-   Store.run $-   liftA2 Cons-      (Store.element left)-      (Store.element right)--instance (Storable a) => Storable (T a) where-   sizeOf = Store.sizeOf store-   alignment = Store.alignment store-   peek = Store.peek store-   poke = Store.poke store---instance (Additive.C a) => Additive.C (T a) where-   {-# INLINE zero #-}-   {-# INLINE negate #-}-   {-# INLINE (+) #-}-   {-# INLINE (-) #-}-   zero                             = Cons zero zero-   (+)    (Cons xl xr) (Cons yl yr) = Cons (xl+yl) (xr+yr)-   (-)    (Cons xl xr) (Cons yl yr) = Cons (xl-yl) (xr-yr)-   negate (Cons xl xr)              = Cons (negate xl) (negate xr)+module Synthesizer.Frame.Stereo (+   T, left, right, cons, map, swap,+   arrowFromMono, arrowFromMonoControlled, arrowFromChannels,+   Stereo.Channel(Left, Right), Stereo.select,+   Stereo.interleave,+   Stereo.sequence,+   Stereo.liftApplicative,+   ) where -instance (Module.C a v) => Module.C a (T v) where-   {-# INLINE (*>) #-}-   s *> (Cons l r)   = Cons (s *> l) (s *> r)+import Sound.Frame.NumericPrelude.Stereo as Stereo+import Control.Arrow (Arrow, (^<<), (<<^), (&&&), )+import Data.Tuple.HT (mapSnd, ) -instance Interpol.C a v => Interpol.C a (T v) where-   {-# INLINE scaleAndAccumulate #-}-   scaleAndAccumulate =-      Interpol.makeMac2 Cons left right+import Prelude hiding (map, )  -instance (Additive.C a, NormedSum.C a v) => NormedSum.C a (T v) where-   norm (Cons l r) =-      NormedSum.norm l + NormedSum.norm r--instance (NormedEuc.Sqr a v) => NormedEuc.Sqr a (T v) where-   normSqr (Cons l r) =-      NormedEuc.normSqr l + NormedEuc.normSqr r--instance (Algebraic.C a, NormedEuc.Sqr a v) => NormedEuc.C a (T v) where-   norm = NormedEuc.defltNorm--instance (Ord a, NormedMax.C a v) => NormedMax.C a (T v) where-   norm (Cons l r) =-      max (NormedMax.norm l) (NormedMax.norm r)+{- |+Run a causal process independently on each stereo channel.+-}+arrowFromMono ::+   (Arrow arrow) =>+   arrow a b -> arrow (Stereo.T a) (Stereo.T b)+arrowFromMono proc =+   uncurry Stereo.cons ^<<+   (proc<<^Stereo.left) &&& (proc<<^Stereo.right) +arrowFromMonoControlled ::+   (Arrow arrow) =>+   arrow (c,a) b -> arrow (c, Stereo.T a) (Stereo.T b)+arrowFromMonoControlled proc =+   uncurry Stereo.cons ^<<+   (proc <<^ mapSnd Stereo.left) &&& (proc <<^ mapSnd Stereo.right) -instance Frame.C a => Frame.C (T a) where-   numberOfChannels y = 2 * Frame.numberOfChannels (left y)-   format y = Frame.format (left y)+arrowFromChannels ::+   (Arrow arrow) =>+   arrow a b -> arrow a b -> arrow (Stereo.T a) (Stereo.T b)+arrowFromChannels leftChan rightChan =+   uncurry Stereo.cons ^<<+   (leftChan<<^Stereo.left) &&& (rightChan<<^Stereo.right)
− src/Synthesizer/FusionList/Control.hs 
@@ -1,245 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{- |-Copyright   :  (c) Henning Thielemann 2008-License     :  GPL--Maintainer  :  synthesizer@henning-thielemann.de-Stability   :  provisional-Portability :  requires multi-parameter type classes--}-module Synthesizer.FusionList.Control where--import qualified Synthesizer.Plain.Control as Ctrl-import qualified Synthesizer.Piecewise as Piecewise---- import Synthesizer.FusionList.Displacement (raise)-import qualified Synthesizer.FusionList.Signal as Sig-import Synthesizer.State.Control (splitDurations, )--import qualified Algebra.Module                as Module-import qualified Algebra.Transcendental        as Trans-import qualified Algebra.RealField             as RealField-import qualified Algebra.Field                 as Field-import qualified Algebra.Ring                  as Ring-import qualified Algebra.Additive              as Additive--import Algebra.Module((*>))---- import Number.Complex (cis,real)--- import qualified Number.Complex as Complex--import qualified Prelude as P-import PreludeBase-import NumericPrelude---{- * Control curve generation -}--{-# INLINE constant #-}-constant :: a -> Sig.T a-constant = Sig.repeat--{-# INLINE linear #-}-linear :: Additive.C a =>-      a   {-^ steepness -}-   -> a   {-^ initial value -}-   -> Sig.T a-          {-^ linear progression -}-linear d y0 = Sig.iterate (d+) y0--{- |-As stable as the addition of time values.--}-{-# INLINE linearMultiscale #-}-linearMultiscale :: Additive.C y =>-      y-   -> y-   -> Sig.T y-linearMultiscale = curveMultiscale (+)--{- |-Linear curve starting at zero.--}-{-# INLINE linearMultiscaleNeutral #-}-linearMultiscaleNeutral :: Additive.C y =>-      y-   -> Sig.T y-linearMultiscaleNeutral slope =-   curveMultiscaleNeutral (+) slope zero--{-# INLINE exponential #-}-{-# INLINE exponentialMultiscale #-}-exponential, exponentialMultiscale :: Trans.C a =>-      a   {-^ time where the function reaches 1\/e of the initial value -}-   -> a   {-^ initial value -}-   -> Sig.T a-          {-^ exponential decay -}-exponential time =-   Sig.iterate (exp (- recip time) *)--exponentialMultiscale time = curveMultiscale (*) (exp (- recip time))--{-# INLINE exponentialMultiscaleNeutral #-}-exponentialMultiscaleNeutral :: Trans.C y =>-      y   {-^ time where the function reaches 1\/e of the initial value -}-   -> Sig.T y {-^ exponential decay -}-exponentialMultiscaleNeutral time =-   curveMultiscaleNeutral (*) (exp (- recip time)) one---{-# INLINE exponential2 #-}-{-# INLINE exponential2Multiscale #-}-exponential2, exponential2Multiscale :: Trans.C a =>-      a   {-^ half life -}-   -> a   {-^ initial value -}-   -> Sig.T a-          {-^ exponential decay -}-exponential2 halfLife =-   Sig.iterate (((Ring.one+Ring.one) ** (- recip halfLife)) *)---   Sig.iterate (((Ring.one/(Ring.one+Ring.one)) ** recip halfLife) *)--exponential2Multiscale halfLife = curveMultiscale (*) (0.5 ** recip halfLife)--{- the 0.5 constant seems to block fusion-   Sig.iterate ((0.5 ** recip halfLife) *)--}-{- dito fromInteger-   Sig.iterate ((fromInteger 2 ** (- recip halfLife)) *)--}--{-# INLINE exponential2MultiscaleNeutral #-}-exponential2MultiscaleNeutral :: Trans.C y =>-      y   {-^ half life -}-   -> Sig.T y {-^ exponential decay -}-exponential2MultiscaleNeutral halfLife =-   curveMultiscaleNeutral (*) (0.5 ** recip halfLife) one---{-# INLINE exponentialFromTo #-}-{-# INLINE exponentialFromToMultiscale #-}-exponentialFromTo, exponentialFromToMultiscale :: Trans.C y =>-      y   {-^ time where the function reaches 1\/e of the initial value -}-   -> y   {-^ initial value -}-   -> y   {-^ value after given time -}-   -> Sig.T y {-^ exponential decay -}-exponentialFromTo time y0 y1 =-   Sig.iterate (*  (y1/y0) ** recip time) y0-exponentialFromToMultiscale time y0 y1 =-   curveMultiscale (*) ((y1/y0) ** recip time) y0-----{-| This is an extension of 'exponential' to vectors-    which is straight-forward but requires more explicit signatures.-    But since it is needed rarely I setup a separate function. -}-{-# INLINE vectorExponential #-}-vectorExponential :: (Trans.C a, Module.C a v) =>-       a  {-^ time where the function reaches 1\/e of the initial value -}-   ->  v  {-^ initial value -}-   -> Sig.T v-          {-^ exponential decay -}-vectorExponential time y0 =-   Sig.iterate (exp (-1/time) *>) y0--{-# INLINE vectorExponential2 #-}-vectorExponential2 :: (Trans.C a, Module.C a v) =>-       a  {-^ half life -}-   ->  v  {-^ initial value -}-   -> Sig.T v-          {-^ exponential decay -}-vectorExponential2 halfLife y0 =-   Sig.iterate (0.5**(1/halfLife) *>) y0----{-# INLINE cosine #-}-cosine :: Trans.C a =>-       a  {-^ time t0 where  1 is approached -}-   ->  a  {-^ time t1 where -1 is approached -}-   -> Sig.T a-          {-^ a cosine wave where one half wave is between t0 and t1 -}-cosine = Ctrl.cosineWithSlope $-   \d x -> Sig.map cos (linear d x)----{-# INLINE cubicHermite #-}-cubicHermite :: Field.C a => (a, (a,a)) -> (a, (a,a)) -> Sig.T a-cubicHermite node0 node1 =-   Sig.map (Ctrl.cubicFunc node0 node1) (linear 1 0)------ * piecewise curves---{-# DEPRECATED Piece, piecewise "use Synthesizer.Generic.Piece instead" #-}-{-# INLINE piecewise #-}-piecewise :: (RealField.C a) =>-   Piecewise.T a a (a -> Sig.T a) -> Sig.T a-piecewise xs =-   Sig.concat $ zipWith-      (\(n, t) (Piecewise.PieceData c yi0 yi1 d) ->-           Sig.take n $ Piecewise.computePiece c yi0 yi1 d t)-      (splitDurations $ map Piecewise.pieceDur xs)-      xs---type Piece a =-   Piecewise.Piece a a-      (a {- fractional start time -} -> Sig.T a)---{-# INLINE stepPiece #-}-stepPiece :: Piece a-stepPiece =-   Piecewise.pieceFromFunction $ \ y0 _y1 _d _t0 ->-      constant y0--{-# INLINE linearPiece #-}-linearPiece :: (Field.C a) => Piece a-linearPiece =-   Piecewise.pieceFromFunction $ \ y0 y1 d t0 ->-      let s = (y1-y0)/d in linear s (y0-t0*s)--{-# INLINE exponentialPiece #-}-exponentialPiece :: (Trans.C a) => a -> Piece a-exponentialPiece saturation =-   Piecewise.pieceFromFunction $ \ y0 y1 d t0 ->-      let y0' = y0-saturation-          y1' = y1-saturation-          yd  = y0'/y1'-      in  raise saturation-             (exponential (d / log yd) (y0' * yd**(t0/d)))--{-# INLINE cosinePiece #-}-cosinePiece :: (Trans.C a) => Piece a-cosinePiece =-   Piecewise.pieceFromFunction $ \ y0 y1 d t0 ->-      Sig.map-         (\y -> (1+y)*(y0/2)+(1-y)*(y1/2))-         (cosine t0 (t0+d))--{-# INLINE cubicPiece #-}-cubicPiece :: (Field.C a) => a -> a -> Piece a-cubicPiece yd0 yd1 =-   Piecewise.pieceFromFunction $ \ y0 y1 d t0 ->-      cubicHermite (t0,(y0,yd0)) (t0+d,(y1,yd1))--raise :: Additive.C a => a -> Sig.T a -> Sig.T a-raise = Sig.map . (+)---- * auxiliary functions--{-# INLINE curveMultiscale #-}-curveMultiscale :: (y -> y -> y) -> y -> y -> Sig.T y-curveMultiscale op d y0 =-   Sig.cons y0 (Sig.map (op y0) (Sig.iterateAssociative op d))--{-# INLINE curveMultiscaleNeutral #-}-curveMultiscaleNeutral :: (y -> y -> y) -> y -> y -> Sig.T y-curveMultiscaleNeutral op d neutral =-   Sig.cons neutral (Sig.iterateAssociative op d)
− src/Synthesizer/FusionList/Filter/NonRecursive.hs 
@@ -1,314 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{- |-Copyright   :  (c) Henning Thielemann 2008-License     :  GPL--Maintainer  :  synthesizer@henning-thielemann.de-Stability   :  provisional-Portability :  requires multi-parameter type classes--}-module Synthesizer.FusionList.Filter.NonRecursive where--import qualified Synthesizer.FusionList.Control as Ctrl-import qualified Synthesizer.FusionList.Signal as Sig--import qualified Algebra.Transcendental as Trans-import qualified Algebra.Module         as Module-import qualified Algebra.RealField      as RealField-import qualified Algebra.Field          as Field-import qualified Algebra.Ring           as Ring-import qualified Algebra.Additive       as Additive--import Algebra.Module( {- linearComb, -} (*>), )--import Data.Function.HT (nest, )--import PreludeBase-import NumericPrelude----{- * Envelope application -}--{-# INLINE amplify #-}-amplify :: (Ring.C a) => a -> Sig.T a -> Sig.T a-amplify v = Sig.map (v*)--{-# INLINE amplifyVector #-}-amplifyVector :: (Module.C a v) => a -> Sig.T v -> Sig.T v-amplifyVector v = Sig.map (v*>)---{-# INLINE envelope #-}-envelope :: (Ring.C a) =>-      Sig.T a  {-^ the envelope -}-   -> Sig.T a  {-^ the signal to be enveloped -}-   -> Sig.T a-envelope = Sig.zipWith (*)--{-# INLINE envelopeVector #-}-envelopeVector :: (Module.C a v) =>-      Sig.T a  {-^ the envelope -}-   -> Sig.T v  {-^ the signal to be enveloped -}-   -> Sig.T v-envelopeVector = Sig.zipWith (*>)----{-# INLINE fadeInOut #-}-fadeInOut :: (Field.C a) =>-   Int -> Int -> Int -> Sig.T a -> Sig.T a-fadeInOut tIn tHold tOut =-   let leadIn  = Sig.take tIn  $ Ctrl.linear (  recip (fromIntegral tIn))  zero-       leadOut = Sig.take tOut $ Ctrl.linear (- recip (fromIntegral tOut)) one-       hold    = Sig.replicate tHold one-   in  envelope (leadIn `Sig.append` hold `Sig.append` leadOut)--{-# INLINE fadeInOutStored #-}-fadeInOutStored :: (Field.C a) =>-   Int -> Int -> Int -> Sig.T a -> Sig.T a-fadeInOutStored tIn tHold tOut xs =-   let leadIn  = Sig.take tIn  $ Ctrl.linear (  recip (fromIntegral tIn))  0-       leadOut = Sig.take tOut $ Ctrl.linear (- recip (fromIntegral tOut)) 1-       (partIn, partHoldOut) = Sig.splitAt tIn xs-       (partHold, partOut) = Sig.splitAt tHold partHoldOut-   in  envelope leadIn partIn `Sig.append`-       partHold `Sig.append`-       envelope leadOut partOut---{- * Shift -}--{-# INLINE delay #-}-delay :: Additive.C y => Int -> Sig.T y -> Sig.T y-delay = delayPad zero--{-# INLINE delayPad #-}-delayPad :: y -> Int -> Sig.T y -> Sig.T y-delayPad z n =-   if n<0-     then Sig.drop (negate n)-     else Sig.append (Sig.replicate n z)---{- * Smoothing -}---{-| Unmodulated non-recursive filter -}-{-# INLINE generic #-}-generic :: (Module.C a v) =>-   Sig.T a -> Sig.T v -> Sig.T v-generic m x =-   let mr = Sig.reverse m-       xp = delay (pred (Sig.length m)) x-   in  Sig.mapTails (Sig.linearComb mr) xp--{--genericSlow :: Module.C a v =>-   Sig.T a -> Sig.T v -> Sig.T v-genericSlow m x =-   let mr = Sig.reverse m-       xp = delay (pred (Sig.length m)) x-   in  Sig.fromList (map (Sig.linearComb mr) (init (Sig.tails xp)))--}--{--{- |-@eps@ is the threshold relatively to the maximum.-That is, if the gaussian falls below @eps * gaussian 0@,-then the function truncated.--}-gaussian ::-   (Trans.C a, RealField.C a, Module.C a v) =>-   a -> a -> a -> Sig.T v -> Sig.T v-gaussian eps ratio freq =-   let var    = ratioFreqToVariance ratio freq-       area   = var * sqrt (2*pi)-       gau t  = exp (-(t/var)^2/2) / area-       width  = ceiling (var * sqrt (-2 * log eps))  -- inverse gau-       gauSmp = map (gau . fromIntegral) [-width .. width]-   in  drop width . generic gauSmp--}--{--GNUPlot.plotList [] (take 1000 $ gaussian 0.001 0.5 0.04 (Filter.Test.chirp 5000) :: [Double])--The filtered chirp must have amplitude 0.5 at 400 (0.04*10000).--}--{--  We want to approximate a Gaussian by a binomial filter.-  The latter one can be implemented by a convolutional power.-  However we still require a number of operations per sample-  which is proportional to the variance.--}-{-# INLINE binomial #-}-binomial ::-   (Trans.C a, RealField.C a, Module.C a v) =>-   a -> a -> Sig.T v -> Sig.T v-binomial ratio freq =-   let width = ceiling (2 * ratioFreqToVariance ratio freq ^ 2)-   in  Sig.drop width . nest (2*width) ((asTypeOf 0.5 freq *>) . binomial1)--{--exp (-(t/var)^2/2) / area *> cis (2*pi*f*t)-  == exp (-(t/var)^2/2 +: 2*pi*f*t) / area-  == exp ((-t^2 +: 2*var^2*2*pi*f*t) / (2*var^2)) / area-  == exp ((t^2 - i*2*var^2*2*pi*f*t) / (-2*var^2)) / area-  == exp (((t^2 - i*var^2*2*pi*f)^2 + (var^2*2*pi*f)^2) / (-2*var^2)) / area-  == exp (((t^2 - i*var^2*2*pi*f)^2 / (-2*var^2) - (var*2*pi*f)^2/2)) / area--sumMap (\t -> exp (-(t/var)^2/2) / area *> cis (2*pi*f*t))-       [-infinity..infinity]-  ~ sumMap (\t -> exp (-(t/var)^2/2)) [-infinity..infinity]-       * exp (-(var*2*pi*f)^2/2) / area-  = exp (-(var*2*pi*f)^2/2)--}-{- |-  Compute the variance of the Gaussian-  such that its Fourier transform has value @ratio@ at frequency @freq@.--}-{-# INLINE ratioFreqToVariance #-}-ratioFreqToVariance :: (Trans.C a) => a -> a -> a-ratioFreqToVariance ratio freq =-   sqrt (-2 * log ratio) / (2*pi*freq)-           -- inverse of the fourier transformed gaussian--{-# INLINE binomial1 #-}-binomial1 :: (Additive.C v) => Sig.T v -> Sig.T v-binomial1 = Sig.zapWith (+)------{- |-Moving (uniformly weighted) average in the most trivial form.-This is very slow and needs about @n * length x@ operations.--}-{-# INLINE sums #-}-sums :: (Additive.C v) => Int -> Sig.T v -> Sig.T v-sums n = Sig.mapTails (Sig.sum . Sig.take n)---{--sumsDownsample2 :: (Additive.C v) => Sig.T v -> Sig.T v-sumsDownsample2 (x0:x1:xs) = (x0+x1) : sumsDownsample2 xs-sumsDownsample2 xs         = xs--downsample2 :: Sig.T a -> Sig.T a-downsample2 (x0:_:xs) = x0 : downsample2 xs-downsample2 xs        = xs---{- |-Given a list of numbers-and a list of sums of (2*k) of successive summands,-compute a list of the sums of (2*k+1) or (2*k+2) summands.--Eample for 2*k+1--@- [0+1+2+3, 2+3+4+5, 4+5+6+7, ...] ->-    [0+1+2+3+4, 1+2+3+4+5, 2+3+4+5+6, 3+4+5+6+7, 4+5+6+7+8, ...]-@--Example for 2*k+2--@- [0+1+2+3, 2+3+4+5, 4+5+6+7, ...] ->-    [0+1+2+3+4+5, 1+2+3+4+5+6, 2+3+4+5+6+7, 3+4+5+6+7+8, 4+5+6+7+8+9, ...]-@--}-sumsUpsampleOdd :: (Additive.C v) => Int -> Sig.T v -> Sig.T v -> Sig.T v-sumsUpsampleOdd n {- 2*k -} xs ss =-   let xs2k = drop n xs-   in  (head ss + head xs2k) :-          concat (zipWith3 (\s x0 x2k -> [x0+s, s+x2k])-                           (tail ss)-                           (downsample2 (tail xs))-                           (tail (downsample2 xs2k)))--sumsUpsampleEven :: (Additive.C v) => Int -> Sig.T v -> Sig.T v -> Sig.T v-sumsUpsampleEven n {- 2*k -} xs ss =-   sumsUpsampleOdd (n+1) xs (zipWith (+) ss (downsample2 (drop n xs)))--sumsPyramid :: (Additive.C v) => Int -> Sig.T v -> Sig.T v-sumsPyramid n xs =-   let aux 1 ys = ys-       aux 2 ys = ys + tail ys-       aux m ys =-          let ysd = sumsDownsample2 ys-          in  if even m-                then sumsUpsampleEven (m-2) ys (aux (div (m-2) 2) ysd)-                else sumsUpsampleOdd  (m-1) ys (aux (div (m-1) 2) ysd)-   in  aux n xs---propSums :: Bool-propSums =-   let n  = 1000-       xs = [0::Double ..]-       naive   =              sums        n xs-       rec     = drop (n-1) $ sumsRec     n xs-       pyramid =              sumsPyramid n xs-   in  and $ take 1000 $-         zipWith3 (\x y z -> x==y && y==z) naive rec pyramid---}----{- * Filter operators from calculus -}--{- |-Forward difference quotient.-Shortens the signal by one.-Inverts 'Synthesizer.Plain.Filter.Recursive.Integration.run' in the sense that-@differentiate (zero : integrate x) == x@.-The signal is shifted by a half time unit.--}-{-# INLINE differentiate #-}-differentiate :: Additive.C v => Sig.T v -> Sig.T v-differentiate x = Sig.zapWith subtract x--{- |-Central difference quotient.-Shortens the signal by two elements,-and shifts the signal by one element.-(Which can be fixed by prepending an appropriate value.)-For linear functions this will yield-essentially the same result as 'differentiate'.-You obtain the result of 'differentiateCenter'-if you smooth the one of 'differentiate'-by averaging pairs of adjacent values.--ToDo: Vector variant--}-{-# INLINE differentiateCenter #-}-differentiateCenter :: Field.C v => Sig.T v -> Sig.T v-differentiateCenter =-   Sig.zapWith (\(x0,_) (_,x1) -> (x1 - x0) * (1/2)) .-   Sig.zapWith (,)-{--differentiateCenter :: Field.C v => Sig.T v -> Sig.T v-differentiateCenter x =-   Sig.map ((1/2)*) $-   Sig.zipWith subtract x (Sig.tail (Sig.tail x))--}--{- |-Second derivative.-It is @differentiate2 == differentiate . differentiate@-but 'differentiate2' should be faster.--}-{-# INLINE differentiate2 #-}-differentiate2 :: Additive.C v => Sig.T v -> Sig.T v-differentiate2 = differentiate . differentiate-{--differentiate2 :: Additive.C v => Sig.T v -> Sig.T v-differentiate2 xs0 =-   let xs1 = Sig.tail xs0-       xs2 = Sig.tail xs1-   in  Sig.zipWith3 (\x0 x1 x2 -> x0+x2-(x1+x1)) xs0 xs1 xs2--}
− src/Synthesizer/FusionList/Oscillator.hs 
@@ -1,137 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{- |-Copyright   :  (c) Henning Thielemann 2006-License     :  GPL--Maintainer  :  synthesizer@henning-thielemann.de-Stability   :  provisional-Portability :  requires multi-parameter type classes--Tone generators--}-module Synthesizer.FusionList.Oscillator where--import qualified Synthesizer.Basic.Wave       as Wave-import qualified Synthesizer.Basic.Phase      as Phase--import qualified Synthesizer.FusionList.Signal as Sig---- import qualified Synthesizer.FusionList.Interpolation as Interpolation--{--import qualified Algebra.RealTranscendental    as RealTrans-import qualified Algebra.Module                as Module-import qualified Algebra.VectorSpace           as VectorSpace--import Algebra.Module((*>))--}-import qualified Algebra.Transcendental        as Trans-import qualified Algebra.RealField             as RealField--- import qualified Algebra.Field                 as Field--- import qualified Algebra.Ring                  as Ring-import qualified Algebra.Additive              as Additive--import NumericPrelude--import qualified Prelude as P-import PreludeBase----{- * Oscillators with arbitrary but constant waveforms -}--{-# INLINE freqToPhase #-}-{- | Convert a list of phase steps into a list of momentum phases-     phase is a number in the interval [0,1)-     freq contains the phase steps -}-freqToPhase :: RealField.C a => Phase.T a -> Sig.T a -> Sig.T (Phase.T a)-freqToPhase phase freq = Sig.scanL (flip Phase.increment) phase freq---{- Inlining blocks fusion of map and iterate - on the other hand it enables fusion in the main program -}-{-# INLINE static #-}-{- | oscillator with constant frequency -}-static :: (RealField.C a) => Wave.T a b -> (Phase.T a -> a -> Sig.T b)-static wave phase freq =-    Sig.map (Wave.apply wave) (Sig.iterate (Phase.increment freq) phase)--{-# INLINE phaseMod #-}-{- | oscillator with modulated phase -}-phaseMod :: (RealField.C a) => Wave.T a b -> a -> Sig.T a -> Sig.T b-phaseMod wave = shapeMod (Wave.phaseOffset wave) zero--{-# INLINE shapeMod #-}-{- | oscillator with modulated shape -}-shapeMod :: (RealField.C a) =>-    (c -> Wave.T a b) -> Phase.T a -> a -> Sig.T c -> Sig.T b-shapeMod wave phase freq parameters =-    Sig.zipWith (Wave.apply . wave) parameters (Sig.iterate (Phase.increment freq) phase)--{-# INLINE freqMod #-}-{- | oscillator with modulated frequency -}-freqMod :: (RealField.C a) => Wave.T a b -> Phase.T a -> Sig.T a -> Sig.T b-freqMod wave phase freqs =-    Sig.map (Wave.apply wave) (freqToPhase phase freqs)--{-# INLINE phaseFreqMod #-}-{- | oscillator with both phase and frequency modulation -}-phaseFreqMod :: (RealField.C a) =>-    Wave.T a b -> Sig.T a -> Sig.T a -> Sig.T b-phaseFreqMod wave = shapeFreqMod (Wave.phaseOffset wave) zero--{-# INLINE shapeFreqMod #-}-{- | oscillator with both shape and frequency modulation -}-shapeFreqMod :: (RealField.C a) =>-    (c -> Wave.T a b) -> Phase.T a -> Sig.T c -> Sig.T a -> Sig.T b-shapeFreqMod wave phase parameters freqs =-    Sig.zipWith (Wave.apply . wave) parameters (freqToPhase phase freqs)--{--{- | oscillator with a sampled waveform with constant frequency-     This essentially an interpolation with cyclic padding. -}-{-# INLINE staticSample #-}-staticSample :: RealField.C a =>-    Interpolation.T a b -> Sig.T b -> Phase.T a -> a -> Sig.T b-staticSample ip wave phase freq =-    freqModSample ip wave phase (Sig.repeat freq)--{- | oscillator with a sampled waveform with modulated frequency-     Should behave homogenously for different types of interpolation. -}-{-# INLINE freqModSample #-}-freqModSample :: RealField.C a =>-    Interpolation.T a b -> Sig.T b -> Phase.T a -> Sig.T a -> Sig.T b-freqModSample ip wave phase freqs =-    let len = Sig.length wave-    in  Interpolation.multiRelativeCyclicPad-           ip (fromIntegral len * Phase.toRepresentative phase)-           (Sig.map (* fromIntegral len) freqs) wave--}----{- * Oscillators with specific waveforms -}--{-# INLINE staticSine #-}-{- | sine oscillator with static frequency -}-staticSine :: (Trans.C a, RealField.C a) => Phase.T a -> a -> Sig.T a-staticSine = static Wave.sine--{-# INLINE freqModSine #-}-{- | sine oscillator with modulated frequency -}-freqModSine :: (Trans.C a, RealField.C a) => Phase.T a -> Sig.T a -> Sig.T a-freqModSine = freqMod Wave.sine--{-# INLINE phaseModSine #-}-{- | sine oscillator with modulated phase, useful for FM synthesis -}-phaseModSine :: (Trans.C a, RealField.C a) => a -> Sig.T a -> Sig.T a-phaseModSine = phaseMod Wave.sine--{-# INLINE staticSaw #-}-{- | saw tooth oscillator with modulated frequency -}-staticSaw :: RealField.C a => Phase.T a -> a -> Sig.T a-staticSaw = static Wave.saw--{-# INLINE freqModSaw #-}-{- | saw tooth oscillator with modulated frequency -}-freqModSaw :: RealField.C a => Phase.T a -> Sig.T a -> Sig.T a-freqModSaw = freqMod Wave.saw
− src/Synthesizer/FusionList/Signal.hs 
@@ -1,716 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# OPTIONS_GHC -fglasgow-exts #-}-{- glasgow-exts are for the rules -}-module Synthesizer.FusionList.Signal where--import qualified Synthesizer.Plain.Signal   as Sig-import qualified Synthesizer.Plain.Modifier as Modifier-import qualified Data.List as List--import qualified Data.StorableVector.Lazy as Vector-import Data.StorableVector.Lazy (ChunkSize, Vector)-import Foreign.Storable (Storable, )--import qualified Algebra.Module   as Module-import qualified Algebra.Additive as Additive-import Algebra.Additive (zero)--import Algebra.Module ((*>))--import qualified Synthesizer.Format as Format--import Control.Monad.Trans.State (runState, )--import Data.Monoid (Monoid, mempty, mappend, )--import qualified Data.List.HT    as ListHT-import Data.Tuple.HT (mapFst, mapSnd, mapPair, fst3, snd3, thd3, )--import Data.Maybe.HT (toMaybe)-import NumericPrelude (fromInteger, )--import Text.Show (Show(showsPrec), showParen, showString, )-import Data.Maybe (Maybe(Just, Nothing), maybe)-import Prelude-   ((.), ($), id, const, flip, curry, uncurry, fst, snd, error,-    (>), (>=), max, Ord,-    succ, pred, Bool, not, Int, Functor, fmap,-    (>>), (>>=), fail, return, (=<<),---    fromInteger,-    )--- import qualified Prelude as P-{--import Prelude hiding-   ((++), iterate, foldl, map, repeat, replicate,-    zipWith, zipWith3, take, takeWhile)--}---newtype T y = Cons {decons :: [y]}--instance (Show y) => Show (T y) where-   showsPrec p x =-      showParen (p >= 10)-         (showString "FusionList.fromList " . showsPrec 11 (toList x))--instance Format.C T where-   format = showsPrec--instance Functor T where-   fmap = map--instance Monoid (T y) where-   mempty = empty-   mappend = append---{- * functions based on 'generate' -}--{-# NOINLINE [0] generate #-}-generate :: (acc -> Maybe (y, acc)) -> acc -> T y-generate f = Cons . snd . Sig.unfoldR f--{-# INLINE unfoldR #-}-unfoldR :: (acc -> Maybe (y, acc)) -> acc -> T y-unfoldR = generate--{-# INLINE generateInfinite #-}-generateInfinite :: (acc -> (y, acc)) -> acc -> T y-generateInfinite f = generate (Just . f)--{-# INLINE fromList #-}-fromList :: [y] -> T y-fromList = generate ListHT.viewL--{-# INLINE toList #-}-toList :: T y -> [y]-toList = decons---toStorableSignal :: Storable y => ChunkSize -> T y -> Vector y-toStorableSignal size  =  Vector.pack size . decons--fromStorableSignal :: Storable y => Vector y -> T y-fromStorableSignal  =  Cons . Vector.unpack---{-# INLINE iterate #-}-iterate :: (a -> a) -> a -> T a-iterate f = generateInfinite (\x -> (x, f x))--{-# INLINE iterateAssociative #-}-iterateAssociative :: (a -> a -> a) -> a -> T a-iterateAssociative op x = iterate (op x) x -- should be optimized--{-# INLINE repeat #-}-repeat :: a -> T a-repeat = iterate id---{- * functions based on 'crochetL' -}--{-# NOINLINE [0] crochetL #-}-crochetL :: (x -> acc -> Maybe (y, acc)) -> acc -> T x -> T y-crochetL f a = Cons . Sig.crochetL f a . decons--{-# INLINE scanL #-}-scanL :: (acc -> x -> acc) -> acc -> T x -> T acc-{--scanL f start xs =-   cons start-     (crochetL (\x acc -> let y = f acc x in Just (y, y)) start xs)--}-scanL f start =-   cons start .-   crochetL (\x acc -> let y = f acc x in Just (y, y)) start---- | input and output have equal length, that's better for fusion-scanLClip :: (acc -> x -> acc) -> acc -> T x -> T acc-scanLClip f start =-   crochetL (\x acc -> Just (acc, f acc x)) start--{-# INLINE map #-}-map :: (a -> b) -> (T a -> T b)-map f = crochetL (\x _ -> Just (f x, ())) ()--{-# RULEZ-  "FusionList.map-crochetL" forall f.-     map f = crochetL (\x _ -> Just (f x, ())) () ;--  "FusionList.repeat-iterate"-     repeat = iterate id ;--  "FusionList.iterate-generate" forall f.-     iterate f = generate (\x -> Just (x, f x)) ;--  "FusionList.take-crochetL"-     take = crochetL (\x n -> toMaybe (n>zero) (x, pred n)) ;--  "FusionList.unfold-dollar" forall f x.-     f $ x = f x ;--  "FusionList.unfold-dot" forall f g.-     f . g  =  \x -> f (g x) ;-  #-}--{-# INLINE unzip #-}-unzip :: T (a,b) -> (T a, T b)-unzip x = (map fst x, map snd x)--{-# INLINE unzip3 #-}-unzip3 :: T (a,b,c) -> (T a, T b, T c)-unzip3 xs = (map fst3 xs, map snd3 xs, map thd3 xs)---{-# INLINE delay1 #-}-{- |-This is a fusion friendly implementation of delay.-However, in order to be a 'crochetL'-the output has the same length as the input,-that is, the last element is removed - at least for finite input.--}-delay1 :: a -> T a -> T a-delay1 = crochetL (flip (curry Just))--{-# INLINE delay #-}-delay :: y -> Int -> T y -> T y-delay z n = append (replicate n z)---{-# INLINE take #-}-take :: Int -> T a -> T a-take = crochetL (\x n -> toMaybe (n>zero) (x, pred n))--{-# INLINE takeWhile #-}-takeWhile :: (a -> Bool) -> T a -> T a-takeWhile p = crochetL (\x _ -> toMaybe (p x) (x, ())) ()--{-# INLINE replicate #-}-replicate :: Int -> a -> T a-replicate n = take n . repeat--{-# RULES-  "FusionList.map/repeat" forall f x.-     map f (repeat x) = repeat (f x) ;--  "FusionList.map/replicate" forall f n x.-     map f (replicate n x) = replicate n (f x) ;--  "FusionList.map/cons" forall f x xs.-      map f (cons x xs) = cons (f x) (map f xs) ;--  "FusionList.map/append" forall f xs ys.-      map f (append xs ys) = append (map f xs) (map f ys) ;--  {- should be subsumed by the map/cons rule,-       but it doesn't fire sometimes-  "FusionList.map/cons/compose" forall f g x xs.-      map f ((cons x . g) xs) = cons (f x) (map f (g xs)) ;-  -}--  {- this does not fire, since 'map' is inlined, crochetL/cons should fire instead -}-  "FusionList.map/scanL" forall f g x0 xs.-      map g (scanL f x0 xs) =-         cons (g x0)-            (crochetL (\x acc -> let y = f acc x in Just (g y, y)) x0 xs) ;--  "FusionList.map/zipWith" forall f g x y.-     map f (zipWith g x y) =-        zipWith (\xi yi -> f (g xi yi)) x y ;--  "FusionList.zipWith/map,*" forall f g x y.-     zipWith g (map f x) y =-        zipWith (\xi yi -> g (f xi) yi) x y ;--  "FusionList.zipWith/*,map" forall f g x y.-     zipWith g x (map f y) =-        zipWith (\xi yi -> g xi (f yi)) x y ;-  #-}--{- * functions consuming multiple lists -}--{-# NOINLINE [0] zipWith #-}-zipWith :: (a -> b -> c) -> (T a -> T b -> T c)-zipWith f s0 s1 =-   Cons $ List.zipWith f (decons s0) (decons s1)--{-# INLINE zipWith3 #-}-zipWith3 :: (a -> b -> c -> d) -> (T a -> T b -> T c -> T d)-zipWith3 f s0 s1 =-   zipWith (uncurry f) (zip s0 s1)--{-# INLINE zipWith4 #-}-zipWith4 :: (a -> b -> c -> d -> e) -> (T a -> T b -> T c -> T d -> T e)-zipWith4 f s0 s1 =-   zipWith3 (uncurry f) (zip s0 s1)---{-# INLINE zip #-}-zip :: T a -> T b -> T (a,b)-zip = zipWith (,)--{-# INLINE zip3 #-}-zip3 :: T a -> T b -> T c -> T (a,b,c)-zip3 = zipWith3 (,,)--{-# INLINE zip4 #-}-zip4 :: T a -> T b -> T c -> T d -> T (a,b,c,d)-zip4 = zipWith4 (,,,)---{- * functions based on 'reduceL' -}--reduceL :: (x -> acc -> Maybe acc) -> acc -> T x -> acc-reduceL f x = Sig.reduceL f x . decons--{-# INLINE foldL' #-}-foldL' :: (x -> acc -> acc) -> acc -> T x -> acc-foldL' f = reduceL (\x -> Just . f x)--{-# INLINE foldL #-}-foldL :: (acc -> x -> acc) -> acc -> T x -> acc-foldL f = foldL' (flip f)--{-# INLINE lengthSlow #-}-{- | can be used to check against native length implementation -}-lengthSlow :: T a -> Int-lengthSlow = foldL' (const succ) zero---{--Do we still need rules for fusion of-  map f (repeat x)-  zipWith f (repeat x) ys-?--}--{- * Fusion helpers -}--{-# INLINE zipWithGenerate #-}-zipWithGenerate ::-      (a -> b -> c)-   -> (acc -> Maybe (a, acc))-   -> acc-   -> T b -> T c-zipWithGenerate h f a y =-   crochetL (\y0 a0 ->-       do (x0,a1) <- f a0-          Just (h x0 y0, a1)) a y--{-# INLINE zipWithCrochetL #-}-zipWithCrochetL ::-      (a -> b -> c)-   -> (x -> acc -> Maybe (a, acc))-   -> acc-   -> T x -> T b -> T c-zipWithCrochetL h f a x y =-   crochetL (\(x0,y0) a0 ->-       do (z0,a1) <- f x0 a0-          Just (h z0 y0, a1))-      a (zip x y)--{-# INLINE mixGenerate #-}-mixGenerate :: (Additive.C a) =>-      (a -> a -> a)-   -> (acc -> Maybe (a, acc))-   -> acc-   -> T a -> T a-mixGenerate plus f a =-   crochetL-      (\y0 a0 ->-         Just (maybe-            (y0, Nothing)-            (\(x0,a1) -> (plus x0 y0, Just a1))-            (f =<< a0)))-      (Just a)--{-# INLINE crochetLCons #-}-crochetLCons ::-      (a -> acc -> Maybe (b, acc))-   -> acc-   -> a -> T a -> T b-crochetLCons f a0 x xs =-   maybe-      empty-      (\(y,a1) -> cons y (crochetL f a1 xs))-      (f x a0)--{--{-# INLINE crochetLAppend #-}-crochetLAppend ::-      (a -> acc -> Maybe (b, acc))-   -> acc-   -> a -> T a -> T a -> T b-crochetLAppend f a0 x xs ys =-   maybe-      empty-      (\(y,a1) -> cons y (crochetL f a1 xs))-      (f x a0)--}--{-# INLINE reduceLCons #-}-reduceLCons ::-      (a -> acc -> Maybe acc)-   -> acc-   -> a -> T a -> acc-reduceLCons f a0 x xs =-   maybe a0 (flip (reduceL f) xs) (f x a0)---{--applyThroughCons ::-   (a -> Maybe (b,acc)) -> (T a -> acc -> T b) -> T a -> T b-applyThroughCons f g =-   maybe empty-      (\(x,xs) -> cons (f x) (g xs)) . viewL--}--{-# INLINE zipWithCons #-}-zipWithCons ::-      (a -> b -> c)-   -> a -> T a -> T b -> T c-zipWithCons f x xs =-   maybe-      empty-      (\(y,ys) -> cons (f x y) (zipWith f xs ys))-    . viewL---{-# RULES-  "FusionList.crochetL/generate" forall f g a b.-     crochetL g b (generate f a) =-        generate (\(a0,b0) ->-            do (y0,a1) <- f a0-               (z0,b1) <- g y0 b0-               Just (z0, (a1,b1))) (a,b) ;--  "FusionList.crochetL/crochetL" forall f g a b x.-     crochetL g b (crochetL f a x) =-        crochetL (\x0 (a0,b0) ->-            do (y0,a1) <- f x0 a0-               (z0,b1) <- g y0 b0-               Just (z0, (a1,b1))) (a,b) x ;--  "FusionList.crochetL/cons" forall g b x xs.-     crochetL g b (cons x xs) =-        crochetLCons g b x xs ;---  "FusionList.tail/generate" forall f a.-     tail (generate f a) =-        maybe (error "FusionList.tail: empty list")-           (generate f . snd) (f a) ;--  "FusionList.tail/cons" forall x xs.-     tail (cons x xs) = xs ;--  "FusionList.zipWith/generate,*" forall f h a y.-     zipWith h (generate f a) y =-        zipWithGenerate h f a y ;--  "FusionList.zipWith/crochetL,*" forall f h a x y.-     zipWith h (crochetL f a x) y =-        zipWithCrochetL h f a x y ;--  "FusionList.zipWith/*,generate" forall f h a y.-     zipWith h y (generate f a) =-        zipWithGenerate (flip h) f a y ;--  "FusionList.zipWith/*,crochetL" forall f h a x y.-     zipWith h y (crochetL f a x) =-        zipWithCrochetL (flip h) f a x y ;--  "FusionList.mix/generate,*" forall f a y.-     mix (generate f a) y =-        mixGenerate (Additive.+) f a y ;--  "FusionList.mix/*,generate" forall f a y.-     mix y (generate f a) =-        mixGenerate (flip (Additive.+)) f a y ;---{- this blocks further fusion and-   is not necessary if the non-cons operand is a 'generate'-  "FusionList.zipWith/cons,*" forall h x xs ys.-     zipWith h (cons x xs) ys =-        zipWithCons h x xs ys ;--  "FusionList.zipWith/*,cons" forall h x xs ys.-     zipWith h ys (cons x xs) =-        zipWithCons (flip h) x xs ys ;--}--  "FusionList.zipWith/cons,cons" forall h x xs y ys.-     zipWith h (cons x xs) (cons y ys) =-        cons (h x y) (zipWith h xs ys) ;--  "FusionList.zipWith/share" forall (h :: a->a->b) (x :: T a).-     zipWith h x x = map (\xi -> h xi xi) x ;----  "FusionList.reduceL/generate" forall f g a b.-     reduceL g b (generate f a) =-        snd-          (recourse (\(a0,b0) ->-              do (y,a1) <- f a0-                 b1 <- g y b0-                 Just (a1, b1)) (a,b)) ;--  "FusionList.reduceL/crochetL" forall f g a b x.-     reduceL g b (crochetL f a x) =-        snd-          (reduceL (\x0 (a0,b0) ->-              do (y,a1) <- f x0 a0-                 b1 <- g y b0-                 Just (a1, b1)) (a,b) x) ;--  "FusionList.reduceL/cons" forall g b x xs.-     reduceL g b (cons x xs) =-        reduceLCons g b x xs ;---  "FusionList.viewL/cons" forall x xs.-     viewL (cons x xs) = Just (x,xs) ;--  "FusionList.viewL/generateInfinite" forall f x.-     viewL (generateInfinite f x) =-        Just (mapSnd (generateInfinite f) (f x)) ;--  "FusionList.viewL/generate" forall f x.-     viewL (generate f x) =-        fmap (mapSnd (generate f)) (f x) ;--  "FusionList.viewL/crochetL" forall f a xt.-     viewL (crochetL f a xt) =-        do (x,xs) <- viewL xt-           (y,a') <- f x a-           return (y, crochetL f a' xs) ;-  #-}---{- * Other functions -}--null :: T a -> Bool-null = List.null . decons--empty :: T a-empty = Cons []--singleton :: a -> T a-singleton = Cons . (: [])--{-# NOINLINE [0] cons #-}-cons :: a -> T a -> T a-cons x = Cons . (x :) . decons--length :: T a -> Int-length = List.length . decons--viewL :: T a -> Maybe (a, T a)-viewL =-   fmap (mapSnd Cons) . ListHT.viewL . decons--viewR :: T a -> Maybe (T a, a)-viewR =-   fmap (mapFst Cons) . ListHT.viewR . decons--extendConstant :: T a -> T a-extendConstant xt =-   maybe empty (append xt . repeat . snd) $-   viewR xt--{-# NOINLINE [0] tail #-}-tail :: T a -> T a-tail = Cons . List.tail . decons--head :: T a -> a-head = List.head . decons--drop :: Int -> T a -> T a-drop n = Cons . List.drop n . decons--dropMarginRem :: Int -> Int -> T a -> (Int, T a)-dropMarginRem n m = mapSnd Cons . Sig.dropMarginRem n m . decons--{--This implementation does only walk once through the dropped prefix.-It is maximally lazy and minimally space consuming.--}-dropMargin :: Int -> Int -> T a -> T a-dropMargin n m = Cons . Sig.dropMargin n m . decons---index :: Int -> T a -> a-index n = (List.!! n) . decons---splitAt :: Int -> T a -> (T a, T a)-splitAt n = mapPair (Cons, Cons) . List.splitAt n . decons--dropWhile :: (a -> Bool) -> T a -> T a-dropWhile p = Cons . List.dropWhile p . decons--span :: (a -> Bool) -> T a -> (T a, T a)-span p = mapPair (Cons, Cons) . List.span p . decons--mapAccumL :: (acc -> x -> (acc, y)) -> acc -> T x -> (acc, T y)-mapAccumL f acc = mapSnd Cons . List.mapAccumL f acc . decons--mapAccumR :: (acc -> x -> (acc, y)) -> acc -> T x -> (acc, T y)-mapAccumR f acc = mapSnd Cons . List.mapAccumR f acc . decons---cycle :: T a -> T a-cycle = Cons . List.cycle . decons--{-# NOINLINE [0] mix #-}-mix :: Additive.C a => T a -> T a -> T a-mix (Cons xs) (Cons ys)  =  Cons (xs Additive.+ ys)--{-# NOINLINE [0] sub #-}-sub :: Additive.C a => T a -> T a -> T a-sub (Cons xs) (Cons ys)  =  Cons (xs Additive.- ys)--{-# NOINLINE [0] neg #-}-neg :: Additive.C a => T a -> T a-neg (Cons xs)  =  Cons (Additive.negate xs)--instance Additive.C y => Additive.C (T y) where-   zero = empty-   (+) = mix-   (-) = sub-   negate = neg--instance Module.C y yv => Module.C y (T yv) where-   (*>) x y = map (x*>) y---infixr 5 `append`--{-# NOINLINE [0] append #-}-append :: T a -> T a -> T a-append (Cons xs) (Cons ys)  =  Cons (xs List.++ ys)--concat :: [T a] -> T a-concat  =  Cons . List.concat . List.map decons--reverse :: T a -> T a-reverse = Cons . List.reverse . decons----sum :: (Additive.C a) => T a -> a-sum = foldL' (Additive.+) Additive.zero--maximum :: (Ord a) => T a -> a-maximum =-   maybe-      (error "FusionList.maximum: empty list")-      (uncurry (foldL' max))-    . viewL--tails :: T y -> [T y]-tails = List.map Cons . List.tails . decons--init :: T y -> T y-init = Cons . List.init . decons--sliceVert :: Int -> T y -> [T y]-sliceVert n =-   List.map (take n) . List.takeWhile (not . null) . List.iterate (drop n)---zapWith :: (a -> a -> b) -> T a -> T b-zapWith f xs0 =-   let xs1 = maybe empty snd (viewL xs0)-   in  zipWith f xs0 xs1--modifyStatic :: Modifier.Simple s ctrl a b -> ctrl -> T a -> T b-modifyStatic modif control x =-   crochetL-      (\a acc ->-         Just (runState (Modifier.step modif control a) acc))-      (Modifier.init modif) x--{-| Here the control may vary over the time. -}-modifyModulated :: Modifier.Simple s ctrl a b -> T ctrl -> T a -> T b-modifyModulated modif control x =-   crochetL-      (\ca acc ->-         Just (runState (uncurry (Modifier.step modif) ca) acc))-      (Modifier.init modif)-      (zip control x)----- cf. Module.linearComb-linearComb ::-   (Module.C t y) =>-   T t -> T y -> y-linearComb ts ys =-   sum $ zipWith (*>) ts ys----- comonadic 'bind'--- only non-empty suffixes are processed-mapTails ::-   (T y0 -> y1) -> T y0 -> T y1-mapTails f =-   generate (\xs ->-      do (_,ys) <- viewL xs-         return (f xs, ys))---- only non-empty suffixes are processed-zipWithTails ::-   (y0 -> T y1 -> y2) -> T y0 -> T y1 -> T y2-zipWithTails f =-   curry $ generate (\(xs0,ys0) ->-      do (x,xs) <- viewL xs0-         (_,ys) <- viewL ys0-         return (f x ys0, (xs,ys)))--zipWithRest ::-   (y0 -> y0 -> y1) ->-   T y0 -> T y0 ->-   (T y1, (Bool, T y0))-zipWithRest f xs ys =-   mapPair (fromList, mapSnd fromList) $-   Sig.zipWithRest f-      (toList xs) (toList ys)--zipWithAppend ::-   (y -> y -> y) ->-   T y -> T y -> T y-zipWithAppend f xs ys =-   uncurry append $ mapSnd snd $ zipWithRest f xs ys--delayLoop ::-      (T y -> T y)-            -- ^ processor that shall be run in a feedback loop-   -> T y   -- ^ prefix of the output, its length determines the delay-   -> T y-delayLoop proc prefix =-   let ys = append prefix (proc ys)-   in  ys--delayLoopOverlap ::-   (Additive.C y) =>-      Int-   -> (T y -> T y)-            -- ^ processor that shall be run in a feedback loop-   -> T y   -- ^ input-   -> T y   -- ^ output has the same length as the input-delayLoopOverlap time proc xs =-   let ys = zipWith (Additive.+) xs (delay zero time (proc ys))-   in  ys----- maybe candidate for Utility--recourse :: (acc -> Maybe acc) -> acc -> acc-recourse f =-   let aux x = maybe x aux (f x)-   in  aux-
src/Synthesizer/Generic/Analysis.hs view
@@ -3,37 +3,22 @@ {-# 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-import qualified Synthesizer.Generic.Signal2 as SigG2 --- import qualified Synthesizer.Plain.Control as Ctrl---- 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-import qualified Algebra.Real                  as Real+import qualified Algebra.RealRing              as RealRing import qualified Algebra.Ring                  as Ring-import qualified Algebra.Additive              as Additive  import qualified Algebra.NormedSpace.Maximum   as NormedMax import qualified Algebra.NormedSpace.Euclidean as NormedEuc import qualified Algebra.NormedSpace.Sum       as NormedSum --- import qualified Data.Array as Array---- import qualified Data.IntMap as IntMap---- import Algebra.Module((*>))---- import Data.Array (accumArray)--import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   {- * Notions of volume -}@@ -41,27 +26,27 @@ {- | Volume based on Manhattan norm. -}-volumeMaximum :: (Real.C y, SigG.Read sig y) => sig y -> y+volumeMaximum :: (RealRing.C y, SigG.Consume 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 :: (Algebraic.C y, SigG.Consume 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 :: (Field.C y, SigG.Consume sig y) => sig y -> y volumeEuclideanSqr =-   Ana.volumeEuclideanSqr . SigG.toState+   AnaS.volumeEuclideanSqr . SigG.toState  {- | Volume based on Sum norm. -}-volumeSum :: (Field.C y, Real.C y, SigG.Read sig y) => sig y -> y+volumeSum :: (Field.C y, RealRing.C y, SigG.Consume sig y) => sig y -> y volumeSum =-   Ana.volumeSum . SigG.toState+   AnaS.volumeSum . SigG.toState   @@ -69,34 +54,34 @@ Volume based on Manhattan norm. -} volumeVectorMaximum ::-   (NormedMax.C y yv, Ord y, SigG.Read sig yv) =>+   (NormedMax.C y yv, Ord y, SigG.Consume sig yv) =>    sig yv -> y volumeVectorMaximum =-   Ana.volumeVectorMaximum . SigG.toState+   AnaS.volumeVectorMaximum . SigG.toState  {- | Volume based on Energy norm. -} volumeVectorEuclidean ::-   (Algebraic.C y, NormedEuc.C y yv, SigG.Read sig yv) =>+   (Algebraic.C y, NormedEuc.C y yv, SigG.Consume 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) =>+   (Field.C y, NormedEuc.Sqr y yv, SigG.Consume sig yv) =>    sig yv -> y volumeVectorEuclideanSqr =-   Ana.volumeVectorEuclideanSqr . SigG.toState+   AnaS.volumeVectorEuclideanSqr . SigG.toState  {- | Volume based on Sum norm. -} volumeVectorSum ::-   (NormedSum.C y yv, Field.C y, SigG.Read sig yv) =>+   (NormedSum.C y yv, Field.C y, SigG.Consume sig yv) =>    sig yv -> y volumeVectorSum =-   Ana.volumeVectorSum . SigG.toState+   AnaS.volumeVectorSum . SigG.toState   @@ -105,9 +90,9 @@ Compute minimum and maximum value of the stream the efficient way. Input list must be non-empty and finite. -}-bounds :: (Ord y, SigG.Read sig y) => sig y -> (y,y)+bounds :: (Ord y, SigG.Consume sig y) => sig y -> (y,y) bounds =-   Ana.bounds . SigG.toState+   AnaS.bounds . SigG.toState   @@ -219,7 +204,7 @@ -}  {--histogramIntMap :: (RealField.C y, SigG.Read sig y) =>+histogramIntMap :: (RealField.C y, SigG.Consume sig y) =>    y -> sig y -> (Int, sig Int) histogramIntMap binsPerUnit =    histogramDiscreteIntMap . quantize binsPerUnit@@ -232,13 +217,13 @@ attachOne = SigG.map (\i -> (i,one))  meanValues ::-   (RealField.C y, SigG.Read sig y) => sig y -> [(Int,y)]+   (RealField.C y, SigG.Consume sig y) => sig y -> [(Int,y)] meanValues x = concatMap spread (zip x (tail x))  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)+   (RealField.C y, SigG.Consume sig y) => (y,y) -> [(Int,y)]+spread lr0 =+   let (l,r) = sortPair lr0        (li,lf) = splitFraction l        (ri,rf) = splitFraction r        k = recip (r-l)@@ -257,27 +242,27 @@ This is identical to the arithmetic mean. -} directCurrentOffset ::-   (Field.C y, SigG.Read sig y) => sig y -> y+   (Field.C y, SigG.Consume sig y) => sig y -> y directCurrentOffset = average   scalarProduct ::-   (Ring.C y, SigG.Read sig y) => sig y -> sig y -> y+   (Ring.C y, SigG.Consume 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 :: (Field.C y, SigG.Consume 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 :: (Field.C y, SigG.Consume sig y) => sig y -> y average =-   Ana.average . SigG.toState+   AnaS.average . SigG.toState -rectify :: (Real.C y, SigG.Transform sig y) => sig y -> sig y+rectify :: (RealRing.C y, SigG.Transform sig y) => sig y -> sig y rectify = SigG.map abs  {- |@@ -290,37 +275,29 @@ @(x !! n >= 0) \/= (x !! (n+1) >= 0)@. The result will be one value shorter than the input. -}-zeros :: (Ord y, Ring.C y, SigG2.Transform sig y Bool) =>+zeros :: (Ord y, Ring.C y, SigG.Transform sig y, SigG.Transform sig Bool) =>    sig y -> sig Bool zeros =-   SigG.mapAdjacent (/=) . SigG2.map (>=zero)+   SigG.mapAdjacent (/=) . SigG.map (>=zero)    {- | Detect thresholds with a hysteresis. -}-flipFlopHysteresis :: (Ord y, SigG2.Transform sig y Bool) =>-   (y,y) -> Bool -> sig y -> sig Bool-flipFlopHysteresis (lower,upper) =-   SigG2.scanL-      (\state x ->-          if state-            then not(x<lower)-            else x>upper)+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, a generalization of the Fourier transform.  More sophisticated algorithms like Rader, Cooley-Tukey, Winograd, Prime-Factor may follow. -}-chirpTransform :: Ring.C y =>-   y -> sig y -> sig y-chirpTransform z xs =-   let powers = Ctrl.curveMultiscaleNeutral (*) z one-       powerPowers =-          SigG.map (\zn -> Ctrl.curveMultiscaleNeutral (*) zn one) powers-   in  SigG.map (scalarProduct xs) powerPowers--}+chirpTransform :: (SigG.Produce sig y, Ring.C y) => y -> sig y -> sig y+chirpTransform z =+   SigG.fromState .+   AnaS.chirpTransform z .+   SigG.toState
src/Synthesizer/Generic/Control.hs view
@@ -1,69 +1,73 @@ {-# 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.Generic.Signal2 as SigG2+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.RealField             as RealField import qualified Algebra.Field                 as Field-import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive -import Algebra.Module((*>))--import Number.Complex (cis,real) import qualified Number.Complex as Complex---- import Control.Applicative ((<$>), )+import Number.Complex (cis,real) -import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   {- * Control curve generation -} -constant :: (SigG.Write sig y) =>-   SigG.LazySize -> y -> sig y+constant :: (SigG.Produce sig y) => y -> sig y constant = SigG.repeat  -linear :: (Additive.C y, SigG.Write sig y) =>-      SigG.LazySize-   -> y   {-^ steepness -}+linear :: (Additive.C y, SigG.Produce sig y) =>+      y   {-^ steepness -}    -> y   {-^ initial value -}    -> sig y           {-^ linear progression -}-linear size d y0 = SigG.iterate size (d+) y0+linear d y0 = SigG.iterate (d+) y0  {- | Minimize rounding errors by reducing number of operations per element to a logarithmuc number. -} linearMultiscale ::-   (Additive.C y, SigG.Write sig y) =>-      SigG.LazySize-   -> y+   (Additive.C y, SigG.Produce sig y) =>+      y    -> y    -> sig y-linearMultiscale size =-   curveMultiscale size (+)+linearMultiscale =+   curveMultiscale (+)  {- | Linear curve starting at zero. -}-linearMultiscaleNeutral :: (Additive.C y, SigG.Write sig y) =>-      SigG.LazySize-   -> y+linearMultiscaleNeutral :: (Additive.C y, SigG.Produce sig y) =>+      y    -> sig y-linearMultiscaleNeutral size slope =-   curveMultiscaleNeutral size (+) slope zero+linearMultiscaleNeutral slope =+   curveMultiscaleNeutral (+) slope zero  {- | Linear curve of a fixed length.@@ -72,54 +76,49 @@ This way we can concatenate several lines without duplicate adjacent values. -}-line :: (Field.C y, SigG.Write sig y) =>-      SigG.LazySize-   -> Int   {-^ length -}+line :: (Field.C y, SigG.Produce sig y) =>+      Int   {-^ length -}    -> (y,y) {-^ initial and final value -}    -> sig y             {-^ linear progression -}-line size n (y0,y1) =-   SigG.take n $ linear size ((y1-y0) / fromIntegral n) y0+line n (y0,y1) =+   SigG.take n $ linear ((y1-y0) / fromIntegral n) y0   exponential, exponentialMultiscale ::-   (Trans.C y, SigG.Write sig y) =>-      SigG.LazySize-   -> y   {-^ time where the function reaches 1\/e of the initial value -}+   (Trans.C y, SigG.Produce sig y) =>+      y   {-^ time where the function reaches 1\/e of the initial value -}    -> y   {-^ initial value -}    -> sig y           {-^ exponential decay -}-exponential size time =-   SigG.iterate size (* exp (- recip time))-exponentialMultiscale size time =-   curveMultiscale size (*) (exp (- recip time))+exponential time =+   SigG.iterate (* exp (- recip time))+exponentialMultiscale time =+   curveMultiscale (*) (exp (- recip time)) -exponentialMultiscaleNeutral :: (Trans.C y, SigG.Write sig y) =>-      SigG.LazySize-   -> y   {-^ time where the function reaches 1\/e of the initial value -}+exponentialMultiscaleNeutral :: (Trans.C y, SigG.Produce sig y) =>+      y   {-^ time where the function reaches 1\/e of the initial value -}    -> sig y           {-^ exponential decay -}-exponentialMultiscaleNeutral size time =-   curveMultiscaleNeutral size (*) (exp (- recip time)) one+exponentialMultiscaleNeutral time =+   curveMultiscaleNeutral (*) (exp (- recip time)) one -exponential2, exponential2Multiscale :: (Trans.C y, SigG.Write sig y) =>-      SigG.LazySize-   -> y   {-^ half life -}+exponential2, exponential2Multiscale :: (Trans.C y, SigG.Produce sig y) =>+      y   {-^ half life -}    -> y   {-^ initial value -}    -> sig y           {-^ exponential decay -}-exponential2 size halfLife =-   SigG.iterate size (*  0.5 ** recip halfLife)-exponential2Multiscale size halfLife =-   curveMultiscale size (*) (0.5 ** recip halfLife)+exponential2 halfLife =+   SigG.iterate (*  0.5 ** recip halfLife)+exponential2Multiscale halfLife =+   curveMultiscale (*) (0.5 ** recip halfLife) -exponential2MultiscaleNeutral :: (Trans.C y, SigG.Write sig y) =>-      SigG.LazySize-   -> y   {-^ half life -}+exponential2MultiscaleNeutral :: (Trans.C y, SigG.Produce sig y) =>+      y   {-^ half life -}    -> sig y           {-^ exponential decay -}-exponential2MultiscaleNeutral size halfLife =-   curveMultiscaleNeutral size (*) (0.5 ** recip halfLife) one+exponential2MultiscaleNeutral halfLife =+   curveMultiscaleNeutral (*) (0.5 ** recip halfLife) one   @@ -128,226 +127,62 @@     which is straight-forward but requires more explicit signatures.     But since it is needed rarely I setup a separate function. -} vectorExponential ::-   (Trans.C y, Module.C y v, SigG.Write sig v) =>-      SigG.LazySize-   ->  y  {-^ time where the function reaches 1\/e of the initial value -}+   (Trans.C y, Module.C y v, SigG.Produce sig v) =>+       y  {-^ time where the function reaches 1\/e of the initial value -}    ->  v  {-^ initial value -}    -> sig v           {-^ exponential decay -}-vectorExponential size time y0 =-   SigG.iterate size (exp (-1/time) *>) y0+vectorExponential time y0 =+   SigG.iterate (exp (-1/time) *>) y0  vectorExponential2 ::-   (Trans.C y, Module.C y v, SigG.Write sig v) =>-      SigG.LazySize-   ->  y  {-^ half life -}+   (Trans.C y, Module.C y v, SigG.Produce sig v) =>+       y  {-^ half life -}    ->  v  {-^ initial value -}    -> sig v           {-^ exponential decay -}-vectorExponential2 size halfLife y0 =-   SigG.iterate size (0.5**(1/halfLife) *>) y0+vectorExponential2 halfLife y0 =+   SigG.iterate (0.5**(1/halfLife) *>) y0   -cosine, cosineMultiscaleLinear :: (Trans.C y, SigG.Write sig y) =>-      SigG.LazySize-   ->  y  {-^ time t0 where  1 is approached -}+cosine, cosineMultiscaleLinear :: (Trans.C y, SigG.Produce sig y) =>+       y  {-^ time t0 where  1 is approached -}    ->  y  {-^ time t1 where -1 is approached -}    -> sig y           {-^ a cosine wave where one half wave is between t0 and t1 -}-cosine size = cosineWithSlope $-   \d x -> SigG.map cos (linear size d x)+cosine = Ctrl.cosineWithSlope $+   \d x -> SigG.map cos (linear d x) -cosineMultiscaleLinear size = cosineWithSlope $-   \d x -> SigG.map cos (linearMultiscale size d x)+cosineMultiscaleLinear = Ctrl.cosineWithSlope $+   \d x -> SigG.map cos (linearMultiscale d x)  cosineMultiscale ::-   (Trans.C y, SigG.Write sig (Complex.T y),-    SigG2.Transform sig (Complex.T y) y) =>-      SigG.LazySize-   ->  y  {-^ time t0 where  1 is approached -}+   (Trans.C y, SigG.Produce sig (Complex.T y),+    SigG.Transform sig (Complex.T y), SigG.Transform sig y) =>+       y  {-^ time t0 where  1 is approached -}    ->  y  {-^ time t1 where -1 is approached -}    -> sig y           {-^ a cosine wave where one half wave is between t0 and t1 -}-cosineMultiscale size = cosineWithSlope $-   \d x -> SigG2.map real (curveMultiscale size (*) (cis d) (cis x))---cosineWithSlope :: (Trans.C y) =>-      (y -> y -> signal)-   ->  y-   ->  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, RealField.C y, SigG.Write sig y) =>-   SigG.LazySize -> [ControlPiece y] -> sig y-piecewise size xs =-   let ts = scanl (\(_,fr) d -> splitFraction (fr+d))-                  (0,1) (map pieceDur xs)-   in  SigG.concat (zipWith3-          (\n t (ControlPiece c yi0 yi1 d) ->-               piecewisePart size yi0 yi1 t d n c)-          (map fst (tail ts)) (map (subtract 1 . snd) ts)-          xs)+cosineMultiscale = Ctrl.cosineWithSlope $+   \d x -> SigG.map real (curveMultiscale (*) (cis d) (cis x))  -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)--}+cubicHermite :: (Field.C y, SigG.Produce sig y) =>+      (y, (y,y)) -> (y, (y,y)) -> sig y+cubicHermite node0 node1 =+   SigG.map (Ctrl.cubicFunc node0 node1) $ linear 1 0   {- * Auxiliary functions -}  -curveMultiscale :: (SigG.Write sig y) =>-   SigG.LazySize -> (y -> y -> y) -> y -> y -> sig y-curveMultiscale size op d y0 =-   SigG.cons y0 . SigG.map (op y0) $ SigG.iterateAssociative size op d+curveMultiscale :: (SigG.Produce sig y) => (y -> y -> y) -> y -> y -> sig y+curveMultiscale op d y0 =+   SigG.cons y0 . SigG.map (op y0) $ SigG.iterateAssociative op d  -curveMultiscaleNeutral :: (SigG.Write sig y) =>-   SigG.LazySize -> (y -> y -> y) -> y -> y -> sig y-curveMultiscaleNeutral size op d neutral =-   SigG.cons neutral $ SigG.iterateAssociative size op d+curveMultiscaleNeutral :: (SigG.Produce sig y) =>+   (y -> y -> y) -> y -> y -> sig y+curveMultiscaleNeutral op d neutral =+   SigG.cons neutral $ SigG.iterateAssociative op d
src/Synthesizer/Generic/Cut.hs view
@@ -9,37 +9,63 @@  import qualified Synthesizer.Plain.Signal as Sig import qualified Synthesizer.State.Signal as SigS-import qualified Synthesizer.FusionList.Signal as SigFL--- import qualified Synthesizer.Storable.Signal as SigSt-import qualified Data.StorableVector.Lazy as Vector+import qualified Data.StorableVector.Lazy.Typed as SVT+import qualified Data.StorableVector.Lazy as SVL+import qualified Data.StorableVector as SV --- import qualified Algebra.ToInteger as ToInteger--- import qualified Numeric.NonNegative.Wrapper as NonNegW-import qualified Numeric.NonNegative.Class as NonNeg-import qualified Numeric.NonNegative.Chunky as Chunky+import qualified Algebra.ToInteger as ToInteger+import qualified Algebra.Ring as Ring -import Foreign.Storable (Storable)+import qualified Data.EventList.Relative.BodyTime as EventList+import qualified Data.EventList.Relative.TimeTime as EventListTT+import qualified Data.EventList.Relative.MixedTime as EventListMT -import Data.Function (fix, )+import qualified Algebra.NonNegative as NonNeg+import qualified Number.NonNegativeChunky as Chunky++import qualified Numeric.NonNegative.Class as NonNeg98+import qualified Numeric.NonNegative.Chunky as Chunky98++import Foreign.Storable (Storable, )+import Control.DeepSeq (NFData, rnf, )++import qualified Data.List.HT as ListHT import qualified Data.List as List-import Data.Tuple.HT (mapPair, ) import qualified Data.Monoid as Monoid-import Data.Monoid (Monoid, )+import Data.Function (fix, )+import Data.Tuple.HT (mapPair, mapFst, mapSnd, )+import Data.Monoid (Monoid, mempty, )  import qualified Prelude as P-import NumericPrelude+import NumericPrelude.Numeric import Prelude-   (Bool, Int, String, (++), error,-    pred, (<=), (>=), (<),-    (.), not, (||), (&&), )+   (Bool, String, (++), error,+    pred, (==), (<=), (>=), (<),+    (.), ($), const, snd,+    not, (||), (&&), min, max, )  -class Read sig where+class Consume sig where    null :: sig -> Bool    length :: sig -> Int -class (Read sig, Monoid sig) => Transform sig where+class (Consume sig) => NormalForm sig where+   {- |+   Evaluating the first value of the signal+   is necessary for avoiding a space leaks+   if you repeatedly drop a prefix from the signal+   and do not consume something from it.+   -}+   evaluateHead :: sig -> ()++class (Consume sig, Monoid sig) => Transform sig where    {- Monoid functions+   {-+   In our categorization 'empty' would belong to the Write class,+   but since an empty signal contains no data,+   the maximum packet size is irrelevant.+   This makes e.g. the definition of mixMulti more general.+   -}    empty :: sig    cycle :: sig -> sig    append :: sig -> sig -> sig@@ -53,42 +79,110 @@    reverse :: sig -> sig  --- instance Storable y => Read SigSt.T y where-instance Storable y => Read (Vector.Vector y) where+instance Storable y => Consume (SV.Vector y) where    {-# INLINE null #-}-   null = Vector.null+   null = SV.null    {-# INLINE length #-}-   length = Vector.length+   length = SV.length -instance Storable y => Transform (Vector.Vector y) where+instance (Storable y) => NormalForm (SV.Vector y) where+   {-# INLINE evaluateHead #-}+   evaluateHead x =+      if SV.null x then () else ()++instance Storable y => Transform (SV.Vector y) where+   {-# INLINE take #-}+   take = SV.take+   {-# INLINE drop #-}+   drop = SV.drop+   {-# INLINE splitAt #-}+   splitAt = SV.splitAt+   {-# INLINE dropMarginRem #-}+   dropMarginRem n m xs =+      let d = min m $ max 0 $ SV.length xs - n+      in  (m-d, SV.drop d xs)+   {-# INLINE reverse #-}+   reverse = SV.reverse+++instance Storable y => Consume (SVL.Vector y) where+   {-# INLINE null #-}+   null = SVL.null+   {-# INLINE length #-}+   length = SVL.length++instance (Storable y) => NormalForm (SVL.Vector y) where+   {-# INLINE evaluateHead #-}+   evaluateHead =+      ListHT.switchL () (\x _ -> evaluateHead x) . SVL.chunks+--      ListHT.switchL () (\x _ -> rnf x) . SVL.chunks+--   evaluateHead x =+--      if SVL.null x then () else ()++{-+instance (Storable y, NFData y) => NormalForm (SVL.Vector y) where+   {-# INLINE evaluateHead #-}+   evaluateHead x = SVL.switchL () (\x _ -> rnf x)+-}++-- instance Storable y => Consume SigSt.T y where+instance Storable y => Transform (SVL.Vector y) where    {-    {-# INLINE empty #-}-   empty = Vector.empty+   empty = SVL.empty    {-# INLINE cycle #-}-   cycle = Vector.cycle+   cycle = SVL.cycle    {-# INLINE append #-}-   append = Vector.append+   append = SVL.append    {-# INLINE concat #-}-   concat = Vector.concat+   concat = SVL.concat    -}    {-# INLINE take #-}-   take = Vector.take+   take = SVL.take    {-# INLINE drop #-}-   drop = Vector.drop+   drop = SVL.drop    {-# INLINE splitAt #-}-   splitAt = Vector.splitAt+   splitAt = SVL.splitAt    {-# INLINE dropMarginRem #-}-   dropMarginRem = Vector.dropMarginRem+   dropMarginRem = SVL.dropMarginRem    {-# INLINE reverse #-}-   reverse = Vector.reverse+   reverse = SVL.reverse  -instance Read ([] y) where+instance (SVT.Size size, Storable y) => Consume (SVT.Vector size y) where    {-# INLINE null #-}+   null = SVT.null+   {-# INLINE length #-}+   length = SVT.length++instance (SVT.Size size, Storable y) => NormalForm (SVT.Vector size y) where+   {-# INLINE evaluateHead #-}+   evaluateHead =+      ListHT.switchL () (\x _ -> evaluateHead x) . SVT.chunks++instance (SVT.Size size, Storable y) => Transform (SVT.Vector size y) where+   {-# INLINE take #-}+   take = SVT.take+   {-# INLINE drop #-}+   drop = SVT.drop+   {-# INLINE splitAt #-}+   splitAt = SVT.splitAt+   {-# INLINE dropMarginRem #-}+   dropMarginRem = SVT.dropMarginRem+   {-# INLINE reverse #-}+   reverse = SVT.reverse+++instance Consume ([] y) where+   {-# INLINE null #-}    null = List.null    {-# INLINE length #-}    length = List.length +instance (NFData y) => NormalForm ([] y) where+   {-# INLINE evaluateHead #-}+   evaluateHead = ListHT.switchL () (\x _ -> rnf x)+ instance Transform ([] y) where    {-    {-# INLINE empty #-}@@ -112,41 +206,22 @@    reverse = List.reverse  -instance Read (SigFL.T y) where+instance Consume (SigS.T y) where    {-# INLINE null #-}-   null = SigFL.null+   null = SigS.null    {-# INLINE length #-}-   length = SigFL.length+   length = SigS.length -instance Transform (SigFL.T y) where+instance (NFData y) => NormalForm (SigS.T y) where    {--   {-# INLINE empty #-}-   empty = SigFL.empty-   {-# INLINE cycle #-}-   cycle = SigFL.cycle-   {-# INLINE append #-}-   append = SigFL.append-   {-# INLINE concat #-}-   concat = SigFL.concat+   Evaluating the first element of a generator might look silly,+   since it is not stored in a data structure.+   However, the generator depends on an internal state,+   which might be in turn a list or a storable vector,+   which is evaluated then.    -}--   {-# INLINE take #-}-   take = SigFL.take-   {-# INLINE drop #-}-   drop = SigFL.drop-   {-# INLINE dropMarginRem #-}-   dropMarginRem = SigFL.dropMarginRem-   {-# INLINE splitAt #-}-   splitAt = SigFL.splitAt-   {-# INLINE reverse #-}-   reverse = SigFL.reverse---instance Read (SigS.T y) where-   {-# INLINE null #-}-   null = SigS.null-   {-# INLINE length #-}-   length = SigS.length+   {-# INLINE evaluateHead #-}+   evaluateHead = SigS.switchL () (\x _ -> rnf x)  instance Transform (SigS.T y) where    {-@@ -175,45 +250,189 @@    reverse = SigS.reverse  +{- |+We abuse event lists for efficient representation of piecewise constant signals.+-}+instance (P.Integral t) => Consume (EventList.T t y) where+   null = EventList.null+   length = fromIntegral . P.toInteger . P.sum . EventList.getTimes++instance (P.Integral t, NFData y) => NormalForm (EventList.T t y) where+   evaluateHead = EventList.switchL () (\x _ _ -> rnf x)++ {-+needed for chunks of MIDI events as input to CausalIO processes+-}+instance (P.Integral t) => Consume (EventListTT.T t y) where+   null = EventListMT.switchTimeL (\t xs -> t==0 && EventList.null xs)+   length = fromIntegral . P.toInteger . P.sum . EventListTT.getTimes++instance (P.Integral t, NonNeg98.C t) => Transform (EventListTT.T t y) where+   take = EventListTT.takeTime . P.fromIntegral+   drop = EventListTT.dropTime . P.fromIntegral+   dropMarginRem =+      dropMarginRemChunky (P.map P.fromIntegral . EventListTT.getTimes)+   splitAt = EventListTT.splitAtTime . P.fromIntegral+   reverse = EventListTT.reverse+++-- cf. StorableVector.Lazy.dropMarginRem+dropMarginRemChunky ::+   (Transform sig) =>+   (sig -> [Int]) -> Int -> Int -> sig -> (Int, sig)+dropMarginRemChunky getTimes n m xs =+   List.foldl'+      (\(mi,xsi) k -> (mi-k, drop k xsi))+      (m, xs)+      (getTimes $ take m $ drop n xs)++{- |+The function defined here are based on the interpretation+of event lists as piecewise constant signals.+They do not fit to the interpretation of atomic events.+Because e.g. it makes no sense to split an atomic event into two instances by splitAt,+and it is also not clear, whether dropping the first chunk+shall leave a chunk of length zero+or remove that chunk completely.++However, sometimes we also need lists of events.+In this case the 'reverse' method would be different.+For an event-oriented instance of EventList.TimeTime+see NoteOffList in synthesizer-alsa package.+-}+instance (P.Integral t, NonNeg98.C t) => Transform (EventList.T t y) where+   take n xs =+      EventList.foldrPair+         (\b t go remain ->+            if remain <= NonNeg98.zero+              then EventList.empty+              else+                let (m, ~(le,d)) = NonNeg98.split t remain+                in  EventList.cons b m $+                    go (if le then d else NonNeg98.zero))+         (const EventList.empty) xs+         (P.fromIntegral n)++   drop =+      let recourse n =+             EventList.switchL EventList.empty $ \b t xs ->+             let (le,d) = snd $ NonNeg98.split t n+             in  if le+                   then recourse d xs+                   else EventList.cons b d xs+      in  recourse . P.fromIntegral++   dropMarginRem =+      dropMarginRemChunky (P.map P.fromIntegral . EventList.getTimes)++   -- cf. StorableVector.Lazy.splitAt+   splitAt =+      let recourse 0 = (,) EventList.empty+          recourse n =+             EventList.switchL (EventList.empty, EventList.empty) $ \b t xs ->+             let (m, ~(le,d)) = NonNeg98.split t n+             in  mapFst (EventList.cons b m) $+                 if le+                   then recourse d xs+                   else (EventList.empty, EventList.cons b d xs)+      in  recourse . P.fromIntegral++   reverse =+      EventList.fromPairList . List.reverse . EventList.toPairList+++{- useful for application of non-negative chunky numbers as gate signals -}-instance (P.Integral a) => Read (Chunky.T a) where+instance (ToInteger.C a, NonNeg.C a) => Consume (Chunky.T a) where    {-# INLINE null #-}    null = List.null . Chunky.toChunks    {-# INLINE length #-}-   length = sum . List.map (P.fromIntegral . P.toInteger) . Chunky.toChunks+   length = sum . List.map (fromIntegral . toInteger) . Chunky.toChunks +instance (ToInteger.C a, NonNeg.C a, NFData a) => NormalForm (Chunky.T a) where+   {-# INLINE evaluateHead #-}+   evaluateHead = ListHT.switchL () (\x _ -> rnf x) . Chunky.toChunks -intToChunky :: (NonNeg.C a) => String -> Int -> Chunky.T a++intToChunky :: (Ring.C a, NonNeg.C a) => String -> Int -> Chunky.T a intToChunky name =    Chunky.fromNumber .+-- the non-negative type is not necessarily a wrapper --   NonNegW.fromNumberMsg ("Generic.Cut."++name) .-   P.fromIntegral .+   fromIntegral .    (\x ->-      if x<0+      if x<zero         then error ("Generic.Cut.NonNeg.Chunky."++name++": negative argument")         else x) -instance (P.Integral a, NonNeg.C a) => Transform (Chunky.T a) where++instance (ToInteger.C a, NonNeg.C a) => Transform (Chunky.T a) where    {-# INLINE take #-}    take n = P.min (intToChunky "take" n)    {-# INLINE drop #-}    drop n x = x NonNeg.-| intToChunky "drop" n    {-# INLINE dropMarginRem #-}    dropMarginRem n m x =-      let (z,d,b) =+      let (z,~(b,d)) =              Chunky.minMaxDiff-                (intToChunky "dropMargin/n" n)-                (x NonNeg.-| intToChunky "dropMargin/m" m)-      in  (if b then 0 else P.fromIntegral (Chunky.toNumber d),+                (intToChunky "dropMargin/n" m)+                (x NonNeg.-| intToChunky "dropMargin/m" n)+      in  (if b then 0 else fromIntegral (Chunky.toNumber d),            x NonNeg.-| z)    {-# INLINE splitAt #-}    splitAt n x =-      let (z,d,b) = Chunky.minMaxDiff (intToChunky "splitAt" n) x-      in  (z, if b then d else Chunky.zero)+      mapSnd+         (\ ~(b,d) -> if b then d else mempty)+         (Chunky.minMaxDiff (intToChunky "splitAt" n) x)    {-# INLINE reverse #-}-   reverse = Chunky.fromChunks . P.reverse . Chunky.toChunks+   reverse = Chunky.fromChunks . List.reverse . Chunky.toChunks++++instance (P.Integral a) => Consume (Chunky98.T a) where+   {-# INLINE null #-}+   null = List.null . Chunky98.toChunks+   {-# INLINE length #-}+   length = sum . List.map (P.fromIntegral . P.toInteger) . Chunky98.toChunks++instance (P.Integral a, NonNeg.C a, NFData a) =>+      NormalForm (Chunky98.T a) where+   {-# INLINE evaluateHead #-}+   evaluateHead = ListHT.switchL () (\x _ -> rnf x) . Chunky98.toChunks+++intToChunky98 :: (P.Num a, NonNeg98.C a) => String -> Int -> Chunky98.T a+intToChunky98 name =+   Chunky98.fromNumber .+--   NonNegW.fromNumberMsg ("Generic.Cut."++name) .+   P.fromIntegral .+   (\x ->+      if x<0+        then error ("Generic.Cut.NonNeg.Chunky98."++name++": negative argument")+        else x)++instance (P.Integral a, NonNeg98.C a) => Transform (Chunky98.T a) where+   {-# INLINE take #-}+   take n = P.min (intToChunky98 "take" n)+   {-# INLINE drop #-}+   drop n x = x NonNeg98.-| intToChunky98 "drop" n+   {-# INLINE dropMarginRem #-}+   dropMarginRem n m x =+      let (z,~(b,d)) =+             NonNeg98.split+                (intToChunky98 "dropMargin/n" m)+                (x NonNeg98.-| intToChunky98 "dropMargin/m" n)+      in  (if b then 0 else P.fromIntegral (Chunky98.toNumber d),+           x NonNeg98.-| z)+   {-# INLINE splitAt #-}+   splitAt n x =+      mapSnd+         (\ ~(b,d) -> if b then d else Chunky98.zero)+         (NonNeg98.split (intToChunky98 "splitAt" n) x)+   {-# INLINE reverse #-}+   reverse = Chunky98.fromChunks . List.reverse . Chunky98.toChunks   {-# INLINE empty #-}
+ src/Synthesizer/Generic/CutChunky.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+module Synthesizer.Generic.CutChunky where++import qualified Synthesizer.Generic.Cut as Cut++import qualified Data.StorableVector.Lazy as SVL+import qualified Data.StorableVector as SV+import Foreign.Storable (Storable)++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+   type Chunk chunky :: *+   fromChunks :: [Chunk chunky] -> chunky+   toChunks :: chunky -> [Chunk chunky]++instance Storable a => C (SVL.Vector a) where+   type Chunk (SVL.Vector a) = SV.Vector a+   fromChunks = SVL.fromChunks+   toChunks = SVL.chunks++instance (ToInteger.C a, NonNeg.C a, Cut.Transform a) => C (Chunky.T a) where+   type Chunk (Chunky.T a) = a+   fromChunks = Chunky.fromChunks+   toChunks = Chunky.toChunks
+ src/Synthesizer/Generic/Cyclic.hs view
@@ -0,0 +1,190 @@+module Synthesizer.Generic.Cyclic where++import qualified Synthesizer.Generic.Filter.NonRecursive as FiltNRG+import qualified Synthesizer.Generic.Analysis as AnaG+import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.Generic.Cut as CutG+import qualified Synthesizer.State.Signal as Sig++import qualified Algebra.Ring as Ring+import qualified Algebra.Additive as Additive++import NumericPrelude.Numeric+import NumericPrelude.Base+import Prelude ()+++fromSignal ::+   (SigG.Produce sig yv, Additive.C yv) =>+   Int -> sig yv -> sig yv+fromSignal n =+   {- almost Sig.sum -}+   Sig.foldL SigG.mix (SigG.replicate n zero) . CutG.sliceVertical n++reverse ::+   (SigG.Transform sig y) =>+   sig y -> sig y+reverse sig =+   SigG.switchL sig+      (\y ys -> SigG.cons y (SigG.reverse ys)) sig+++{- |+It must hold @n <= CutG.length x@.+-}+reperiodize ::+   (SigG.Transform sig yv, Additive.C yv) =>+   Int -> sig yv -> sig yv+reperiodize n =+   {- Sig.sum -}+   Sig.foldL SigG.mix CutG.empty .+   CutG.sliceVertical n++{- |+length of the input signals must be equal+-}+convolve ::+   (SigG.Transform sig y, Ring.C y) =>+   sig y -> sig y -> sig y+convolve x y =+   reperiodize (CutG.length x) $+   FiltNRG.karatsubaFinite (*) x y++++{- |+The size of both input signals must be equal.++Could be optimized by computing only first (length x) elements.+-}+filterNaive ::+   (SigG.Transform sig y, Ring.C y) =>+   sig y -> sig y -> sig y+filterNaive x y =+   SigG.takeStateMatch y $+   SigG.toState $+   SigG.mapTails+      (AnaG.scalarProduct x)+      (SigG.append y y)++convolveNaive ::+   (SigG.Transform sig y, Ring.C y) =>+   sig y -> sig y -> sig y+convolveNaive x y =+   SigG.takeStateMatch y $+   SigG.toState $+   SigG.mapTails+      (AnaG.scalarProduct (SigG.reverse x))+      (SigG.laxTail $ SigG.append y y)+++{-+Some small size convolutions using the Karatsuba trick.+We do not use Toom-3 multiplication,+because this requires division by 2 and 6.++In principle we could implement them+by calling the corresponding functions in Filter.NonRecursive+and periodize them afterwards.+However the custom implementations below+allow a litte bit more optimization,+namely sharing of some sums.+-}++type Pair y = (y,y)++{-# INLINE convolvePair #-}+convolvePair ::+   (Ring.C y) =>+   Pair y -> Pair y -> Pair y+convolvePair a b =+   snd $ sumAndConvolvePair a b++{-# INLINE sumAndConvolvePair #-}+sumAndConvolvePair ::+   (Ring.C y) =>+   Pair y -> Pair y -> ((y,y), Pair y)+sumAndConvolvePair (a0,a1) (b0,b1) =+   let sa01 = a0+a1+       sb01 = b0+b1+       ab0ab1 = a0*b0+a1*b1+   in  ((sa01, sb01), (ab0ab1, sa01*sb01-ab0ab1))+++type Triple y = (y,y,y)++{-# INLINE convolveTriple #-}+convolveTriple ::+   (Ring.C y) =>+   Triple y -> Triple y -> Triple y+convolveTriple a b =+   snd $ sumAndConvolveTriple a b++{-# INLINE sumAndConvolveTriple #-}+sumAndConvolveTriple ::+   (Ring.C y) =>+   Triple y -> Triple y -> ((y,y), Triple y)+sumAndConvolveTriple (a0,a1,a2) (b0,b1,b2) =+   let ab0 = a0*b0+       dab12 = a1*b1 - a2*b2+       sa01 = a0+a1; sb01 = b0+b1; tab01 = sa01*sb01 - ab0+       sa02 = a0+a2; sb02 = b0+b2; tab02 = sa02*sb02 - ab0+       sa012 = sa01+a2+       sb012 = sb01+b2++       d0 = sa012*sb012 - tab01 - tab02+       d1 = tab01 - dab12+       d2 = tab02 + dab12+   in  ((sa012, sb012), (d0, d1, d2))++{-# INLINE sumAndConvolveTripleAlt #-}+sumAndConvolveTripleAlt ::+   (Ring.C y) =>+   Triple y -> Triple y -> ((y,y), Triple y)+sumAndConvolveTripleAlt (a0,a1,a2) (b0,b1,b2) =+   let ab0 = a0*b0+       ab1 = a1*b1+       ab2 = a2*b2+       sa01 = a0+a1; sb01 = b0+b1+       ab01 = sa01*sb01 - (ab0+ab1)+       sa02 = a0+a2; sb02 = b0+b2+       ab02 = sa02*sb02 - (ab0+ab2)+       sa12 = a1+a2; sb12 = b1+b2+       ab12 = sa12*sb12 - (ab1+ab2)+   in  ((sa01+a2, sb01+b2), (ab0+ab12, ab2+ab01, ab1+ab02))+++type Quadruple y = (y,y,y,y)++{-# INLINE convolveQuadruple #-}+convolveQuadruple ::+   (Ring.C y) =>+   Quadruple y -> Quadruple y -> Quadruple y+convolveQuadruple a b =+   snd $ sumAndConvolveQuadruple a b++{-# INLINE sumAndConvolveQuadruple #-}+sumAndConvolveQuadruple ::+   (Ring.C y) =>+   Quadruple y -> Quadruple y -> ((y,y), Quadruple y)+sumAndConvolveQuadruple (a0,a1,a2,a3) (b0,b1,b2,b3) =+   let ab0 = a0*b0+       ab1 = a1*b1+       sa01 = a0+a1; sb01 = b0+b1+       ab01 = sa01*sb01 - (ab0+ab1)+       ab2 = a2*b2+       ab3 = a3*b3+       sa23 = a2+a3; sb23 = b2+b3+       ab23 = sa23*sb23 - (ab2+ab3)+       c0 = ab0  + ab2 - (ab1 + ab3)+       c1 = ab01 + ab23+       ab02 = (a0+a2)*(b0+b2)+       ab13 = (a1+a3)*(b1+b3)+       sa0123 = sa01+sa23+       sb0123 = sb01+sb23+       ab0123 = sa0123*sb0123 - (ab02+ab13)+       d0 = ab13   + c0+       d1 =          c1+       d2 = ab02   - c0+       d3 = ab0123 - c1+   in  ((sa0123, sb0123), (d0, d1, d2, d3))
src/Synthesizer/Generic/Displacement.hs view
@@ -4,17 +4,18 @@ -} module Synthesizer.Generic.Displacement where -import qualified Algebra.Additive              as Additive- import qualified Synthesizer.Generic.Signal as SigG --- import qualified Prelude as P-import PreludeBase-import NumericPrelude+import qualified Algebra.Transcendental        as Trans+import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive +import NumericPrelude.Numeric+import NumericPrelude.Base -{- * Mixing -} +-- * Mixing+ {-| Mix two signals.     In opposition to 'zipWith' the result has the length of the longer signal. -} mix :: (Additive.C v, SigG.Transform sig v) =>@@ -41,11 +42,36 @@ raise x = SigG.map ((+) x)  -{- * Distortion -}+-- * Distortion+ {- | In "Synthesizer.Basic.Distortion" you find a collection of appropriate distortion functions. -}-distort :: (SigG.Read sig c, SigG.Transform sig v) =>+distort :: (SigG.Consume sig c, SigG.Transform sig v) =>    (c -> v -> v) -> sig c -> sig v -> sig v distort = SigG.zipWith+++-- * Preprocessing of control curves++{-# INLINE mapLinear #-}+mapLinear :: (Ring.C a, SigG.Transform sig a) =>+   a ->+   a ->+   sig a ->+   sig a+mapLinear depth center =+   SigG.map (\x -> center*(one+x*depth))++{-# INLINE mapExponential #-}+mapExponential :: (Trans.C a, SigG.Transform sig a) =>+   a ->+   a ->+   sig a ->+   sig a+mapExponential depth center =+   -- SigG.map ((center*) . (depth**))+   -- should be faster+   let logDepth = log depth+   in  SigG.map ((center*) . exp . (logDepth*))
src/Synthesizer/Generic/Filter/Delay.hs view
@@ -1,17 +1,20 @@ {-# 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-import qualified Synthesizer.Generic.Signal2 as SigG2 import qualified Synthesizer.Generic.Signal  as SigG  import qualified Algebra.RealField as RealField import qualified Algebra.Additive  as Additive --- import qualified Prelude as P--- import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric   @@ -19,25 +22,25 @@  {-# INLINE static #-} static ::-   (Additive.C y, SigG.Write sig y) =>+   (Additive.C y, SigG.Produce sig y) =>    Int -> sig y -> sig y static = FiltNR.delay  {-# INLINE staticPad #-} staticPad ::-   (SigG.Write sig y) =>+   (SigG.Produce sig y) =>    y -> Int -> sig y -> sig y staticPad = FiltNR.delayPad  {-# INLINE staticPos #-} staticPos ::-   (Additive.C y, SigG.Write sig y) =>+   (Additive.C y, SigG.Produce sig y) =>    Int -> sig y -> sig y staticPos = FiltNR.delayPos  {-# INLINE staticNeg #-} staticNeg ::-   (SigG.Write sig y) =>+   (SigG.Produce sig y) =>    Int -> sig y -> sig y staticNeg = FiltNR.delayNeg @@ -46,11 +49,11 @@  {-# INLINE modulatedCore #-} modulatedCore ::-   (RealField.C t, Additive.C y, SigG.Read sig t, SigG2.Transform sig t y) =>+   (RealField.C t, Additive.C y, SigG.Consume sig t, SigG.Transform sig t, SigG.Transform sig y) =>    Interpolation.T t y -> Int ->    sig t -> sig y -> sig y modulatedCore ip size =-   SigG2.zipWithTails+   SigG.zipWithTails       (\t -> Interpolation.single ip (fromIntegral size + t))  @@ -64,7 +67,7 @@ {-# INLINE modulated #-} modulated ::    (RealField.C t, Additive.C y,-    SigG.Read sig t, SigG2.Transform sig t y, SigG.Write sig y) =>+    SigG.Consume sig t, SigG.Transform sig t, SigG.Transform sig y, SigG.Produce sig y) =>    Interpolation.T t y -> Int ->    sig t -> sig y -> sig y modulated ip minDev ts xs =
src/Synthesizer/Generic/Filter/NonRecursive.hs view
@@ -1,22 +1,90 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleContexts #-} {- |-Copyright   :  (c) Henning Thielemann 2008-2009+Copyright   :  (c) Henning Thielemann 2008-2011 License     :  GPL  Maintainer  :  synthesizer@henning-thielemann.de 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,+   binomialMask,+   binomial,+   binomial1,+   sums,+   sumsDownsample2,+   downsample2,+   downsample,+   sumRange,+   pyramid,+   sumRangeFromPyramid,+   sumsPosModulated,+   sumsPosModulatedPyramid,+   movingAverageModulatedPyramid,+   inverseFrequencyModulationFloor, -import qualified Synthesizer.Generic.Signal as SigG-import qualified Synthesizer.Generic.Signal2 as SigG2+   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,++   -- 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.Basic.Filter.NonRecursive as Filt+import qualified Synthesizer.State.Filter.NonRecursive as FiltS import qualified Synthesizer.State.Signal as SigS-import qualified Synthesizer.Plain.Filter.NonRecursive as Filt +import Control.Monad (mplus, )++import qualified Data.List.Match as Match+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@@ -24,16 +92,12 @@ import qualified Algebra.Ring           as Ring import qualified Algebra.Additive       as Additive -import Algebra.Module( {- linearComb, -} (*>), )--import Data.Function.HT (nest, )-import Data.Tuple.HT (mapSnd, mapPair, )--import PreludeBase-import NumericPrelude as NP+import qualified NumericPrelude.Numeric as NP+import NumericPrelude.Numeric hiding (negate, )+import NumericPrelude.Base  -{- * Envelope application -}+-- * Envelope application  {-# INLINE negate #-} negate ::@@ -53,6 +117,13 @@    a -> sig v -> sig v amplifyVector v = SigG.map (v*>) +{-# INLINE normalize #-}+normalize ::+   (Field.C a, SigG.Transform sig a) =>+   (sig a -> a) -> sig a -> sig a+normalize volume xs =+   amplify (recip $ volume xs) xs+ {-# INLINE envelope #-} envelope ::    (Ring.C a, SigG.Transform sig a) =>@@ -63,7 +134,7 @@  {-# INLINE envelopeVector #-} envelopeVector ::-   (Module.C a v, SigG.Read sig a, SigG.Transform sig v) =>+   (Module.C a v, SigG.Consume sig a, SigG.Transform sig v) =>       sig a  {-^ the envelope -}    -> sig v  {-^ the signal to be enveloped -}    -> sig v@@ -73,7 +144,7 @@  {-# INLINE fadeInOut #-} fadeInOut ::-   (Field.C a, SigG.Write sig a) =>+   (Field.C a, SigG.Produce sig a) =>    Int -> Int -> Int -> sig a -> sig a fadeInOut tIn tHold tOut xs =    let slopeIn  =                  recip (fromIntegral tIn)@@ -85,10 +156,10 @@        But I assume that concatenating chunks of an envelope        is more efficient than concatenating generator loops.        However, our intermediate envelope is still observable,-       because we have to use SigG.Write class.+       because we have to use SigG.Produce class.        -}-       leadIn  = SigG.take tIn  $ Ctrl.linear SigG.defaultLazySize slopeIn  0-       leadOut = SigG.take tOut $ Ctrl.linear SigG.defaultLazySize slopeOut 1+       leadIn  = SigG.take tIn  $ Ctrl.linear slopeIn  0+       leadOut = SigG.take tOut $ Ctrl.linear slopeOut 1        (partIn, partHoldOut) = SigG.splitAt tIn xs        (partHold, partOut)   = SigG.splitAt tHold partHoldOut    in  envelope leadIn partIn `SigG.append`@@ -96,27 +167,27 @@        envelope leadOut partOut  -{- * Smoothing -}+-- * Delay  {-# INLINE delay #-}-delay :: (Additive.C y, SigG.Write sig y) =>+delay :: (Additive.C y, SigG.Produce sig y) =>    Int -> sig y -> sig y delay =    delayPad zero  {-# INLINE delayPad #-}-delayPad :: (SigG.Write sig y) =>+delayPad :: (SigG.Produce sig y) =>    y -> Int -> sig y -> sig y delayPad z n =    if n<0      then SigG.drop (Additive.negate n)-     else SigG.append (SigG.replicate SigG.defaultLazySize n z)+     else SigG.append (SigG.replicate n z)  {-# INLINE delayPos #-}-delayPos :: (Additive.C y, SigG.Write sig y) =>+delayPos :: (Additive.C y, SigG.Produce sig y) =>    Int -> sig y -> sig y delayPos n =-   SigG.append (SigG.replicate SigG.defaultLazySize n zero)+   SigG.append (SigG.replicate n zero)  {-# INLINE delayNeg #-} delayNeg :: (SigG.Transform sig y) =>@@ -125,41 +196,19 @@   -{-# INLINE delayLazySize #-}-delayLazySize :: (Additive.C y, SigG.Write sig y) =>-   SigG.LazySize -> Int -> sig y -> sig y-delayLazySize size =-   delayPadLazySize size zero--{- |-The pad value @y@ must be defined,-otherwise the chunk size of the padding can be observed.--}-{-# INLINE delayPadLazySize #-}-delayPadLazySize :: (SigG.Write sig y) =>-   SigG.LazySize -> y -> Int -> sig y -> sig y-delayPadLazySize size z n =-   if n<0-     then SigG.drop (Additive.negate n)-     else SigG.append (SigG.replicate size n z)--{-# INLINE delayPosLazySize #-}-delayPosLazySize :: (Additive.C y, SigG.Write sig y) =>-   SigG.LazySize -> Int -> sig y -> sig y-delayPosLazySize size n =-   SigG.append (SigG.replicate size n zero)-+-- * smoothing +binomialMask :: (Field.C a, SigG.Produce sig a) => Int -> sig a+binomialMask n =+   SigG.unfoldR+      (\(x, a, b) ->+          toMaybe (b>=0)+             (x, (x * fromInteger b / fromInteger (a+1), a+1, b-1)))+      (recip $ 2 ^ fromIntegral n, 0, fromIntegral n) -{-| Unmodulated non-recursive filter -}-{-# INLINE generic #-}-generic ::-   (Module.C a v, SigG.Transform sig a, SigG.Write sig v) =>-   sig a -> sig v -> sig v-generic m x =-   let mr = SigG.reverse m-       xp = delayPos (pred (SigG.length m)) x-   in  SigG.mapTails (SigG.linearComb mr) xp+{-+property: must sum up to 1+-}  {- {- |@@ -171,7 +220,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@@ -196,34 +245,10 @@    (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 ::    (Additive.C v, SigG.Transform sig v) => sig v -> sig v@@ -245,23 +270,29 @@   sumsDownsample2 ::-   (Additive.C v, SigG.Write sig v) =>-   SigG.LazySize -> sig v -> sig v-sumsDownsample2 cs =-   SigG.unfoldR cs (\xs ->+   (Additive.C v, SigG.Produce sig v) =>+   sig v -> sig v+sumsDownsample2 =+   SigG.unfoldR (\xs ->       flip fmap (SigG.viewL xs) $ \xxs0@(x0,xs0) ->          SigG.switchL xxs0 {- xs0 is empty -}             (\ x1 xs1 -> (x0+x1, xs1))             xs0)  downsample2 ::-   (SigG.Write sig v) =>-   SigG.LazySize -> sig v -> sig v-downsample2 cs =-   SigG.unfoldR cs-      (fmap (mapSnd SigG.laxTail) . SigG.viewL)+   (SigG.Produce sig v) =>+   sig v -> sig v+downsample2 =+   SigG.unfoldR (fmap (mapSnd SigG.laxTail) . SigG.viewL) +downsample ::+   (SigG.Produce sig v) =>+   Int -> sig v -> sig v+downsample n =+   SigG.unfoldR+      (\xs -> fmap (mapSnd (const (SigG.drop n xs))) $ SigG.viewL xs) + {- {- | Given a list of numbers@@ -327,19 +358,34 @@    SigG.sum . SigG.take (r-l) . SigG.drop l  pyramid ::-   (Additive.C v, SigG.Write sig v) =>+   (Additive.C v, SigG.Produce sig v) =>    Int -> sig v -> ([Int], [sig v]) pyramid height sig =-   let sizes =-          reverse $ take (1+height) $ iterate (2*) 1-   in  (sizes,-        scanl (flip sumsDownsample2) sig (map SigG.LazySize $ tail sizes))+   let sizes = reverse $ take (1+height) $ iterate (2*) 1+   in  (sizes, Match.take sizes $ iterate sumsDownsample2 sig) +{-# INLINE sumRangeFromPyramid #-} sumRangeFromPyramid ::-   (Additive.C v, SigG.Write sig v) =>+   (Additive.C v, SigG.Transform sig v) =>    [sig v] -> (Int,Int) -> v sumRangeFromPyramid =-   Filt.sumRangePrepare $ \(l0,r0) pyr0 ->+   Filt.sumRangePrepare $ \lr0 pyr0 ->+   consumeRangeFromPyramid (\v k s -> k (s+v)) id pyr0 lr0 zero++-- add from right to left, which is inefficient+sumRangeFromPyramidReverse ::+   (Additive.C v, SigG.Transform sig v) =>+   [sig v] -> (Int,Int) -> v+sumRangeFromPyramidReverse =+   Filt.sumRangePrepare $ \lr0 pyr0 ->+   consumeRangeFromPyramid (+) zero pyr0 lr0++-- for speed benchmarks+sumRangeFromPyramidFoldr ::+   (Additive.C v, SigG.Transform sig v) =>+   [sig v] -> (Int,Int) -> v+sumRangeFromPyramidFoldr =+   Filt.sumRangePrepare $ \lr0 pyr0 ->    case pyr0 of       [] -> error "empty pyramid"       (ps0:pss) ->@@ -359,13 +405,61 @@                          s)             (\(l,r) ps s ->                s + (SigG.sum $ SigG.take (r-l) $ SigG.drop l ps))-            pss (l0,r0) ps0 zero+            pss lr0 ps0 zero +{-# INLINE maybeAccumulateRangeFromPyramid #-}+maybeAccumulateRangeFromPyramid ::+   (SigG.Transform sig v) =>+   (v -> v -> v) ->+   [sig v] -> (Int,Int) -> Maybe v+maybeAccumulateRangeFromPyramid acc =+   Filt.symmetricRangePrepare $ \lr0 pyr0 ->+   consumeRangeFromPyramid+      (\v k s -> k (fmap (acc v) s `mplus` Just v))+      id pyr0 lr0 Nothing++{-+This would also be a useful signature,+but that's not easy to implement+and I don't know whether it can be computed efficiently.++getRangeFromPyramid ::+   (Additive.C v, SigG.Transform sig v) =>+   [sig v] -> (Int,Int) -> SigS.T v+-}++{-# INLINE consumeRangeFromPyramid #-}+consumeRangeFromPyramid ::+   (SigG.Transform sig v) =>+   (v -> a -> a) -> a ->+   [sig v] -> (Int,Int) -> a+consumeRangeFromPyramid acc init0 pyr0 lr0 =+   case pyr0 of+      [] -> error "empty pyramid"+      (ps0:pss) ->+         foldr+            (\psNext k (l,r) ps ->+               case r-l of+                  0 -> init0+                  1 -> acc (SigG.index ps l) init0+                  _ ->+                     let (lh,ll) = NP.negate $ divMod (NP.negate l) 2+                         (rh,rl) = divMod r 2+                         {-# INLINE inc #-}+                         inc b x = if b==0 then id else acc x+                     in  inc ll (SigG.index ps l) $+                         inc rl (SigG.index ps (r-1)) $+                         k (lh,rh) psNext)+            (\(l,r) ps ->+               SigG.foldR acc init0 $+               SigG.take (r-l) $ SigG.drop l ps)+            pss lr0 ps0+ sumsPosModulated ::-   (Additive.C v, SigG2.Transform sig (Int,Int) v) =>+   (Additive.C v, SigG.Transform sig (Int,Int), SigG.Transform sig v) =>    sig (Int,Int) -> sig v -> sig v sumsPosModulated ctrl xs =-   SigG2.zipWithTails (flip sumRange) ctrl xs+   SigG.zipWithTails (flip sumRange) ctrl xs   {- |@@ -373,26 +467,45 @@  The laziness granularity is @2^height@. -}-sumsPosModulatedPyramid ::-   (Additive.C v, SigG.Transform sig (Int,Int), SigG.Write sig v) =>-   Int -> sig (Int,Int) -> sig v -> sig v-sumsPosModulatedPyramid height ctrl xs =-   let (sizes,pyr0) = pyramid height xs-       blockSize = head sizes-       pyrStarts =-          iterate (zipWith SigG.drop sizes) pyr0-       ctrlBlocks =-          SigS.toList $-          SigG.sliceVertical blockSize ctrl+{-# INLINE accumulatePosModulatedFromPyramid #-}+accumulatePosModulatedFromPyramid ::+   (SigG.Transform sig (Int,Int), SigG.Produce sig v) =>+   ([sig v] -> (Int,Int) -> v) ->+   ([Int], [sig v]) ->+   sig (Int,Int) -> sig v+accumulatePosModulatedFromPyramid accumulate (sizes,pyr0) ctrl =+   let blockSize = head sizes+       pyrStarts = iterate (zipWith SigG.drop sizes) pyr0+       ctrlBlocks = SigS.toList $ SigG.sliceVertical blockSize ctrl    in  SigG.concat $        zipWith           (\pyr ->-              SigG.fromState (SigG.LazySize blockSize) .-              SigS.map (sumRangeFromPyramid pyr) .+              SigG.fromState .+              SigS.map (accumulate pyr) .               SigS.zipWith (\d -> mapPair ((d+), (d+))) (SigS.iterate (1+) 0) .               SigG.toState)           pyrStarts ctrlBlocks +sumsPosModulatedPyramid ::+   (Additive.C v, SigG.Transform sig (Int,Int), SigG.Produce sig v) =>+   Int -> sig (Int,Int) -> sig v -> sig v+sumsPosModulatedPyramid height ctrl xs =+   accumulatePosModulatedFromPyramid+      sumRangeFromPyramid+      (pyramid height xs) ctrl++withPaddedInput ::+   (SigG.Transform sig Int, SigG.Transform sig (Int, Int),+    SigG.Produce sig y) =>+   y -> (sig (Int, Int) -> sig y -> v) ->+   Int ->+   sig Int ->+   sig y -> v+withPaddedInput pad proc maxC ctrl xs =+   proc+      (SigG.map (\c -> (maxC - c, maxC + c + 1)) ctrl)+      (delayPad pad maxC xs)+ {- | The first argument is the amplification. The main reason to introduce it,@@ -401,16 +514,26 @@ -} movingAverageModulatedPyramid ::    (Field.C a, Module.C a v,-    SigG2.Transform sig Int (Int,Int), SigG.Write sig v) =>+    SigG.Transform sig Int, SigG.Transform sig (Int,Int), SigG.Produce sig v) =>    a -> Int -> Int -> sig Int -> sig v -> sig v-movingAverageModulatedPyramid amp height maxC ctrl xs =-   SigG.zipWith (\c x -> (amp / fromIntegral (2*c+1)) *> x) ctrl $-   sumsPosModulatedPyramid height-      (SigG2.map (\c -> (maxC - c, maxC + c)) ctrl)-      (delay maxC xs)+movingAverageModulatedPyramid amp height maxC ctrl0 =+   withPaddedInput zero+      (\ctrl xs ->+         SigG.zipWith (\c x -> (amp / fromIntegral (2*c+1)) *> x) ctrl0 $+         sumsPosModulatedPyramid height ctrl xs)+      maxC ctrl0  +inverseFrequencyModulationFloor ::+   (Ord t, Ring.C t, SigG.Produce sig v, SigG.Consume sig t) =>+   sig t -> sig v -> sig v+inverseFrequencyModulationFloor ctrl xs =+   SigG.fromState+      (FiltS.inverseFrequencyModulationFloor+         (SigG.toState ctrl) (SigG.toState xs)) ++ {- * Filter operators from calculus -}  {- |@@ -464,3 +587,335 @@    (Additive.C v, SigG.Transform sig v) =>    sig v -> sig v differentiate2 = differentiate . differentiate+++-- * general non-recursive filters++{-|+Unmodulated non-recursive filter (convolution)++Brute force implementation.+-}+{-# INLINE generic #-}+generic ::+   (Module.C a v, SigG.Transform sig a, SigG.Produce sig v) =>+   sig a -> sig v -> sig v+generic m x =+   if SigG.null m || SigG.null x+     then CutG.empty+     else+       let mr = SigG.reverse m+           xp = delayPos (pred (SigG.length m)) x+       in  SigG.mapTails (SigG.linearComb mr) xp+++{- |+Both should signals should have similar length.+If they have considerably different length,+then better use 'karatsubaFiniteInfinite'.++Implementation using Karatsuba trick and split-and-overlap-add.+This way we stay in a ring, are faster than quadratic runtime+but do not reach log-linear runtime.+-}+karatsubaFinite ::+   (Additive.C a, Additive.C b, Additive.C c,+    SigG.Transform sig a, SigG.Transform sig b, SigG.Transform sig c) =>+   (a -> b -> c) ->+   sig a -> sig b -> sig c+karatsubaFinite mul a b =+   SigL.toSignal $+   karatsubaBounded mul+      (SigL.fromSignal a) (SigL.fromSignal b)++{-# INLINE karatsubaBounded #-}+karatsubaBounded ::+   (Additive.C a, Additive.C b, Additive.C c,+    SigG.Transform sig a, SigG.Transform sig b, SigG.Transform sig c) =>+   (a -> b -> c) ->+   SigL.T (sig a) -> SigL.T (sig b) -> SigL.T (sig c)+karatsubaBounded mul a b =+   case (SigL.length a, SigL.length b) of+      (0,_) -> CutG.empty+      (_,0) -> CutG.empty+      (1,_) ->+         SigG.switchL+            (error "karatsubaBounded: empty signal")+            (\y _ -> fmap (SigG.map (mul y)) b) $+         SigL.body a+      (_,1) ->+         SigG.switchL+            (error "karatsubaBounded: empty signal")+            (\y _ -> fmap (SigG.map (flip mul y)) a) $+         SigL.body b+      (2,2) ->+         let [a0,a1] = SigG.toList (SigL.toSignal a)+             [b0,b1] = SigG.toList (SigL.toSignal b)+             (c0,c1,c2) = convolvePair mul (a0,a1) (b0,b1)+         in  SigL.Cons 3 $ rechunk a b $+             c0 : c1 : c2 : []+      (2,3) ->+         let [a0,a1]    = SigG.toList (SigL.toSignal a)+             [b0,b1,b2] = SigG.toList (SigL.toSignal b)+             (c0,c1,c2,c3) =+                convolvePairTriple mul (a0,a1) (b0,b1,b2)+         in  SigL.Cons 4 $ rechunk a b $+             c0 : c1 : c2 : c3 : []+      (3,2) ->+         let [a0,a1,a2] = SigG.toList (SigL.toSignal a)+             [b0,b1]    = SigG.toList (SigL.toSignal b)+             (c0,c1,c2,c3) =+                convolvePairTriple (flip mul) (b0,b1) (a0,a1,a2)+         in  SigL.Cons 4 $ rechunk a b $+             c0 : c1 : c2 : c3 : []+      (3,3) ->+         let [a0,a1,a2] = SigG.toList (SigL.toSignal a)+             [b0,b1,b2] = SigG.toList (SigL.toSignal b)+             (c0,c1,c2,c3,c4) =+                convolveTriple mul (a0,a1,a2) (b0,b1,b2)+         in  SigL.Cons 5 $ rechunk a b $+             c0 : c1 : c2 : c3 : c4 : []+      (4,4) ->+         let [a0,a1,a2,a3] = SigG.toList (SigL.toSignal a)+             [b0,b1,b2,b3] = SigG.toList (SigL.toSignal b)+             (c0,c1,c2,c3,c4,c5,c6) =+                convolveQuadruple mul (a0,a1,a2,a3) (b0,b1,b2,b3)+         in  SigL.Cons 7 $ rechunk a b $+             c0 : c1 : c2 : c3 : c4 : c5 : c6 : []+      (lenA,lenB) ->+         let n2 = div (max lenA lenB) 2+             (a0,a1) = SigL.splitAt n2 a+             (b0,b1) = SigL.splitAt n2 b+             (c0,c1,c2) =+                convolvePair+                   (karatsubaBounded mul)+                   (a0,a1) (b0,b1)+         in  fmap (rechunk a b) $+             SigL.addShiftedSimple n2 c0 $+             SigL.addShiftedSimple n2 c1 c2++{-# INLINE rechunk #-}+rechunk ::+   (SigG.Transform sig1 a, SigG.Transform sig1 b, SigG.Transform sig1 c,+    SigG.Transform sig0 c) =>+   SigL.T (sig1 a) -> SigL.T (sig1 b) -> sig0 c -> sig1 c+rechunk a b c =+   let (ac,bc) = CutG.splitAt (SigL.length a) c+   in  SigG.takeStateMatch (SigL.body a) (SigG.toState ac)+       `SigG.append`+       SigG.takeStateMatch (SigL.body b) (SigG.toState bc)+++{- |+The first operand must be finite and+the second one can be infinite.+For efficient operation we expect that the second signal+is longer than the first one.+-}+{-+Implemented by overlap-add of pieces that are convolved by Karatsuba trick.+Is it more efficient to round the chunk size up to the next power of two?+Can we make use of the fact,+that the first operand is always split in the same way?+-}+karatsubaFiniteInfinite ::+   (Additive.C a, Additive.C b, Additive.C c,+    SigG.Transform sig a, SigG.Transform sig b, SigG.Transform sig c) =>+   (a -> b -> c) ->+   sig a -> sig b -> sig c+karatsubaFiniteInfinite mul a b =+   let al = SigL.fromSignal a+   in  case SigL.length al of+          0 -> CutG.empty+          alen ->+             SigS.foldR (addShiftedSimple alen) CutG.empty $+             SigS.map SigL.toSignal $+             SigS.map (karatsubaBounded mul al . SigL.fromSignal) $+             SigG.sliceVertical alen b+++karatsubaInfinite ::+   (Additive.C a, Additive.C b, Additive.C c,+    SigG.Transform sig a, SigG.Transform sig c, SigG.Transform sig b) =>+   (a -> b -> c) ->+   sig a -> sig b -> sig c+karatsubaInfinite mul =+   let recourse n a b =+          let (a0,a1) = SigG.splitAt n a+              (b0,b1) = SigG.splitAt n b+              {-+              We could also apply Karatsuba's trick to these pairs.+              But this requires Additive (sig a) constraint+              and I do not know whether this is actually an optimization.+              -}+              ab00 =+                 SigL.toSignal $+                 karatsubaBounded mul+                    (SigL.fromSignal a0) (SigL.fromSignal b0)+              ab01 = karatsubaFiniteInfinite mul a0 b1+              ab10 = karatsubaFiniteInfinite (flip mul) b0 a1+              ab11 = recourse (2*n) a1 b1+          in  if SigG.null a || SigG.null b+                then CutG.empty+                else+                  addShiftedSimple n ab00 $+                  addShiftedSimple n (SigG.mix ab01 ab10) ab11+   in  recourse 1+++{- |+It must hold @delay <= length a@.+-}+{-+It is crucial that 'mix' uses the chunk size structure of the second operand.+This way we avoid unnecessary and even infinite look-ahead.+-}+{-# INLINE addShiftedSimple #-}+addShiftedSimple ::+   (Additive.C a, SigG.Transform sig a) =>+   Int -> sig a -> sig a -> sig a+addShiftedSimple del a b =+   uncurry CutG.append $+   mapSnd (flip SigG.mix b) $+   CutG.splitAt del a+++-- ** hard-wired convolutions for small sizes++{-+Some small size convolutions using the Karatsuba trick.+We do not use Toom-3 multiplication,+because this requires division by 2 and 6.+With Karatsuba we can stay in a ring.+-}++type Pair a = (a,a)++{- |+Reasonable choices for the multiplication operation are '(*)', '(*>)', 'convolve'.+-}+{-# INLINE convolvePair #-}+convolvePair ::+   (Additive.C a, Additive.C b, Additive.C c) =>+   (a -> b -> c) ->+   Pair a -> Pair b -> Triple c+convolvePair mul a b =+   snd $ sumAndConvolvePair mul a b++{-# INLINE sumAndConvolvePair #-}+sumAndConvolvePair ::+   (Additive.C a, Additive.C b, Additive.C c) =>+   (a -> b -> c) ->+   Pair a -> Pair b -> ((a,b), Triple c)+sumAndConvolvePair (!*!) (a0,a1) (b0,b1) =+   let sa01 = a0+a1+       sb01 = b0+b1+       ab0 = a0!*!b0+       ab1 = a1!*!b1+   in  ((sa01, sb01), (ab0, sa01!*!sb01-(ab0+ab1), ab1))++type Triple a = (a,a,a)++{-# INLINE convolvePairTriple #-}+convolvePairTriple ::+   (Additive.C a, Additive.C b, Additive.C c) =>+   (a -> b -> c) ->+   Pair a -> Triple b -> (c,c,c,c)+convolvePairTriple (!*!) (a0,a1) (b0,b1,b2) =+   let ab0 = a0!*!b0+       ab1 = a1!*!b1+       sa01 = a0+a1; sb01 = b0+b1; ab01 = sa01!*!sb01+   in  (ab0, ab01 - (ab0+ab1),+        a0!*!b2 + ab1, a1!*!b2)+++{-# INLINE convolveTriple #-}+convolveTriple ::+   (Additive.C a, Additive.C b, Additive.C c) =>+   (a -> b -> c) ->+   Triple a -> Triple b -> (c,c,c,c,c)+convolveTriple mul a b =+   snd $ sumAndConvolveTriple mul a b++{-# INLINE sumAndConvolveTriple #-}+sumAndConvolveTriple ::+   (Additive.C a, Additive.C b, Additive.C c) =>+   (a -> b -> c) ->+   Triple a -> Triple b -> ((a,b), (c,c,c,c,c))+sumAndConvolveTriple (!*!) (a0,a1,a2) (b0,b1,b2) =+   let ab0 = a0!*!b0+       ab1 = a1!*!b1+       ab2 = a2!*!b2+       sa01 = a0+a1; sb01 = b0+b1; ab01 = sa01!*!sb01+       sa02 = a0+a2; sb02 = b0+b2; ab02 = sa02!*!sb02+       sa012 = sa01+a2+       sb012 = sb01+b2+   in  ((sa012, sb012),+        (ab0, ab01 - (ab0+ab1),+         ab02 + ab1 - (ab0+ab2),+         sa012!*!sb012 - ab02 - ab01 + ab0, ab2))++{-# INLINE sumAndConvolveTripleAlt #-}+sumAndConvolveTripleAlt ::+   (Additive.C a, Additive.C b, Additive.C c) =>+   (a -> b -> c) ->+   Triple a -> Triple b -> ((a,b), (c,c,c,c,c))+sumAndConvolveTripleAlt (!*!) (a0,a1,a2) (b0,b1,b2) =+   let ab0 = a0!*!b0+       ab1 = a1!*!b1+       ab2 = a2!*!b2+       sa01 = a0+a1; sb01 = b0+b1+       ab01 = sa01!*!sb01 - (ab0+ab1)+       sa02 = a0+a2; sb02 = b0+b2+       ab02 = sa02!*!sb02 - (ab0+ab2)+       sa12 = a1+a2; sb12 = b1+b2+       ab12 = sa12!*!sb12 - (ab1+ab2)+   in  ((sa01+a2, sb01+b2),+        (ab0, ab01, ab1+ab02, ab12, ab2))++type Quadruple a = (a,a,a,a)++{-# INLINE convolveQuadruple #-}+convolveQuadruple ::+   (Additive.C a, Additive.C b, Additive.C c) =>+   (a -> b -> c) ->+   Quadruple a -> Quadruple b -> (c,c,c,c,c,c,c)+convolveQuadruple mul a b =+   snd $ sumAndConvolveQuadruple mul a b++{-# INLINE sumAndConvolveQuadruple #-}+sumAndConvolveQuadruple ::+   (Additive.C a, Additive.C b, Additive.C c) =>+   (a -> b -> c) ->+   Quadruple a -> Quadruple b -> ((a,b), (c,c,c,c,c,c,c))+sumAndConvolveQuadruple (!*!) (a0,a1,a2,a3) (b0,b1,b2,b3) =+   let ab0 = a0!*!b0+       ab1 = a1!*!b1+       sa01 = a0+a1; sb01 = b0+b1+       ab01 = sa01!*!sb01 - (ab0+ab1)+       ab2 = a2!*!b2+       ab3 = a3!*!b3+       sa23 = a2+a3; sb23 = b2+b3+       ab23 = sa23!*!sb23 - (ab2+ab3)+       ab02 = (a0+a2)!*!(b0+b2)+       ab13 = (a1+a3)!*!(b1+b3)+       sa0123 = sa01+sa23+       sb0123 = sb01+sb23+       ab0123 = sa0123!*!sb0123 - (ab02+ab13)+   in  ((sa0123, sb0123),+        (ab0, ab01, ab1+ab02-(ab0+ab2),+         ab0123 - (ab01+ab23),+         ab2+ab13-(ab1+ab3), ab23, ab3))++{-# INLINE sumAndConvolveQuadrupleAlt #-}+sumAndConvolveQuadrupleAlt ::+   (Additive.C a, Additive.C b, Additive.C c) =>+   (a -> b -> c) ->+   Quadruple a -> Quadruple b -> ((a,b), (c,c,c,c,c,c,c))+sumAndConvolveQuadrupleAlt mul (a0,a1,a2,a3) (b0,b1,b2,b3) =+   let (((sa02,sa13), (sb02,sb13)),+        ((c00,c01,c02), (c10,c11,c12), (c20,c21,c22))) =+          sumAndConvolvePair (convolvePair mul)+             ((a0,a1),(a2,a3)) ((b0,b1),(b2,b3))+   in  ((sa02+sa13, sb02+sb13),+        (c00,c01,c02+c10,c11,c12+c20,c21,c22))
src/Synthesizer/Generic/Filter/Recursive/Comb.hs view
@@ -11,21 +11,25 @@ Comb filters, useful for emphasis of tones with harmonics and for repeated echos. -}-module Synthesizer.Generic.Filter.Recursive.Comb where+module Synthesizer.Generic.Filter.Recursive.Comb (+   karplusStrong,+   run,+   runMulti,+   runProc,+   ) where  import qualified Synthesizer.Generic.Filter.NonRecursive as Filt import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1  import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.Generic.Cut as CutG  import qualified Algebra.Module                as Module--- import qualified Algebra.Field                 as Field import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive -import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   {- |@@ -35,7 +39,7 @@ -} {-# INLINE karplusStrong #-} karplusStrong ::-   (Ring.C t, Module.C t y, SigG.Write sig y) =>+   (Ring.C t, Module.C t y, SigG.Transform sig y) =>    Filt1.Parameter t -> sig y -> sig y karplusStrong c wave =    SigG.delayLoop (SigG.modifyStatic Filt1.lowpassModifier c) wave@@ -49,7 +53,7 @@ instead of cutting the result according to the input length. -} {-# INLINE run #-}-run :: (Module.C t y, SigG.Write sig y) =>+run :: (Module.C t y, SigG.Transform sig y) =>    Int -> t -> sig y -> sig y run time gain =    runProc time (Filt.amplifyVector gain)@@ -59,7 +63,7 @@ Chunk size must be smaller than all of the delay times. -} {-# INLINE runMulti #-}-runMulti :: (Ring.C t, Module.C t y, SigG.Write sig y) =>+runMulti :: (Module.C t y, SigG.Produce sig y) =>    [Int] -> t -> sig y -> sig y runMulti times gain x =     let y = foldl@@ -70,6 +74,25 @@  {- | Echos can be piped through an arbitrary signal processor. -} {-# INLINE runProc #-}-runProc :: (Additive.C y, SigG.Write sig y) =>+runProc :: (Additive.C y, SigG.Transform sig y) =>    Int -> (sig y -> sig y) -> sig y -> sig y runProc = SigG.delayLoopOverlap+++{- |+Alternative to 'run' that uses 'CutG.splitAt' at the beginning+instead of adding a zero signal.+-}+_run :: (Module.C t y, SigG.Transform sig y) => t -> Int -> sig y -> sig y+_run gain delay xs =+   let (xs0,xs1) = CutG.splitAt delay $ Filt.amplifyVector (1-gain) xs+       ys = CutG.append xs0 $ SigG.zipWith (+) xs1 $ Filt.amplifyVector gain ys+   in  ys++_runInf :: (Module.C t y, SigG.Produce sig y) => t -> Int -> sig y -> sig y+_runInf gain delay xs =+   let (xs0,xs1) =+          CutG.splitAt delay $+          Filt.amplifyVector (1-gain) xs `CutG.append` SigG.repeat zero+       ys = CutG.append xs0 $ SigG.zipWith (+) xs1 $ Filt.amplifyVector gain ys+   in  ys
src/Synthesizer/Generic/Filter/Recursive/Integration.hs view
@@ -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 PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base
src/Synthesizer/Generic/Filter/Recursive/MovingAverage.hs view
@@ -8,13 +8,12 @@ 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-import qualified Synthesizer.Generic.Signal2 as SigG2  import qualified Synthesizer.Generic.Filter.Recursive.Integration as Integration import qualified Synthesizer.Generic.Filter.Delay as Delay@@ -25,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 PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   @@ -47,7 +43,7 @@ @ -} {-# INLINE sumsStaticInt #-}-sumsStaticInt :: (Additive.C v, SigG.Write sig v) =>+sumsStaticInt :: (Additive.C v, SigG.Produce sig v) =>    Int -> sig v -> sig v sumsStaticInt n xs =    Integration.run (sub xs (Delay.staticPos n xs))@@ -106,7 +102,7 @@  {-# INLINE addNext #-} addNext ::-   (Additive.C v, SigG.Read sig a) =>+   (Additive.C v, SigG.Transform sig a) =>    (a -> v) -> (v -> sig a -> v) -> v -> sig a -> v addNext f next s =    SigG.switchL s@@ -118,7 +114,7 @@ -} {-# INLINE sumDiffsModulated #-} sumDiffsModulated ::-   (RealField.C a, Module.C a v, SigG2.Transform sig a v) =>+   (RealField.C a, Module.C a v, SigG.Transform sig a, SigG.Transform sig v) =>    a -> sig a -> sig v -> sig v sumDiffsModulated d ds =    maybe (error "MovingAverage: signal must be non-empty because we prepended a zero before") fst .@@ -134,10 +130,10 @@ -}  zipRangesWithTails ::-   (SigG2.Transform sig a v) =>+   (SigG.Transform sig a, SigG.Transform sig v) =>    (a -> a -> sig v -> v) -> sig a -> sig a -> sig v -> sig v zipRangesWithTails f tls tus xs =-   SigG2.zipWithState+   SigG.zipWithState       (\(tl,suffix) tu -> f tl tu suffix)       (SigS.zip (SigG.toState tls) (SigG.tails xs))       tus@@ -159,7 +155,7 @@ -} {-# INLINE sumsModulatedHalf #-} sumsModulatedHalf ::-   (RealField.C a, Module.C a v, SigG2.Transform sig a v, SigG.Write sig v) =>+   (RealField.C a, Module.C a v, SigG.Transform sig a, SigG.Produce sig v) =>    Int -> sig a -> sig v -> sig v sumsModulatedHalf maxDInt ds xs =    let maxD  = fromIntegral maxDInt@@ -171,7 +167,7 @@  {-# INLINE modulatedFrac #-} modulatedFrac ::-   (RealField.C a, Module.C a v, SigG2.Transform sig a v, SigG.Write sig v) =>+   (RealField.C a, Module.C a v, SigG.Transform sig a, SigG.Produce sig v) =>    Int -> sig a -> sig v -> sig v modulatedFrac maxDInt ds xs =    SigG.zipWith (\d y -> recip (2*d) *> y) ds $
+ src/Synthesizer/Generic/Fourier.hs view
@@ -0,0 +1,994 @@+{- |+Complete implementation for Fast Fourier Transform for any signal length.+Although defined for all kinds of signal storage,+we need fast access to arbitrary indices.+-}+{-+further thoughts+ - Test the algorithms using remainder polynomials+     with respect to [-1,0,...,0,1]+     Problem: We would need large polynomial degrees,+     namely LCM of the size of all sub-transforms.+     Those numbers are in the same magnitude+     as the integers we use for our integer residue class arithmetic.+ - a z-transform by convolving with a chirp would be nice,+     however we need a square of the primitive root of unity+     in order to compute cis((i/n)^2/2)+ - Can we write the Fourier transforms for lengths larger than the input signal length+     with implicit zero padding?+     This would be useful for Fourier based convolution.+     Our frequent use of 'rechunk' would be a problem, though.+     transformCoprime also needs explicit zero padding.+ - a type class could unify all Level generators+     and thus they would allow for a generic way to call a certain sub-transform+-}+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.Generic.Fourier (+   Element(..),+   -- * conversion between time and frequency domain (spectrum)+   transformForward,+   transformBackward,+   cacheForward,+   cacheBackward,+   cacheDuplex,+   transformWithCache,+   -- * convolution based on Fourier transform+   convolveCyclic,+   Window,+   window,+   convolveWithWindow,+   ) where++import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.Generic.Cut as CutG+import qualified Synthesizer.Generic.Cyclic as Cyclic+import qualified Synthesizer.Generic.Filter.NonRecursive as FiltNRG++import qualified Synthesizer.Generic.Permutation as Permutation+import qualified Synthesizer.Basic.NumberTheory as NumberTheory++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.Ring as Ring+import qualified Algebra.PrincipalIdealDomain as PID+import qualified Algebra.IntegralDomain as Integral++import qualified Number.ResidueClass.Check as RC+import Number.ResidueClass.Check ((/:), )++import qualified Number.Complex as Complex+import Number.Complex ((+:))++import NumericPrelude.Numeric+import NumericPrelude.Base hiding (head, )++++class Ring.C y => Element y where+   recipInteger :: (SigG.Consume sig y) => sig y -> y+   addId :: (SigG.Consume sig y) => sig y -> y+   multId :: (SigG.Consume sig y) => sig y -> y+   {- |+   It must hold:++   > uncurry (*) (conjugatePrimitiveRootsOfUnity n) = 1++   > mapPair ((^m), (^m)) (conjugatePrimitiveRootsOfUnity (n*m) y)+   >    == conjugatePrimitiveRootsOfUnity n y@++   since we need for caching that the cache is uniquely determined+   by singal length and transform direction.+   -}+   conjugatePrimitiveRootsOfUnity :: (SigG.Consume sig y) => sig y -> (y,y)++instance Trans.C a => Element (Complex.T a) where+   recipInteger sig = recip (fromIntegral (SigG.length sig)) +: zero+   addId _sig = zero+   multId _sig = one+   conjugatePrimitiveRootsOfUnity sig =+      (\x -> (x, Complex.conjugate x)) $+      case SigG.length sig of+         1 -> one+         2 -> negate one+         3 -> (negate one +: sqrt 3) / 2+         4 -> zero +: one+         5 ->+            let sqrt5 = sqrt 5+            in  ((sqrt5 - 1) +: sqrt 2 * sqrt(5 + sqrt5)) / 4+         6 -> (one +: sqrt 3) / 2+         8 -> Complex.scale (sqrt 2 / 2) (one +: one)+         12 -> (sqrt 3 +: one) / 2+         n -> Complex.cis (2*pi / fromIntegral n)++instance (NumberTheory.PrimitiveRoot a, PID.C a, Eq a) => Element (RC.T a) where+   recipInteger sig =+      recip (fromIntegral (SigG.length sig) /: RC.modulus (head sig))+   addId sig = zero /: RC.modulus (head sig)+   multId sig = one /: RC.modulus (head sig)+   {-+   We cannot simply compute+     NumberTheory.primitiveRootsOfUnity modu (SigG.length sig)+   since we have to fulfill the laws.+   In order to fulfill them,+   we choose a root with maximum order,+   this will always be the same,+   and it is a root of all primitive roots+   of any possible order in that ring.+   -}+   conjugatePrimitiveRootsOfUnity sig =+      let modu = RC.modulus (head sig)+          order@(NumberTheory.Order expo) =+             NumberTheory.maximumOrderOfPrimitiveRootsOfUnity modu+          r:_ = NumberTheory.primitiveRootsOfUnity modu order+          n = Integral.divChecked expo (fromIntegral (SigG.length sig))+          z = (r /: modu) ^ n+      in  (z, recip z)+++head :: (SigG.Consume sig y) => sig y -> y+head =+   SigG.switchL (error "Generic.Signal.head: empty signal") const .+   SigG.toState+++directionPrimitiveRootsOfUnity ::+   (Element y, SigG.Consume sig y) =>+   sig y -> ((Direction,y), (Direction,y))+directionPrimitiveRootsOfUnity x =+   let (z,zInv) = conjugatePrimitiveRootsOfUnity x+   in  ((Forward,z), (Backward,zInv))++transformForward ::+   (Element y, SigG.Transform sig y) =>+   sig y -> sig y+transformForward xs =+   transformWithCache (cacheForward xs) xs++{- |+Shall we divide the result values by the length of the signal?+Our dimensional wrapper around the Fourier transform does not expect this.+-}+transformBackward ::+   (Element y, SigG.Transform sig y) =>+   sig y -> sig y+transformBackward xs =+   transformWithCache (cacheBackward xs) xs++{- |+The size of the signal must match the size, that the plan was generated for.+-}+_transformPlan ::+   (Element y, SigG.Transform sig y) =>+   Plan -> (Direction,y) -> sig y -> sig y+_transformPlan p z xs =+   transformWithCache (cacheFromPlan p z xs) xs++{- |+The size and type of the signal must match the parameters,+that the cache was generated for.+-}+transformWithCache ::+   (Element y, SigG.Transform sig y) =>+   Cache sig y -> sig y -> sig y+transformWithCache cache xs =+   case cache of+      CacheIdentity -> xs+      CacheSmall size ->+         case size of+            LevelCache2 zs -> transform2 zs xs+            LevelCache3 zs -> transform3 zs xs+            LevelCache4 zs -> transform4 zs xs+            LevelCache5 zs -> transform5 zs xs+      CacheNaive level ->+         transformNaive level xs+      CacheRadix2 level subCache ->+         transformRadix2InterleavedFrequency level subCache xs+      CachePrime level subCaches ->+         transformPrime level subCaches xs+      CacheCoprime level subCaches ->+         transformCoprime level subCaches xs+      CacheComposite level subCaches ->+         transformComposite level subCaches xs+++{- |+Memorize factorizations of the data size and permutation vectors.+-}+data Plan =+     PlanIdentity+   | PlanSmall LevelSmall+   | PlanNaive  -- mainly for debugging+   | PlanRadix2 LevelRadix2 Plan+   | PlanPrime LevelPrime Plan+   | PlanCoprime LevelCoprime (Plan, Plan)+   | PlanComposite LevelComposite (Plan, Plan)+   deriving (Show)++{-+efficient swallow comparison+only correct for Plans generated by 'plan'.+-}+instance Eq Plan where+   p0 == p1  =  compare p0 p1 == EQ++{-+Needed for keys in CacheMap+-}+instance Ord Plan where+   compare p0 p1  =+      case (p0,p1) of+         (PlanIdentity, PlanIdentity) -> EQ+         (PlanIdentity, _) -> LT+         (_, PlanIdentity) -> GT+         (PlanSmall l0, PlanSmall l1) -> compare l0 l1+         (PlanSmall _, _) -> LT+         (_, PlanSmall _) -> GT+         (PlanNaive, PlanNaive) -> EQ+         (PlanNaive, _) -> LT+         (_, PlanNaive) -> GT+         (PlanRadix2 l0 _, PlanRadix2 l1 _) -> compare l0 l1+         (PlanRadix2 _ _, _) -> LT+         (_, PlanRadix2 _ _) -> GT+         (PlanPrime l0 _, PlanPrime l1 _) -> compare l0 l1+         (PlanPrime _ _, _) -> LT+         (_, PlanPrime _ _) -> GT+         (PlanCoprime l0 _, PlanCoprime l1 _) -> compare l0 l1+         (PlanCoprime _ _, _) -> LT+         (_, PlanCoprime _ _) -> GT+         (PlanComposite l0 _, PlanComposite l1 _) -> compare l0 l1+++plan :: Integer -> Plan+plan n =+   State.evalState (planWithMapUpdate n) smallPlanMap++type PlanMap = Map.Map Integer Plan++smallPlanMap :: PlanMap+smallPlanMap =+   Map.fromAscList $ zip [0..] $+   PlanIdentity :+   PlanIdentity :+   PlanSmall Level2 :+   PlanSmall Level3 :+   PlanSmall Level4 :+   PlanSmall Level5 :+   []++{- |+Detect and re-use common sub-plans.+-}+planWithMap :: Integer -> State.State PlanMap Plan+planWithMap n =+   case divMod n 2 of+      (n2,0) -> PlanRadix2 (levelRadix2 n2) <$> planWithMapUpdate n2+      _ ->+         let facs = NumberTheory.fermatFactors n+         in  -- find unitary divisors+             case filter (\(a,b) -> a>1 && gcd a b == 1) facs of+                q2 : _ ->+                   PlanCoprime (levelCoprime q2) <$>+                   planWithMapUpdate2 q2+                _ ->+                   let (q2 : _) = facs+                   in  if fst q2 == 1+                         then PlanPrime (levelPrime $ snd q2) <$>+                              planWithMapUpdate (n-1)+                         else PlanComposite (levelComposite q2) <$>+                              planWithMapUpdate2 q2++planWithMapUpdate :: Integer -> State.State PlanMap Plan+planWithMapUpdate n = do+   item <- State.gets (Map.lookup n)+   case item of+      Just p -> return p+      Nothing ->+         planWithMap n >>= \m -> State.modify (Map.insert n m) >> return m++planWithMapUpdate2 :: (Integer, Integer) -> State.State PlanMap (Plan, Plan)+planWithMapUpdate2 =+   uncurry (liftM2 (,)) .+   mapPair (planWithMapUpdate,planWithMapUpdate)+++{- |+Cache powers of the primitive root of unity+in a storage compatible to the processed signal.+-}+data Cache sig y =+     CacheIdentity+   | CacheSmall (LevelCacheSmall y)+   | CacheNaive (LevelCacheNaive y)+   | CacheRadix2 (LevelCacheRadix2 sig y) (Cache sig y)+   | CachePrime (LevelCachePrime sig y) (Cache sig y, Cache sig y)+   | CacheCoprime LevelCoprime (Cache sig y, Cache sig y)+   | CacheComposite (LevelCacheComposite sig y) (Cache sig y, Cache sig y)+   deriving (Show)++{- |+The expression @cacheForward prototype@+precomputes all data that is needed for forward Fourier transforms+for signals of the type and length @prototype@.+You can use this cache in 'transformWithCache'.+-}+cacheForward ::+   (Element y, SigG.Transform sig y) =>+   sig y -> Cache sig y+cacheForward xs =+   cacheFromPlan+      (plan $ fromIntegral $ SigG.length xs)+      (fst $ directionPrimitiveRootsOfUnity xs)+      xs++{- |+See 'cacheForward'.+-}+cacheBackward ::+   (Element y, SigG.Transform sig y) =>+   sig y -> Cache sig y+cacheBackward xs =+   cacheFromPlan+      (plan $ fromIntegral $ SigG.length xs)+      (snd $ directionPrimitiveRootsOfUnity xs)+      xs++{- |+It is @(cacheForward x, cacheBackward x) = cacheDuplex x@+but 'cacheDuplex' shared common data of both caches.+-}+cacheDuplex ::+   (Element y, SigG.Transform sig y) =>+   sig y -> (Cache sig y, Cache sig y)+cacheDuplex xs =+   let p = plan $ fromIntegral $ SigG.length xs+       (z,zInv) = directionPrimitiveRootsOfUnity xs+   in  State.evalState+          (cacheFromPlanWithMapUpdate2 (p,p) (z,zInv) (xs,xs)) $+       Map.empty+++data Direction = Forward | Backward+   deriving (Show, Eq, Ord)++type CacheMap sig y = Map.Map (Plan,Direction) (Cache sig y)++cacheFromPlan ::+   (Element y, SigG.Transform sig y) =>+   Plan -> (Direction, y) -> sig y -> Cache sig y+cacheFromPlan p z xs =+   State.evalState (cacheFromPlanWithMapUpdate p z xs) $+   Map.empty++{- |+Detect and re-use common sub-caches.+-}+cacheFromPlanWithMap ::+   (Element y, SigG.Transform sig y) =>+   Plan -> (Direction,y) -> sig y ->+   State.State (CacheMap sig y) (Cache sig y)+cacheFromPlanWithMap p (d,z) xs =+   case p of+      PlanIdentity -> return $ CacheIdentity+      PlanSmall size -> return $ CacheSmall $+         case size of+            Level2 -> LevelCache2 $ cache2 z+            Level3 -> LevelCache3 $ cache3 z+            Level4 -> LevelCache4 $ cache4 z+            Level5 -> LevelCache5 $ cache5 z+      PlanNaive ->+         return $ CacheNaive $ LevelCacheNaive z+      PlanRadix2 level@(LevelRadix2 n2) subPlan ->+         let subxs = CutG.take n2 xs+         in  CacheRadix2 (levelCacheRadix2 level z subxs) <$>+             cacheFromPlanWithMapUpdate subPlan (d,z*z) subxs+      PlanPrime level@(LevelPrime (perm,_,_)) subPlan ->+         (\subCaches ->+            CachePrime+               (levelCachePrime level (fst subCaches) z xs) subCaches)+         <$>+         let subxs = CutG.take (Permutation.size perm) xs+         in  cacheFromPlanWithMapUpdate2 (subPlan,subPlan)+                (directionPrimitiveRootsOfUnity subxs)+                (subxs,subxs)+      PlanCoprime level@(LevelCoprime (n,m) _) subPlans ->+         CacheCoprime level <$>+         cacheFromPlanWithMapUpdate2 subPlans ((d,z^m), (d,z^n))+            (CutG.take (fromInteger n) xs, CutG.take (fromInteger m) xs)+      PlanComposite level@(LevelComposite (n,m) _) subPlans ->+         CacheComposite (levelCacheComposite level z xs) <$>+         cacheFromPlanWithMapUpdate2 subPlans ((d,z^m), (d,z^n))+            (CutG.take (fromInteger n) xs, CutG.take (fromInteger m) xs)++cacheFromPlanWithMapUpdate ::+   (Element y, SigG.Transform sig y) =>+   Plan -> (Direction,y) -> sig y ->+   State.State (CacheMap sig y) (Cache sig y)+cacheFromPlanWithMapUpdate p z xs = do+   let key = (p, fst z)+   item <- State.gets (Map.lookup key)+   case item of+      Just c -> return c+      Nothing ->+         cacheFromPlanWithMap p z xs >>= \m ->+         State.modify (Map.insert key m) >>+         return m++cacheFromPlanWithMapUpdate2 ::+   (Element y, SigG.Transform sig y) =>+   (Plan, Plan) -> ((Direction,y),(Direction,y)) -> (sig y, sig y) ->+   State.State (CacheMap sig y) (Cache sig y, Cache sig y)+cacheFromPlanWithMapUpdate2 (p0,p1) (z0,z1) (xs0,xs1) =+   liftM2 (,)+      (cacheFromPlanWithMapUpdate p0 z0 xs0)+      (cacheFromPlanWithMapUpdate p1 z1 xs1)+++newtype LevelCacheNaive y =+      LevelCacheNaive y+   deriving (Show)++transformNaive ::+   (Element y, SigG.Transform sig y) =>+   LevelCacheNaive y -> sig y -> sig y+transformNaive (LevelCacheNaive z) sig =+   SigG.takeStateMatch sig $+   SigS.map+      (scalarProduct1 (SigG.toState sig) . powers sig)+      (powers sig z)++scalarProduct1 ::+   (Ring.C a) =>+   SigS.T a -> SigS.T a -> a+scalarProduct1 xs ys =+   SigS.foldL1 (+) $ SigS.zipWith (*) xs ys++_transformRing ::+   (Ring.C y, SigG.Transform sig y) =>+   y -> sig y -> sig y+_transformRing z sig =+   SigG.takeStateMatch sig $+   Ana.chirpTransform z $ SigG.toState sig++powers ::+   (Element y, SigG.Consume sig y) =>+   sig y -> y -> SigS.T y+powers sig c = SigS.iterate (c*) $ multId sig+++data LevelSmall = Level2 | Level3 | Level4 | Level5+   deriving (Show, Eq, Ord, Enum)++data LevelCacheSmall y =+     LevelCache2 y+   | LevelCache3 (y,y)+   | LevelCache4 (y,y,y)+   | LevelCache5 (y,y,y,y)+   deriving (Show)++cache2 :: (Ring.C y) => y -> y+cache3 :: (Ring.C y) => y -> (y,y)+cache4 :: (Ring.C y) => y -> (y,y,y)+cache5 :: (Ring.C y) => y -> (y,y,y,y)++cache2 z = z+cache3 z = (z, z*z)+cache4 z = let z2=z*z in (z,z2,z*z2)+cache5 z = let z2=z*z in (z,z2,z*z2,z2*z2)+++transform2 ::+   (Ring.C y, SigG.Transform sig y) =>+   y -> sig y -> sig y+transform2 z sig =+   let x0:x1:_ = SigG.toList sig+   in  SigG.takeStateMatch sig $+       SigS.fromList [x0+x1, x0+z*x1]++transform3 ::+   (Ring.C y, SigG.Transform sig y) =>+   (y,y) -> sig y -> sig y+transform3 (z,z2) sig =+   let x0:x1:x2:_ = SigG.toList sig+{- Rader's algorithm with convolution by 2-size-Fourier-transform+       xf1 = x1+x2+       xf2 = x1-x2+       zf1 = z+z2+       zf2 = z-z2+       xzf1 = xf1*zf1+       xzf2 = xf2*zf2+       xz1 = (xzf1+xzf2)/2+       xz2 = (xzf1-xzf2)/2+-}+{- naive+       [x0+x1+x2, x0+z*x1+z2*x2, x0+z2*x1+z*x2]+-}+       ((s,_), (zx1,zx2)) = Cyclic.sumAndConvolvePair (x1,x2) (z,z2)+   in  SigG.takeStateMatch sig $+       SigS.fromList [x0+s, x0+zx1, x0+zx2]++transform4 ::+   (Ring.C y, SigG.Transform sig y) =>+   (y,y,y) -> sig y -> sig y+transform4 (z,z2,z3) sig =+   let x0:x1:x2:x3:_ = SigG.toList sig+       x02a = x0+x2; x02b = x0+z2*x2+       x13a = x1+x3; x13b = x1+z2*x3+   in  SigG.takeStateMatch sig $+       SigS.fromList [x02a+   x13a, x02b+z *x13b,+                      x02a+z2*x13a, x02b+z3*x13b]+{-+This needs also five multiplications,+but in complex numbers it is z=i, and thus multiplications are cheap+and we should better make use of distributive law in order to save additions.++       x02a = x0+x2; x02b = x0+z2*x2+       x1_2 = z2*x1; x3_2 = z2*x3+   in  SigG.takeStateMatch sig $+       SigS.fromList [x02a + x1   + x3  , x02b+z*(x1   + x3_2),+                      x02a + x1_2 + x3_2, x02b+z*(x1_2 + x3  )]+-}++{-+Use Rader's trick for mapping the transform to a convolution+and apply Karatsuba's trick at two levels (i.e. total three times)+to that convolution.++0 0 0 0 0+0 1 2 3 4+0 2 4 1 3+0 3 1 4 2+0 4 3 2 1++Permutation.T: 0 1 2 4 3++0 0 0 0 0+0 1 2 4 3+0 2 4 3 1+0 4 3 1 2+0 3 1 2 4+-}+transform5 ::+   (Ring.C y, SigG.Transform sig y) =>+   (y,y,y,y) -> sig y -> sig y+transform5 (z1,z2,z3,z4) sig =+   let x0:x1:x2:x3:x4:_ = SigG.toList sig+       ((s,_), (d1,d2,d4,d3)) =+          Cyclic.sumAndConvolveQuadruple (x1,x3,x4,x2) (z1,z2,z4,z3)+   in  SigG.takeStateMatch sig $+       SigS.fromList [x0+s, x0+d1, x0+d2, x0+d3, x0+d4]++{-+transform7++Toom-3-multiplication at the highest level and Karatsuba below?+Toom-2.5-multiplication with manual addition of the missing parts?++Toom-3-multiplication with complex interpolation nodes?+Still requires division by 4 and then complex multiplication in the frequency domain.+A:=matrix(5,5,[1,0,0,0,0,1,1,1,1,1,1,-1,1,-1,1,1,I,-1,-I,1,0,0,0,0,1]);+A:=matrix(5,5,[1,0,0,0,0,1,1,1,1,1,1,-1,1,-1,1,1,I,-1,-I,1,1,-I,-1,I,1]);++Karatsuba at three levels for convolution of signal of size 8 with zero padding?++Modify the 3x3 Fourier matrix by multiplying a regular matrix+to make it more convenient to work with?+We will hardly get rid of the irrational numbers.+-}++newtype LevelRadix2 = LevelRadix2 Int+   deriving (Show, Eq, Ord)++levelRadix2 :: Integer -> LevelRadix2+levelRadix2 =+   LevelRadix2 . fromIntegral+++data LevelCacheRadix2 sig y =+   LevelCacheRadix2 Int (sig y)+   deriving (Show)++levelCacheRadix2 ::+   (Element y, SigG.Transform sig y) =>+   LevelRadix2 -> y -> sig y -> LevelCacheRadix2 sig y+levelCacheRadix2 (LevelRadix2 n2) z sig =+   LevelCacheRadix2 n2+      (SigG.takeStateMatch sig $ powers sig z)+++{- |+Cooley-Tukey specialised to one factor of the size being 2.++Size of the input signal must be even.+-}+transformRadix2InterleavedFrequency ::+   (Element y, SigG.Transform sig y) =>+   LevelCacheRadix2 sig y -> Cache sig y -> sig y -> sig y+transformRadix2InterleavedFrequency+      (LevelCacheRadix2 n2 twiddle) subCache sig =+   let (xs0,xs1) = SigG.splitAt n2 sig+       fs0 = transformWithCache subCache $ SigG.zipWith (+) xs0 xs1+       fs1 = transformWithCache subCache $+                SigG.zipWith3+                   (\w x0 x1 -> w*(x0-x1))+                   twiddle xs0 xs1+   in  SigG.takeStateMatch sig $+       SigS.interleave (SigG.toState fs0) (SigG.toState fs1)+++data LevelComposite =+   LevelComposite+      (Integer, Integer)+      (Permutation.T, Permutation.T)+   deriving (Show)++instance Eq LevelComposite where+   a == b  =  compare a b == EQ++instance Ord LevelComposite where+   compare (LevelComposite a _) (LevelComposite b _)  =+      compare a b++levelComposite :: (Integer, Integer) -> LevelComposite+levelComposite (n,m) =+   let ni = fromInteger n+       mi = fromInteger m+   in  LevelComposite (n,m)+          (Permutation.transposition ni mi,+           Permutation.transposition mi ni)+++data LevelCacheComposite sig y =+   LevelCacheComposite+      (Integer, Integer)+      (Permutation.T, Permutation.T)+      (sig y)+   deriving (Show)++levelCacheComposite ::+   (Element y, SigG.Transform sig y) =>+   LevelComposite -> y -> sig y -> LevelCacheComposite sig y+levelCacheComposite (LevelComposite (n,m) transpose) z sig =+   LevelCacheComposite (n,m) transpose $+   SigG.takeStateMatch sig $+   flip SigS.generateInfinite (n, multId sig, multId sig) $ \(i,zi,zij) ->+   (zij,+    case pred i of+      0 -> (n, zi*z, multId sig)+      i1 -> (i1, zi, zij*zi))+{-+   {-# SCC "levelCacheComposite:rechunk" #-}+   concatRechunk sig $+   {-# SCC "levelCacheComposite:subpowers" #-}+   SigS.map+      (SigG.takeStateMatch (SigG.take (fromIntegral n) sig) . powers sig)+      ({-# SCC "levelCacheComposite:powers" #-}+       powers sig z)+-}+{-+   SigS.map+      (SigG.takeStateMatch sig . SigS.take (fromIntegral n) . powers sig)+      ({-# SCC "levelCacheComposite:powers" #-}+       powers sig z)+-}+{- suffers from big inefficiency of repeated 'append'+   SigG.takeStateMatch sig $+   SigS.fold $+   SigS.map (SigS.take (fromIntegral n) . powers sig) $+   SigS.take (fromIntegral m) $ -- necessary for strict storable vectors+   powers sig z+-}++{- |+For @transformComposite z (n,m) sig@,+it must hold @n*m == length sig@ and @z ^ length sig == 1@.++Cooley-Tukey-algorithm+-}+transformComposite ::+   (Element y, SigG.Transform sig y) =>+   LevelCacheComposite sig y -> (Cache sig y, Cache sig y) -> sig y -> sig y+transformComposite+      (LevelCacheComposite (n,m) (transposeNM, transposeMN) twiddle)+      (subCacheN,subCacheM) sig =+   Permutation.apply transposeMN .+       concatRechunk sig .+       SigS.map (transformWithCache subCacheM) .+       SigG.sliceVertical (fromInteger m) .+       Permutation.apply transposeNM .+--       concatRechunk sig .+       SigG.zipWith (*) twiddle .+       SigS.fold .+       SigS.map (transformWithCache subCacheN) .+       SigG.sliceVertical (fromInteger n) .+       Permutation.apply transposeMN $+       sig+++data LevelCoprime =+   LevelCoprime+      (Integer, Integer)+      (Permutation.T, Permutation.T, Permutation.T)+   deriving (Show)++instance Eq LevelCoprime where+   a == b  =  compare a b == EQ++instance Ord LevelCoprime where+   compare (LevelCoprime a _) (LevelCoprime b _)  =+      compare a b++{-+Fourier exponent matrix of a signal of size 6.++0 0 0 0 0 0     0               0   0   0       0     0+0 1 2 3 4 5               0       2   0   4       3     0+0 2 4 0 2 4  =          0    *  0   2   4    *      0     0+0 3 0 3 0 3           0           0   0   0     0     3+0 4 2 0 4 2         0           0   4   2         0     0+0 5 4 3 2 1       0               4   0   2         0     3+-}+levelCoprime :: (Integer, Integer) -> LevelCoprime+levelCoprime (n,m) =+   let ni = fromInteger n+       mi = fromInteger m+   in  LevelCoprime (n,m)+          (Permutation.skewGrid mi ni,+           Permutation.transposition ni mi,+           Permutation.skewGridCRTInv ni mi)+++{- |+For @transformCoprime z (n,m) sig@,+the parameters @n@ and @m@ must be relatively prime+and @n*m == length sig@ and @z ^ length sig == 1@.++Good-Thomas algorithm+-}+{-+A very elegant way would be to divide the signal into chunks of size n,+define ring operations on these chunks+and perform one (length/n)-size-sub-transform in this chunk-ring.+This way we would also only have to plan the sub-transform once.+On StorableVectors the chunking could be performed in-place+in terms of a virtual reshape operation.+In the general case the performance can become very bad+if the chunks are very small, say 2 or 3 elements.+-}+transformCoprime ::+   (Element y, SigG.Transform sig y) =>+   LevelCoprime -> (Cache sig y, Cache sig y) -> sig y -> sig y+transformCoprime+      (LevelCoprime (n,m) (grid, transpose, gridInv)) (subCacheN,subCacheM) =+   let subTransform cache j sig =+          concatRechunk sig .+          SigS.map (transformWithCache cache) .+          SigG.sliceVertical (fromIntegral j) $ sig+   in  Permutation.apply gridInv .+       subTransform subCacheM m .+       Permutation.apply transpose .+       subTransform subCacheN n .+       Permutation.apply grid+++-- concatenate and reorganize for faster indexing+concatRechunk ::+   (SigG.Transform sig y) =>+   sig y -> SigS.T (sig y) -> sig y+concatRechunk pattern =+   SigG.takeStateMatch pattern .+   SigG.toState .+   SigS.fold+++data LevelPrime =+   LevelPrime (Permutation.T, Permutation.T, Permutation.T)+      deriving (Show)++instance Eq LevelPrime where+   a == b  =  compare a b == EQ++instance Ord LevelPrime where+   compare (LevelPrime (a,_,_)) (LevelPrime (b,_,_))  =+      compare (Permutation.size a) (Permutation.size b)++{-+Fourier exponent matrix of a signal of size 7.++0 0 0 0 0 0 0+0 1 2 3 4 5 6+0 2 4 6 1 3 5+0 3 6 2 5 1 4+0 4 1 5 2 6 3+0 5 3 1 6 4 2+0 6 5 4 3 2 1++multiplicative generator in Z7: 3+permutation of rows and columns by powers of 3: 1 3 2 6 4 5++0 0 0 0 0 0 0+0 1 3 2 6 4 5+0 3 2 6 4 5 1+0 2 6 4 5 1 3+0 6 4 5 1 3 2+0 4 5 1 3 2 6+0 5 1 3 2 6 4++Inverse permutation: 1 3 2 5 6 4+The inverse permutations seems not to be generated by a multiplication.+-}+levelPrime :: Integer -> LevelPrime+levelPrime n =+   let perm = Permutation.multiplicative $ fromIntegral n+   in  LevelPrime+          (perm, Permutation.reverse perm, Permutation.inverse perm)+++data LevelCachePrime sig y =+   LevelCachePrime (Permutation.T, Permutation.T) (sig y)+      deriving (Show)++levelCachePrime ::+   (Element y, SigG.Transform sig y) =>+   LevelPrime -> Cache sig y -> y -> sig y -> LevelCachePrime sig y+levelCachePrime (LevelPrime (perm, rev, inv)) subCache z sig =+   LevelCachePrime (rev, inv)+      ((\zs -> FiltNRG.amplify (recipInteger zs) zs) $+       transformWithCache subCache $+       Permutation.apply perm $+       SigG.takeStateMatch sig $+       SigS.iterate (z*) z)++{- |+Rader's algorithm for prime length signals.+-}+transformPrime ::+   (Element y, SigG.Transform sig y) =>+   LevelCachePrime sig y -> (Cache sig y, Cache sig y) -> sig y -> sig y+transformPrime (LevelCachePrime (rev, inv) zs) subCaches =+   SigG.switchL (error "transformPrime: empty signal") $+   \x0 rest ->+      SigG.cons (SigG.foldL (+) x0 rest) $+      SigG.map (x0+) $+      Permutation.apply inv $+      convolveSpectrumCyclicCache subCaches zs $+      Permutation.apply rev rest++{-+Cyclic.reverse xs = shiftR 1 (reverse xs)+Cyclic.reverse (xs <*> ys) = Cyclic.reverse xs <*> Cyclic.reverse ys+Cyclic.reverse (Cyclic.reverse xs) = xs++We could move the 'Cyclic.reverse' over to the z-vector,+but then we would have to reverse again after convolution.++zs <*> Cyclic.reverse rest+ = Cyclic.reverse (Cyclic.reverse zs <*> rest)+-}++{-+This uses Cyclic.filter instead of Cyclic.convolve.+This is simpler, but Fourier.convolveCyclic is a bit simpler than Fourier.filterCyclic,+since it does not need to reverse an operand.+-}+_transformPrimeAlt ::+   (Ring.C y, SigG.Transform sig y) =>+   LevelPrime -> y -> sig y -> sig y+_transformPrimeAlt (LevelPrime (perm, _, inv)) z =+   SigG.switchL (error "transformPrime: empty signal") $+   \x0 rest ->+      SigG.cons (SigG.foldL (+) x0 rest) $+      SigG.map (x0+) $+      Permutation.apply inv $+      Cyclic.filterNaive+         (Permutation.apply perm rest)+         (Permutation.apply perm (SigG.takeStateMatch rest (SigS.iterate (z*) z)))++++{- |+Filter window stored as spectrum+such that it can be applied efficiently to long signals.+-}+data Window sig y =+   Window Int (Cache sig y, Cache sig y) (sig y)+   deriving (Show)+++window ::+   (Element y, SigG.Transform sig y) =>+   sig y -> Window sig y+window x =+   if CutG.null x+     then Window 0 (CacheIdentity, CacheIdentity) CutG.empty+     else+       let size  = CutG.length x+           size2 = 2 * NumberTheory.ceilingPowerOfTwo size+           padded =+              SigG.take size2 $+              CutG.append x $+                 let pad = SigG.takeStateMatch x $ SigS.repeat $ addId x+                 in  CutG.append pad (SigG.append pad pad)+           caches@(cache, _cacheInv) =+              cacheDuplex padded+       in  Window+              (size2-size+1)+              caches+              (transformWithCache cache $+               FiltNRG.amplify (recipInteger padded) padded)++{- |+Efficient convolution of a large filter window+with a probably infinite signal.+-}+convolveWithWindow ::+   (Element y, SigG.Transform sig y) =>+   Window sig y -> sig y -> sig y+convolveWithWindow (Window blockSize caches spectrum) b =+   if blockSize==zero+     then CutG.empty+     else+       let windowSize = SigG.length spectrum - blockSize+       in  SigS.foldR (FiltNRG.addShiftedSimple blockSize) CutG.empty $+           SigS.map+              (\block ->+                 SigG.take (windowSize + SigG.length block) $+                 convolveSpectrumCyclicCache caches spectrum $+                 flip CutG.append+                    {-+                    The last block may be shorter than blockSize+                    and thus needs more padding.+                    -}+                    (SigG.takeStateMatch spectrum $ SigS.repeat $ addId b) $+                 block) $+           SigG.sliceVertical blockSize b+++{- |+Signal must have equal size and must not be empty.+-}+convolveCyclic ::+   (Element y, SigG.Transform sig y) =>+   sig y -> sig y -> sig y+convolveCyclic x =+   let len = fromIntegral $ SigG.length x+       (z,zInv) =+          directionPrimitiveRootsOfUnity x+   in  convolveCyclicCache+          (cacheFromPlan (plan len) z x,+           cacheFromPlan (plan len) zInv x)+          x++convolveCyclicCache ::+   (Element y, SigG.Transform sig y) =>+   (Cache sig y, Cache sig y) -> sig y -> sig y -> sig y+convolveCyclicCache caches x =+   convolveSpectrumCyclicCache caches $+   FiltNRG.amplify (recipInteger x) $ transformWithCache (fst caches) x++{- |+This function does not apply scaling.+That is you have to scale the spectrum by @recip (length x)@+if you want a plain convolution.+-}+convolveSpectrumCyclicCache ::+   (Element y, SigG.Transform sig y) =>+   (Cache sig y, Cache sig y) -> sig y -> sig y -> sig y+convolveSpectrumCyclicCache (cache,cacheInv) x y =+   transformWithCache cacheInv $+   SigG.zipWith (*) x $+   transformWithCache cache y++{-+Test:++let xs = [0,1,0,0,0,0 :: Complex.T Double]; z = fst $ conjugatePrimitiveRootsOfUnity xs in print (transformNaive z xs) >> print (transformCoprime z (2,3) xs)+-}
src/Synthesizer/Generic/Interpolation.hs view
@@ -15,36 +15,33 @@ import Synthesizer.Interpolation.Module (constant, linear, cubic, )  import qualified Synthesizer.Generic.Signal  as SigG-import qualified Synthesizer.Generic.Signal2 as SigG2 import qualified Synthesizer.Generic.Filter.NonRecursive as FiltNR  import qualified Algebra.Module    as Module import qualified Algebra.RealField as RealField--- import qualified Algebra.Field     as Field--- import qualified Algebra.Ring      as Ring+import qualified Algebra.RealRing  as RealRing import qualified Algebra.Additive  as Additive -import Algebra.Additive(zero, ) import Data.Maybe (fromMaybe, ) -import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   {-* Interpolation with various padding methods -}  {-# INLINE zeroPad #-}-zeroPad :: (RealField.C t, SigG.Write sig y) =>+zeroPad :: (RealRing.C t, SigG.Produce sig y) =>    (T t y -> t -> sig y -> a) ->    y -> T t y -> t -> sig y -> a zeroPad interpolate z ip phase x =    let (phInt, phFrac) = splitFraction phase    in  interpolate ip phFrac           (FiltNR.delayPad z (offset ip - phInt)-              (SigG.append x (SigG.repeat SigG.defaultLazySize z)))+              (SigG.append x (SigG.repeat z)))  {-# INLINE constantPad #-}-constantPad :: (RealField.C t, SigG.Write sig y) =>+constantPad :: (RealRing.C t, SigG.Produce sig y) =>    (T t y -> t -> sig y -> a) ->    T t y -> t -> sig y -> a constantPad interpolate ip phase x =@@ -52,7 +49,7 @@        xPad =           do (xFirst,_) <- SigG.viewL x              return (FiltNR.delayPad xFirst-                (offset ip - phInt) (SigG.extendConstant SigG.defaultLazySize x))+                (offset ip - phInt) (SigG.extendConstant x))    in  interpolate ip phFrac           (fromMaybe SigG.empty xPad) @@ -61,7 +58,7 @@ Only for finite input signals. -} {-# INLINE cyclicPad #-}-cyclicPad :: (RealField.C t, SigG.Transform sig y) =>+cyclicPad :: (RealRing.C t, SigG.Transform sig y) =>    (T t y -> t -> sig y -> a) ->    T t y -> t -> sig y -> a cyclicPad interpolate ip phase x =@@ -73,7 +70,7 @@ The extrapolation may miss some of the first and some of the last points -} {-# INLINE extrapolationPad #-}-extrapolationPad :: (RealField.C t, SigG.Transform sig y) =>+extrapolationPad :: (RealRing.C t, SigG.Transform sig y) =>    (T t y -> t -> sig y -> a) ->    T t y -> t -> sig y -> a extrapolationPad interpolate ip phase =@@ -86,13 +83,13 @@  {-* Interpolation of multiple values with various padding methods -} -func :: (SigG.Read sig y) =>+func :: (SigG.Consume sig y) =>    T t y -> t -> sig y -> y func ip phase =    Interpolation.func ip phase . SigG.toState  {-# INLINE skip #-}-skip :: (RealField.C t, SigG.Transform sig y) =>+skip :: (RealRing.C t, SigG.Transform sig y) =>    T t y -> (t, sig y) -> (t, sig y) skip ip (phase0, x0) =    let (n, frac) = splitFraction phase0@@ -100,7 +97,7 @@    in  (fromIntegral m + frac, x1)  {-# INLINE single #-}-single :: (RealField.C t, SigG.Transform sig y) =>+single :: (RealRing.C t, SigG.Transform sig y) =>    T t y -> t -> sig y -> y single ip phase0 x0 =    uncurry (func ip) $ skip ip (phase0, x0)@@ -115,10 +112,10 @@ {- | All values of frequency control must be non-negative. -} {-# INLINE multiRelative #-} multiRelative ::-   (RealField.C t, SigG2.Transform sig t y) =>+   (RealRing.C t, SigG.Transform sig t, SigG.Transform sig y) =>    T t y -> t -> sig y -> sig t -> sig y multiRelative ip phase0 x0 =-   SigG2.crochetL+   SigG.crochetL       (\freq pos ->           let (phase,x) = skip ip pos           in  Just (func ip phase x, (phase+freq,x)))@@ -127,21 +124,21 @@  {-# INLINE multiRelativeZeroPad #-} multiRelativeZeroPad ::-   (RealField.C t, SigG2.Transform sig t y, SigG.Write sig y) =>+   (RealRing.C t, SigG.Transform sig t, SigG.Transform sig y, SigG.Produce sig y) =>    y -> T t y -> t -> sig t -> sig y -> sig y multiRelativeZeroPad z ip phase fs x =    zeroPad multiRelative z ip phase x fs  {-# INLINE multiRelativeConstantPad #-} multiRelativeConstantPad ::-   (RealField.C t, SigG2.Transform sig t y, SigG.Write sig y) =>+   (RealRing.C t, SigG.Transform sig t, SigG.Transform sig y, SigG.Produce sig y) =>    T t y -> t -> sig t -> sig y -> sig y multiRelativeConstantPad ip phase fs x =    constantPad multiRelative ip phase x fs  {-# INLINE multiRelativeCyclicPad #-} multiRelativeCyclicPad ::-   (RealField.C t, SigG2.Transform sig t y) =>+   (RealRing.C t, SigG.Transform sig t, SigG.Transform sig y) =>    T t y -> t -> sig t -> sig y -> sig y multiRelativeCyclicPad ip phase fs x =    cyclicPad multiRelative ip phase x fs@@ -151,7 +148,7 @@ -} {-# INLINE multiRelativeExtrapolationPad #-} multiRelativeExtrapolationPad ::-   (RealField.C t, SigG2.Transform sig t y) =>+   (RealRing.C t, SigG.Transform sig t, SigG.Transform sig y) =>    T t y -> t -> sig t -> sig y -> sig y multiRelativeExtrapolationPad ip phase fs x =    extrapolationPad multiRelative ip phase x fs@@ -164,21 +161,21 @@  {-# INLINE multiRelativeZeroPadConstant #-} multiRelativeZeroPadConstant ::-   (RealField.C t, Additive.C y, SigG2.Transform sig t y, SigG.Write sig y) =>+   (RealRing.C t, Additive.C y, SigG.Transform sig t, SigG.Transform sig y, SigG.Produce sig y) =>    t -> sig t -> sig y -> sig y multiRelativeZeroPadConstant =    multiRelativeZeroPad zero constant  {-# INLINE multiRelativeZeroPadLinear #-} multiRelativeZeroPadLinear ::-   (RealField.C t, Module.C t y, SigG2.Transform sig t y, SigG.Write sig y) =>+   (RealRing.C t, Module.C t y, SigG.Transform sig t, SigG.Transform sig y, SigG.Produce sig y) =>    t -> sig t -> sig y -> sig y multiRelativeZeroPadLinear =    multiRelativeZeroPad zero linear  {-# INLINE multiRelativeZeroPadCubic #-} multiRelativeZeroPadCubic ::-   (RealField.C t, Module.C t y, SigG2.Transform sig t y, SigG.Write sig y) =>+   (RealField.C t, Module.C t y, SigG.Transform sig t, SigG.Transform sig y, SigG.Produce sig y) =>    t -> sig t -> sig y -> sig y multiRelativeZeroPadCubic =    multiRelativeZeroPad zero cubic
+ src/Synthesizer/Generic/LengthSignal.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE FlexibleInstances #-}+module Synthesizer.Generic.LengthSignal where++import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.Generic.Cut as CutG++import Data.Monoid (Monoid, mempty, mappend, )+import Data.Semigroup (Semigroup, (<>), )+import Data.Tuple.HT (mapSnd, )++import qualified Algebra.Additive       as Additive++import NumericPrelude.Numeric as NP+import NumericPrelude.Base hiding (length, splitAt, )+++data T sig = Cons {length :: Int, body :: sig}+   deriving (Show)++fromSignal :: (CutG.Consume sig) => sig -> T sig+fromSignal xs  =  Cons (CutG.length xs) xs++toSignal :: T sig -> sig+toSignal  =  body++{- |+Each fmap must preserve the signal length.+-}+instance Functor T where+   fmap f (Cons xl xs) = Cons xl (f xs)++instance (Additive.C a, SigG.Transform sig a) => Additive.C (T (sig a)) where+   zero = mempty+   negate xs = xs{body = SigG.map negate (body xs)}+   (Cons xl xs) + (Cons yl ys) =+      Cons (max xl yl) (SigG.mix xs ys)++instance (Semigroup sig) => Semigroup (T sig) where+   Cons xl xs <> Cons yl ys = Cons (xl+yl) (xs <> ys)++instance (Monoid sig) => Monoid (T sig) where+   mempty = Cons zero mempty++splitAt :: (CutG.Transform sig) => Int -> T sig -> (T sig, T sig)+splitAt n (Cons xl xs) =+   let (ys,zs) = SigG.splitAt n xs+   in  (Cons (min n xl) ys, Cons (max n xl - n) zs)++{- |+It must hold @delay <= length a@.+-}+{-+It is crucial that 'mix' uses the chunk size structure of the second operand.+This way we avoid unnecessary and even infinite look-ahead.+-}+{-# INLINE addShiftedSimple #-}+addShiftedSimple ::+   (Additive.C a, SigG.Transform sig a) =>+   Int -> T (sig a) -> T (sig a) -> T (sig a)+addShiftedSimple del a b =+   uncurry mappend $+   mapSnd (flip (+) b) $+   splitAt del a
+ src/Synthesizer/Generic/Loop.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+Several functions that add a loop to a sampled sound.+This way you can obtain an infinite sound+that consumes only finite space.+-}+module Synthesizer.Generic.Loop (+   simple,+   fade,++   timeReverse,+   TimeControl,+   timeControlSine,+   timeControlZigZag,+   ) where++import qualified Synthesizer.Generic.Signal    as SigG+import qualified Synthesizer.Generic.Cut       as CutG+import qualified Synthesizer.Generic.Wave      as WaveG++import qualified Synthesizer.Basic.Wave        as Wave+import qualified Synthesizer.Basic.Phase       as Phase++import qualified Synthesizer.State.Signal      as SigS+import qualified Synthesizer.State.Control     as CtrlS+import qualified Synthesizer.State.Oscillator  as OsciS++import qualified Synthesizer.Interpolation as Interpolation++import qualified Algebra.Transcendental as Trans+import qualified Algebra.Module         as Module+import qualified Algebra.RealField      as RealField+import qualified Algebra.RealRing       as RealRing++import NumericPrelude.Numeric+import NumericPrelude.Base+++{- |+Most simple of looping:+You give start and length of the loop body+and this part is repeated.+The data behind start+length is ignored.+-}+simple :: (CutG.Transform sig) => Int -> Int -> sig -> sig+simple len start xs =+   let (prefix, suffix) = CutG.splitAt start xs+       loopBody = CutG.take len suffix+   in  CutG.append prefix (CutG.cycle loopBody)++{- |+Create a smooth loop by cross-fading a part+with delayed versions of itself.+The loop length will be rounded to the next smaller even number.+-}+fade :: (SigG.Transform sig yv, Trans.C y, Module.C y yv) =>+   y -> Int -> Int -> sig yv -> sig yv+fade dummy loopLen2 start xs =+   let loopLen = div loopLen2 2+       (prefix, loopOut) = CutG.splitAt (start+loopLen) xs+       loopIn = CutG.drop start prefix+       loopBody =+          SigG.zipWithState3+             (\s x y ->+                let s2 = 0.5*s `asTypeOf` dummy+                in  (0.5-s2)*>x + (0.5+s2)*>y)+             (CtrlS.cosine 0 (fromIntegral loopLen))+             (SigG.toState loopIn)+             loopOut+   in  CutG.append prefix (CutG.cycle loopBody)++{- |+Resample a sampled sound with a smooth loop+using our time manipulation algorithm.+Time is first controlled linearly,+then switches to a sine or triangular control.+Loop start must be large enough in order provide enough spare data+for interpolation at the beginning+and loop start plus length must preserve according space at the end.+One period is enough space for linear interpolation.++In order to get a loopable sound with finite space+we have to reduce the loop length to a multiple of a wave period.+We will also modify the period a little bit,+such that in our loop body there is an integral number of periods.++We return the modified period and the looped sound.+-}+{-# INLINE timeReverse #-}+timeReverse ::+   (SigG.Produce sig yv, RealField.C q, Module.C q yv) =>+   Interpolation.T q yv ->+   Interpolation.T q yv ->+   TimeControl q ->+   q -> q -> (q, sig yv) -> (q, sig yv)+timeReverse ipLeap ipStep+      timeCtrlWave loopLen loopStart (period0, sample) =+   let (period, timeCtrl) =+          timeControl timeCtrlWave period0 (loopLen/2)+       wave = WaveG.sampledTone ipLeap ipStep period sample+       loopCenter = round $ loopStart + loopLen/2+       loop =+          SigG.fromState $+          OsciS.shapeFreqMod wave+             (Phase.fromRepresentative $ fromIntegral loopCenter / period)+             (SigS.map (fromIntegral loopCenter +) timeCtrl)+             (SigS.repeat (recip period))+   in  (period,+        CutG.append+           (CutG.take loopCenter sample)+           (CutG.cycle loop))++timeControl ::+   (RealField.C a) =>+   TimeControl a ->+   a -> a -> (a, SigS.T a)+timeControl (TimeControl slope wave) period0 loopDepth0 =+   let numberOfWaves =+          fromIntegral $+          (floor(slope*loopDepth0/period0) :: Int)+       loopLenInt = floor (numberOfWaves * period0)+       loopLen = fromIntegral loopLenInt+       period = loopLen / numberOfWaves+       loopDepth = loopLen / slope+   in  (period,+        SigS.take loopLenInt $+        SigS.map (loopDepth *) $+        OsciS.static wave zero (recip loopLen))+++data TimeControl a = TimeControl a (Wave.T a a)++timeControlSine :: (Trans.C a) => TimeControl a+timeControlSine = TimeControl (2*pi) Wave.sine++timeControlZigZag :: (RealRing.C a) => TimeControl a+timeControlZigZag = TimeControl 4 Wave.triangle
src/Synthesizer/Generic/Noise.hs view
@@ -5,36 +5,27 @@  import qualified Synthesizer.State.Noise as Noise -import qualified Synthesizer.Generic.Signal  as SigG-import qualified Synthesizer.Generic.Signal2 as SigG2-import qualified Synthesizer.State.Signal      as SigS+import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.State.Signal as SigS -import qualified Algebra.Real                  as Real+import qualified Algebra.RealRing              as RealRing import qualified Algebra.Ring                  as Ring  import System.Random (Random, RandomGen, randomR, mkStdGen, )-import qualified System.Random as Rnd -import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   {-| Deterministic white noise, uniformly distributed between -1 and 1. That is, variance is 1\/3. -}-white ::-   (Ring.C y, Random y, SigG.Write sig y) =>-   SigG.LazySize -> sig y-white size =-   SigG.fromState size $ Noise.white+white :: (Ring.C y, Random y, SigG.Produce sig y) => sig y+white = SigG.fromState $ Noise.white -whiteGen ::-   (Ring.C y, Random y, RandomGen g, SigG.Write sig y) =>-   SigG.LazySize -> g -> sig y-whiteGen size =-   SigG.fromState size . Noise.whiteGen+whiteGen :: (Ring.C y, Random y, RandomGen g, SigG.Produce sig y) => g -> sig y+whiteGen = SigG.fromState . Noise.whiteGen   {- |@@ -42,14 +33,13 @@ by a quadratic B-spline distribution. -} whiteQuadraticBSplineGen ::-   (Ring.C y, Random y, RandomGen g, SigG.Write sig y) =>-   SigG.LazySize -> g -> sig y-whiteQuadraticBSplineGen size =-   SigG.fromState size . Noise.whiteQuadraticBSplineGen+   (Ring.C y, Random y, RandomGen g, SigG.Produce sig y) => g -> sig y+whiteQuadraticBSplineGen =+   SigG.fromState . Noise.whiteQuadraticBSplineGen   randomPeeks ::-   (Real.C y, Random y, SigG2.Transform sig y Bool) =>+   (RealRing.C y, Random y, SigG.Transform sig y, SigG.Transform sig Bool) =>       sig y    {- ^ momentary densities, @p@ means that there is about one peak                       in the time range of @1\/p@ samples -}    -> sig Bool {- ^ Every occurence of 'True' represents a peak. -}@@ -57,9 +47,9 @@    randomPeeksGen (mkStdGen 876)  randomPeeksGen ::-   (Real.C y, Random y, RandomGen g, SigG2.Transform sig y Bool) =>+   (RealRing.C y, Random y, RandomGen g, SigG.Transform sig y, SigG.Transform sig Bool) =>       g    -> sig y    -> sig Bool randomPeeksGen =-   SigG2.zipWithState (<) . SigS.unfoldR (Just . randomR (0,1))+   SigG.zipWithState (<) . SigS.unfoldR (Just . randomR (0,1))
src/Synthesizer/Generic/Oscillator.hs view
@@ -25,71 +25,56 @@ import qualified Synthesizer.Causal.Interpolation as Interpolation  import qualified Synthesizer.Generic.Signal  as SigG-import qualified Synthesizer.Generic.Signal2 as SigG2  import Control.Arrow ((>>>), ) -{--import qualified Algebra.RealTranscendental    as RealTrans-import qualified Algebra.Module                as Module-import qualified Algebra.VectorSpace           as VectorSpace--import Algebra.Module((*>))--} import qualified Algebra.Transcendental        as Trans import qualified Algebra.RealField             as RealField--- import qualified Algebra.Field                 as Field-import qualified Algebra.Ring                  as Ring-import qualified Algebra.Additive              as Additive --- import qualified Number.NonNegative       as NonNeg--import NumericPrelude---- import qualified Prelude as P-import PreludeBase+import NumericPrelude.Numeric+import NumericPrelude.Base    {- * Oscillators with arbitrary but constant waveforms -}  {- | oscillator with constant frequency -}-static :: (RealField.C a, SigG.Write sig b) =>-   SigG.LazySize ->+static :: (RealField.C a, SigG.Produce sig b) =>    Wave.T a b -> (Phase.T a -> a -> sig b)-static size wave phase freq =-   SigG.fromState size (OsciS.static wave phase freq)+static wave phase freq =+   SigG.fromState (OsciS.static wave phase freq)  {- | oscillator with modulated frequency -}-freqMod :: (RealField.C a, SigG2.Transform sig a b) =>+freqMod :: (RealField.C a, SigG.Transform sig a, SigG.Transform sig b) =>    Wave.T a b -> Phase.T a -> sig a -> sig b freqMod wave phase =-   Causal.applyGeneric (OsciC.freqMod wave phase)+   Causal.apply (OsciC.freqMod wave phase)  {- | oscillator with modulated phase -}-phaseMod :: (RealField.C a, SigG2.Transform sig a b) =>+phaseMod :: (RealField.C a, SigG.Transform sig a, SigG.Transform sig b) =>    Wave.T a b -> a -> sig a -> sig b phaseMod wave =    shapeMod (Wave.phaseOffset wave) zero  {- | oscillator with modulated shape -}-shapeMod :: (RealField.C a, SigG2.Transform sig c b) =>+shapeMod :: (RealField.C a, SigG.Transform sig c, SigG.Transform sig b) =>    (c -> Wave.T a b) -> Phase.T a -> a -> sig c -> sig b shapeMod wave phase freq =-   Causal.applyGeneric (OsciC.shapeMod wave phase freq)+   Causal.apply (OsciC.shapeMod wave phase freq)  {- | oscillator with both phase and frequency modulation -}-phaseFreqMod :: (RealField.C a, SigG2.Transform sig a b) =>+phaseFreqMod :: (RealField.C a, SigG.Transform sig a, SigG.Transform sig b) =>    Wave.T a b -> sig a -> sig a -> sig b phaseFreqMod wave =    shapeFreqMod (Wave.phaseOffset wave) zero  {- | oscillator with both shape and frequency modulation -} shapeFreqMod ::-   (RealField.C a, SigG.Read sig c, SigG2.Transform sig a b) =>+   (RealField.C a,+    SigG.Consume sig c, SigG.Transform sig a, SigG.Transform sig b) =>    (c -> Wave.T a b) -> Phase.T a -> sig c -> sig a -> sig b shapeFreqMod wave phase parameters =-   Causal.applyGeneric+   Causal.apply       (Causal.feedGenericFst parameters >>>        OsciC.shapeFreqMod wave phase) @@ -97,12 +82,11 @@ {- | oscillator with a sampled waveform with constant frequency This is essentially an interpolation with cyclic padding. -}-staticSample :: (RealField.C a, SigG.Read wave b, SigG.Write sig b) =>-   SigG.LazySize ->+staticSample :: (RealField.C a, SigG.Consume wave b, SigG.Produce sig b) =>    Interpolation.T a b -> wave b -> Phase.T a -> a -> sig b-staticSample size ip wave phase freq =+staticSample ip wave phase freq =    let len = fromIntegral $ SigG.length wave-   in  SigG.fromState size $+   in  SigG.fromState $        Interpolation.relativeCyclicPad           ip (len * Phase.toRepresentative phase)           (SigG.toState wave)@@ -112,14 +96,16 @@ {- | oscillator with a sampled waveform with modulated frequency Should behave homogenously for different types of interpolation. -}-freqModSample :: (RealField.C a, SigG.Read wave b, SigG2.Transform sig a b) =>+freqModSample ::+   (RealField.C a,+    SigG.Consume wave b, SigG.Transform sig a, SigG.Transform sig b) =>    Interpolation.T a b -> wave b -> Phase.T a -> sig a -> sig b freqModSample ip wave phase freqs =    let len = fromIntegral $ SigG.length wave    in  Interpolation.relativeCyclicPad           ip (len * Phase.toRepresentative phase)           (SigG.toState wave)-       `Causal.applyGeneric`+       `Causal.apply`        SigG.map (* len) freqs  @@ -130,33 +116,28 @@ {- * Oscillators with specific waveforms -}  {- | sine oscillator with static frequency -}-staticSine :: (Trans.C a, RealField.C a, SigG.Write sig a) =>-   SigG.LazySize ->+staticSine :: (Trans.C a, RealField.C a, SigG.Produce sig a) =>    Phase.T a -> a -> sig a-staticSine size =-   static size Wave.sine+staticSine = static Wave.sine  {- | sine oscillator with modulated frequency -} freqModSine :: (Trans.C a, RealField.C a, SigG.Transform sig a) =>    Phase.T a -> sig a -> sig a freqModSine phase =-   Causal.applyGenericSameType (OsciC.freqMod Wave.sine phase)+   Causal.applySameType (OsciC.freqMod Wave.sine phase)  {- | sine oscillator with modulated phase, useful for FM synthesis -} phaseModSine :: (Trans.C a, RealField.C a, SigG.Transform sig a) =>    a -> sig a -> sig a phaseModSine freq =-   Causal.applyGenericSameType (OsciC.phaseMod Wave.sine freq)+   Causal.applySameType (OsciC.phaseMod Wave.sine freq)  {- | saw tooth oscillator with modulated frequency -}-staticSaw :: (RealField.C a, SigG.Write sig a) =>-   SigG.LazySize ->-   Phase.T a -> a -> sig a-staticSaw size =-   static size Wave.saw+staticSaw :: (RealField.C a, SigG.Produce sig a) => Phase.T a -> a -> sig a+staticSaw = static Wave.saw  {- | saw tooth oscillator with modulated frequency -} freqModSaw :: (RealField.C a, SigG.Transform sig a) =>    Phase.T a -> sig a -> sig a freqModSaw phase =-   Causal.applyGenericSameType (OsciC.freqMod Wave.saw phase)+   Causal.applySameType (OsciC.freqMod Wave.saw phase)
src/Synthesizer/Generic/Piece.hs view
@@ -6,102 +6,110 @@ I created a new module. -} module Synthesizer.Generic.Piece (-   T, run,+   T, run, runChunks,    step, linear, exponential,    cosine, halfSine, cubic,    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 qualified Synthesizer.Storable.Signal as SigSt+import qualified Synthesizer.State.Signal as SigS+import Synthesizer.Generic.Displacement (raise, ) +import Foreign.Storable (Storable)+ import qualified Algebra.Transcendental        as Trans import qualified Algebra.RealField             as RealField import qualified Algebra.Field                 as Field-import qualified Algebra.Ring                  as Ring-import qualified Algebra.Additive              as Additive -import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base    {-# INLINE run #-} run :: (RealField.C a, CutG.Transform (sig a)) =>-   SigG.LazySize ->-   Piecewise.T a a (SigG.LazySize -> a -> sig a) ->-   sig a-run lazySize xs =+   Piecewise.T a a (a -> sig a) -> sig a+run xs =    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)+         SigG.take n $ Piecewise.computePiece c yi0 yi1 d t)+      (Piecewise.splitDurations $ map Piecewise.pieceDur xs)       xs +{-# INLINE runChunks #-}+runChunks :: (RealField.C a, Storable a) =>+   Piecewise.T a a (a -> SigS.T a) -> SigSt.T a+runChunks xs =+   SigSt.fromChunks $+   zipWith+      (\(n, t) (Piecewise.PieceData c yi0 yi1 d) ->+         SigS.toStrictStorableSignal n $ Piecewise.computePiece c yi0 yi1 d t)+      (Piecewise.splitDurations $ map Piecewise.pieceDur xs)+      xs + type T sig a =-   Piecewise.Piece a a-      (SigG.LazySize -> a {- fractional start time -} -> sig a)+   Piecewise.Piece a a (a {- fractional start time -} -> sig a)   {-# INLINE step #-}-step :: (SigG.Write sig a) => T sig a+step :: (SigG.Produce sig a) => T sig a step =-   Piecewise.pieceFromFunction $ \ y0 _y1 _d lazySize _t0 ->-      Ctrl.constant lazySize y0+   Piecewise.pieceFromFunction $ \ y0 _y1 _d _t0 ->+      Ctrl.constant y0  {-# INLINE linear #-}-linear :: (Field.C a, SigG.Write sig a) => T sig a+linear :: (Field.C a, SigG.Produce sig a) => T sig a linear =-   Piecewise.pieceFromFunction $ \ y0 y1 d lazySize t0 ->+   Piecewise.pieceFromFunction $ \ y0 y1 d t0 ->       let s = (y1-y0)/d-      in  Ctrl.linear lazySize s (y0-t0*s)+      in  Ctrl.linear s (y0-t0*s)  {-# INLINE exponential #-}-exponential :: (Trans.C a, SigG.Write sig a) => a -> T sig a+exponential :: (Trans.C a, SigG.Produce sig a) => a -> T sig a exponential saturation =-   Piecewise.pieceFromFunction $ \ y0 y1 d lazySize t0 ->+   Piecewise.pieceFromFunction $ \ y0 y1 d t0 ->       let y0' = y0-saturation           y1' = y1-saturation           yd  = y0'/y1'       in  raise saturation-             (Ctrl.exponential lazySize (d / log yd) (y0' * yd**(t0/d)))+             (Ctrl.exponential (d / log yd) (y0' * yd**(t0/d)))  {-# INLINE cosine #-}-cosine :: (Trans.C a, SigG.Write sig a) => T sig a+cosine :: (Trans.C a, SigG.Produce sig a) => T sig a cosine =-   Piecewise.pieceFromFunction $ \ y0 y1 d lazySize t0 ->+   Piecewise.pieceFromFunction $ \ y0 y1 d t0 ->       SigG.map          (\y -> ((1+y)*y0+(1-y)*y1)/2)-         (Ctrl.cosine lazySize t0 (t0+d))+         (Ctrl.cosine t0 (t0+d))   {- | > Graphics.Gnuplot.Simple.plotList [] $ Sig.toList $ run $ 1 |# (10.9, halfSine FlatRight) #| 2 -} {-# INLINE halfSine #-}-halfSine :: (Trans.C a, SigG.Write sig a) => FlatPosition -> T sig a+halfSine :: (Trans.C a, SigG.Produce sig a) => FlatPosition -> T sig a halfSine FlatLeft =-   Piecewise.pieceFromFunction $ \ y0 y1 d lazySize t0 ->+   Piecewise.pieceFromFunction $ \ y0 y1 d t0 ->       SigG.map          (\y -> y*y0 + (1-y)*y1)-         (Ctrl.cosine lazySize t0 (t0+2*d))+         (Ctrl.cosine t0 (t0+2*d)) halfSine FlatRight =-   Piecewise.pieceFromFunction $ \ y0 y1 d lazySize t0 ->+   Piecewise.pieceFromFunction $ \ y0 y1 d t0 ->       SigG.map          (\y -> (1+y)*y0 - y*y1)-         (Ctrl.cosine lazySize (t0-d) (t0+d))+         (Ctrl.cosine (t0-d) (t0+d))   {-# INLINE cubic #-}-cubic :: (Field.C a, SigG.Write sig a) => a -> a -> T sig a+cubic :: (Field.C a, SigG.Produce sig a) => a -> a -> T sig a cubic yd0 yd1 =-   Piecewise.pieceFromFunction $ \ y0 y1 d lazySize t0 ->-      Ctrl.cubicHermite lazySize (t0,(y0,yd0)) (t0+d,(y1,yd1))+   Piecewise.pieceFromFunction $ \ y0 y1 d t0 ->+      Ctrl.cubicHermite (t0,(y0,yd0)) (t0+d,(y1,yd1))
src/Synthesizer/Generic/Signal.hs view
@@ -1,5 +1,9 @@+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-} {- | Type classes that give a uniform interface to storable signals, stateful signals, lists, fusable lists.@@ -9,102 +13,121 @@ 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-import qualified Synthesizer.FusionList.Signal as SigFL import qualified Synthesizer.Storable.Signal as SigSt-import qualified Data.StorableVector.Lazy as Vector+import qualified Data.StorableVector.Lazy.Typed as SVT+import qualified Data.StorableVector.Lazy as SVL+import qualified Data.StorableVector as SV  import qualified Synthesizer.Plain.Modifier as Modifier -import qualified Algebra.Module   as Module-import qualified Algebra.Additive as Additive- import Foreign.Storable (Storable)  import Control.Monad.Trans.State (runState, runStateT, ) -import Data.Function (fix, ) import qualified Data.List.HT as ListHT import qualified Data.List as List-import Data.Tuple.HT (mapPair, mapFst, )+import Data.Function (fix, )+import Data.Tuple.HT (mapPair, mapFst, fst3, snd3, thd3, )+import Data.Bool.HT (if')+import Data.Monoid (Monoid, mappend, mempty, ) +import qualified Algebra.Module   as Module+import qualified Algebra.Additive as Additive++import qualified Data.EventList.Relative.BodyTime as EventList++import qualified Numeric.NonNegative.Class as NonNeg98++import qualified Prelude as P import Prelude-   (Bool, Int, Maybe(Just), maybe, snd, (<),-    flip, uncurry, const, (.), ($), id, (++),+   (Bool, Int, Maybe(Just), maybe, fst, snd,+    (==), (<), (>), (<=), (>=), compare, min, Ordering(..),+    flip, uncurry, const, (.), ($), (&&), id, (++),     fmap, return, error, show, )  -class Cut.Read (sig y) => Read sig y where-   toList :: sig y -> [y]-   toState :: sig y -> SigS.T y---   toState :: StateT (sig y) Maybe y-   foldL :: (s -> y -> s) -> s -> sig y -> s--- better move to Transform class?-   viewL :: sig y -> Maybe (y, sig y)-   viewR :: sig y -> Maybe (sig y, y)+{- $setup+>>> import qualified Synthesizer.Storable.Signal as SigSt+>>> import Synthesizer.Generic.Signal (delay, delayLoopOverlap)+>>> import Synthesizer.Generic.Filter.NonRecursive (amplify)+>>> import qualified Algebra.Additive as Additive+>>> import Data.Function (fix)+>>> import qualified Test.QuickCheck as QC+-} -class (Read sig y, Cut.Transform (sig y)) => Transform sig y where+++class Storage signal where++   data Constraints signal :: *++   constraints :: signal -> Constraints signal+++class Consume0 sig where+   toList :: Storage (sig y) => sig y -> [y]+   toState :: Storage (sig y) => sig y -> SigS.T y+--   toState :: Storage (sig y) => StateT (sig y) Maybe y+   foldL :: Storage (sig y) => (s -> y -> s) -> s -> sig y -> s+   foldR :: Storage (sig y) => (y -> s -> s) -> s -> sig y -> s+   index :: Storage (sig y) => sig y -> Int -> y++class (Cut.Consume (sig y), Consume0 sig, Storage (sig y)) => Consume sig y where++class (Consume0 sig) => Transform0 sig where+   cons :: Storage (sig y) => y -> sig y -> sig y+   takeWhile :: Storage (sig y) => (y -> Bool) -> sig y -> sig y+   dropWhile :: Storage (sig y) => (y -> Bool) -> sig y -> sig y+   span :: Storage (sig y) => (y -> Bool) -> sig y -> (sig y, sig y)+    {- |-   This function belongs logically to the Write class,-   but since an empty signal contains no data,-   the maximum package size is irrelevant.-   This makes e.g. the definition of mixMulti more general.+   When using 'viewL' for traversing a signal,+   it is certainly better to convert to State signal first,+   since this might involve optimized traversing+   like in case of Storable signals.    -}-   cons :: y -> sig y -> sig y-   takeWhile :: (y -> Bool) -> sig y -> sig y-   dropWhile :: (y -> Bool) -> sig y -> sig y-   span :: (y -> Bool) -> sig y -> (sig y, sig y)-   -- functions from Transform2 that are oftenly used with only one type variable-   map :: (y -> y) -> (sig y -> sig y)-   scanL :: (y -> y -> y) -> y -> sig y -> sig y-   crochetL :: (y -> s -> Maybe (y, s)) -> s -> sig y -> sig y-   zipWithAppend :: (y -> y -> y) -> sig y -> sig y -> sig y+   viewL :: Storage (sig y) => sig y -> Maybe (y, sig y)+   viewR :: Storage (sig y) => sig y -> Maybe (sig y, y) +   zipWithAppend :: Storage (sig y) => (y -> y -> y) -> sig y -> sig y -> sig y -{- |-This type is used for specification of the maximum size of strict packets.-Packets can be smaller, can have different sizes in one signal.-In some kinds of streams, like lists and stateful generators,-the packet size is always 1.-The packet size is not just a burden caused by efficiency,-but we need control over packet size in applications with feedback.--}-newtype LazySize = LazySize Int+   map ::+      (Storage (sig y0), Storage (sig y1)) =>+      (y0 -> y1) -> (sig y0 -> sig y1)+   scanL ::+      (Storage (sig y0), Storage (sig y1)) =>+      (y1 -> y0 -> y1) -> y1 -> sig y0 -> sig y1+   crochetL ::+      (Storage (sig y0), Storage (sig y1)) =>+      (y0 -> s -> Maybe (y1, s)) -> s -> sig y0 -> sig y1 -{- |-This can be used for internal signals-that have no observable effect on laziness.-E.g. when you construct a list-by @repeat defaultLazySize zero@-we assume that 'zero' is defined for all Additive types.--}-defaultLazySize :: LazySize-defaultLazySize =-   let (Vector.ChunkSize size) = Vector.defaultChunkSize-   in  LazySize size+class (Cut.Transform (sig y), Transform0 sig, Consume sig y) => Transform sig y where ++ {- | We could provide the 'LazySize' by a Reader monad, but we don't do that because we expect that the choice of the lazy size@@ -112,85 +135,245 @@ E.g. there is no need to have the same laziness coarseness for multiple signal processors. -}-class Transform sig y => Write sig y where-   fromList :: LazySize -> [y] -> sig y---   fromState :: LazySize -> SigS.T y -> sig y---   fromState :: LazySize -> StateT s Maybe y -> s -> sig y-   repeat :: LazySize -> y -> sig y-   replicate :: LazySize -> Int -> y -> sig y-   iterate :: LazySize -> (y -> y) -> y -> sig y-   iterateAssociative :: LazySize -> (y -> y -> y) -> y -> sig y-   unfoldR :: LazySize -> (s -> Maybe (y,s)) -> s -> sig y+class Transform0 sig => Produce0 sig where+   fromList :: Storage (sig y) => [y] -> sig y+   repeat :: Storage (sig y) => y -> sig y+   replicate :: Storage (sig y) => Int -> y -> sig y+   iterate :: Storage (sig y) => (y -> y) -> y -> sig y+   iterateAssociative :: Storage (sig y) => (y -> y -> y) -> y -> sig y+   unfoldR :: Storage (sig y) => (s -> Maybe (y,s)) -> s -> sig y +class (Produce0 sig, Transform sig y) => Produce sig y where --- instance Storable y => Read SigSt.T y where-instance Storable y => Read Vector.Vector y where++instance (Storable y) => Storage (SVT.Vector size y) where+   data Constraints (SVT.Vector size y) = Storable y => StorableTypedConstraints+   constraints _ = StorableTypedConstraints+++consumeSVT ::+   (Storable a => SVT.Vector size a -> b) ->+   (Storage (SVT.Vector size a) => SVT.Vector size a -> b)+consumeSVT f x = case constraints x of StorableTypedConstraints -> f x++produceSVT ::+   (Storable a => SVT.Vector size a) ->+   (Storage (SVT.Vector size a) => SVT.Vector size a)+produceSVT x =+   let z = case constraints z of StorableTypedConstraints -> x+   in  z++instance (SVT.Size size, Storable y) => Consume (SVT.Vector size) y where+-- instance Storable y => Consume SigSt.T y where++instance (SVT.Size size) => Consume0 (SVT.Vector size) where    {-# INLINE toList #-}-   toList = Vector.unpack+   toList = consumeSVT SVT.unpack    {-# INLINE toState #-}-   toState = SigS.fromStorableSignal-   {-# INLINE viewL #-}-   viewL = Vector.viewL-   {-# INLINE viewR #-}-   viewR = Vector.viewR+   toState = consumeSVT (SigS.fromStorableSignal . SVT.toVectorLazy)    {-# INLINE foldL #-}-   foldL = Vector.foldl+   foldL f x = consumeSVT (SVT.foldl f x)+   {-# INLINE foldR #-}+   foldR f x = consumeSVT (SVT.foldr f x)+   {-# INLINE index #-}+   index = consumeSVT SVT.index -instance Storable y => Transform Vector.Vector y where++instance (SVT.Size size, Storable y) => Transform (SVT.Vector size) y where++instance (SVT.Size size) => Transform0 (SVT.Vector size) where    {-# INLINE cons #-}-   cons = Vector.cons+   cons x = consumeSVT (SVT.cons x)    {-# INLINE takeWhile #-}-   takeWhile = Vector.takeWhile+   takeWhile p = consumeSVT (SVT.takeWhile p)    {-# INLINE dropWhile #-}-   dropWhile = Vector.dropWhile+   dropWhile p = consumeSVT (SVT.dropWhile p)    {-# INLINE span #-}-   span = Vector.span+   span p = consumeSVT (SVT.span p) +   {-# INLINE viewL #-}+   viewL = consumeSVT SVT.viewL+   {-# INLINE viewR #-}+   viewR = consumeSVT SVT.viewR+    {-# INLINE map #-}-   map = Vector.map+   map f x = produceSVT (consumeSVT (SVT.map f) x)    {-# INLINE scanL #-}-   scanL = Vector.scanl+   scanL f a x = produceSVT (consumeSVT (SVT.scanl f a) x)    {-# INLINE crochetL #-}-   crochetL = Vector.crochetL+   crochetL f a x = produceSVT (consumeSVT (SVT.crochetL f a) x)    {-# INLINE zipWithAppend #-}-   zipWithAppend = SigSt.zipWithAppend+   zipWithAppend f = consumeSVT (SVT.zipWithAppend f)   -withStorableContext ::-   (Vector.ChunkSize -> a) -> (LazySize -> a)-withStorableContext f =-   \(LazySize size) -> f (Vector.ChunkSize size)+instance (SVT.Size size, Storable y) => Produce (SVT.Vector size) y where -instance Storable y => Write Vector.Vector y where+instance (SVT.Size size) => Produce0 (SVT.Vector size) where    {-# INLINE fromList #-}-   fromList = withStorableContext $ \size -> Vector.pack size+   fromList = \x -> produceSVT (SVT.pack x)    {-# INLINE repeat #-}-   repeat = withStorableContext $ \size -> Vector.repeat size+   repeat = \x -> produceSVT (SVT.repeat x)    {-# INLINE replicate #-}-   replicate = withStorableContext $ \size -> Vector.replicate size+   replicate = \n x -> produceSVT (SVT.replicate n x)    {-# INLINE iterate #-}-   iterate = withStorableContext $ \size -> Vector.iterate size+   iterate = \f x -> produceSVT (SVT.iterate f x)    {-# INLINE unfoldR #-}-   unfoldR = withStorableContext $ \size -> Vector.unfoldr size+   unfoldR = \f x -> produceSVT (SVT.unfoldr f x)    {-# INLINE iterateAssociative #-}-   iterateAssociative = withStorableContext $ \size op x -> Vector.iterate size (op x) x -- should be optimized+   iterateAssociative = \op x -> produceSVT (SVT.iterate (op x) x) -- should be optimized   -instance Read [] y where+instance (Storable y) => Storage (SVL.Vector y) where+   data Constraints (SVL.Vector y) = Storable y => StorableLazyConstraints+   constraints _ = StorableLazyConstraints+++consumeSVL ::+   (Storable a => SVL.Vector a -> b) ->+   (Storage (SVL.Vector a) => SVL.Vector a -> b)+consumeSVL f x = case constraints x of StorableLazyConstraints -> f x++produceSVL ::+   (Storable a => SVL.Vector a) ->+   (Storage (SVL.Vector a) => SVL.Vector a)+produceSVL x =+   let z = case constraints z of StorableLazyConstraints -> x+   in  z++instance Storable y => Consume SVL.Vector y where+-- instance Storable y => Consume SigSt.T y where++instance Consume0 SVL.Vector where    {-# INLINE toList #-}-   toList = id+   toList = consumeSVL SVL.unpack    {-# INLINE toState #-}-   toState = SigS.fromList+   toState = consumeSVL SigS.fromStorableSignal+   {-# INLINE foldL #-}+   foldL f x = consumeSVL (SVL.foldl f x)+   {-# INLINE foldR #-}+   foldR f x = consumeSVL (SVL.foldr f x)+   {-# INLINE index #-}+   index = consumeSVL SVL.index+++instance Storable y => Transform SVL.Vector y where++instance Transform0 SVL.Vector where+   {-# INLINE cons #-}+   cons x = consumeSVL (SVL.cons x)+   {-# INLINE takeWhile #-}+   takeWhile p = consumeSVL (SVL.takeWhile p)+   {-# INLINE dropWhile #-}+   dropWhile p = consumeSVL (SVL.dropWhile p)+   {-# INLINE span #-}+   span p = consumeSVL (SVL.span p)+    {-# INLINE viewL #-}-   viewL = ListHT.viewL+   viewL = consumeSVL SVL.viewL    {-# INLINE viewR #-}-   viewR = ListHT.viewR+   viewR = consumeSVL SVL.viewR++   {-# INLINE map #-}+   map f x = produceSVL (consumeSVL (SVL.map f) x)+   {-# INLINE scanL #-}+   scanL f a x = produceSVL (consumeSVL (SVL.scanl f a) x)+   {-# INLINE crochetL #-}+   crochetL f a x = produceSVL (consumeSVL (SVL.crochetL f a) x)+   {-# INLINE zipWithAppend #-}+   zipWithAppend f = consumeSVL (SigSt.zipWithAppend f)++++instance (Storable y) => Storage (SV.Vector y) where+   data Constraints (SV.Vector y) = Storable y => StorableConstraints+   constraints _ = StorableConstraints++consumeSV ::+   (Storable a => SV.Vector a -> b) ->+   (Storage (SV.Vector a) => SV.Vector a -> b)+consumeSV f x = case constraints x of StorableConstraints -> f x++produceSV ::+   (Storable a => SV.Vector a) ->+   (Storage (SV.Vector a) => SV.Vector a)+produceSV x =+   let z = case constraints z of StorableConstraints -> x+   in  z+++instance Storable y => Consume SV.Vector y where++instance Consume0 SV.Vector where+   {-# INLINE toList #-}+   toList = consumeSV SV.unpack+   {-# INLINE toState #-}+   toState = consumeSV SigS.fromStrictStorableSignal    {-# INLINE foldL #-}+   foldL f x = consumeSV (SV.foldl f x)+   {-# INLINE foldR #-}+   foldR f x = consumeSV (SV.foldr f x)+   {-# INLINE index #-}+   index = consumeSV SV.index++instance Storable y => Transform SV.Vector y where++instance Transform0 SV.Vector where+   {-# INLINE cons #-}+   cons x = consumeSV (SV.cons x)+   {-# INLINE takeWhile #-}+   takeWhile p = consumeSV (SV.takeWhile p)+   {-# INLINE dropWhile #-}+   dropWhile p = consumeSV (SV.dropWhile p)+   {-# INLINE span #-}+   span p = consumeSV (SV.span p)++   {-# INLINE viewL #-}+   viewL = consumeSV SV.viewL+   {-# INLINE viewR #-}+   viewR = consumeSV SV.viewR++   {-# INLINE map #-}+   map f x = produceSV (consumeSV (SV.map f) x)+   {-# INLINE scanL #-}+   scanL f a x = produceSV (consumeSV (SV.scanl f a) x)+   {-# INLINE crochetL #-}+   crochetL f a x =+      produceSV (fst (consumeSV (SV.crochetLResult f a) x))+      -- fst . SV.crochetContL f acc+   {-# INLINE zipWithAppend #-}+   zipWithAppend f =+      consumeSV (\xs ys ->+         case compare (SV.length xs) (SV.length ys) of+            EQ -> SV.zipWith f xs ys+            LT -> SV.append (SV.zipWith f xs ys) (SV.drop (SV.length xs) ys)+            GT -> SV.append (SV.zipWith f xs ys) (SV.drop (SV.length ys) xs))++++instance Storage [y] where+   data Constraints [y] = ListConstraints+   constraints _ = ListConstraints++instance Consume [] y where++instance Consume0 [] where+   {-# INLINE toList #-}+   toList = id+   {-# INLINE toState #-}+   toState = SigS.fromList+   {-# INLINE foldL #-}    foldL = List.foldl+   {-# INLINE foldR #-}+   foldR = List.foldr+   {-# INLINE index #-}+   index = (List.!!) + instance Transform [] y where++instance Transform0 [] where    {-# INLINE cons #-}    cons = (:)    {-# INLINE takeWhile #-}@@ -200,6 +383,11 @@    {-# INLINE span #-}    span = List.span +   {-# INLINE viewL #-}+   viewL = ListHT.viewL+   {-# INLINE viewR #-}+   viewR = ListHT.viewR+    {-# INLINE map #-}    map = List.map    {-# INLINE scanL #-}@@ -210,151 +398,339 @@    zipWithAppend = Sig.zipWithAppend  -instance Write [] y where+instance Produce [] y where++instance Produce0 [] where    {-# INLINE fromList #-}-   fromList _ = id+   fromList = id    {-# INLINE repeat #-}-   repeat _ = List.repeat+   repeat = List.repeat    {-# INLINE replicate #-}-   replicate _ = List.replicate+   replicate = List.replicate    {-# INLINE iterate #-}-   iterate _ = List.iterate+   iterate = List.iterate    {-# INLINE unfoldR #-}-   unfoldR _ = List.unfoldr+   unfoldR = List.unfoldr    {-# INLINE iterateAssociative #-}-   iterateAssociative _ = ListHT.iterateAssociative+   iterateAssociative = ListHT.iterateAssociative   -instance Read SigFL.T y where+instance Storage (SigS.T y) where+   data Constraints (SigS.T y) = StateConstraints+   constraints _ = StateConstraints++instance Consume SigS.T y++instance Consume0 SigS.T where    {-# INLINE toList #-}-   toList = SigFL.toList+   toList = SigS.toList    {-# INLINE toState #-}-   toState = SigS.fromList . SigFL.toList-   {-# INLINE viewL #-}-   viewL = SigFL.viewL-   {-# INLINE viewR #-}-   viewR = SigFL.viewR+   toState = id    {-# INLINE foldL #-}-   foldL = SigFL.foldL+   foldL = SigS.foldL+   {-# INLINE foldR #-}+   foldR = SigS.foldR+   {-# INLINE index #-}+   index = indexByDrop -instance Transform SigFL.T y where++instance Transform SigS.T y++instance Transform0 SigS.T where    {-# INLINE cons #-}-   cons = SigFL.cons+   cons = SigS.cons    {-# INLINE takeWhile #-}-   takeWhile = SigFL.takeWhile+   takeWhile = SigS.takeWhile    {-# INLINE dropWhile #-}-   dropWhile = SigFL.dropWhile+   dropWhile = SigS.dropWhile    {-# INLINE span #-}-   span = SigFL.span+   span p =+      -- This implementation is slow. Better leave it unimplemented?+      mapPair (SigS.fromList, SigS.fromList) .+      List.span p . SigS.toList +   {-# INLINE viewL #-}+   viewL = SigS.viewL+   {-# INLINE viewR #-}+   viewR =+      -- This implementation is slow. Better leave it unimplemented?+      fmap (mapFst SigS.fromList) .+      ListHT.viewR . SigS.toList+    {-# INLINE map #-}-   map = SigFL.map+   map = SigS.map    {-# INLINE scanL #-}-   scanL = SigFL.scanL+   scanL = SigS.scanL    {-# INLINE crochetL #-}-   crochetL = SigFL.crochetL+   crochetL = SigS.crochetL    {-# INLINE zipWithAppend #-}-   zipWithAppend = SigFL.zipWithAppend+   zipWithAppend = SigS.zipWithAppend  -instance Write SigFL.T y where+instance Produce SigS.T y++instance Produce0 SigS.T where    {-# INLINE fromList #-}-   fromList _ = SigFL.fromList+   fromList = SigS.fromList    {-# INLINE repeat #-}-   repeat _ = SigFL.repeat+   repeat = SigS.repeat    {-# INLINE replicate #-}-   replicate _ = SigFL.replicate+   replicate = SigS.replicate    {-# INLINE iterate #-}-   iterate _ = SigFL.iterate+   iterate = SigS.iterate    {-# INLINE unfoldR #-}-   unfoldR _ = SigFL.unfoldR+   unfoldR = SigS.unfoldR    {-# INLINE iterateAssociative #-}-   iterateAssociative _ = SigFL.iterateAssociative+   iterateAssociative = SigS.iterateAssociative  +instance Storage (EventList.T time y) where+   data Constraints (EventList.T time y) = EventListConstraints+   constraints _ = EventListConstraints -instance Read SigS.T y where+instance (NonNeg98.C time, P.Integral time) =>+      Consume (EventList.T time) y where++instance (NonNeg98.C time, P.Integral time) =>+      Consume0 (EventList.T time) where    {-# INLINE toList #-}-   toList = SigS.toList+   toList =+      List.concatMap (uncurry (flip List.genericReplicate)) .+      EventList.toPairList    {-# INLINE toState #-}-   toState = id-   {-# INLINE viewL #-}-   viewL = SigS.viewL-   {-# INLINE viewR #-}-   viewR =-      -- This implementation is slow. Better leave it unimplemented?-      fmap (mapFst SigS.fromList) .-      ListHT.viewR . SigS.toList+   toState = SigS.fromPiecewiseConstant    {-# INLINE foldL #-}-   foldL = SigS.foldL+   foldL f x = SigS.foldL f x . toState+   {-# INLINE foldR #-}+   foldR f x = SigS.foldR f x . toState+   {-# INLINE index #-}+   index sig n =+      EventList.foldrPair+         (\b t go k ->+            if k < t+              then b+              else go (t NonNeg98.-| k))+         (error $ "EventList.index: positions " ++ show n ++ " out of range")+         sig+         (P.fromIntegral n) -instance Transform SigS.T y where+instance (NonNeg98.C time, P.Integral time) =>+      Transform (EventList.T time) y where++instance (NonNeg98.C time, P.Integral time) =>+      Transform0 (EventList.T time) where    {-# INLINE cons #-}-   cons = SigS.cons+   cons b = EventList.cons b (P.fromInteger 1)    {-# INLINE takeWhile #-}-   takeWhile = SigS.takeWhile+   takeWhile p =+      EventList.foldrPair+         (\b t rest ->+            if p b+              then EventList.cons b t rest+              else EventList.empty)+         EventList.empty    {-# INLINE dropWhile #-}-   dropWhile = SigS.dropWhile+   dropWhile p =+      let recourse xs =+             flip (EventList.switchL EventList.empty) xs $ \b _t rest ->+             if p b+               then recourse rest+               else xs+      in  recourse    {-# INLINE span #-}    span p =-      -- This implementation is slow. Better leave it unimplemented?-      mapPair (SigS.fromList, SigS.fromList) .-      List.span p . SigS.toList+      let recourse xs =+             flip (EventList.switchL (EventList.empty,EventList.empty)) xs $ \b t rest ->+             if p b+               then mapFst (EventList.cons b t) $ recourse rest+               else (EventList.empty, xs)+      in  recourse +   {-# INLINE viewL #-}+   viewL xs = do+      ((b,t),ys) <- EventList.viewL xs+      if t>0+        then Just (b, if t==1 then ys else EventList.cons b (t NonNeg98.-|1) ys)+        else viewL ys+   {-# INLINE viewR #-}+   viewR =+      let dropTrailingZeros =+             EventList.foldrPair+                (\b t rest ->+                   if t==0 && EventList.null rest+                     then EventList.empty+                     else EventList.cons b t rest)+                EventList.empty+          recourse (b,t) =+             EventList.switchL+                (if t<=1+                   then EventList.empty+                   else EventList.singleton b (t NonNeg98.-| 1),+                 b)+                (\b0 t0 xs0 ->+                   mapFst (EventList.cons b t) $ recourse (b0,t0) xs0)+      in  fmap (uncurry recourse) . EventList.viewL . dropTrailingZeros+    {-# INLINE map #-}-   map = SigS.map+   map = fmap    {-# INLINE scanL #-}-   scanL = SigS.scanL+   scanL f x = eventListFromList . toList . SigS.scanL f x . toState    {-# INLINE crochetL #-}-   crochetL = SigS.crochetL+   crochetL f x = eventListFromList . toList . SigS.crochetL f x . toState    {-# INLINE zipWithAppend #-}-   zipWithAppend = SigS.zipWithAppend+   zipWithAppend f =+      let recourse xs ys =+             flip (EventList.switchL ys) xs $ \x xn xs0 ->+             flip (EventList.switchL xs) ys $ \y yn ys0 ->+             let n = min xn yn+                 drop_ a an as0 =+                    if n>=an+                      then as0+                      else EventList.cons a (an NonNeg98.-| n) as0+             in  EventList.cons (f x y) n $+                 recourse+                    (drop_ x xn xs0)+                    (drop_ y yn ys0)+      in  recourse +eventListFromList ::+   (NonNeg98.C time, P.Integral time) => [y] -> EventList.T time y+eventListFromList =+   EventList.fromPairList . List.map (flip (,) (P.fromInteger 1)) -instance Write SigS.T y where++{-+instance (NonNeg98.C time, P.Integral time) => Produce (EventList.T time) y where++instance (NonNeg98.C time, P.Integral time) => Produce0 (EventList.T time) where    {-# INLINE fromList #-}-   fromList _ = SigS.fromList+   fromList _ =+      EventList.fromPairList .+      List.map (flip (,) (P.fromInteger 1))    {-# INLINE repeat #-}-   repeat _ = SigS.repeat+   repeat (LazySize n) a =+      let xs = EventList.cons a (P.fromIntegral n) xs+      in  xs    {-# INLINE replicate #-}-   replicate _ = SigS.replicate+   replicate size m a =+      Cut.take m (repeat size a)    {-# INLINE iterate #-}-   iterate _ = SigS.iterate+   iterate size f =+      fromState size . SigS.iterate f    {-# INLINE unfoldR #-}-   unfoldR _ = SigS.unfoldR+   unfoldR _size f =+      let recourse =+             maybe EventList.empty+                (\(x,s) -> EventList.cons x+                   (P.fromInteger 1) (recourse s)) . f+      in  recourse    {-# INLINE iterateAssociative #-}-   iterateAssociative _ = SigS.iterateAssociative-+   iterateAssociative size f x = iterate size (f x) x+-}   {-# INLINE switchL #-}-switchL :: (Read sig y) =>+switchL :: (Transform sig y) =>    a -> (y -> sig y -> a) -> sig y -> a switchL nothing just =    maybe nothing (uncurry just) . viewL +{-# INLINE switchR #-}+switchR :: (Transform sig y) =>+   a -> (sig y -> y -> a) -> sig y -> a+switchR nothing just =+   maybe nothing (uncurry just) . viewR++{-# INLINE runViewL #-}+runViewL ::+   (Consume sig y) =>+   sig y ->+   (forall s. (s -> Maybe (y, s)) -> s -> x) ->+   x+runViewL xs =+   SigS.runViewL (toState xs)++{-# INLINE runSwitchL #-}+runSwitchL ::+   (Consume sig y) =>+   sig y ->+   (forall s. (forall z. z -> (y -> s -> z) -> s -> z) -> s -> x) ->+   x+runSwitchL xs =+   SigS.runSwitchL (toState xs)+++{-# INLINE singleton #-}+singleton :: (Transform sig y) => y -> sig y+singleton x = cons x mempty+ {-# INLINE mix #-} mix :: (Additive.C y, Transform sig y) =>    sig y -> sig y -> sig y mix = zipWithAppend (Additive.+) +{-# INLINE zip #-}+zip :: (Consume sig a, Transform sig b, Transform sig (a,b)) =>+   sig a -> sig b -> sig (a,b)+zip = zipWith (,)+ {-# INLINE zipWith #-}-zipWith :: (Read sig a, Transform sig b) =>-   (a -> b -> b) -> (sig a -> sig b -> sig b)-zipWith h a =-   crochetL-      (\x0 a0 ->-          do (y0,a1) <- viewL a0-             Just (h y0 x0, a1))-      a+zipWith :: (Consume sig a, Transform sig b, Transform sig c) =>+   (a -> b -> c) -> (sig a -> sig b -> sig c)+zipWith h = zipWithState h . toState +{-# INLINE zipWith3 #-}+zipWith3 :: (Consume sig a, Consume sig b, Transform sig c) =>+   (a -> b -> c -> c) -> (sig a -> sig b -> sig c -> sig c)+zipWith3 h as bs = zipWithState3 h (toState as) (toState bs) +{-# INLINE zipWithState #-}+zipWithState :: (Transform sig b, Transform sig c) =>+   (a -> b -> c) -> SigS.T a -> sig b -> sig c+zipWithState f sig =+   SigS.runViewL sig (\next ->+   crochetL (\b as0 ->+      do (a,as1) <- next as0+         Just (f a b, as1)))++{-# INLINE zipWithState3 #-}+zipWithState3 :: (Transform sig c, Transform sig d) =>+   (a -> b -> c -> d) -> (SigS.T a -> SigS.T b -> sig c -> sig d)+zipWithState3 h a b =+   zipWithState ($) (SigS.zipWith h a b)++++{-# INLINE unzip #-}+unzip :: (Transform sig (a,b), Transform sig a, Transform sig b) =>+   sig (a,b) -> (sig a, sig b)+unzip xs =+   (map fst xs, map snd xs)++{-# INLINE unzip3 #-}+unzip3 :: (Transform sig (a,b,c), Transform sig a, Transform sig b, Transform sig c) =>+   sig (a,b,c) -> (sig a, sig b, sig c)+unzip3 xs =+   (map fst3 xs, map snd3 xs, map thd3 xs)++++{- |+@takeStateMatch len xs@+keeps a prefix of @xs@ of the same length and block structure as @len@+and stores it in the same type of container as @len@.+-}+{-# INLINE takeStateMatch #-}+takeStateMatch :: (Transform sig a, Transform sig b) =>+   sig a -> SigS.T b -> sig b+takeStateMatch x y =+   zipWithState const y x++ {-# INLINE delay #-}-delay :: (Write sig y) =>-   LazySize -> y -> Int -> sig y -> sig y-delay size z n =-   append (replicate size n z)+delay :: (Produce sig y) => y -> Int -> sig y -> sig y+delay z n = append (replicate n z)  {-# INLINE delayLoop #-} delayLoop ::@@ -367,29 +743,87 @@    fix (append prefix . proc)  +{- |+Inefficient for @State.Signal@.++>>> delayLoopOverlap 5 (amplify 0.5) [1::Float]+[1.0]+>>> delayLoopOverlap 5 (amplify 0.5) [1,0,0,0,0::Float]+[1.0,0.0,0.0,0.0,0.0]+>>> delayLoopOverlap 5 (amplify 0.5) [1,0,0,0,0,0::Float]+[1.0,0.0,0.0,0.0,0.0,0.5]+>>> delayLoopOverlap 5 (amplify 0.5) [1,0,0,0,0,0,0,0,0::Float]+[1.0,0.0,0.0,0.0,0.0,0.5,0.0,0.0,0.0]++prop> :{+   QC.forAll (QC.choose (1,10)) $ \time ->+   QC.forAll (QC.choose (1,10)) $ \cs ->+   QC.forAll (QC.choose (0.5,1.0::Float)) $ \gain ->+   \xs ->+   delayLoopOverlap time (amplify gain) xs+   ==+   (SigSt.toList $+    delayLoopOverlap time (amplify gain) $+    SigSt.fromList (SigSt.chunkSize cs) xs)+:}++prop> :{+   let delayLoopOverlapProduce time proc xs =+         fix (zipWith (Additive.+) xs . delay Additive.zero time . proc)+   in QC.forAll (QC.choose (1,10)) $ \time ->+      QC.forAll (QC.choose (0.5,1.0)) $ \gain ->+      \xs ->+      delayLoopOverlap time (amplify gain) xs+      ==+      delayLoopOverlapProduce time (amplify gain) (xs :: [Float])+:}+-} {-# INLINE delayLoopOverlap #-} delayLoopOverlap ::-   (Additive.C y, Write sig y) =>+   (Additive.C y, Transform sig y) =>       Int    -> (sig y -> sig y)             {- ^ Processor that shall be run in a feedback loop.                  It's absolutely necessary that this function preserves the chunk structure                  and that it does not look a chunk ahead.                  That's guaranteed for processes that do not look ahead at all,-                 like 'Vector.map', 'Vector.crochetL' and+                 like 'SVL.map', 'SVL.crochetL' and                  all of type @Causal.Process@. -}    -> sig y -- ^ input    -> sig y -- ^ output has the same length as the input delayLoopOverlap time proc xs =-   fix (zipWith (Additive.+) xs .-        delay defaultLazySize Additive.zero time . proc)+   if' (Cut.null xs) mempty $+   let (prefix, suffix) = Cut.splitAt time xs+   in fix (mappend prefix . zipWith (Additive.+) suffix . proc)    {-# INLINE sum #-}-sum :: (Additive.C a, Read sig a) => sig a -> a+sum :: (Additive.C a, Consume sig a) => sig a -> a sum = foldL (Additive.+) Additive.zero +{-# INLINE sum1 #-}+sum1 :: (Additive.C a, Consume sig a) => sig a -> a+sum1 = SigS.foldL1 (Additive.+) . toState+{-+sum1 :: (Additive.C a, Transform sig a) => sig a -> a+sum1 =+   switchL+      (error "Generic.Signal.sum1: signal must be non-empty in order to avoid to use a non-existing zero")+      (foldL (Additive.+))+-}+++{-# INLINE foldMap #-}+foldMap :: (Consume sig a, Monoid m) => (a -> m) -> sig a -> m+foldMap f = foldR (mappend . f) mempty++{-# DEPRECATED monoidConcatMap "Use foldMap instead." #-}+{-# INLINE monoidConcatMap #-}+monoidConcatMap :: (Consume sig a, Monoid m) => (a -> m) -> sig a -> m+monoidConcatMap = foldMap++ {-# INLINE tails #-} tails :: (Transform sig y) => sig y -> SigS.T (sig y) tails =@@ -404,7 +838,7 @@    switchL xs (flip const) xs  {-# INLINE mapAdjacent #-}-mapAdjacent :: (Read sig a, Transform sig a) =>+mapAdjacent :: (Consume sig a, Transform sig a) =>    (a -> a -> a) -> sig a -> sig a mapAdjacent f xs0 =    let xs1 = maybe xs0 snd (viewL xs0)@@ -418,15 +852,16 @@  {-| Here the control may vary over the time. -} {-# INLINE modifyModulated #-}-modifyModulated :: (Transform sig a, Read sig ctrl) =>-   Modifier.Simple s ctrl a a -> sig ctrl -> sig a -> sig a+modifyModulated :: (Transform sig a, Transform sig b, Consume sig ctrl) =>+   Modifier.Simple s ctrl a b -> sig ctrl -> sig a -> sig b modifyModulated (Modifier.Simple state proc) control =+   runViewL control (\next c0 ->    crochetL       (\x (acc0,cs0) ->-         do (c,cs1) <- viewL cs0+         do (c,cs1) <- next cs0             let (y,acc1) = runState (proc c x) acc0             return (y,(acc1,cs1)))-      (state,control)+      (state, c0)) {- modifyModulated (Modifier.Simple state proc) control x =    crochetL@@ -437,27 +872,27 @@ -- cf. Module.linearComb {-# INLINE linearComb #-} linearComb ::-   (Module.C t y, Read sig t, Read sig y) =>+   (Module.C t y, Consume sig t, Consume sig y) =>    sig t -> sig y -> y linearComb ts ys =    SigS.sum (SigS.zipWith (Module.*>) (toState ts) (toState ys))  -fromState :: (Write sig y) =>-   LazySize -> SigS.T y -> sig y-fromState size (SigS.Cons f x) =-   unfoldR size (runStateT f) x+fromState :: (Produce sig y) => SigS.T y -> sig y+fromState (SigS.Cons f x) = unfoldR (runStateT f) x  {-# INLINE extendConstant #-}-extendConstant :: (Write sig y) =>-   LazySize -> sig y -> sig y-extendConstant size xt =+extendConstant :: (Produce sig y) => sig y -> sig y+extendConstant xt =    maybe       xt-      (append xt . repeat size . snd)+      (append xt . repeat . snd)       (viewR xt) +snoc :: (Transform sig y) => sig y -> y -> sig y+snoc xs x = append xs $ singleton x + -- comonadic 'bind' -- only non-empty suffixes are processed {-# INLINE mapTails #-}@@ -474,10 +909,9 @@ Thus we prefer crochetL, although we do not consume single elements of the input signal. -} mapTailsAlt ::-   (Read sig a, Write sig b) =>-   LazySize -> (sig a -> b) -> sig a -> sig b-mapTailsAlt size f =-   unfoldR size (\xs ->+   (Transform sig a, Produce sig b) => (sig a -> b) -> sig a -> sig b+mapTailsAlt f =+   unfoldR (\xs ->       do (_,ys) <- viewL xs          Just (f xs, ys)) @@ -485,15 +919,15 @@ Only non-empty suffixes are processed. More oftenly we might need -> zipWithTails :: (Read sig b, Transform2 sig a) =>+> zipWithTails :: (Consume sig b, Transform sig a) => >    (b -> sig a -> a) -> sig b -> sig a -> sig a  this would preserve the chunk structure of @sig a@, but it is a bit more hassle to implement that. -} {-# INLINE zipWithTails #-}-zipWithTails :: (Read sig b, Transform sig a) =>-   (a -> sig b -> a) -> sig a -> sig b -> sig a+zipWithTails :: (Transform sig a, Transform sig b, Transform sig c) =>+   (a -> sig b -> c) -> sig a -> sig b -> sig c zipWithTails f =    flip (crochetL (\x ys0 ->       do (_,ys) <- viewL ys0@@ -506,12 +940,8 @@ -}  --{--ToDo: make a method of Read class--}-index :: (Transform sig a) => sig a -> Int -> a-index xs n =+indexByDrop :: (Transform sig a) => sig a -> Int -> a+indexByDrop xs n =    if n<0      then error $ "Generic.index: negative index " ++ show n      else switchL
− src/Synthesizer/Generic/Signal2.hs 
@@ -1,167 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{- |-Type class for several signal storage types-that allows alter element types.-There is some overlap between the two @Transform@ classes.-This was done in order to save us-from ubiquitous @Transform sig y y@ constraints.--}-module Synthesizer.Generic.Signal2 where--import Synthesizer.Generic.Signal (Read, viewL, sum, )-import qualified Synthesizer.Generic.Signal as SigG--import qualified Algebra.Module   as Module--- import qualified Algebra.Additive as Additive--import qualified Synthesizer.State.Signal as SigS-import qualified Synthesizer.Plain.Signal as Sig--- import qualified Synthesizer.Storable.Signal as SigSt-import qualified Data.StorableVector.Lazy as Vector--import qualified Synthesizer.Plain.Modifier as Modifier--import Foreign.Storable (Storable)--import Control.Monad.Trans.State (runState, )--import qualified Data.List as List--import Data.Tuple.HT (fst3, snd3, thd3, )-import Prelude-   (Bool, Int, Maybe(Just), maybe, fst, snd,-    flip,-    return, )---class (SigG.Transform sig y0, SigG.Transform sig y1) =>-          Transform sig y0 y1 where-   map :: (y0 -> y1) -> (sig y0 -> sig y1)-   scanL :: (y1 -> y0 -> y1) -> y1 -> sig y0 -> sig y1-   crochetL :: (y0 -> s -> Maybe (y1, s)) -> s -> sig y0 -> sig y1---instance (Storable y0, Storable y1) => Transform Vector.Vector y0 y1 where-   {-# INLINE map #-}-   map = Vector.map-   {-# INLINE scanL #-}-   scanL = Vector.scanl-   {-# INLINE crochetL #-}-   crochetL = Vector.crochetL---instance Transform [] y0 y1 where-   {-# INLINE map #-}-   map = List.map-   {-# INLINE scanL #-}-   scanL = List.scanl-   {-# INLINE crochetL #-}-   crochetL = Sig.crochetL---instance Transform SigS.T y0 y1 where-   {-# INLINE map #-}-   map = SigS.map-   {-# INLINE scanL #-}-   scanL = SigS.scanL-   {-# INLINE crochetL #-}-   crochetL = SigS.crochetL----{-# INLINE zipWith #-}-zipWith :: (Read sig a, Transform sig b c) =>-   (a -> b -> c) -> (sig a -> sig b -> sig c)-zipWith h a =-   crochetL-      (\x0 a0 ->-          do (y0,a1) <- viewL a0-             Just (h y0 x0, a1))-      a--{-# INLINE mapAdjacent #-}-mapAdjacent :: (Read sig a, Transform sig a b) =>-   (a -> a -> b) -> sig a -> sig b-mapAdjacent f xs0 =-   let xs1 = maybe xs0 snd (viewL xs0)-   in  zipWith f xs0 xs1---{-# INLINE zip #-}-zip :: (Read sig a, Transform sig b (a,b)) =>-   sig a -> sig b -> sig (a,b)-zip = zipWith (,)---{-# INLINE unzip #-}-unzip :: (Transform sig (a,b) a, Transform sig (a,b) b) =>-   sig (a,b) -> (sig a, sig b)-unzip xs =-   (map fst xs, map snd xs)--{-# INLINE unzip3 #-}-unzip3 :: (Transform sig (a,b,c) a, Transform sig (a,b,c) b, Transform sig (a,b,c) c) =>-   sig (a,b,c) -> (sig a, sig b, sig c)-unzip3 xs =-   (map fst3 xs, map snd3 xs, map thd3 xs)----{-# INLINE modifyStatic #-}-modifyStatic :: (Transform sig a b) =>-   Modifier.Simple s ctrl a b -> ctrl -> sig a -> sig b-modifyStatic (Modifier.Simple state proc) control =-   crochetL (\a acc -> Just (runState (proc control a) acc)) state--{-| Here the control may vary over the time. -}-{-# INLINE modifyModulated #-}-modifyModulated :: (Transform sig a b, Read sig ctrl) =>-   Modifier.Simple s ctrl a b -> sig ctrl -> sig a -> sig b-modifyModulated (Modifier.Simple state proc) control =-   crochetL-      (\x (acc0,cs0) ->-         do (c,cs1) <- viewL cs0-            let (y,acc1) = runState (proc c x) acc0-            return (y,(acc1,cs1)))-      (state,control)--linearComb ::-   (Module.C t y, Read sig t, Transform sig y y) =>-   sig t -> sig y -> y-linearComb ts ys =-   sum (zipWith (Module.*>) ts ys)--mapTails :: (Transform sig a b) =>-   (sig a -> b) -> sig a -> sig b-mapTails f x =-   crochetL (\_ xs0 ->-      do (_,xs1) <- viewL xs0-         Just (f xs0, xs1))-      x x--{-# INLINE zipWithTails #-}-zipWithTails :: (Read sig b, Transform sig a c) =>-   (a -> sig b -> c) -> sig a -> sig b -> sig c-zipWithTails f =-   flip (crochetL (\x ys0 ->-      do (_,ys) <- viewL ys0-         Just (f x ys0, ys)))--{-# INLINE zipWith2Tails #-}-zipWith2Tails :: (Read sig b, Read sig c, Transform sig a d) =>-   (a -> sig b -> sig c -> d) -> sig a -> sig b -> sig c -> sig d-zipWith2Tails f as bs cs =-   crochetL (\x (ys0,zs0) ->-      do (_,ys1) <- viewL ys0-         (_,zs1) <- viewL zs0-         Just (f x ys0 zs0, (ys1,zs1)))-      (bs,cs) as--zipWithState :: (Transform sig b c) =>-   (a -> b -> c) -> SigS.T a -> sig b -> sig c-zipWithState f =-   crochetL (\b as0 ->-      do (a,as1) <- SigS.viewL as0-         Just (f a b, as1))
src/Synthesizer/Generic/Tutorial.hs view
@@ -16,9 +16,7 @@ import qualified Sound.Sox.Write as Write import qualified Sound.Sox.Option.Format as SoxOpt import qualified Synthesizer.Basic.Binary as BinSmp-import qualified Synthesizer.Storable.Signal as SigSt import qualified Synthesizer.Generic.Signal as SigG-import qualified Synthesizer.Generic.Signal2 as SigG2 import qualified Synthesizer.State.Signal as Sig import qualified Synthesizer.Causal.Process as Causal import Control.Arrow ((&&&), (^<<), (<<^), (<<<), )@@ -34,12 +32,17 @@ import qualified Synthesizer.State.Control as CtrlS import qualified Synthesizer.State.Oscillator as OsciS +import qualified Data.StorableVector.Lazy.Typed as SVT+import Data.Int (Int16, )+ import System.Exit (ExitCode, )-import NumericPrelude-import PreludeBase+import NumericPrelude.Numeric+import NumericPrelude.Base import Prelude ()  +type Signal = SVT.Vector SVT.DefaultChunkSize+ {- | First, we define a play routine for lazy storable vectors. Storable lazy vectors are lazy lists of low-level arrays.@@ -49,11 +52,12 @@ This means that elements must have fixed size and advanced data types like functions cannot be used. -}-play :: SigSt.T Double -> IO ExitCode-play =-   Play.simple SigSt.hPut SoxOpt.none 44100 .-   SigSt.map BinSmp.int16FromDouble+play :: Signal Double -> IO ExitCode+play = playInt16 . SigG.map BinSmp.int16FromDouble +playInt16 :: Signal Int16 -> IO ExitCode+playInt16 = Play.simple SVT.hPut SoxOpt.none 44100+ {- | Here is a simple oscillator generated as lazy storable vector. An oscillator is a signal generator,@@ -64,16 +68,16 @@ -} oscillator :: IO ExitCode oscillator =-   play (Osci.static SigG.defaultLazySize Wave.sine zero (0.01::Double))+   play (Osci.static Wave.sine zero (0.01::Double))   {- | A routine just for the case that we want to post-process a signal somewhere else. -}-write :: FilePath -> SigSt.T Double -> IO ExitCode+write :: FilePath -> Signal Double -> IO ExitCode write name =-   Write.simple SigSt.hPut SoxOpt.none name 44100 .-   SigSt.map BinSmp.int16FromDouble+   Write.simple SVT.hPut SoxOpt.none name 44100 .+   SigG.map BinSmp.int16FromDouble  {- | The simple brass sound demonstrates@@ -86,11 +90,11 @@ --   write "brass.aiff" $    play $    Filt.envelope-      (Piece.run SigG.defaultLazySize $+      (Piece.run $        0    |# ( 3000, Piece.cubic 0.002 0) #|-        0.7 -|# (50000, Piece.step) #|-        0.7 -|# (10000, Piece.exponential 0) #| (0.01::Double)) $-   SigG.fromState SigG.defaultLazySize $+   SigG.fromState $    Filt.amplify 0.5 $    SigG.mix       (OsciS.static Wave.saw zero (0.00499::Double))@@ -105,13 +109,12 @@ can be used in the addressed signal type. -} filterSawSig ::-   (SigG.Write sig Double,-    SigG2.Transform sig (UniFilter.Result Double) Double,-    SigG2.Transform sig Double (UniFilter.Result Double),-    SigG2.Transform sig Double (UniFilter.Parameter Double)) =>+   (SigG.Produce sig Double,+    SigG.Transform sig (UniFilter.Result Double),+    SigG.Transform sig (UniFilter.Parameter Double)) =>    sig Double filterSawSig =-   SigG2.map UniFilter.lowpass $ SigG2.modifyModulated UniFilter.modifier (SigG2.map (\f -> UniFilter.parameter $ FiltRec.Pole 10 (0.04+0.02*f)) $ Osci.static SigG.defaultLazySize Wave.sine zero (0.00001::Double)) $ Osci.static SigG.defaultLazySize Wave.saw zero (0.002::Double)+   SigG.map UniFilter.lowpass $ SigG.modifyModulated UniFilter.modifier (SigG.map (\f -> UniFilter.parameter $ FiltRec.Pole 10 (0.04+0.02*f)) $ Osci.static Wave.sine zero (0.00001::Double)) $ Osci.static Wave.saw zero (0.002::Double)  {- | Here we instantiate 'filterSawSig' for storable vectors and play it.@@ -143,10 +146,7 @@ that generates the storable vector to be played in one go. -} playState :: Sig.T Double -> IO ExitCode-playState =-   Play.simple SigSt.hPut SoxOpt.none 44100 .-   SigG.fromState SigG.defaultLazySize .-   Sig.map BinSmp.int16FromDouble+playState = playInt16 . SigG.fromState . Sig.map BinSmp.int16FromDouble  {- | We demonstrate the stateful signal generator using the known 'filterSaw' example.
src/Synthesizer/Generic/Wave.hs view
@@ -7,23 +7,22 @@  import qualified Synthesizer.Interpolation as Interpolation -import qualified Algebra.RealField             as RealField---- import Data.Tuple.HT (swap, )+import qualified Algebra.RealField            as RealField+import qualified Algebra.RealRing             as RealRing -import NumericPrelude-import PreludeBase+import NumericPrelude.Numeric+import NumericPrelude.Base import Prelude ()   sample ::-   (RealField.C a, SigG.Transform sig v) =>+   (RealRing.C a, SigG.Transform sig v) =>    Interpolation.T a v -> sig v -> Wave.T a v sample ip wave =    let len = SigG.length wave        cycleWave = SigG.cycle wave    in  Wave.fromFunction $ \ phase ->-           let (n,q) = RealField.splitFraction (phase * fromIntegral len)+           let (n,q) = RealRing.splitFraction (phase * fromIntegral len)            in  Interpolation.func ip q $                SigG.toState $                SigG.drop n cycleWave@@ -43,6 +42,8 @@ --   uncurry (ToneMod.interpolateCell ipStep ipLeap . swap) $    uncurry (ToneMod.interpolateCell ipLeap ipStep) $    ToneMod.sampledToneCell-      (ToneMod.makePrototype (Interpolation.margin ipLeap) (Interpolation.margin ipStep) period tone)+      (ToneMod.makePrototype+          (Interpolation.margin ipLeap) (Interpolation.margin ipStep)+          period tone)       shape phase
src/Synthesizer/Interpolation.hs view
@@ -1,19 +1,31 @@ {-# 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 PreludeBase-import NumericPrelude+import qualified Test.QuickCheck as QC +import NumericPrelude.Numeric+import NumericPrelude.Base   + {- | interpolation as needed for resampling -} data T t y =   Cons {@@ -30,6 +42,10 @@     }    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 =    Cons (Margin num off)@@ -83,7 +99,10 @@                  ($t)                  (evalStateT parser xs)) -{-| Consider the signal to be piecewise constant. -}+{-|+Consider the signal to be piecewise constant,+where the leading value is used for filling the interval [0,1).+-} {-# INLINE constant #-} constant :: T t y constant =
src/Synthesizer/Interpolation/Class.hs view
@@ -10,16 +10,16 @@ import qualified Algebra.Module as Module import qualified Algebra.PrincipalIdealDomain as PID import qualified Algebra.Ring as Ring-import qualified Algebra.Additive as Additive +import qualified Sound.Frame.NumericPrelude.Stereo as Stereo import qualified Number.Ratio as Ratio import qualified Number.Complex as Complex -import Control.Applicative (Applicative(pure, (<*>)), )+import Control.Applicative (Applicative(pure, (<*>)), liftA2, ) import Data.Tuple.HT (mapPair, mapSnd, fst3, snd3, thd3, ) -import NumericPrelude hiding (zero, )-import PreludeBase+import NumericPrelude.Numeric hiding (zero, )+import NumericPrelude.Base import Prelude ()  {- |@@ -96,8 +96,13 @@    {-# INLINE scaleAndAccumulate #-}    scaleAndAccumulate = makeMac3 (,,) fst3 snd3 thd3 +instance C a v => C a (Stereo.T v) where+   {-# INLINE scaleAndAccumulate #-}+   scaleAndAccumulate =+      makeMac2 Stereo.cons Stereo.left Stereo.right  + infixl 6 +.*  {-# INLINE scale #-}@@ -144,6 +149,31 @@ scaleAndAccumulateModule (a,x) =    let ax = a *> x    in  (ax, (ax+))+++{-# INLINE scaleAndAccumulateApplicative #-}+scaleAndAccumulateApplicative ::+   (C a v, Applicative f) =>+   (a, f v) -> (f v, f v -> f v)+scaleAndAccumulateApplicative (a,x) =+   let ax = fmap (curry scaleAndAccumulate a) x+   in  (fmap fst ax, (fmap snd ax <*>))++{-# INLINE scaleAndAccumulateRingApplicative #-}+scaleAndAccumulateRingApplicative ::+   (Ring.C a, Applicative f) =>+   (a, f a) -> (f a, f a -> f a)+scaleAndAccumulateRingApplicative (a,x) =+   let ax = fmap (a*) x+   in  (ax, liftA2 (+) ax)++{-# INLINE scaleAndAccumulateModuleApplicative #-}+scaleAndAccumulateModuleApplicative ::+   (Module.C a v, Applicative f) =>+   (a, f v) -> (f v, f v -> f v)+scaleAndAccumulateModuleApplicative (a,x) =+   let ax = fmap (a*>) x+   in  (ax, liftA2 (+) ax)   {- |
+ src/Synthesizer/Interpolation/Core.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+Plain interpolation functions.+-}+module Synthesizer.Interpolation.Core (+   linear,+   cubic,+   cubicAlt,+   ) where++import qualified Algebra.Module    as Module+import qualified Algebra.Field     as Field++import Synthesizer.Utility (affineComb, )++import NumericPrelude.Numeric+import NumericPrelude.Base++++{-# INLINE linear #-}+linear ::+   (Module.C a v) =>+   v -> v -> a -> v+linear x0 x1 phase = affineComb phase (x0,x1)++{-# INLINE cubic #-}+cubic ::+   (Module.C a v, Field.C a) =>+   v -> v -> v -> v -> a -> v+cubic xm1 x0 x1 x2 t =+   let lipm12 = affineComb t (xm1,x2)+       lip01  = affineComb t (x0, x1)+       three  = 3 `asTypeOf` t+   in  lip01 + (t*(t-1)/2) *>+                  (lipm12 + (x0+x1) - three *> lip01)++{- |+The interpolators for module operations+do not simply compute a straight linear combination of some vectors.+Instead they add then scale, then add again, and so on.+This is efficient whenever scaling and addition is cheap.+In this case they might save multiplications.+I can't say much about numeric cancellations, however.+-}+{-# INLINE cubicAlt #-}+cubicAlt ::+   (Module.C a v, Field.C a) =>+   v -> v -> v -> v -> a -> v+cubicAlt xm1 x0 x1 x2 t =+   let half = 1/2 `asTypeOf` t+   in  cubicHalf    t  x0 (half *> (x1-xm1)) ++       cubicHalf (1-t) x1 (half *> (x0-x2))++{- |+@\t -> cubicHalf t x x'@ has a double zero at 1 and+at 0 it has value x and slope x'.+-}+{-# INLINE cubicHalf #-}+cubicHalf :: (Module.C t y) => t -> y -> y -> y+cubicHalf t x x' =+   (t-1)^2 *> ((1+2*t)*>x + t*>x')
src/Synthesizer/Interpolation/Custom.hs view
@@ -24,16 +24,13 @@    )  import qualified Algebra.Field     as Field-import qualified Algebra.Ring      as Ring-import qualified Algebra.Additive  as Additive  import Synthesizer.Interpolation.Class ((+.*), ) -import Control.Applicative (liftA2, )-import Synthesizer.ApplicativeUtility (liftA4, )+import qualified Control.Applicative.HT as App -import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   @@ -42,7 +39,7 @@ linear :: (Interpol.C t y) => T t y linear =    fromPrefixReader "linear" 0-      (liftA2+      (App.lift2           (\x0 x1 phase -> Interpol.combine2 phase (x0,x1))           getNode getNode) @@ -59,7 +56,7 @@ {-# INLINE cubic #-} cubic :: (Field.C t, Interpol.C t y) => T t y cubic =-   fromPrefixReader "cubicAlt" 1 $ liftA4+   fromPrefixReader "cubicAlt" 1 $ App.lift4       (\xm1 x0 x1 x2 t ->        let (am1, a0, a1) = cubicHalf    t            ( b2, b1, b0) = cubicHalf (1-t)@@ -94,7 +91,7 @@       combineMany          "Interpolation.element: list of functions empty"          "Interpolation.element: list of samples empty" $-            Sig.map ($t) $ Sig.fromList $ reverse ps+            Sig.map ($ t) $ Sig.fromList $ reverse ps  {-# INLINE piecewiseConstant #-} piecewiseConstant :: (Interpol.C t y) => T t y
src/Synthesizer/Interpolation/Module.hs view
@@ -18,25 +18,20 @@ import qualified Synthesizer.State.Signal  as Sig import qualified Synthesizer.Plain.Control as Ctrl +import qualified Synthesizer.Interpolation.Core as Core+ import Synthesizer.Interpolation (    T, cons, getNode, fromPrefixReader,    constant,    )  import qualified Algebra.Module    as Module--- import qualified Algebra.RealField as RealField import qualified Algebra.Field     as Field-import qualified Algebra.Ring      as Ring-import qualified Algebra.Additive  as Additive -import Algebra.Module((*>))--import Control.Applicative (liftA2, )-import Synthesizer.ApplicativeUtility (liftA4, )-import Synthesizer.Utility (affineComb, )+import qualified Control.Applicative.HT as App -import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   {-| Consider the signal to be piecewise linear. -}@@ -44,9 +39,7 @@ linear :: (Module.C t y) => T t y linear =    fromPrefixReader "linear" 0-      (liftA2-          (\x0 x1 phase -> affineComb phase (x0,x1))-          getNode getNode)+      (App.lift2 Core.linear getNode getNode)  {- | Consider the signal to be piecewise cubic,@@ -62,43 +55,13 @@ cubic :: (Field.C t, Module.C t y) => T t y cubic =    fromPrefixReader "cubic" 1-      (liftA4-         (\xm1 x0 x1 x2 t ->-            let lipm12 = affineComb t (xm1,x2)-                lip01  = affineComb t (x0, x1)-                three  = 3 `asTypeOf` t-            in  lip01 + (t*(t-1)/2) *>-                           (lipm12 + (x0+x1) - three *> lip01))-         getNode getNode getNode getNode)+      (App.lift4 Core.cubic getNode getNode getNode getNode) -{- |-The interpolators for module operations-do not simply compute a straight linear combination of some vectors.-Instead they add then scale, then add again, and so on.-This is efficient whenever scaling and addition is cheap.-In this case they might save multiplications.-I can't say much about numeric cancellations, however.--} {-# INLINE cubicAlt #-} cubicAlt :: (Field.C t, Module.C t y) => T t y cubicAlt =    fromPrefixReader "cubicAlt" 1-      (liftA4-         (\xm1 x0 x1 x2 t ->-          let half = 1/2 `asTypeOf` t-          in  cubicHalf    t  x0 (half *> (x1-xm1)) +-              cubicHalf (1-t) x1 (half *> (x0-x2)))-         getNode getNode getNode getNode)---{- |-@\t -> cubicHalf t x x'@ has a double zero at 1 and-at 0 it has value x and slope x'.--}-{-# INLINE cubicHalf #-}-cubicHalf :: (Module.C t y) => t -> y -> y -> y-cubicHalf t x x' =-   (t-1)^2 *> ((1+2*t)*>x + t*>x')+      (App.lift4 Core.cubicAlt getNode getNode getNode getNode)   @@ -109,7 +72,7 @@    Int -> [t -> t] -> T t y piecewise center ps =    cons (length ps) (center-1)-      (\t -> Sig.linearComb (Sig.fromList (map ($t) (reverse ps))))+      (\t -> Sig.linearComb (Sig.fromList (map ($ t) (reverse ps))))  {-# INLINE piecewiseConstant #-} piecewiseConstant :: (Module.C t y) => T t y
src/Synthesizer/Piecewise.hs view
@@ -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)
+ src/Synthesizer/PiecewiseConstant/Generic.hs view
@@ -0,0 +1,43 @@+module Synthesizer.PiecewiseConstant.Generic (+   toSignal,+   toSignalInit,+   toSignalInitWith,+   ) where++import qualified Synthesizer.PiecewiseConstant.Private as PC+import Synthesizer.PiecewiseConstant.Private (StrictTime)++import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.Generic.Cut    as CutG++import qualified Data.EventList.Relative.BodyTime as EventListBT+import qualified Data.EventList.Relative.TimeBody as EventList++import qualified Numeric.NonNegative.Wrapper as NonNegW++++replicateLong ::+   (SigG.Produce sig y) =>+   StrictTime -> y -> sig y+replicateLong tl y =+   CutG.concat $+   map (\t ->+      SigG.replicate+--         (SigG.LazySize $ fromIntegral $ maxBound::Int)+         (NonNegW.toNumber t) y) $+   PC.chopLongTime tl++{-# INLINE toSignal #-}+toSignal :: (SigG.Produce sig y) => EventListBT.T StrictTime y -> sig y+toSignal = PC.toSignal replicateLong++{-# INLINE toSignalInit #-}+toSignalInit :: (SigG.Produce sig y) => y -> EventList.T StrictTime y -> sig y+toSignalInit = PC.toSignalInit replicateLong++{-# INLINE toSignalInitWith #-}+toSignalInitWith ::+   (SigG.Produce sig c) =>+   (y -> c) -> c -> EventList.T StrictTime [y] -> sig c+toSignalInitWith = PC.toSignalInitWith replicateLong
+ src/Synthesizer/PiecewiseConstant/Private.hs view
@@ -0,0 +1,75 @@+module Synthesizer.PiecewiseConstant.Private where++import qualified Synthesizer.Generic.Signal as SigG++import qualified Data.EventList.Relative.BodyTime  as EventListBT+import qualified Data.EventList.Relative.TimeBody  as EventList++import qualified Numeric.NonNegative.Wrapper as NonNegW++import Control.Monad.Trans.State (evalState, get, put, )++import qualified Data.List as List+import Data.Traversable (traverse, )+import Data.Foldable (traverse_, )++++type StrictTime = NonNegW.Integer+type ShortStrictTime = NonNegW.Int+++{-# INLINE toSignal #-}+toSignal ::+   (SigG.Transform sig y) =>+   (StrictTime -> y -> sig y) ->+   EventListBT.T StrictTime y -> sig y+toSignal replicateLong =+   EventListBT.foldrPair+      (\y t -> SigG.append (replicateLong t y))+      SigG.empty++{-# INLINE toSignalInit #-}+toSignalInit ::+   (SigG.Transform sig y) =>+   (StrictTime -> y -> sig y) ->+   y -> EventList.T StrictTime y -> sig y+toSignalInit replicateLong initial =+   (\ ~(t,rest) -> SigG.append (replicateLong t initial) rest)+   .+   EventList.foldr+      (,)+      (\y ~(t,rest) -> SigG.append (replicateLong t y) rest)+      (0, SigG.empty)+{-+   toSignal .+--   EventListBM.switchBodyR const .+--   EventListBM.snocTime NonNeg.zero .+--   EventListMB.consBody initial .+   -- switchBodyR causes a space leak+   EventListTM.switchBodyR EventListBT.empty+      (\xs _ -> EventListMT.consBody initial xs)+-}++{-# INLINE toSignalInitWith #-}+toSignalInitWith ::+   (SigG.Transform sig c) =>+   (StrictTime -> c -> sig c) ->+   (y -> c) -> c -> EventList.T StrictTime [y] -> sig c+toSignalInitWith replicateLong f initial =+   toSignalInit replicateLong initial .+   flip evalState initial .+   traverse (\evs -> traverse_ (put . f) evs >> get)+++{- |+Returns a list of non-zero times.+-}+{-# INLINE chopLongTime #-}+chopLongTime :: StrictTime -> [ShortStrictTime]+chopLongTime n =+   let d = fromIntegral (maxBound :: Int)+       (q,r) = divMod (NonNegW.toNumber n) d+   in  map (NonNegW.fromNumberMsg "chopLongTime" . fromInteger) $+       List.genericReplicate q d +++       if r/=0 then [r] else []
+ src/Synthesizer/PiecewiseConstant/Signal.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.PiecewiseConstant.Signal (+   T,+   StrictTime,+   ShortStrictTime,+   LazyTime,+   subdivideLazy,+   subdivideLazyToShort,+   subdivideLongStrict,+   chopLongTime,+   longFromShortTime,+   zipWith,+   ) where++import Synthesizer.PiecewiseConstant.Private+         (StrictTime, ShortStrictTime, chopLongTime)++import qualified Data.EventList.Relative.TimeTime  as EventListTT+import qualified Data.EventList.Relative.MixedTime as EventListMT+import qualified Data.EventList.Relative.BodyTime  as EventListBT++import qualified Numeric.NonNegative.Class   as NonNeg+import qualified Numeric.NonNegative.Wrapper as NonNegW+import qualified Numeric.NonNegative.Chunky as NonNegChunky+import Numeric.NonNegative.Class ((-|), )++import Control.Monad.Trans.State (evalState, get, put, )+import Data.Traversable (traverse, )++import qualified Data.List as List+import Data.Maybe.HT (toMaybe, )++import NumericPrelude.Numeric+import NumericPrelude.Base hiding (zipWith, )+import qualified Prelude as P+++type LazyTime = NonNegChunky.T StrictTime++type T = EventListBT.T StrictTime+++{-# INLINE subdivideLazy #-}+subdivideLazy ::+   (NonNeg.C time) =>+   EventListBT.T (NonNegChunky.T time) body ->+   EventListBT.T time body+subdivideLazy =+   EventListBT.foldrPair+      (\y lt r ->+         List.foldr+            (\dt ->+               EventListMT.consBody y .+               EventListMT.consTime dt) r $+         NonNegChunky.toChunks (NonNegChunky.normalize lt))+      EventListBT.empty++{- |+Subdivide lazy times into chunks that fit into the number range+representable by @Int@.+-}+{-# INLINE subdivideLazyToShort #-}+subdivideLazyToShort ::+   EventListBT.T LazyTime y -> EventListBT.T ShortStrictTime y+subdivideLazyToShort =+   subdivideLazy .+   EventListBT.mapTime+      (NonNegChunky.fromChunks .+       List.concatMap chopLongTime .+       NonNegChunky.toChunks)++{-# INLINE longFromShortTime #-}+longFromShortTime :: ShortStrictTime -> StrictTime+longFromShortTime =+   NonNegW.fromNumberMsg "longFromShortTime" .+   fromIntegral .+   NonNegW.toNumber+++{-# INLINE subdivideLongStrict #-}+subdivideLongStrict ::+   EventListBT.T StrictTime y -> EventListBT.T ShortStrictTime y+subdivideLongStrict =+   subdivideLazy .+   EventListBT.mapTime+      (NonNegChunky.fromChunks . chopLongTime)+++_subdivideMaybe ::+   EventListBT.T LazyTime y -> EventListBT.T StrictTime (Maybe y)+_subdivideMaybe =+   EventListBT.foldrPair+      (\y lt r ->+         case NonNegChunky.toChunks (NonNegChunky.normalize lt) of+            [] -> r+            (t:ts) ->+               EventListBT.cons (Just y) t $+               List.foldr (EventListBT.cons Nothing) r ts)+      EventListBT.empty++{- |+When a lazy time value is split into chunks+then do not just replicate the sample for the whole time,+but insert 'Nothing's.+-}+{-# INLINE subdivideMaybe #-}+subdivideMaybe ::+   EventListTT.T LazyTime y ->+   EventListTT.T StrictTime (Maybe y)+subdivideMaybe =+   EventListTT.foldr+      (\lt r ->+         uncurry EventListMT.consTime $+         case NonNegChunky.toChunks (NonNegChunky.normalize lt) of+            [] ->+               (NonNegW.fromNumber zero, r)+            (t:ts) ->+               (t, List.foldr (EventListBT.cons Nothing) r ts))+      (\y r -> EventListMT.consBody (Just y) r)+      EventListBT.empty++{-# INLINE unionMaybe #-}+unionMaybe ::+   EventListTT.T StrictTime (Maybe y) ->+   EventListTT.T LazyTime y+unionMaybe =+   EventListTT.foldr+      (\t ->+         EventListMT.mapTimeHead+            (NonNegChunky.fromChunks . (t:) . NonNegChunky.toChunks))+      (\my ->+         case my of+            Nothing -> id+            Just y ->+               EventListMT.consTime NonNegChunky.zero .+               EventListMT.consBody y)+      (EventListTT.pause NonNegChunky.zero)++zipWithCore ::+   (NonNeg.C time) =>+   (a -> b -> c) ->+   a -> b ->+   EventListTT.T time (Maybe a) ->+   EventListTT.T time (Maybe b) ->+   EventListTT.T time (Maybe c)+zipWithCore f =+   let switch ac ar g =+          flip (EventListMT.switchBodyL EventListBT.empty) ar $ \am ar1 ->+          g (maybe (False,ac) ((,) True) am) ar1+       cont j ac bc as bs =+          EventListMT.consBody (toMaybe j $ f ac bc) $+          recourse ac bc as bs+       recourse ac bc as bs =+          flip EventListMT.switchTimeL as $ \at ar ->+          flip EventListMT.switchTimeL bs $ \bt br ->+          let ct = min at bt+          in  -- ToDo: redundant comparison of 'at' and 'bt'+              EventListMT.consTime ct $+              case compare at bt of+                 LT ->+                    switch ac ar $ \(ab,a) ar1 ->+                       cont ab a bc ar1 (EventListMT.consTime (bt-|ct) br)+                 GT ->+                    switch bc br $ \(bb,b) br1 ->+                       cont bb ac b (EventListMT.consTime (at-|ct) ar) br1+                 EQ ->+                    switch ac ar $ \(ab,a) ar1 ->+                    switch bc br $ \(bb,b) br1 ->+                       cont (ab||bb) a b ar1 br1+   in  recourse++zipWith ::+   (NonNeg.C time) =>+   (a -> b -> c) ->+   EventListBT.T time a ->+   EventListBT.T time b ->+   EventListBT.T time c+zipWith f as0 bs0 =+   flip (EventListMT.switchBodyL EventListBT.empty) as0 $ \a0 as1 ->+   flip (EventListMT.switchBodyL EventListBT.empty) bs0 $ \b0 bs1 ->+   let c0 = f a0 b0+   in  EventListMT.consBody c0 $+       flip evalState c0 $+       traverse (\mc -> maybe (return ()) put mc >> get) $+       zipWithCore f a0 b0 (fmap Just as1) (fmap Just bs1)++_zipWithLazy ::+   (a -> b -> c) ->+   EventListBT.T LazyTime a ->+   EventListBT.T LazyTime b ->+   EventListBT.T LazyTime c+_zipWithLazy f as0 bs0 =+   flip (EventListMT.switchBodyL EventListBT.empty) as0 $ \a0 as1 ->+   flip (EventListMT.switchBodyL EventListBT.empty) bs0 $ \b0 bs1 ->+   EventListMT.consBody (f a0 b0) $ unionMaybe $+   zipWithCore f a0 b0 (subdivideMaybe as1) (subdivideMaybe bs1)+{-+*Synthesizer.PiecewiseConstant.ALSA.MIDI Data.EventList.Relative.MixedTime> zipWithLazy (,) ('a' ./ 2 /. 'b' ./ 7 /. EventListBT.empty) ('c' ./ (1 P.+ 1) /. 'd' ./ 1 /. EventListBT.empty)+-}
+ src/Synthesizer/PiecewiseConstant/Storable.hs view
@@ -0,0 +1,47 @@+module Synthesizer.PiecewiseConstant.Storable (+   toSignal,+   toSignalInit,+   toSignalInitWith,+   ) where++import qualified Synthesizer.PiecewiseConstant.Private as PC+import Synthesizer.PiecewiseConstant.Private (StrictTime)++import qualified Synthesizer.Storable.Signal     as SigSt+import qualified Data.StorableVector.Lazy.Pattern as SigStV+import qualified Data.StorableVector.Lazy        as SVL++import qualified Data.EventList.Relative.BodyTime  as EventListBT+import qualified Data.EventList.Relative.TimeBody  as EventList++import Foreign.Storable (Storable, )++import qualified Numeric.NonNegative.Wrapper as NonNegW+import qualified Numeric.NonNegative.Chunky as NonNegChunky++++chunkSizesFromStrictTime :: StrictTime -> NonNegChunky.T SigSt.ChunkSize+chunkSizesFromStrictTime =+   NonNegChunky.fromChunks .+   map (SVL.ChunkSize . NonNegW.toNumber) .+   PC.chopLongTime+++replicateLong :: (Storable y) => StrictTime -> y -> SigSt.T y+replicateLong t y =+   SigStV.replicate (chunkSizesFromStrictTime t) y++{-# INLINE toSignal #-}+toSignal :: (Storable y) => EventListBT.T StrictTime y -> SigSt.T y+toSignal = PC.toSignal replicateLong++{-# INLINE toSignalInit #-}+toSignalInit :: (Storable y) => y -> EventList.T StrictTime y -> SigSt.T y+toSignalInit = PC.toSignalInit replicateLong++{-# INLINE toSignalInitWith #-}+toSignalInitWith ::+   (Storable c) =>+   (y -> c) -> c -> EventList.T StrictTime [y] -> SigSt.T c+toSignalInitWith = PC.toSignalInitWith replicateLong
src/Synthesizer/Plain/Analysis.hs view
@@ -1,18 +1,60 @@ {-# 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-import qualified Algebra.Real                  as Real+import qualified Algebra.RealRing              as RealRing+import qualified Algebra.Absolute              as Absolute import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive @@ -20,18 +62,8 @@ import qualified Algebra.NormedSpace.Euclidean as NormedEuc import qualified Algebra.NormedSpace.Sum       as NormedSum -import qualified Data.Array as Array--import qualified Data.IntMap as IntMap---- import Algebra.Module((*>))--import Data.Array (accumArray)-import Data.List (foldl', )--import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   {- * Notions of volume -}@@ -39,7 +71,7 @@ {- | Volume based on Manhattan norm. -}-volumeMaximum :: (Real.C y) => Sig.T y -> y+volumeMaximum :: (RealRing.C y) => Sig.T y -> y volumeMaximum =    foldl max zero . rectify --   maximum . rectify@@ -58,7 +90,7 @@ {- | Volume based on Sum norm. -}-volumeSum :: (Field.C y, Real.C y) => Sig.T y -> y+volumeSum :: (Absolute.C y, Field.C y) => Sig.T y -> y volumeSum = average . rectify  @@ -96,9 +128,8 @@ Compute minimum and maximum value of the stream the efficient way. Input list must be non-empty and finite. -}-bounds :: Ord y => Sig.T y -> (y,y)-bounds [] = error "Analysis.bounds: List must contain at least one element."-bounds (x:xs) =+bounds :: Ord y => NonEmpty.T Sig.T y -> (y,y)+bounds (NonEmpty.Cons x xs) =    foldl' (\(minX,maxX) y -> (min y minX, max y maxX)) (x,x) xs  @@ -138,13 +169,11 @@ Input list must be finite. List is scanned twice, but counting may be faster. -}-histogramDiscreteArray :: Sig.T Int -> (Int, Sig.T Int)-histogramDiscreteArray [] =-   (error "histogramDiscreteArray: no bounds found", [])+histogramDiscreteArray :: NonEmpty.T Sig.T Int -> (Int, Sig.T Int) histogramDiscreteArray x =    let hist =           accumArray (+) zero-             (bounds x) (attachOne x)+             (bounds x) (attachOne $ NonEmpty.flatten x)    in  (fst (Array.bounds hist), Array.elems hist)  @@ -154,10 +183,8 @@ List is scanned twice, but counting may be faster. The sum of all histogram values is one less than the length of the signal. -}-histogramLinearArray :: RealField.C y => Sig.T y -> (Int, Sig.T y)-histogramLinearArray [] =-   (error "histogramLinearArray: no bounds found", [])-histogramLinearArray [x] = (floor x, [])+histogramLinearArray :: RealField.C y => NonEmpty.T Sig.T y -> (Int, Sig.T y)+histogramLinearArray (NonEmpty.Cons x []) = (floor x, []) histogramLinearArray x =    let (xMin,xMax) = bounds x        hist =@@ -172,11 +199,9 @@ If the input signal is empty, the offset is @undefined@. List is scanned once, counting may be slower. -}-histogramDiscreteIntMap :: Sig.T Int -> (Int, Sig.T Int)-histogramDiscreteIntMap [] =-   (error "histogramDiscreteIntMap: no bounds found", [])+histogramDiscreteIntMap :: NonEmpty.T Sig.T Int -> (Int, Sig.T Int) histogramDiscreteIntMap x =-   let hist = IntMap.fromListWith (+) (attachOne x)+   let hist = IntMap.fromListWith (+) (attachOne $ NonEmpty.flatten x)    in  case IntMap.toAscList hist of           [] -> error "histogramDiscreteIntMap: the list was non-empty before processing ..."           fAll@((fIndex,fHead):fs) -> (fIndex, fHead :@@ -184,10 +209,8 @@                  (\(i0,_) (i1,f1) -> replicate (i1-i0-1) zero ++ [f1])                  fAll fs)) -histogramLinearIntMap :: RealField.C y => Sig.T y -> (Int, Sig.T y)-histogramLinearIntMap [] =-   (error "histogramLinearIntMap: no bounds found", [])-histogramLinearIntMap [x] = (floor x, [])+histogramLinearIntMap :: RealField.C y => NonEmpty.T Sig.T y -> (Int, Sig.T y)+histogramLinearIntMap (NonEmpty.Cons x []) = (floor x, []) histogramLinearIntMap x =    let hist = IntMap.fromListWith (+) (meanValues x)    -- we can rely on the fact that the keys are contiguous@@ -209,22 +232,22 @@ The bug has gone in IntMap as shipped with GHC-6.6. -} -histogramIntMap :: (RealField.C y) => y -> Sig.T y -> (Int, Sig.T Int)+histogramIntMap :: (RealField.C y) => y -> NonEmpty.T Sig.T y -> (Int, Sig.T Int) histogramIntMap binsPerUnit =    histogramDiscreteIntMap . quantize binsPerUnit -quantize :: (RealField.C y) => y -> Sig.T y -> Sig.T Int-quantize binsPerUnit = map (floor . (binsPerUnit*))+quantize :: (Functor f, RealField.C y) => y -> f y -> f Int+quantize binsPerUnit = fmap (floor . (binsPerUnit*))  attachOne :: Sig.T i -> Sig.T (i,Int) attachOne = map (\i -> (i,one)) -meanValues :: RealField.C y => Sig.T y -> [(Int,y)]-meanValues x = concatMap spread (zip x (tail x))+meanValues :: RealField.C y => NonEmpty.T Sig.T y -> [(Int,y)]+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)@@ -269,7 +292,7 @@ average x =    sum x / fromIntegral (length x) -rectify :: Real.C y => Sig.T y -> Sig.T y+rectify :: Absolute.C y => Sig.T y -> Sig.T y rectify = map abs  {- |@@ -306,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<lower)-            Low  -> x>upper)+            Low  -> x>upper  {- | Almost naive implementation of the chirp transform,@@ -322,21 +348,44 @@ chirpTransform :: Ring.C y =>    y -> Sig.T y -> Sig.T y chirpTransform z xs =-   let powers = Ctrl.curveMultiscaleNeutral (*) z one-       powerPowers =-          map (\zn -> Ctrl.curveMultiscaleNeutral (*) zn one) powers-   in  map (scalarProduct xs) powerPowers+   map (scalarProduct xs) $+   map (\zn -> Ctrl.curveMultiscaleNeutral (*) zn one) $+   Ctrl.curveMultiscaleNeutral (*) z one  -binarySign :: Real.C y => Sig.T y -> Sig.T BinaryLevel+binarySign ::+   (Ord y, Additive.C y) => Sig.T y -> Sig.T BinaryLevel binarySign =    map (binaryLevelFromBool . (zero <=))  {- |-The output type could be different from the input type-but then we would need a conversion from output to input for feedback.+A kind of discretization for signals with sample values between -1 and 1.+If you smooth the resulting signal+(after you transformed with 'map binaryLevelToNumber'),+you should obtain an approximation to the input signal. -}-deltaSigmaModulation :: Real.C y => Sig.T y -> Sig.T BinaryLevel+deltaSigmaModulation ::+   RealRing.C y => Sig.T y -> Sig.T BinaryLevel deltaSigmaModulation x =+   let y = binarySign (Integration.run (x - (zero : map binaryLevelToNumber y)))+   in  y+{-    let y = binarySign (Integration.runInit zero (x - map binaryLevelToNumber y))+   in  y+-}++{- |+A kind of discretization for signals with sample values between 0 and a threshold.+We accumulate input values and emit a threshold value+whenever the accumulator exceeds the threshold.+This is intended for generating clicks from input noise.++See also 'deltaSigmaModulation'.+-}+deltaSigmaModulationPositive ::+   RealRing.C y => y -> Sig.T y -> Sig.T y+deltaSigmaModulationPositive threshold x =+   let y =+          map (\xi -> if xi>=threshold then threshold else zero) $+          Integration.run (x - (zero:y))    in  y
src/Synthesizer/Plain/Builder.hs view
@@ -5,15 +5,15 @@  import qualified Synthesizer.Basic.Binary as BinSmp -import Data.Monoid (Monoid, mempty, mappend, mconcat, Endo(Endo), appEndo, )+import Data.Monoid (Monoid, mempty, mconcat, Endo(Endo), appEndo, )+import Data.Semigroup (Semigroup, (<>), ) +import qualified Algebra.FloatingPoint as Float import qualified Algebra.ToInteger as ToInteger-import qualified Algebra.RealField as RealField -import qualified Prelude as P98--import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base+import Prelude ()   @@ -22,9 +22,11 @@ type Put a = a -> T a  +instance Semigroup (T a) where+   x <> y = Cons $ decons x <> decons y+ instance Monoid (T a) where    mempty = Cons mempty-   mappend x y = Cons $ decons x `mappend` decons y  put :: Put a put = Cons . Endo . (:)@@ -42,14 +44,14 @@  {-# INLINE signalToBinaryMono #-} signalToBinaryMono ::-   (RealField.C a, ToInteger.C int, Bounded int) =>+   (Float.C a, ToInteger.C int, Bounded int) =>    [a] -> [int] signalToBinaryMono =    map (BinSmp.fromCanonicalWith round)  {-# INLINE signalToBinaryStereo #-} signalToBinaryStereo ::-   (RealField.C a, ToInteger.C int, Bounded int) =>+   (Float.C a, ToInteger.C int, Bounded int) =>    [(a,a)] -> [int] signalToBinaryStereo =    concatMap (\(l,r) ->
src/Synthesizer/Plain/Control.hs view
@@ -1,29 +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.RealField             as RealField import qualified Algebra.Field                 as Field import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive -import Algebra.Module((*>))--import Number.Complex (cis,real)--- import qualified Number.Complex as Complex-import Data.List (zipWith4, tails, )-import Data.List.HT (iterateAssociative, )+import Number.Complex (cis,real, ) -import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   {- * Control curve generation -}@@ -73,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@@ -228,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 =@@ -283,7 +302,7 @@ cubicHermiteMultiscale node0@(t0,y0) node1@(t1,y1) =    let -- could be inlined and simplified        ys = map (cubicFunc node0 node1) [0,1,2,3]-       (d0:d1:d2:d3:_) = iterate (zapWith substract) ys+       (d0:d1:d2:d3:_) = iterate (mapAdjacent substract) ys  I thought multiplying difference schemes could help somehow, but it doesn't. :-(@@ -326,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, RealField.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) =>@@ -480,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
src/Synthesizer/Plain/Cut.hs view
@@ -22,23 +22,23 @@  import qualified Data.EventList.Relative.TimeBody as EventList +import Data.Array (Array, Ix, (!))+ import qualified MathObj.LaurentPolynomial as Laurent-import qualified Algebra.Real     as Real+import qualified Algebra.RealRing as RealRing import qualified Algebra.Additive as Additive -import Data.Array (Array, Ix, (!))- import qualified Number.NonNegative as NonNeg -import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base    {- | Take signal until it falls short of a certain amplitude for a given time. -}-takeUntilPause :: (Real.C a) => a -> Int -> Sig.T a -> Sig.T a+takeUntilPause :: (RealRing.C a) => a -> Int -> Sig.T a -> Sig.T a takeUntilPause y =    takeUntilInterval ((<=y) . abs) @@ -57,7 +57,7 @@   --- Better use zipWithMatch from NumericPrelude?+-- Better use zipWithMatch from NumericPrelude.Numeric? selectBool :: (Sig.T a, Sig.T a) -> Sig.T Bool -> Sig.T a selectBool =    uncurry (zipWith3 (\xf xt c -> if c then xt else xf))
src/Synthesizer/Plain/Displacement.hs view
@@ -8,9 +8,8 @@  import qualified Synthesizer.Plain.Signal as Sig --- import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   {- * Mixing -}
src/Synthesizer/Plain/Effect.hs view
@@ -3,34 +3,31 @@ 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) import Synthesizer.Plain.Instrument import Synthesizer.Plain.Effect.Glass(glass)+ import qualified Synthesizer.Plain.File as File-import Synthesizer.Filter.Example(guitarRaw, flangedSaw)---import Interpolation(interpolate,interpolateConstant)---import System.Random-import System.Exit(ExitCode)-import System.Cmd(rawSystem)+import qualified Control.Monad.Exception.Synchronous as Exc+import System.Process (rawSystem, )+import System.Exit (ExitCode, ) + main :: IO ExitCode main =    let rate = 44100-   in  do {- File.writeMono "test" rate+   in  Exc.toExitCodeT $+       do {- File.writeMono "test" rate                 (take (round (3*rate)) (soundD rate)) -}-          File.renderMonoToInt16 "test.aiff" rate soundE-          rawSystem "play" ["test.aiff"]+          Exc.fromExitCodeT $ File.renderMonoToInt16 "test.aiff" rate soundE+          Exc.fromExitCodeT $ rawSystem "play" ["test.aiff"]  -soundE, soundD,-   soundC, soundB, soundA,+soundE, soundB, soundA,    sound9, sound8, sound7,    sound6, sound5, sound4,    sound3, sound2, sound1,@@ -38,9 +35,10 @@  soundE = glass +{- moved to synthesizer-filter soundD = flangedSaw- soundC _ = guitarRaw+-}  cFreq :: Double cFreq = 521.3417849066773
src/Synthesizer/Plain/Effect/Fly.hs view
@@ -1,24 +1,27 @@ {-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE FlexibleContexts #-} module Synthesizer.Plain.Effect.Fly where +import qualified Synthesizer.Causal.Spatial as Spatial+import qualified Synthesizer.Causal.Process as Causal+ import qualified Synthesizer.Plain.Oscillator as Osci import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR import qualified Synthesizer.Plain.Interpolation as Interpolation-import qualified Synthesizer.Plain.Miscellaneous as Syn  import qualified Synthesizer.Plain.File as File import System.Exit(ExitCode) -import System.Random+import System.Random (randomRs, mkStdGen, )  import qualified Algebra.NormedSpace.Euclidean as Euc -import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   {--  ghc -O -fvia-C -fglasgow-exts -fallow-undecidable-instances --make Fly.hs && echo start && time a.out+  ghc -O -fvia-C --make Fly.hs && echo start && time a.out -}  main :: IO ExitCode@@ -29,7 +32,7 @@ sampleRate :: Double sampleRate = 44100 -{-| stereo sound of a humming fly -}+{- | stereo sound of a humming fly -} fly :: [(Double,Double)] fly =    let pinkNoise seed freq range =@@ -49,11 +52,12 @@                (flyCoord 654891)         channel ear =-          let (phase,volumes) = Syn.receive3Dsound 1 0.1 ear trajectory+          let (phase,volumes) =+                 unzip $ Causal.apply (Spatial.moveAround 1 0.1 ear) trajectory               -- (*sampleRate) in 'speed' and               -- (/sampleRate) in 'freqs' neutralizes-              speeds  = map (\v -> 250/sampleRate+2*(Euc.norm v))-                            (zipWith subtract (tail trajectory) trajectory)+              speeds  = map (\v -> 250/sampleRate + 2 * Euc.norm v)+                            (FiltNR.differentiate trajectory)               freqs   = zipWith (+) speeds (FiltNR.differentiate phase)               sound   = Osci.freqModSaw 0 freqs           in  zipWith (*) (map (10*) volumes) sound
src/Synthesizer/Plain/Effect/Glass.hs view
@@ -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,15 +11,16 @@ import qualified Synthesizer.Plain.Noise      as Noise import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR +import System.Random(randomRs, mkStdGen)++import qualified Data.List.HT as ListHT+ import qualified Algebra.Transcendental as Trans import qualified Algebra.RealField      as RealField-import qualified Algebra.Additive       as Additive import qualified Algebra.Module         as Module -import System.Random(randomRs, mkStdGen)--import PreludeBase-import NumericPrelude as NP+import NumericPrelude.Numeric+import NumericPrelude.Base as NP   {- | We try to simulate the sound of broken glass@@ -51,20 +52,16 @@                 (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 _ [] = []    in  diffs (NonNeg.fromNumber 0)  timeDiffs :: [Bool] -> [NonNeg.Int]-timeDiffs = map (NonNeg.fromNumber . length) . segmentBefore id--segmentBefore :: (a -> Bool) -> [a] -> [[a]]-segmentBefore p =-   foldr (\ x ~(y:ys) -> (if p x then ([]:) else id) ((x:y):ys)) [[]]+timeDiffs = map (NonNeg.fromNumber . length) . ListHT.segmentBefore id
src/Synthesizer/Plain/File.hs view
@@ -1,5 +1,22 @@ {-# LANGUAGE NoImplicitPrelude #-}-module Synthesizer.Plain.File where+module Synthesizer.Plain.File (+   render,+   renderToInt16,+   renderMonoToInt16,+   renderStereoToInt16,+   write,+   writeToInt16,+   writeMonoToInt16,+   writeStereoToInt16,+   writeRaw,+   writeRawCompressed,+   rawToAIFF,+   compress,+   readAIFFMono,+   readMonoFromInt16,+   -- will no longer be exported+   getInt16List,+   ) where  import qualified Sound.Sox.Convert as Convert import qualified Sound.Sox.Frame as Frame@@ -18,19 +35,22 @@ import Foreign.Storable (Storable, ) import Data.Int (Int16, ) -import System.Cmd (rawSystem, )+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.RealField          as RealField+import qualified Algebra.RealRing           as RealRing import qualified Algebra.Field              as Field -import qualified System.FilePath as FilePath--import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   @@ -39,22 +59,22 @@ -} render ::    (Storable int, Frame.C int, ToInteger.C int, Bounded int,-    RealField.C a, BinSmp.C v) =>+    RealRing.C a, BinSmp.C v) =>    Builder.Put int -> FilePath -> a -> (a -> [v]) -> IO ExitCode render put fileName sampleRate renderer =    write put fileName sampleRate (renderer sampleRate) -renderToInt16 :: (RealField.C a, BinSmp.C v) =>+renderToInt16 :: (RealRing.C a, BinSmp.C v) =>    FilePath -> a -> (a -> [v]) -> IO ExitCode renderToInt16 fileName sampleRate renderer =    writeToInt16 fileName sampleRate (renderer sampleRate) -renderMonoToInt16 :: (RealField.C a) =>+renderMonoToInt16 :: (RealRing.C a) =>    FilePath -> a -> (a -> [a]) -> IO ExitCode renderMonoToInt16 fileName sampleRate renderer =    writeMonoToInt16 fileName sampleRate (renderer sampleRate) -renderStereoToInt16 :: (RealField.C a) =>+renderStereoToInt16 :: (RealRing.C a) =>    FilePath -> a -> (a -> [(a,a)]) -> IO ExitCode renderStereoToInt16 fileName sampleRate renderer =    writeStereoToInt16 fileName sampleRate (renderer sampleRate)@@ -72,7 +92,7 @@ -} write ::    (Storable int, Frame.C int, ToInteger.C int, Bounded int,-    RealField.C a, BinSmp.C v) =>+    RealRing.C a, BinSmp.C v) =>    Builder.Put int -> FilePath -> a -> [v] -> IO ExitCode write put fileName sampleRate signal =    writeRaw@@ -82,24 +102,24 @@       (Builder.run . mconcat . map (BinSmp.outputFromCanonical put) $        signal) -writeToInt16 :: (RealField.C a, BinSmp.C v) =>+writeToInt16 :: (RealRing.C a, BinSmp.C v) =>    FilePath -> a -> [v] -> IO ExitCode writeToInt16 =    write (Builder.put :: Builder.Put Int16) -writeMonoToInt16 :: (RealField.C a) =>+writeMonoToInt16 :: (RealRing.C a) =>    FilePath -> a -> [a] -> IO ExitCode writeMonoToInt16 fileName sampleRate signal =    writeRaw SoxOpt.none fileName sampleRate       (map BinSmp.int16FromCanonical signal) -writeStereoToInt16 :: (RealField.C a) =>+writeStereoToInt16 :: (RealRing.C a) =>    FilePath -> a -> [(a,a)] -> IO ExitCode writeStereoToInt16 fileName sampleRate signal =    writeRaw SoxOpt.none fileName sampleRate       (map (fmap BinSmp.int16FromCanonical . uncurry Stereo.cons) signal) -writeRaw :: (RealField.C a, Frame.C v, Storable v) =>+writeRaw :: (RealRing.C a, Frame.C v, Storable v) =>    SoxOpt.T -> FilePath -> a -> [v] -> IO ExitCode writeRaw opts fileName sampleRate signal =    Write.extended SoxList.put opts SoxOpt.none fileName (round sampleRate) signal@@ -110,15 +130,16 @@ extension for 'writeRaw' and SoX will do the corresponding compression for you. -}-writeRawCompressed :: (RealField.C a, Frame.C v, Storable v) =>+writeRawCompressed :: (RealRing.C a, Frame.C v, Storable v) =>    SoxOpt.T -> FilePath -> a -> [v] -> IO ExitCode writeRawCompressed opts fileName sampleRate signal =-   do writeRaw opts fileName sampleRate signal-      compress fileName+   Exc.toExitCodeT $+   do Exc.fromExitCodeT $ writeRaw opts fileName sampleRate signal+      Exc.fromExitCodeT $ compress fileName   {-# DEPRECATED rawToAIFF "If you want to generate AIFF, then just write to files with .aiff filename extension. If you want to convert files to AIFF, use Sound.Sox.Convert." #-}-rawToAIFF :: (RealField.C a) =>+rawToAIFF :: (RealRing.C a) =>    FilePath -> SoxOpt.T -> a -> Int -> IO ExitCode rawToAIFF fileName soxOptions sampleRate numChannels =    let fileNameRaw  = fileName ++ ".sw"@@ -133,9 +154,9 @@           SoxOpt.none fileNameAIFF  compress :: FilePath -> IO ExitCode-compress fileName =-   do rawSystem "oggenc" ["--quality", "5", fileName]-      rawSystem "lame"+compress fileName = Exc.toExitCodeT $+   do Exc.fromExitCodeT $ rawSystem "oggenc" ["--quality", "5", fileName]+      Exc.fromExitCodeT $ rawSystem "lame"          ["-h", fileName, FilePath.replaceExtension fileName "mp3"]  @@ -146,7 +167,7 @@ after all system calls to Sox are performed. Aren't the calls serialized? -readAIFFMono :: (RealField.C a, Floating a) => FilePath -> IO [a]+readAIFFMono :: (RealRing.C a, Floating a) => FilePath -> IO [a] readAIFFMono file =    do putStrLn ("sox "++file++" /tmp/sample.sw")       system ("sox "++file++" /tmp/sample.sw")@@ -155,10 +176,12 @@ -} readAIFFMono :: (Field.C a) => FilePath -> IO [a] readAIFFMono file =-   do --putStrLn ("sox "++file++" "++tmp)-      let tmp = FilePath.replaceExtension file "sw"-      Convert.simple SoxOpt.none file SoxOpt.none tmp-      fmap (map BinSmp.int16ToCanonical) (FileL.readInt16StreamStrict tmp)+   let tmp = FilePath.replaceExtension file "s16"+   in  Exc.resolveT (const $ return []) $ do+          -- lift $ putStrLn ("sox "++file++" "++tmp)+          Exc.fromExitCodeT $ Convert.simple SoxOpt.none file SoxOpt.none tmp+          fmap (map BinSmp.int16ToCanonical) $+             lift $ FileL.readInt16StreamStrict tmp   {- |@@ -167,12 +190,14 @@ readMonoFromInt16 :: (Field.C a) => FilePath -> IO [a] readMonoFromInt16 fileName =    Read.open SoxOpt.none fileName >>=-   Read.withHandle1 (fmap (Get.runGet getInt16List) . B.hGetContents) >>=+   Read.withHandle1 (fmap (Get.runGet getInt16ListPrivate) . B.hGetContents) >>=    return . map BinSmp.int16ToCanonical -getInt16List :: Get.Get [Int16]-getInt16List =+{-# DEPRECATED getInt16List "This function will no longer be exported" #-}+getInt16List, getInt16ListPrivate :: Get.Get [Int16]+getInt16List = getInt16ListPrivate+getInt16ListPrivate =    do b <- Get.isEmpty       if b         then return []-        else liftM2 (:) (fmap fromIntegral Get.getWord16host) getInt16List+        else liftM2 (:) (fmap fromIntegral Get.getWord16host) getInt16ListPrivate
src/Synthesizer/Plain/Filter/Delay.hs view
@@ -1,15 +1,20 @@ {-# 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 import qualified Synthesizer.Plain.Noise   as Noise-import System.Random (Random, randomRs, mkStdGen, )+import System.Random (randomRs, mkStdGen, )  import qualified Algebra.Module    as Module import qualified Algebra.RealField as RealField-import qualified Algebra.Additive  as Additive  import qualified Synthesizer.Plain.Interpolation as Interpolation @@ -17,9 +22,8 @@ import qualified Synthesizer.Plain.Filter.Delay.List  as DelayList import qualified Synthesizer.Plain.Filter.Delay.Block as DelayBlock -import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   phaser :: (Module.C a v, RealField.C a) => a -> [a] -> [v] -> [v]
src/Synthesizer/Plain/Filter/Delay/Block.hs view
@@ -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,9 +23,8 @@  import Test.QuickCheck ((==>), Property) -import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   modulatedCore :: (RealField.C a, Additive.C v) =>@@ -79,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)]
src/Synthesizer/Plain/Filter/Delay/List.hs view
@@ -1,16 +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 qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   {- |
src/Synthesizer/Plain/Filter/Delay/ST.hs view
@@ -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,9 +13,8 @@ import Control.Monad.ST.Lazy(runST,strictToLazyST,ST) import Data.Array.ST -import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   {-
src/Synthesizer/Plain/Filter/LinearPredictive.hs view
@@ -1,15 +1,14 @@ module Synthesizer.Plain.Filter.LinearPredictive where -import qualified Algebra.Field    as Field-import qualified Algebra.Ring     as Ring-import qualified Algebra.Additive as Additive import Synthesizer.Plain.Analysis (scalarProduct)  import qualified Data.List.Match as ListMatch import qualified Data.List as List -import NumericPrelude-import PreludeBase+import qualified Algebra.Field    as Field++import NumericPrelude.Numeric+import NumericPrelude.Base import Prelude ()
src/Synthesizer/Plain/Filter/NonRecursive.hs view
@@ -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 @@ -19,18 +60,15 @@ import qualified Algebra.Ring           as Ring import qualified Algebra.Additive       as Additive -import Algebra.Module(linearComb, (*>))+import Algebra.Module(linearComb, )  import Data.Function.HT (nest, ) import Data.Tuple.HT (mapPair, ) import Data.List.HT (sliceVertical, ) import Data.List (tails, ) --- import Control.Monad.Trans.State (StateT)--- import Control.Monad.Trans.Writer (WriterT)--import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   {- * Envelope application -}@@ -151,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 [] = []@@ -260,15 +275,6 @@ pyramid :: (Additive.C v) => Sig.T v -> [Sig.T v] pyramid = iterate sumsDownsample2 -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@.@@ -277,8 +283,16 @@ -} sumRangeFromPyramid :: (Additive.C v) => [Sig.T v] -> (Int,Int) -> v sumRangeFromPyramid =-   sumRangePrepare $ \(l0,r0) pyr0 ->-   sum $+   sumRangePrepare $ \lr0 pyr0 ->+   sum $ getRangeFromPyramid pyr0 lr0++minRange :: (Ord v) => Sig.T v -> (Int,Int) -> v+minRange =+   symmetricRangePrepare $ \ (l,r) ->+   minimum . take (r-l) . drop l++getRangeFromPyramid :: [Sig.T v] -> (Int,Int) -> [v]+getRangeFromPyramid pyr0 lr0 =    case pyr0 of       [] -> error "empty pyramid"       (ps0:pss) ->@@ -293,16 +307,18 @@                      1 -> [ps!!l]                      _ -> ls ++ rs ++ k ((lh,rh), psNext))             (\((l,r), ps) -> take (r-l) $ drop l ps)-            pss ((l0,r0), ps0)+            pss (lr0, ps0)  {- mapAccumL cannot work since the pyramid might be infinitely high    sum $ takeWhileJust $ snd $-   mapAccumL () (l0,r0) $+   mapAccumL () lr0 $    zip pyr0 $    tail (Match.replicate pyr0 False ++ [True]) -} -sumRangeFromPyramidRec :: (Additive.C v) => [Sig.T v] -> (Int,Int) -> v+sumRangeFromPyramidRec ::+   (Additive.C v) =>+   [Sig.T v] -> (Int,Int) -> v sumRangeFromPyramidRec =    let recourse s (l,r) pyr =           case pyr of@@ -320,6 +336,32 @@              [] -> error "empty pyramid"    in  sumRangePrepare (recourse zero) +sumRangeFromPyramidFoldr ::+   (Additive.C v) =>+   [Sig.T v] -> (Int,Int) -> v+sumRangeFromPyramidFoldr =+   sumRangePrepare $ \lr0 pyr0 ->+   case pyr0 of+      [] -> error "empty pyramid"+      (ps0:pss) ->+         foldr+            (\psNext k (l,r) ps s ->+               case r-l of+                  0 -> s+                  1 -> s + ps!!l+                  _ ->+                     let (lh,ll) = - divMod (-l) 2+                         (rh,rl) =   divMod   r  2+                         {-# INLINE inc #-}+                         inc b x = if b==0 then id else (x+)+                     in  k (lh,rh) psNext $+                         inc ll (ps!!l) $+                         inc rl (ps!!(r-1)) $+                         s)+            (\(l,r) ps s ->+               s + (sum $ take (r-l) $ drop l ps))+            pss lr0 ps0 zero+ sumsPosModulated :: (Additive.C v) =>    Sig.T (Int,Int) -> Sig.T v -> Sig.T v sumsPosModulated ctrl xs =@@ -334,11 +376,10 @@    Int -> Sig.T (Int,Int) -> Sig.T v -> Sig.T v sumsPosModulatedPyramid height ctrl xs =    let blockSize = 2 ^ fromIntegral height-       sizes =-          reverse $ take (1+height) $ iterate (2*) 1+       pyr0 = take (1+height) $ pyramid xs+       sizes = unitSizesFromPyramid pyr0        pyrStarts =-          iterate (zipWith drop sizes) $-          take (1+height) $ pyramid xs+          iterate (zipWith drop sizes) pyr0        ctrlBlocks =           map (zipWith (\d -> mapPair ((d+), (d+))) $ iterate (1+) 0) $           sliceVertical blockSize ctrl@@ -352,6 +393,8 @@ The main reason to introduce it, was to have only a Module constraint instead of Field. This way we can also filter stereo signals.++A control value @n@ corresponds to filter window size @2*n+1@. -} movingAverageModulatedPyramid ::    (Field.C a, Module.C a v) =>@@ -359,7 +402,7 @@ movingAverageModulatedPyramid amp height maxC ctrl xs =    zipWith (\c x -> (amp / fromIntegral (2*c+1)) *> x) ctrl $    sumsPosModulatedPyramid height-      (map (\c -> (maxC - c, maxC + c)) ctrl)+      (map (\c -> (maxC - c, maxC + c + 1)) ctrl)       (delay maxC xs)
src/Synthesizer/Plain/Filter/Recursive.hs view
@@ -12,17 +12,10 @@ module Synthesizer.Plain.Filter.Recursive where  import qualified Algebra.Module                as Module--- import qualified Algebra.Transcendental        as Trans--- import qualified Algebra.Field                 as Field--- import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive -import Algebra.Additive((+), (-), negate, )-import Algebra.Module((*>))--import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   {- * Various Filters -}
src/Synthesizer/Plain/Filter/Recursive/Allpass.hs view
@@ -2,39 +2,72 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {- |-Copyright   :  (c) Henning Thielemann 2008+Copyright   :  (c) Henning Thielemann 2008-2010 License     :  GPL  Maintainer  :  synthesizer@henning-thielemann.de 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))+ import qualified Algebra.Module                as Module import qualified Algebra.RealTranscendental    as RealTrans import qualified Algebra.Transcendental        as Trans import qualified Algebra.Field                 as Field import qualified Algebra.Ring                  as Ring-import qualified Algebra.Additive              as Additive--import Algebra.Module((*>))+import qualified Algebra.ZeroTestable          as ZeroTestable -import Number.Complex ((+:)) import qualified Number.Complex as Complex-import Data.Tuple.HT (mapSnd, )-import Data.Function.HT (nest, ) -import Control.Monad.Trans.State (State, state, runState, evalState, )--import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   @@ -42,48 +75,120 @@    Parameter {getParameter :: a}  {- ^ Feedback factor. -}    deriving Show +instance Functor Parameter where+   {-# INLINE fmap #-}+   fmap f (Parameter k) = Parameter (f k) +instance App.Applicative Parameter where+   {-# INLINE pure #-}+   pure x = Parameter x+   {-# INLINE (<*>) #-}+   Parameter f <*> Parameter k =+      Parameter (f k)++instance Fold.Foldable Parameter where+   {-# INLINE foldMap #-}+   foldMap = Trav.foldMapDefault++instance Trav.Traversable Parameter where+   {-# INLINE sequenceA #-}+   sequenceA (Parameter k) =+      fmap Parameter k+ instance Interpol.C a v => Interpol.C a (Parameter v) where    {-# INLINE scaleAndAccumulate #-}    scaleAndAccumulate = Interpol.makeMac Parameter getParameter +instance Storable a => Storable (Parameter a) where+   sizeOf = Store.sizeOf getParameter+   alignment = Store.alignment getParameter+   peek = Store.peek Parameter+   poke = Store.poke getParameter + {--Shall the phase parameter be of type Phase?-I think no, because for the allpass cascade we divide by the order+cos phi = (1-r^2)/(1+r^2)+cos omega = (1-s^2)/(1+s^2)+cos (phi-omega)+   = cos phi * cos omega + sin phi * sin omega+   = ((1-r^2)*(1-s^2) + 4*r*s) / ((1+r^2) * (1+s^2))+k = ((1-r^2)*(1+s^2) - (1+r^2)*(1-s^2)) /+    ((1+r^2) * (1+s^2) - ((1-r^2)*(1-s^2) + 4*r*s))+k = 2*(s^2-r^2) / (2*r^2+2*s^2 - 4*r*s)+k = (s^2-r^2) / (r-s)^2+k = (s+r) / (s-r)+-}+{- |+Compute the filter parameter+such that a given phase shift is achieved at a certain frequency.++Both frequency and phase are with respect to unit 1.+This is conform to Phase definition+and allows to avoid Transcendental constraint in some cases+since we need no factor @2*pi@.+See for instance 'parameterApprox'.+However, it is intended that the phase parameter is not of type Phase,+because for the 'cascadeParameter' we divide by the cascade order and then there is a difference between phase pi and 3*pi. -} {-# INLINE parameter #-} parameter :: Trans.C a =>-     Int  {- ^ The number of equally designed 1st order allpasses. -}-  -> a    {- ^ The phase shift to be achieved for the given frequency. -}+     a    {- ^ The phase shift to be achieved for the given frequency. -}   -> a    {- ^ The frequency we specified the phase shift for. -}   -> Parameter a-parameter order phase frequency =-    let orderFloat = fromIntegral order-        omega = frequency * 2 * pi-        phi = phase / orderFloat-        k = (cos phi - cos omega) / (1 - cos (phi - omega))-    in  Parameter k+parameter phase frequency =+   let s = tan (pi*frequency)+       r = tan (pi*phase)+   in  Parameter $ (s+r) / (s-r) -{-# INLINE flangerPhase #-}-flangerPhase :: Trans.C a => a-flangerPhase = -2*pi -{-# INLINE flangerParameter #-}-flangerParameter :: Trans.C a => Int -> a -> Parameter a-flangerParameter order frequency =-   parameter order flangerPhase frequency+{- |+This is the same as 'parameter',+but for @phase = frequency@+it has a division of a zero by a zero of multiplicity 2,+whereas 'parameter' has a division  of a non-zero number by zero.+Thus 'parameter' suffers less from cancellation+if @phase@ is close to @frequency@.+-}+{-# INLINE parameterAlt #-}+parameterAlt :: Trans.C a =>+     a    {- ^ The phase shift to be achieved for the given frequency. -}+  -> a    {- ^ The frequency we specified the phase shift for. -}+  -> Parameter a+parameterAlt phase frequency =+   let omega = 2*pi * frequency+       phi   = 2*pi * phase+       k = (cos phi - cos omega) / (1 - cos (phi - omega))+   in  Parameter k ++{- |+An approximation to 'parameter' for small phase and frequency values.+It needs only field operations+due to our choice of the unit 1 for the phase parameter.+-}+{-# INLINE parameterApprox #-}+parameterApprox :: Trans.C a =>+     a    {- ^ The phase shift to be achieved for the given frequency. -}+  -> a    {- ^ The frequency we specified the phase shift for. -}+  -> Parameter a+parameterApprox phase frequency =+   Parameter $ (frequency + phase) / (frequency - phase)+++-- * atomic first order allpass++type State v = (v,v)+ {-# INLINE firstOrderStep #-} firstOrderStep :: (Ring.C a, Module.C a v) =>-   Parameter a -> v -> State (v,v) v+   Parameter a -> v -> MS.State (State v) v firstOrderStep (Parameter k) u0 =-   state (\(u1,y1) -> let y0 = u1 + k *> (u0-y1) in (y0,(u0,y0)))+   MS.state (\(u1,y1) -> let y0 = u1 + k *> (u0-y1) in (y0,(u0,y0)))  {-# INLINE firstOrderModifier #-} firstOrderModifier :: (Ring.C a, Module.C a v) =>-   Modifier.Simple (v,v) (Parameter a) v v+   Modifier.Simple (State v) (Parameter a) v v firstOrderModifier =    Modifier.Simple (zero,zero) firstOrderStep @@ -99,12 +204,42 @@ firstOrder = Sig.modifyModulated firstOrderModifier  +{- |+Compute phase shift of an allpass at a given frequency.+-} {-# INLINE makePhase #-}-makePhase :: RealTrans.C a => Parameter a -> a -> a+makePhase :: (RealTrans.C a, ZeroTestable.C a) => Parameter a -> a -> a makePhase (Parameter k) frequency =-    let omega = 2*pi * frequency-    in  2 * Complex.phase ((k+cos omega)+:(- sin omega)) + omega+   let cis = Complex.cis (- 2*pi * frequency)+   in  Complex.phase (Complex.fromReal k + cis) / pi + frequency ++-- * allpass cascade with uniform control++{-# INLINE cascadeParameter #-}+cascadeParameter :: Trans.C a =>+     Int  {- ^ The number of equally designed 1st order allpasses. -}+  -> a    {- ^ The phase shift to be achieved for the given frequency. -}+  -> a    {- ^ The frequency we specified the phase shift for. -}+  -> Parameter a+cascadeParameter order phase =+   parameter (phase / fromIntegral order)++{-# INLINE flangerPhase #-}+flangerPhase :: Field.C a => a+flangerPhase = -1++{-# INLINE flangerParameter #-}+flangerParameter :: Trans.C a => Int -> a -> Parameter a+flangerParameter order frequency =+   cascadeParameter order flangerPhase frequency+++{-# INLINE cascadeStep #-}+cascadeStep :: (Ring.C a, Module.C a v) =>+   Parameter a -> v -> MS.State [v] v+cascadeStep = cascadeStepRec+ {- internal storage is not very efficient because the second value of one pair is equal@@ -112,18 +247,21 @@ -} {-# INLINE cascadeStepStackPairs #-} cascadeStepStackPairs :: (Ring.C a, Module.C a v) =>-   Parameter a -> v -> State [(v,v)] v+   Parameter a -> v -> MS.State [State v] v cascadeStepStackPairs k =    -- stackStatesR would work as well, but with reversed list of states    Modifier.stackStatesL (firstOrderStep k)  {-# INLINE cascadeStepStack #-}-cascadeStepStack :: (Ring.C a, Module.C a v) =>-   Parameter a -> v -> State [v] v+{-# INLINE cascadeStepRec #-}+{-# INLINE cascadeStepScanl #-}+cascadeStepStack, cascadeStepRec, cascadeStepScanl ::+   (Ring.C a, Module.C a v) =>+   Parameter a -> v -> MS.State [v] v cascadeStepStack k x =-   state $+   MS.state $       mapSnd fromPairs .-      runState (cascadeStepStackPairs k x) .+      MS.runState (cascadeStepStackPairs k x) .       toPairs  {-# INLINE fromPairs #-}@@ -133,34 +271,28 @@  {-# INLINE toPairs #-} toPairs :: [a] -> [(a,a)]-toPairs xs = zip xs (tail xs)+toPairs xs = mapAdjacent (,) xs -{-# INLINE cascadeStep #-}-{-# INLINE cascadeStepRec #-}-{-# INLINE cascadeStepRecAlt #-}-cascadeStep, cascadeStepRec, cascadeStepRecAlt ::-   (Ring.C a, Module.C a v) =>-   Parameter a -> v -> State [v] v -cascadeStep = cascadeStepRec+cascadeStepRec (Parameter k) x = MS.state $ \s ->+   let crawl _ [] = error "Allpass.crawl needs at least one element in the list"+       crawl u0 (_:[]) = u0:[]+       crawl u0 (u1:y1:us) =+           let y0 = u1 + k *> (u0-y1)+           in  u0 : crawl y0 (y1:us)+       news = crawl x s+   in  (last news, news) -cascadeStepRec (Parameter k) x = state $ \s ->-    let crawl _ [] = error "Allpass.crawl needs at least one element in the list"-        crawl u0 (_:[]) = u0:[]-        crawl u0 (u1:y1:us) =-            let y0 = u1 + k *> (u0-y1)-            in  u0 : crawl y0 (y1:us)-        news = crawl x s-    in  (last news, news)+cascadeStepScanl k x = MS.state $ \s ->+   let news =+          scanl+             (MS.evalState . firstOrderStep k)+             x (mapAdjacent (,) s)+   in  (switchR+           (error "Allpass.cascade needs at least one element in the state list")+           (flip const) news,+        news) -cascadeStepRecAlt k x = state $ \s ->-    let crawl _ [] = error "Allpass.crawl needs at least one element in the list"-        crawl u0 (u1:u1s) = mapSnd (u0:) $-           case u1s of-              [] -> (u0,[])-              (y1:_) ->-                 crawl (evalState (firstOrderStep k u0) (u1,y1)) u1s-    in  crawl x s  {-# INLINE cascadeModifier #-} cascadeModifier :: (Ring.C a, Module.C a v) =>@@ -200,3 +332,23 @@ {-| Directly implement the allpass cascade as multiple application of allpasses of 1st order -} cascadeIterative order c =    nest order (firstOrder c)++++-- * allpass cascade with independently controlled atomic allpasses++{-# INLINE cascadeDiverseStep #-}+{-# INLINE cascadeDiverseStepScanl #-}+cascadeDiverseStep, cascadeDiverseStepScanl :: (Ring.C a, Module.C a v) =>+   [Parameter a] -> v -> MS.State [v] v+cascadeDiverseStep = cascadeDiverseStepScanl++cascadeDiverseStepScanl ks x = MS.state $ \s ->+   let news =+          scanl+             (\u0 (k,uy1) -> MS.evalState (firstOrderStep k u0) uy1)+             x (zip ks $ mapAdjacent (,) s)+   in  (switchR+           (error "Allpass.cascadeDiverse needs at least one element in the state list")+           (flip const) news,+        news)
src/Synthesizer/Plain/Filter/Recursive/AllpassPoly.hs view
@@ -11,25 +11,19 @@ -} 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 import qualified Algebra.Field                 as Field-import qualified Algebra.Ring                  as Ring-import qualified Algebra.Additive              as Additive--import Algebra.Module((*>))+import qualified Algebra.ZeroTestable          as ZeroTestable  import Number.Complex (cis,(+:),real,imag) import qualified Number.Complex as Complex import Orthogonals(Scalar,one_ket_solution)  import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   @@ -54,7 +48,7 @@ {-   GNUPlot.plotFunc (GNUPlot.linearScale 500 (0,1)) ((fwrap (-pi,pi)).(makePhase (shiftParam 6 (-6) (-pi/2::Double)))) -}-makePhase :: RealTrans.C a => Parameter a -> a -> a+makePhase :: (RealTrans.C a, ZeroTestable.C a) => Parameter a -> a -> a makePhase (Parameter ks) frequency =     let omega  = 2*pi * frequency         omegas = iterate (omega+) omega@@ -83,7 +77,7 @@         q = (exp (2*pi*r) - 1) / (r^2 + k^2)     in  (r*q, -k*q) -{- Should be moved to NumericPrelude -}+{- Should be moved to NumericPrelude.Numeric -} integrateNum :: (Field.C a, Module.C a v) => Int -> (a,a) -> (a->v) -> v integrateNum n (lo,hi) f =     let xs = map (\k -> lo + (hi-lo) * fromIntegral k / fromIntegral n)
src/Synthesizer/Plain/Filter/Recursive/Butterworth.hs view
@@ -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@@ -24,23 +39,20 @@  import qualified Algebra.Module                as Module import qualified Algebra.Transcendental        as Trans-import qualified Algebra.Field                 as Field import qualified Algebra.Ring                  as Ring-import qualified Algebra.Additive              as Additive  import qualified Data.StorableVector as SV import Foreign.Storable (Storable) -import qualified Prelude as P-import PreludeBase-import NumericPrelude+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 =@@ -63,11 +75,11 @@   -partialParameterInstable, partialParameter :: (Trans.C a) =>+_partialLowpassParameterInstable, partialLowpassParameter :: (Trans.C a) =>    a -> a -> a -> Filt2.Parameter a  {- must handle infinite values when 'freq' approaches 0.5 -}-partialParameterInstable ratio freq sinw =+_partialLowpassParameterInstable ratio freq sinw =    let wc    = ratio * tan (pi*freq)        sinw2 = 2 * wc * sinw        wc2   = wc * wc@@ -77,7 +89,7 @@           (2*(1-wc2)/denom) ((-wc2+sinw2-1)/denom)  -- using ratio disallows simplification by trigonometric Pythagoras' theorem-partialParameter ratio freq =+partialLowpassParameter ratio freq =    let phi      = pi*freq        rsin2phi = ratio * sin (2*phi)        cosphi2  = cos phi ^ 2@@ -107,16 +119,24 @@    let sinesVec = SV.pack (makeSines order)    in  \ (Pole ratio freq) ->            Cascade.Parameter $-           SV.map (\sinw ->-              Filt2.adjustPassband kind-                 (flip (partialParameter (partialRatio order ratio)) sinw) freq) $+           SV.map+              (\sinw ->+                 partialParameter kind (partialRatio order ratio) sinw freq) $            sinesVec +partialParameter ::+   Trans.C a =>+   Passband -> a -> a -> a -> Filt2.Parameter a+partialParameter kind partRatio sinw freq =+   Filt2.adjustPassband kind+      (flip (partialLowpassParameter partRatio) sinw)+      freq+ {-# INLINE modifier #-} modifier ::    (Ring.C a, Module.C a v, Storable a, Storable v) =>    Int ->-   Modifier.Simple (Cascade.Status v) (Parameter a) v v+   Modifier.Simple (Cascade.State v) (Parameter a) v v modifier =    Cascade.modifier @@ -158,15 +178,17 @@  It uses the frequency and ratio information directly and thus cannot benefit from efficient parameter interpolation-(asynchronous run of a ControlledProcess.+(asynchronous run of a ControlledProcess). -} runPole :: (Trans.C a, Module.C a v) =>    Passband -> Int -> Sig.T a -> Sig.T a -> Sig.T v -> Sig.T v runPole kind order ratios freqs =    let makePartialFilter s =-          Filt2.run (zipWith (\ratio ->-             Filt2.adjustPassband kind $ \freq ->-                partialParameter (partialRatio order ratio) freq s) ratios freqs)+          Filt2.run $+          zipWith+             (\ratio freq ->+                partialParameter kind (partialRatio order ratio) s freq)+             ratios freqs    in  foldl (.) id (map makePartialFilter (makeSines order))  causalPole :: (Trans.C a, Module.C a v) =>@@ -174,9 +196,10 @@ causalPole kind order =    let {-# INLINE makePartialFilter #-}        makePartialFilter s =-          Causal.first (Causal.map (\(Pole ratio freq) ->-             Filt2.adjustPassband kind-                (flip (partialParameter (partialRatio order ratio)) s) freq)) >>>+          Causal.first+             (Causal.map (\(Pole ratio freq) ->+                partialParameter kind (partialRatio order ratio) s freq))+          >>>           Filt2.causal    in  Causal.chainControlled $ map makePartialFilter $ makeSines order
src/Synthesizer/Plain/Filter/Recursive/Chebyshev.hs view
@@ -11,48 +11,51 @@  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 ((>>>), (^>>), (&&&), ) --- import qualified Algebra.VectorSpace           as VectorSpace import qualified Algebra.Module                as Module import qualified Algebra.Transcendental        as Trans import qualified Algebra.Field                 as Field import qualified Algebra.Ring                  as Ring-import qualified Algebra.Additive              as Additive -import Algebra.Module((*>))- import Number.Complex (real, imag, cis, ) import qualified Number.Complex as Complex --- import Control.Monad.Trans.State (State(..), evalState)- import qualified Data.StorableVector as SV import Foreign.Storable (Storable) -import qualified Prelude as P-import PreludeBase-import NumericPrelude+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@@ -69,10 +72,10 @@ for the Butterworth filter the quadratic factors of the polynomial can be determined more efficiently than the zeros. -}-partialParameterA, partialParameterB :: (Trans.C a) =>+partialLowpassParameterA, partialLowpassParameterB :: (Trans.C a) =>    Int -> a -> a -> Complex.T a -> Filt2.Parameter a {--partialParameterA order ratio freq =+partialLowpassParameterA order ratio freq =    let {- if ratio == (sqrt 2) then the product of the normalization factors is           2^(1-2*order) -} --       bn = asinh (ratio/sqrt(1-ratio^2)) / fromIntegral (2*order)@@ -99,7 +102,7 @@                  (-2*(cpims*cmims - resin2)/denom) ((cpims^2 + resin2)/denom) -} -partialParameterA order ratio freq =+partialLowpassParameterA order ratio freq =    let {- if ratio == (sqrt 2) then the product of the normalization factors is           2^(1-2*order) -} --       bn = asinh (ratio/sqrt(1-ratio^2)) / fromIntegral (2*order)@@ -133,7 +136,7 @@                  (-2*(cpims*cmims - resin2)/denom) ((cpims^2 + resin2)/denom)  {--partialParameterA order ratio freq =+partialLowpassParameterA order ratio freq =    let {- if ratio == (sqrt 2) then the product of the normalization factors is           2^(1-2*order) -}        bn = asinh (ratio/sqrt(1-ratio^2)) / fromIntegral (2*order)@@ -163,7 +166,7 @@ -}  {--partialParameterA order ratio freq =+partialLowpassParameterA order ratio freq =    let {- if ratio == (sqrt 2) then the product of the normalization factors is           2^(1-2*order) -}        bn = asinh (ratio/sqrt(1-ratio^2)) / fromIntegral (2*order)@@ -193,7 +196,7 @@ -}  {--partialParameterB order ratio freq =+partialLowpassParameterB order ratio freq =    let -- bn = asinh (sqrt(1-ratio^2)/ratio) / fromIntegral (2*order)        bn = (log(1+sqrt(1-ratio^2)) - log ratio) / fromIntegral (2*order)        coshbn  = cosh bn@@ -221,7 +224,7 @@                  (-2*(spimc*smimc - recos2)/denom) (-(spimc^2 + recos2)/denom) -} -partialParameterB order ratio freq =+partialLowpassParameterB order ratio freq =    let -- bn = asinh (sqrt(1-ratio^2)/ratio) / fromIntegral (2*order)        bn = (log(1+sqrt(1-ratio^2)) - log ratio) / fromIntegral (2*order)        coshbn  = cosh bn@@ -252,6 +255,30 @@  -- * use second order filter parameters for control +{-# INLINE partialParameter #-}+partialParameter ::+   (Field.C a) =>+   (a -> a -> Complex.T a -> Filt2.Parameter a) ->+   Passband -> a -> Complex.T a -> a -> Filt2.Parameter a+partialParameter lowpassParameter kind ratio c freq =+   Filt2.adjustPassband kind+      (flip (lowpassParameter ratio) c)+      freq++{-# INLINE partialParameterA #-}+{-# INLINE partialParameterB #-}+partialParameterA, partialParameterB ::+   (Trans.C a) =>+   Passband -> Int -> a -> Complex.T a -> a -> Filt2.Parameter a+partialParameterA kind order =+   partialParameter (partialLowpassParameterA order) kind+partialParameterB kind order =+   partialParameter (partialLowpassParameterB order) kind++{-+We could prevent definition of an extra parameter type+by applying application to one of the filters using Filt2.amplify.+-} type ParameterA a = (a, Cascade.Parameter a)  {-# INLINE parameterA #-}@@ -264,12 +291,18 @@    in  \ (Pole ratio freq) ->           (ratio,            Cascade.Parameter $-           SV.map (\c ->-              Filt2.adjustPassband kind-                 (flip (partialParameterA order ratio) c) freq) $+           SV.map (\c -> partialParameterA kind order ratio c freq) $            circleVec) +{-# INLINE canonicalizeParameterA #-}+canonicalizeParameterA ::+   (Ring.C a, Storable a) =>+   ParameterA a -> Cascade.Parameter a+canonicalizeParameterA (amp, Cascade.Parameter p) =+   Cascade.Parameter+      (SV.switchL SV.empty (\h -> SV.cons (Filt2.amplify amp h)) p) + type ParameterB a = Cascade.Parameter a  {-# INLINE parameterB #-}@@ -281,9 +314,7 @@    let circleVec = SV.pack (makeCirclePoints order)    in  \ (Pole ratio freq) ->            Cascade.Parameter $-           SV.map (\c ->-              Filt2.adjustPassband kind-                 (flip (partialParameterB order ratio) c) freq) $+           SV.map (\c -> partialParameterB kind order ratio c freq) $            circleVec  {-@@ -291,7 +322,7 @@ modifierB ::    (Ring.C a, Module.C a v, Storable a, Storable v) =>    Int ->-   Modifier.Simple (Cascade.Status v) (Cascade.Parameter a) v v+   Modifier.Simple (Cascade.State v) (Cascade.Parameter a) v v modifierB =    Cascade.modifierB -}@@ -322,8 +353,7 @@    let makePartialFilter c =           Filt2.run              (zipWith-                 (\ratio -> Filt2.adjustPassband kind $-                  \freq -> partialParameterA order ratio freq c)+                 (\ratio freq -> partialParameterA kind order ratio c freq)                  ratios freqs)    in  foldl (.) (zipWith (*>) ratios)           (map makePartialFilter (makeCirclePoints order))@@ -332,8 +362,7 @@    let makePartialFilter c =           Filt2.run              (zipWith-                 (\ratio -> Filt2.adjustPassband kind $-                  \freq -> partialParameterB order ratio freq c)+                 (\ratio freq -> partialParameterB kind order ratio c freq)                  ratios freqs)    in  foldl (.) id (map makePartialFilter (makeCirclePoints order)) @@ -344,8 +373,7 @@    let {-# INLINE makePartialFilter #-}        makePartialFilter c =           Causal.first (Causal.map (\(Pole ratio freq) ->-             Filt2.adjustPassband kind-             (flip (partialParameterA order ratio) c) freq)) >>>+             partialParameterA kind order ratio c freq)) >>>           Filt2.causal    in  (\(p, y) -> (p, poleResonance p *> y)) ^>>        (Causal.chainControlled $@@ -356,8 +384,7 @@    let {-# INLINE makePartialFilter #-}        makePartialFilter c =           Causal.first (Causal.map (\(Pole ratio freq) ->-             Filt2.adjustPassband kind-             (flip (partialParameterB order ratio) c) freq)) >>>+             partialParameterB kind order ratio c freq)) >>>           Filt2.causal    in  Causal.chainControlled $        map makePartialFilter $
src/Synthesizer/Plain/Filter/Recursive/Comb.hs view
@@ -14,22 +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.Field                 as Field import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive -import Algebra.Module((*>))--import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   {- |
src/Synthesizer/Plain/Filter/Recursive/FirstOrder.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {- |-Copyright   :  (c) Henning Thielemann 2008+Copyright   :  (c) Henning Thielemann 2008-2011 License     :  GPL  Maintainer  :  synthesizer@henning-thielemann.de@@ -16,34 +16,70 @@ import qualified Synthesizer.Plain.Signal   as Sig import qualified Synthesizer.Plain.Modifier as Modifier import qualified Synthesizer.Causal.Process as Causal+ import qualified Synthesizer.Interpolation.Class as Interpol +import qualified Control.Applicative as App+import Control.Monad.Trans.State (State, state, )+import Control.Applicative (pure, liftA2, )++import qualified Data.Foldable as Fold+import qualified Data.Traversable as Trav++import qualified Foreign.Storable.Newtype as Store+import qualified Foreign.Storable.Traversable as StoreTrav+import Foreign.Storable (Storable(sizeOf, alignment, peek, poke))++import qualified Test.QuickCheck as QC+ import qualified Algebra.Module                as Module import qualified Algebra.Transcendental        as Trans--- import qualified Algebra.Field                 as Field import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive -import Algebra.Module((*>))+import NumericPrelude.Numeric+import NumericPrelude.Base --- import qualified Number.Complex as Complex -import Control.Monad.Trans.State (State, state, ) -import PreludeBase-import NumericPrelude+newtype Parameter a = Parameter {getParameter :: a}+   deriving (Eq, Show)  +instance Functor Parameter where+   {-# INLINE fmap #-}+   fmap f (Parameter k) = Parameter (f k) -newtype Parameter a = Parameter {getParameter :: a}-   deriving Show+instance App.Applicative Parameter where+   {-# INLINE pure #-}+   pure x = Parameter x+   {-# INLINE (<*>) #-}+   Parameter f <*> Parameter k =+      Parameter (f k) +instance Fold.Foldable Parameter where+   {-# INLINE foldMap #-}+   foldMap = Trav.foldMapDefault +instance Trav.Traversable Parameter where+   {-# INLINE sequenceA #-}+   sequenceA (Parameter k) =+      fmap Parameter k+ instance Interpol.C a v => Interpol.C a (Parameter v) where    {-# INLINE scaleAndAccumulate #-}    scaleAndAccumulate = Interpol.makeMac Parameter getParameter +instance Storable a => Storable (Parameter a) where+   sizeOf = Store.sizeOf getParameter+   alignment = Store.alignment getParameter+   peek = Store.peek Parameter+   poke = Store.poke getParameter +instance QC.Arbitrary a => QC.Arbitrary (Parameter a) where+   arbitrary = fmap Parameter QC.arbitrary++ {-| Convert cut-off frequency to feedback factor. -} {-# INLINE parameter #-} parameter :: Trans.C a => a -> Parameter a@@ -98,7 +134,7 @@ highpassModifierInit :: (Ring.C a, Module.C a v) =>    Modifier.Initialized v v (Parameter a) v v highpassModifierInit =-   Modifier.Initialized negate highpassStep+   Modifier.Initialized id highpassStep  {-# INLINE highpassModifier #-} highpassModifier :: (Ring.C a, Module.C a v) =>@@ -115,7 +151,7 @@ highpassInitAlt :: (Ring.C a, Module.C a v) =>    v -> Sig.T (Parameter a) -> Sig.T v -> Sig.T v highpassInitAlt y0 control x =-   x - lowpassInit (-y0) control x+   zipWith (-) x $ lowpassInit y0 control x  {-# INLINE highpass #-} highpass :: (Ring.C a, Module.C a v) =>@@ -124,27 +160,88 @@   -data Result a =-        Result {highpass_, lowpass_ :: !a}+data Result a = Result {highpass_, lowpass_ :: !a}+   deriving (Eq) +instance Functor Result where+   {-# INLINE fmap #-}+   fmap f p = Result (f $ highpass_ p) (f $ lowpass_ p)++instance App.Applicative Result where+   {-# INLINE pure #-}+   pure x = Result x x+   {-# INLINE (<*>) #-}+   f <*> p = Result (highpass_ f $ highpass_ p) (lowpass_ f $ lowpass_ p)++instance Fold.Foldable Result where+   {-# INLINE foldMap #-}+   foldMap = Trav.foldMapDefault++instance Trav.Traversable Result where+   {-# INLINE sequenceA #-}+   sequenceA p = liftA2 Result (highpass_ p) (lowpass_ p)+ instance Additive.C v => Additive.C (Result v) where    {-# INLINE zero #-}    {-# INLINE (+) #-}    {-# INLINE (-) #-}    {-# INLINE negate #-}+   zero   = pure zero+   (+)    = liftA2 (+)+   (-)    = liftA2 (-)+   negate = fmap negate+{-    zero = Result zero zero    (+) (Result xhp xlp) (Result yhp ylp) = Result (xhp + yhp) (xlp + ylp)    (-) (Result xhp xlp) (Result yhp ylp) = Result (xhp - yhp) (xlp - ylp)    negate               (Result xhp xlp) = Result (negate xhp) (negate xlp)-+-}  instance Module.C a v => Module.C a (Result v) where    {-# INLINE (*>) #-}+   s*>v = fmap (s*>) v+{-    s *> (Result hp lp) = Result (s *> hp) (s *> lp)+-} +instance Storable a => Storable (Result a) where+   sizeOf    = StoreTrav.sizeOf+   alignment = StoreTrav.alignment+   peek      = StoreTrav.peekApplicative+   poke      = StoreTrav.poke +instance QC.Arbitrary a => QC.Arbitrary (Result a) where+   arbitrary = liftA2 Result QC.arbitrary QC.arbitrary++ {-# INLINE step #-}-step :: (Ring.C a, Module.C a v) =>+step :: (Module.C a v) =>    Parameter a -> v -> State v (Result v) step c x =    fmap (\lp -> Result (x-lp) lp) (lowpassStep c x)++{-# INLINE modifierInit #-}+modifierInit :: (Module.C a v) =>+   Modifier.Initialized v v (Parameter a) v (Result v)+modifierInit =+   Modifier.Initialized id step++{-# INLINE modifier #-}+modifier :: (Module.C a v) =>+   Modifier.Simple v (Parameter a) v (Result v)+modifier =+   Sig.modifierInitialize modifierInit zero++{-# INLINE causal #-}+causal ::+   (Module.C a v) =>+   Causal.T (Parameter a, v) (Result v)+causal =+   Causal.fromSimpleModifier modifier++{-# INLINE causalInit #-}+causalInit ::+   (Module.C a v) =>+   v -> Causal.T (Parameter a, v) (Result v)+causalInit =+   Causal.fromInitializedModifier modifierInit
src/Synthesizer/Plain/Filter/Recursive/FirstOrderComplex.hs view
@@ -11,6 +11,7 @@  First order lowpass and highpass with complex valued feedback. The complex feedback allows resonance.+It is often called complex resonator. -} module Synthesizer.Plain.Filter.Recursive.FirstOrderComplex (    Parameter,@@ -32,27 +33,23 @@  import qualified Synthesizer.Interpolation.Class as Interpol +import qualified Synthesizer.Basic.ComplexModule as CM import qualified Number.Complex as Complex-import Number.Complex ((+:))  import qualified Algebra.Module                as Module import qualified Algebra.Transcendental        as Trans import qualified Algebra.Algebraic             as Algebraic-import qualified Algebra.Field                 as Field import qualified Algebra.Ring                  as Ring-import qualified Algebra.Additive              as Additive -import Algebra.Module((*>))- import Control.Monad.Trans.State (State, state, ) -import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   data Parameter a =         Parameter {c, amp :: !(Complex.T a)}+   deriving Show   instance Interpol.C a v => Interpol.C a (Parameter v) where@@ -191,21 +188,9 @@    Parameter a -> v -> State (Complex.T v) (Result v) step p u =    state $ \s ->-      let y = scale (amp p) u + mul (c p) s+      let y = CM.scale (amp p) u + CM.mul (c p) s       in  (y, y) --      in (Result (Complex.imag y) (Complex.real y), y)--scale :: (Module.C a v) =>-   Complex.T a -> v -> Complex.T v-scale s x =-   Complex.real s *> x  +:  Complex.imag s *> x--mul :: (Module.C a v) =>-   Complex.T a -> Complex.T v -> Complex.T v-mul x y =-   (Complex.real x *> Complex.real y - Complex.imag x *> Complex.imag y)-   +:-   (Complex.real x *> Complex.imag y + Complex.imag x *> Complex.real y)   {-# INLINE modifierInit #-}
+ src/Synthesizer/Plain/Filter/Recursive/Hilbert.hs view
@@ -0,0 +1,252 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{- |+Copyright   :  (c) Henning Thielemann 2009+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++Two allpasses that approach a relative phase difference of 90 degree+over a large range of frequencies.++ToDo:+More parameters for controling the affected frequency range.+-}+module Synthesizer.Plain.Filter.Recursive.Hilbert (+   Parameter (Parameter, parameterCosine, parameterSine),+   polesCosine, polesSine,+   parameter,+   step2,+   modifierInit2,+   runInit2, run2,+   cascade,+   causal2, causalComplex2,+   causal,  causalComplex,++   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.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 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+import qualified Algebra.Field                 as Field+import qualified Algebra.Ring                  as Ring++import qualified Number.Complex as Complex+import Number.Complex ((+:), )++import NumericPrelude.Numeric+import NumericPrelude.Base++++data Parameter a =+     Parameter {parameterCosine, parameterSine :: [Allpass.Parameter a]}+   deriving Show+++-- taken from Bernie Hutchins, "Musical Engineer's Handbook"+polesCosine, polesSine :: Field.C a => [a]+polesCosine = [1.2524, 5.5671, 22.3423, 89.6271, 364.7914, 2770.1114]+polesSine   = [0.3609, 2.7412, 11.1573, 44.7581, 179.6242, 798.4578]+++{-| Convert sample rate to allpass parameters. -}+{-# INLINE parameter #-}+parameter :: Trans.C a => a -> Parameter a+parameter rate =+   Parameter+      (map (Allpass.parameterApprox (-1/(15*pi)) . (/rate)) polesCosine)+      (map (Allpass.parameterApprox (-1/(15*pi)) . (/rate)) polesSine)+++{-# INLINE step2 #-}+step2 :: (Ring.C a, Module.C a v) =>+   Parameter a -> v -> State [Complex.T v] (Complex.T v)+step2 param x = state $ \s ->+   let mr = Allpass.cascadeDiverseStep (parameterCosine param) x+       mi = Allpass.cascadeDiverseStep (parameterSine   param) x+       (r,sr) = runState mr (map Complex.real s)+       (i,si) = runState mi (map Complex.imag s)+   in  (r+:i, zipWith (+:) sr si)++{-# INLINE modifierInit2 #-}+modifierInit2 :: (Ring.C a, Module.C a v) =>+   Modifier.Initialized [Complex.T v] [Complex.T v] (Parameter a) v (Complex.T v)+modifierInit2 =+   Modifier.Initialized id step2++{-+It would need an order parameter which is ugly.++{-# INLINE modifier2 #-}+modifier2 :: (Ring.C a, Module.C a v) =>+   Int -> Modifier.Simple [Complex.T v] (Parameter a) v (Complex.T v)+modifier2 order =+   Sig.modifierInitialize modifierInit2 (replicate (succ order) zero)+-}+++cascade ::+   (Ring.C a, Module.C a v) =>+   [Allpass.Parameter a] -> Causal.T v v+cascade ps =+   foldl1 (>>>)+      (map (\p -> Allpass.firstOrderCausal <<< Causal.feedConstFst p) ps)++{- |+Although we get (almost) only the right-rotating part of the real input signal,+the amplitude is as large as the input amplitude.+That is, the amplitude actually doubled.+-}+{-# INLINE causal2 #-}+causal2 ::+   (Ring.C a, Module.C a v) =>+   Parameter a -> Causal.T v (Complex.T v)+causal2 param =+   (cascade (parameterCosine param) &&&+    cascade (parameterSine param))+       >>^ uncurry (+:)++{-# INLINE causalComplex2 #-}+causalComplex2 ::+   (Ring.C a, Module.C a v) =>+   Parameter a -> Causal.T (Complex.T v) (Complex.T v)+causalComplex2 param =+   (cascade (parameterCosine param) &&&+    cascade (parameterSine param))+       >>^ (\(c,s) -> c + Complex.quarterLeft s)+++{-# INLINE scaleWithParamType #-}+scaleWithParamType ::+   (Module.C a v) =>+   Parameter a -> a -> v -> v+scaleWithParamType _ k v =+   k *> v+++{-# INLINE causal #-}+causal ::+   (Field.C a, Module.C a v) =>+   Parameter a -> Causal.T v (Complex.T v)+causal param =+   causal2 param >>^ scaleWithParamType param 0.5++{-# INLINE causalComplex #-}+causalComplex ::+   (Field.C a, Module.C a v) =>+   Parameter a -> Causal.T (Complex.T v) (Complex.T v)+causalComplex param =+   causalComplex2 param >>^ scaleWithParamType param 0.5+++{-# INLINE runInit2 #-}+runInit2 :: (Ring.C a, Module.C a v) =>+   [Complex.T v] -> Parameter a -> Sig.T v -> Sig.T (Complex.T v)+runInit2 =+   Sig.modifyStaticInit modifierInit2++{-# INLINE run2 #-}+run2 :: (Ring.C a, Module.C a v) =>+   Parameter a -> Sig.T v -> Sig.T (Complex.T v)+run2 param =+   runInit2 (Match.replicate (undefined : parameterCosine param) zero) param+++{- |+Approximation to perfect lowpass.+However in the low frequencies the above filter+is far away from being a perfect Hilbert filter,+thus the cut is not straight as expected.+This implementation is lazy, but shifts phases.+-}+lowpassStream ::+   (Trans.C a, RealField.C a, Module.C a v) =>+   a -> a -> Sig.T v -> Sig.T v+lowpassStream freq cutoff =+   let clearLeft = Causal.apply (causalComplex (parameter freq))+   in  zipWith CM.project+          (Osci.static Wave.helix zero (cutoff/freq)) .+       map Complex.conjugate .+       clearLeft .+       map Complex.conjugate .+       zipWith CM.mul+          (Osci.static Wave.helix zero (-2*cutoff/freq)) .+       clearLeft .+       zipWith CM.scale+          (Osci.static Wave.helix zero (cutoff/freq))+++{- |+If we could achieve lowpass filtering while maintaining phases,+we could do approximate Whittaker interpolation.+Here we try to do this by filtering forward and backward.+However, this does not work since we move the spectrum+between two Hilbert transforms+and thus the phase distortions do not match.+It does not even yield a fine lowpass,+since reversing the signal does not reverse the spectrum.+-}+lowpassMaintainPhase ::+   (Trans.C a, RealField.C a, Module.C a v) =>+   a -> a -> Sig.T v -> Sig.T v+lowpassMaintainPhase freq cutoff =+   let clearLeft = Causal.apply (causalComplex (parameter freq))+   in  zipWith CM.project+          (Osci.static Wave.helix zero (cutoff/freq)) .+       reverse .+       clearLeft .+       reverse .+       zipWith CM.mul+          (Osci.static Wave.helix zero (-2*cutoff/freq)) .+       clearLeft .+       zipWith CM.scale+          (Osci.static Wave.helix zero (cutoff/freq))+++{-+exampleHilbert :: IO ()+exampleHilbert =+   let -- xs = take 10000 $ Osci.staticSine 0 (0.001::Double)+       xs = Osci.freqModSine 0 $ Ctrl.line 10000 (0, 0.1::Double)+       ys = Causal.apply (causal2 (parameter (44100::Double))) xs+       zs = run2 (parameter (44100::Double)) xs+   in  Gnuplot.plotLists [] $+          xs :+          map Complex.real ys : map Complex.imag ys :+          map Complex.magnitude ys :+          map Complex.real zs : map Complex.imag zs :+          map Complex.magnitude zs :+          []+++exampleLowpass :: IO ()+exampleLowpass =+   let xs = Osci.freqModSine 0 $ Ctrl.line 22050 (0, 0.05::Double)+       ys = lowpassStream (44100::Double) 882 xs+       zs = lowpassMaintainPhase (44100::Double) 882 xs+   in  Gnuplot.plotLists [] [xs, ys, zs]+-}
src/Synthesizer/Plain/Filter/Recursive/Integration.hs view
@@ -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 PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   @@ -35,7 +32,7 @@ {- | Integrate with initial condition. First emitted value is the initial condition.-The signal become one element longer.+The signal becomes one element longer. -} {-# INLINE runInit #-} runInit :: Additive.C v => v -> Sig.T v -> Sig.T v
src/Synthesizer/Plain/Filter/Recursive/Moog.hs view
@@ -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)@@ -22,22 +29,21 @@  import qualified Synthesizer.Interpolation.Class as Interpol -import qualified Algebra.Module                as Module-import qualified Algebra.Transcendental        as Trans-import qualified Algebra.Field                 as Field-import qualified Algebra.Ring                  as Ring-import qualified Algebra.Additive              as Additive--import Algebra.Module((*>))+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 Control.Monad.Trans.State (State, state, evalState, gets)-import Control.Arrow ((&&&), (>>^), (^>>), )+import qualified Algebra.Module                as Module+import qualified Algebra.Transcendental        as Trans+import qualified Algebra.Ring                  as Ring -import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   data Parameter a =@@ -49,13 +55,38 @@   deriving Show  +instance Functor Parameter where+   {-# INLINE fmap #-}+   fmap f p = Parameter+      (f $ feedback p) (fmap f $ lowpassParam p)++instance App.Applicative Parameter where+   {-# INLINE pure #-}+   pure x = Parameter x (Filt1.Parameter x)+   {-# INLINE (<*>) #-}+   f <*> p = Parameter+      (feedback f $ feedback p) (lowpassParam f <*> lowpassParam p)++instance Fold.Foldable Parameter where+   {-# INLINE foldMap #-}+   foldMap = Trav.foldMapDefault++instance Trav.Traversable Parameter where+   {-# INLINE sequenceA #-}+   sequenceA p =+      liftA2 Parameter+         (feedback p) (Trav.sequenceA (lowpassParam p))+ instance Interpol.C a v => Interpol.C a (Parameter v) where    {-# INLINE scaleAndAccumulate #-}    scaleAndAccumulate = Interpol.makeMac2 Parameter feedback lowpassParam  -parameter :: Trans.C a => Int -> Pole a -> Parameter a-parameter order (Pole resonance frequency) =+{-+For small frequencies we get cancellations and division zero by zero.+-}+_parameterInstable :: Trans.C a => Int -> Pole a -> Parameter a+_parameterInstable order (Pole resonance frequency) =     let beta  = frequency * 2 * pi         alpha = (pi-beta) / fromIntegral order         k     = sin alpha / sin (alpha+beta)@@ -65,37 +96,65 @@     in  Parameter f (Filt1.Parameter k)  {--Used for lowpassState,+sin (a+b)+ = sin a * cos b + cos a * sin b+ = (2*ta*(1-tb^2) + 2*tb*(1-ta^2)) / ((1+ta^2)*(1+tb^2)) where ta = tan(a/2); tb = tan(b/2)++sin (a+b) - sin a+ = 2*(ta*(1-tb^2) + tb*(1-ta^2) - ta*(1+tb^2)) / ((1+ta^2)*(1+tb^2))+ = 2*(tb*(1-ta^2) - 2*ta*tb^2) / ((1+ta^2)*(1+tb^2))+ = sin b * (1-ta^2 - 2*ta*tb) / (1+ta^2)+-}+parameter :: Trans.C a => Int -> Pole a -> Parameter a+parameter order (Pole resonance frequency) =+    let beta2  = frequency * pi+        alpha2 = (pi/2-beta2) / fromIntegral order+        tanAlpha2 = tan alpha2+        tanBeta2  = tan beta2+        k =+           tanAlpha2*(1+tanBeta2^2) /+           (tanAlpha2*(1-tanBeta2^2) + tanBeta2*(1-tanAlpha2^2))++        d = (1-tanAlpha2^2 - 2*tanAlpha2*tanBeta2) / (1+tanAlpha2^2)+        q = d ^ fromIntegral order+        f = (resonance-1) / (resonance*q+1)+    in  Parameter f (Filt1.Parameter k)+++type State = []++{-+Used for _lowpassState, list of internal values may be processed by Applicative.traverse. -} lowpassStepStack :: (Ring.C a, Module.C a v) =>-   Parameter a -> v -> State [v] v+   Parameter a -> v -> MS.State (State v) v lowpassStepStack (Parameter f k) x =-   do y0 <- gets head+   do y0 <- MS.gets head       y1 <- Modifier.stackStatesR (Filt1.lowpassStep k) (x - f *> y0)       return ((1+f) *> y1) -lowpassStepRev :: (Ring.C a, Module.C a v) =>-   Parameter a -> v -> State [v] v-lowpassStepRev (Parameter f k) x = state (\s ->+_lowpassStepRev :: (Ring.C a, Module.C a v) =>+   Parameter a -> v -> MS.State (State v) v+_lowpassStepRev (Parameter f k) x = MS.state $ \s ->     let news =            tail (scanl-              (evalState . Filt1.lowpassStep k)+              (MS.evalState . Filt1.lowpassStep k)               -- (\u0 y1 -> let Filt1.Parameter k0 = k in (1-k0) *> u0 + k0 *> y1)               (x - f *> last s) s)-    in  ((1+f) *> last news, news))+    in  ((1+f) *> last news, news)   lowpassModifier :: (Ring.C a, Module.C a v) =>-   Int -> Modifier.Simple [v] (Parameter a) v v+   Int -> Modifier.Simple (State v) (Parameter a) v v lowpassModifier order =    Modifier.Simple (replicate order zero) lowpassStepStack   {-# 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@@ -108,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 @@ -120,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 -}
src/Synthesizer/Plain/Filter/Recursive/MovingAverage.hs view
@@ -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 PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   @@ -60,8 +56,8 @@ It adds from @from@ (inclusively) to @to@ (exclusively), that is, it sums up @abs (to-from)@ values -}-sumFromTo :: (Additive.C v) => Int -> Int -> Sig.T v -> v-sumFromTo from to =+_sumFromTo :: (Additive.C v) => Int -> Int -> Sig.T v -> v+_sumFromTo from to =    if from <= to      then          sum . take (to-from) . drop from      else negate . sum . take (from-to) . drop to@@ -111,9 +107,9 @@    init . tails -} -sumsModulated :: (RealField.C a, Module.C a v) =>+_sumsModulated :: (RealField.C a, Module.C a v) =>    Int -> Sig.T a -> Sig.T v -> Sig.T v-sumsModulated maxDInt ds xs =+_sumsModulated maxDInt ds xs =    let maxD  = fromIntegral maxDInt        posXs = sumDiffsModulated 0 ds xs        negXs = sumDiffsModulated maxD (map (maxD-) ds) (delay maxDInt xs)
src/Synthesizer/Plain/Filter/Recursive/SecondOrder.hs view
@@ -13,37 +13,48 @@ 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 qualified Control.Applicative.HT as App+import Control.Applicative (Applicative, pure, (<*>), )++import qualified Data.Foldable as Fold+import qualified Data.Traversable as Trav+ import qualified Synthesizer.Causal.Process as Causal --- import qualified Algebra.VectorSpace           as VectorSpace import qualified Algebra.Module                as Module--- import qualified Algebra.Transcendental        as Trans import qualified Algebra.Field                 as Field import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive -import Algebra.Module((*>))- import Data.List (zipWith6) -import Control.Monad.Trans.State (State, state, )+import qualified Control.Monad.Trans.State as MS -import Foreign.Storable (Storable(..)) import qualified Foreign.Storable.Record as Store+import Foreign.Storable (Storable(..)) -import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   {- | Parameters for a general recursive filter of 2nd order. -}@@ -51,22 +62,34 @@    Parameter {c0, c1, c2, d1, d2 :: !a}        deriving Show -data Status a =-   Status {u1, u2, y1, y2 :: !a}-       deriving Show -zeroStatus :: Additive.C a => Status a-zeroStatus =-   Status-      {u1 = zero, u2 = zero,-       y1 = zero, y2 = zero}+instance Functor Parameter where+   {-# INLINE fmap #-}+   fmap f p = Parameter+      (f $ c0 p) (f $ c1 p) (f $ c2 p) (f $ d1 p) (f $ d2 p) +instance Applicative Parameter where+   {-# INLINE pure #-}+   pure x = Parameter x x x x x+   {-# INLINE (<*>) #-}+   f <*> p = Parameter+      (c0 f $ c0 p) (c1 f $ c1 p) (c2 f $ c2 p) (d1 f $ d1 p) (d2 f $ d2 p) +instance Fold.Foldable Parameter where+   {-# INLINE foldMap #-}+   foldMap = Trav.foldMapDefault++instance Trav.Traversable Parameter where+   {-# INLINE sequenceA #-}+   sequenceA p =+      App.lift5 Parameter+         (c0 p) (c1 p) (c2 p) (d1 p) (d2 p)+ instance Interpol.C a v => Interpol.C a (Parameter v) where    {-# INLINE scaleAndAccumulate #-}    scaleAndAccumulate =       Interpol.runMac $-         liftA5 Parameter+         App.lift5 Parameter             (Interpol.element c0)             (Interpol.element c1)             (Interpol.element c2)@@ -75,6 +98,41 @@   +data State a =+   State {u1, u2, y1, y2 :: !a}+       deriving Show++zeroState :: Additive.C a => State a+zeroState =+   State+      {u1 = zero, u2 = zero,+       y1 = zero, y2 = zero}+++instance Functor State where+   {-# INLINE fmap #-}+   fmap f p = State+      (f $ u1 p) (f $ u2 p) (f $ y1 p) (f $ y2 p)++instance Applicative State where+   {-# INLINE pure #-}+   pure x = State x x x x+   {-# INLINE (<*>) #-}+   f <*> p = State+      (u1 f $ u1 p) (u2 f $ u2 p) (y1 f $ y1 p) (y2 f $ y2 p)++instance Fold.Foldable State where+   {-# INLINE foldMap #-}+   foldMap = Trav.foldMapDefault++instance Trav.Traversable State where+   {-# INLINE sequenceA #-}+   sequenceA p =+      App.lift4 State+         (u1 p) (u2 p) (y1 p) (y2 p)+++ instance Storable a => Storable (Parameter a) where    sizeOf    = Store.sizeOf storeParameter    alignment = Store.alignment storeParameter@@ -85,7 +143,7 @@    Storable a => Store.Dictionary (Parameter a) storeParameter =    Store.run $-   liftA5 Parameter+   App.lift5 Parameter       (Store.element c0)       (Store.element c1)       (Store.element c2)@@ -93,17 +151,17 @@       (Store.element d2)  -instance Storable a => Storable (Status a) where-   sizeOf    = Store.sizeOf storeStatus-   alignment = Store.alignment storeStatus-   peek      = Store.peek storeStatus-   poke      = Store.poke storeStatus+instance Storable a => Storable (State a) where+   sizeOf    = Store.sizeOf storeState+   alignment = Store.alignment storeState+   peek      = Store.peek storeState+   poke      = Store.poke storeState -storeStatus ::-   Storable a => Store.Dictionary (Status a)-storeStatus =+storeState ::+   Storable a => Store.Dictionary (State a)+storeState =    Store.run $-   liftA4 Status+   App.lift4 State       (Store.element u1)       (Store.element u2)       (Store.element y1)@@ -126,30 +184,41 @@          let p = comp (0.5-f)          in  Parameter (c0 p) (- c1 p) (c2 p) (- d1 p) (d2 p) +{- |+Change filter parameter such that result is amplified by a given factor.+-}+{-# INLINE amplify #-}+amplify :: (Ring.C a) =>+   a -> Parameter a -> Parameter a+amplify a p =+   p{c0 = a * c0 p,+     c1 = a * c1 p,+     c2 = a * c2 p}+ {-# INLINE step #-} step :: (Ring.C a, Module.C a v) =>-   Parameter a -> v -> State (Status v) v-step c u0 = state $ \s ->+   Parameter a -> v -> MS.State (State v) v+step c u0 = MS.state $ \s ->    let y0 =           c0 c *> u0   +           c1 c *> u1 s + d1 c *> y1 s +           c2 c *> u2 s + d2 c *> y2 s-   in  (y0, Status+   in  (y0, State                {u1 = u0, u2 = u1 s,                 y1 = y0, y2 = y1 s})   {-# INLINE modifierInit #-} modifierInit :: (Ring.C a, Module.C a v) =>-   Modifier.Initialized (Status v) (Status v) (Parameter a) v v+   Modifier.Initialized (State v) (State v) (Parameter a) v v modifierInit =    Modifier.Initialized id step  {-# INLINE modifier #-} modifier :: (Ring.C a, Module.C a v) =>-   Modifier.Simple (Status v) (Parameter a) v v+   Modifier.Simple (State v) (Parameter a) v v modifier =-   Sig.modifierInitialize modifierInit zeroStatus+   Sig.modifierInitialize modifierInit zeroState  {-# INLINE causal #-} causal :: (Ring.C a, Module.C a v) =>@@ -160,7 +229,7 @@  {-# INLINE runInit #-} runInit :: (Ring.C a, Module.C a v) =>-   Status v -> Sig.T (Parameter a) -> Sig.T v -> Sig.T v+   State v -> Sig.T (Parameter a) -> Sig.T v -> Sig.T v runInit sInit control input =    let u0s = input        u1s = u1 sInit : u0s@@ -179,4 +248,4 @@ run :: (Ring.C a, Module.C a v) =>    Sig.T (Parameter a) -> Sig.T v -> Sig.T v run =-   runInit zeroStatus+   runInit zeroState
src/Synthesizer/Plain/Filter/Recursive/SecondOrderCascade.hs view
@@ -16,34 +16,32 @@ 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 --- import qualified Algebra.VectorSpace           as VectorSpace import qualified Algebra.Module                as Module--- import qualified Algebra.Transcendental        as Trans--- import qualified Algebra.Field                 as Field import qualified Algebra.Ring                  as Ring--- import qualified Algebra.Additive              as Additive --- import Algebra.Module((*>))--import Control.Monad.Trans.State (State, )+import qualified Control.Monad.Trans.State as MS  import qualified Data.StorableVector as SV import Foreign.Storable (Storable(..)) -import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   {-@@ -62,8 +60,8 @@ then we could use a writeable storable vector for the status. This would save us many allocations. -}-type Status a =-   SV.Vector (Filt2.Status a)+type State a =+   SV.Vector (Filt2.State a)   {-# INLINE checkSizes #-}@@ -94,14 +92,14 @@ {-# INLINE step #-} step ::    (Ring.C a, Module.C a v, Storable a, Storable v) =>-   Parameter a -> v -> State (Status v) v+   Parameter a -> v -> MS.State (State v) v step (Parameter p) =    Modifier.stackStatesStorableVaryL Filt2.step p  {-# INLINE modifierInit #-} modifierInit ::    (Ring.C a, Module.C a v, Storable a, Storable v) =>-   Modifier.Initialized (Status v) (Status v) (Parameter a) v v+   Modifier.Initialized (State v) (State v) (Parameter a) v v modifierInit =    Modifier.Initialized id step @@ -110,10 +108,10 @@ modifier ::    (Ring.C a, Module.C a v, Storable a, Storable v) =>    Int ->-   Modifier.Simple (Status v) (Parameter a) v v+   Modifier.Simple (State v) (Parameter a) v v modifier order =    Sig.modifierInitialize modifierInit-      (SV.replicate order Filt2.zeroStatus)+      (SV.replicate order Filt2.zeroState)  {-# INLINE causal #-} causal :: (Ring.C a, Module.C a v, Storable a, Storable v) =>
src/Synthesizer/Plain/Filter/Recursive/Test.hs view
@@ -18,8 +18,8 @@ import qualified Algebra.Transcendental      as Trans import qualified Algebra.Ring                as Ring -import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   sampleRate :: Ring.C a => a
src/Synthesizer/Plain/Filter/Recursive/Universal.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {- |-Copyright   :  (c) Henning Thielemann 2008+Copyright   :  (c) Henning Thielemann 2008-2012 License     :  GPL  Maintainer  :  synthesizer@henning-thielemann.de@@ -12,48 +12,90 @@ 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 import qualified Synthesizer.Causal.Process as Causal +import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as SecondOrder+ import qualified Synthesizer.Interpolation.Class as Interpol-import Synthesizer.ApplicativeUtility (liftA4, liftA6, ) +import qualified Control.Monad.Trans.State as MS+import qualified Control.Applicative.HT as App+import Control.Applicative (Applicative, pure, (<*>))++import qualified Data.Foldable as Fold+import qualified Data.Traversable as Trav+ import Foreign.Storable (Storable(..)) import qualified Foreign.Storable.Record as Store  import qualified Algebra.Module                as Module import qualified Algebra.Transcendental        as Trans-import qualified Algebra.Field                 as Field import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive -import Algebra.Module((*>))--import Control.Monad.Trans.State (State, state, )--import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   data Parameter a =         Parameter {k1, k2, ampIn, ampI1, ampI2, ampLimit :: !a} +instance Functor Parameter where+   {-# INLINE fmap #-}+   fmap f p = Parameter+      (f $ k1 p) (f $ k2 p) (f $ ampIn p) (f $ ampI1 p) (f $ ampI2 p) (f $ ampLimit p) +instance Applicative Parameter where+   {-# INLINE pure #-}+   pure x = Parameter x x x x x x+   {-# INLINE (<*>) #-}+   f <*> p = Parameter+      (k1 f $ k1 p) (k2 f $ k2 p) (ampIn f $ ampIn p) (ampI1 f $ ampI1 p) (ampI2 f $ ampI2 p) (ampLimit f $ ampLimit p)++instance Fold.Foldable Parameter where+   {-# INLINE foldMap #-}+   foldMap = Trav.foldMapDefault++instance Trav.Traversable Parameter where+   {-# INLINE sequenceA #-}+   sequenceA p =+      App.lift6 Parameter+         (k1 p) (k2 p) (ampIn p) (ampI1 p) (ampI2 p) (ampLimit p)+ instance Interpol.C a v => Interpol.C a (Parameter v) where    {-# INLINE scaleAndAccumulate #-}    scaleAndAccumulate =-      Interpol.runMac $ liftA6 Parameter+      Interpol.scaleAndAccumulateApplicative+{-+      Interpol.runMac $ App.lift6 Parameter          (Interpol.element k1)          (Interpol.element k2)          (Interpol.element ampIn)          (Interpol.element ampI1)          (Interpol.element ampI2)          (Interpol.element ampLimit)+-}  instance Storable a => Storable (Parameter a) where    sizeOf    = Store.sizeOf storeParameter@@ -65,7 +107,7 @@    Storable a => Store.Dictionary (Parameter a) storeParameter =    Store.run $-   liftA6 Parameter+   App.lift6 Parameter       (Store.element k1)       (Store.element k2)       (Store.element ampIn)@@ -77,23 +119,54 @@ data Result a =         Result {highpass, bandpass, lowpass, bandlimit :: !a} +instance Functor Result where+   {-# INLINE fmap #-}+   fmap f p = Result+      (f $ highpass p) (f $ bandpass p) (f $ lowpass p) (f $ bandlimit p)++instance Applicative Result where+   {-# INLINE pure #-}+   pure x = Result x x x x+   {-# INLINE (<*>) #-}+   f <*> p = Result+      (highpass f $ highpass p) (bandpass f $ bandpass p) (lowpass f $ lowpass p) (bandlimit f $ bandlimit p)++instance Fold.Foldable Result where+   {-# INLINE foldMap #-}+   foldMap = Trav.foldMapDefault++instance Trav.Traversable Result where+   {-# INLINE sequenceA #-}+   sequenceA p =+      App.lift4 Result+         (highpass p) (bandpass p) (lowpass p) (bandlimit p)+ instance Additive.C v => Additive.C (Result v) where    {-# INLINE zero #-}    {-# INLINE (+) #-}    {-# INLINE (-) #-}    {-# INLINE negate #-}+   zero   = pure zero+   (+)    = App.lift2 (+)+   (-)    = App.lift2 (-)+   negate = fmap negate+{-    zero = Result zero zero zero zero    (+) (Result xhp xbp xlp xbl) (Result yhp ybp ylp ybl) =       Result (xhp + yhp) (xbp + ybp) (xlp + ylp) (xbl + ybl)    (-) (Result xhp xbp xlp xbl) (Result yhp ybp ylp ybl) =       Result (xhp - yhp) (xbp - ybp) (xlp - ylp) (xbl - ybl)-   negate                   (Result xhp xbp xlp xbl) =+   negate (Result xhp xbp xlp xbl) =       Result (negate xhp) (negate xbp) (negate xlp) (negate xbl)+-}  instance Module.C a v => Module.C a (Result v) where    {-# INLINE (*>) #-}+   s*>v = fmap (s*>) v+{-    s *> (Result hp bp lp bl) =       Result (s *> hp) (s *> bp) (s *> lp) (s *> bl)+-}  instance Storable a => Storable (Result a) where    sizeOf    = Store.sizeOf storeResult@@ -105,7 +178,7 @@    Storable a => Store.Dictionary (Result a) storeResult =    Store.run $-   liftA4 Result+   App.lift4 Result       (Store.element highpass)       (Store.element bandpass)       (Store.element lowpass)@@ -133,29 +206,105 @@   by factor one and cancels the resonance frequency. -} {-# INLINE parameter #-}-parameter :: Trans.C a => Pole a -> Parameter a+parameter, parameterAlt, parameterOld :: Trans.C a => Pole a -> Parameter a parameter (Pole resonance frequency) =-    let zr     = cos (2*pi*frequency)-        zr1    = zr-1-        q2     = resonance^2-        sqrtQZ = sqrt (zr1*(-8*q2+zr1-4*q2*zr1))-        pk1    = (-zr1+sqrtQZ) / (2*q2-zr1+sqrtQZ)-        q21zr  = 4*q2*zr-        a      = 2 * (zr1*zr1-q21zr*zr) / (zr1+q21zr+(1+2*zr1)*sqrtQZ)-        pk2    = a+2-pk1-        volHP  = (4-2*pk1-pk2) / 4-        volLP  = pk2-        volBP  = sqrt (volHP*volLP)-    in  Parameter-           (pk1*volHP/volBP)  (pk2*volHP/volLP)-           volHP  (volBP/volHP)  (volLP/volBP)  (recip resonance)+   let w      = sin (pi*frequency)+       w2     = w^2+       q2     = resonance^2+       q21w2  = 4*q2*(1-w2)+       sqrtQZ = w * sqrt (q21w2 + w2)+       pk1    = (w2+sqrtQZ) / (q2+w2+sqrtQZ)+       d      = (q21w2*w2 + w2^2 - q2)+                  / (q21w2 - 2*q2 - w2 + (1-4*w2)*sqrtQZ)+       volHP  = (2-pk1)/4 - d+       volRel = sqrt ((2-pk1 + 4 * d) / volHP)+   in  Parameter+          (pk1/volRel)  volHP+          volHP  volRel  volRel  (recip resonance) +parameterAlt (Pole resonance frequency) =+   let w      = sin (pi*frequency)+       w2     = w^2+       q2     = resonance^2+       sqrtQZ = w * sqrt (4*q2 + w2 - 4*q2*w2)+       pk1    = (w2+sqrtQZ) / (q2+w2+sqrtQZ)+       zr     = 1 - 2 * w2+       pk2    = 2-pk1 ++                   4 * (w2^2-q2*zr^2) / (2*q2*zr-w2+(1-4*w2)*sqrtQZ)+       volHP  = (4-2*pk1-pk2) / 4+       volLP  = pk2+       volBP  = sqrt (volHP*volLP)+   in  Parameter+          (pk1*volHP/volBP)  (pk2*volHP/volLP)+          volHP  (volBP/volHP)  (volLP/volBP)  (recip resonance)++{-+This computation is more affected by cancelations+for small frequencies, i.e. zr1 = cos eps - 1.+-}+parameterOld (Pole resonance frequency) =+   let zr     = cos (2*pi*frequency)+       zr1    = zr-1+       q2     = resonance^2+       sqrtQZ = sqrt (zr1*(-8*q2+zr1-4*q2*zr1))+       pk1    = (-zr1+sqrtQZ) / (2*q2-zr1+sqrtQZ)+       q21zr  = 4*q2*zr+       a      = 2 * (zr1*zr1-q21zr*zr) / (zr1+q21zr+(1+2*zr1)*sqrtQZ)+       pk2    = a+2-pk1+       volHP  = (4-2*pk1-pk2) / 4+       volLP  = pk2+       volBP  = sqrt (volHP*volLP)+   in  Parameter+          (pk1*volHP/volBP)  (pk2*volHP/volLP)+          volHP  (volBP/volHP)  (volLP/volBP)  (recip resonance)+++{-+simplified iteration:++s'  = u + k1*i1 - k2*i2+i1' = i1 - s'+i2' = i2 - i1'+y0 = i2'++s' = u + k1*i1 - k2*i2+y0 = i2 - (i1 - s')++y0 = i2 - (i1 - (u + k1*i1 - k2*i2))++y0 = i2 - i1 + u + k1*i1 - k2*i2++y0 = u + (k1-1)*i1 + (1-k2)*i2++y0 = u + (k1-1)*(y1-y2) + (1-k2)*y1++y0 = u + (k1-k2)*y1 + (1-k1)*y2+-}+{- |+Convert parameters of universal filter to general second order filter parameters.+Filtering with these parameters does not yield exactly the same result+since the initial conditions are different.+-}+parameterToSecondOrderLowpass ::+   (Ring.C a) => Parameter a -> SecondOrder.Parameter a+parameterToSecondOrderLowpass p =+   SecondOrder.Parameter {+      SecondOrder.c0 = 1,+      SecondOrder.c1 = 0,+      SecondOrder.c2 = 0,+      SecondOrder.d1 = k1 p - k2 p,+      SecondOrder.d2 = 1 - k1 p+   }+++type State v = (v,v)+ {-| Universal filter: Computes high pass, band pass, low pass in one go -} {-# INLINE step #-} step :: (Ring.C a, Module.C a v) =>-   Parameter a -> v -> State (v,v) (Result v)+   Parameter a -> v -> MS.State (State v) (Result v) step p u =-   state $ \(i1,i2) ->+   MS.state $ \(i1,i2) ->       let newsum = ampIn p *> u + k1 p *> i1 - k2 p *> i2           newi1  = i1 - ampI1 p *> newsum           newi2  = i2 - ampI2 p *> newi1@@ -164,13 +313,13 @@  {-# INLINE modifierInit #-} modifierInit :: (Ring.C a, Module.C a v) =>-   Modifier.Initialized (v,v) (v,v) (Parameter a) v (Result v)+   Modifier.Initialized (State v) (v,v) (Parameter a) v (Result v) modifierInit =    Modifier.Initialized id step  {-# INLINE modifier #-} modifier :: (Ring.C a, Module.C a v) =>-   Modifier.Simple (v,v) (Parameter a) v (Result v)+   Modifier.Simple (State v) (Parameter a) v (Result v) modifier = Sig.modifierInitialize modifierInit (zero, zero)  {-# INLINE causal #-}
src/Synthesizer/Plain/IO.hs view
@@ -18,19 +18,14 @@ import Control.Exception (bracket, ) import Control.Monad (liftM, ) -import Data.Monoid (Monoid, mconcat, )- import qualified Data.ByteString.Lazy as B import qualified Data.Binary.Builder as Builder--import qualified Algebra.Ring      as Ring-+import Data.Monoid (mconcat, ) import Data.Char (ord, ) +import NumericPrelude.Numeric+import NumericPrelude.Base import qualified Prelude as P98--import PreludeBase-import NumericPrelude
src/Synthesizer/Plain/Instrument.hs view
@@ -26,8 +26,8 @@ import qualified Algebra.Field          as Field import qualified Algebra.Ring           as Ring -import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   @@ -254,7 +254,7 @@ osciSharp sampleRate freq =    let --control = iterate (+ (-1/sampleRate)) 4        control = exponential2 (0.01*sampleRate) 10-   in  Osci.shapeMod Wave.powerNormed 0 (freq/sampleRate) control+   in  Osci.shapeMod Wave.powerNormed2 0 (freq/sampleRate) control  {-| Build a saw sound from its harmonics and modulate it.     Different to normal modulation
src/Synthesizer/Plain/Interpolation.hs view
@@ -14,7 +14,8 @@     Interpolation.Margin, Interpolation.margin, -   singleRec, -- for testing+   -- for testing+   singleRec,    ) where  import qualified Synthesizer.Interpolation as Interpolation@@ -27,24 +28,24 @@ 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 Algebra.Additive(zero)-import Data.Maybe (fromMaybe)-import qualified Data.List.HT as ListHT--import Control.Monad (guard, )--import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   {-* Interpolation with various padding methods -} -zeroPad :: (RealField.C t) =>+zeroPad :: (RealRing.C t) =>    (T t y -> t -> Sig.T y -> a) ->    y -> T t y -> t -> Sig.T y -> a zeroPad interpolate z ip phase x =@@ -52,7 +53,7 @@    in  interpolate ip phFrac           (FiltNR.delayPad z (offset ip - phInt) (x ++ repeat z)) -constantPad :: (RealField.C t) =>+constantPad :: (RealRing.C t) =>    (T t y -> t -> Sig.T y -> a) ->    T t y -> t -> Sig.T y -> a constantPad interpolate ip phase x =@@ -68,7 +69,7 @@ {- | Only for finite input signals. -}-cyclicPad :: (RealField.C t) =>+cyclicPad :: (RealRing.C t) =>    (T t y -> t -> Sig.T y -> a) ->    T t y -> t -> Sig.T y -> a cyclicPad interpolate ip phase x =@@ -79,7 +80,7 @@ {- | The extrapolation may miss some of the first and some of the last points -}-extrapolationPad :: (RealField.C t) =>+extrapolationPad :: (RealRing.C t) =>    (T t y -> t -> Sig.T y -> a) ->    T t y -> t -> Sig.T y -> a extrapolationPad interpolate ip phase =@@ -97,14 +98,14 @@ func ip phase =    Interpolation.func ip phase . SigS.fromList -skip :: (RealField.C t) =>+skip :: (RealRing.C t) =>    T t y -> (t, Sig.T y) -> (t, Sig.T y) skip ip (phase0, x0) =    let (n, frac) = splitFraction phase0        (m, x1) = Sig.dropMarginRem (number ip) n x0    in  (fromIntegral m + frac, x1) -single :: (RealField.C t) =>+single :: (RealRing.C t) =>    T t y -> t -> Sig.T y -> y single ip phase0 x0 =    uncurry (func ip) $ skip ip (phase0, x0)@@ -129,7 +130,7 @@ {-* Interpolation of multiple values with various padding methods -}  {- | All values of frequency control must be non-negative. -}-multiRelative :: (RealField.C t) =>+multiRelative :: (RealRing.C t) =>    T t y -> t -> Sig.T y -> Sig.T t -> Sig.T y multiRelative ip phase0 x0 =    map (uncurry (func ip)) .@@ -138,17 +139,17 @@       (skip ip (phase0,x0))  -multiRelativeZeroPad :: (RealField.C t) =>+multiRelativeZeroPad :: (RealRing.C t) =>    y -> T t y -> t -> Sig.T t -> Sig.T y -> Sig.T y multiRelativeZeroPad z ip phase fs x =    zeroPad multiRelative z ip phase x fs -multiRelativeConstantPad :: (RealField.C t) =>+multiRelativeConstantPad :: (RealRing.C t) =>    T t y -> t -> Sig.T t -> Sig.T y -> Sig.T y multiRelativeConstantPad ip phase fs x =    constantPad multiRelative ip phase x fs -multiRelativeCyclicPad :: (RealField.C t) =>+multiRelativeCyclicPad :: (RealRing.C t) =>    T t y -> t -> Sig.T t -> Sig.T y -> Sig.T y multiRelativeCyclicPad ip phase fs x =    cyclicPad multiRelative ip phase x fs@@ -156,7 +157,7 @@ {- | The extrapolation may miss some of the first and some of the last points -}-multiRelativeExtrapolationPad :: (RealField.C t) =>+multiRelativeExtrapolationPad :: (RealRing.C t) =>    T t y -> t -> Sig.T t -> Sig.T y -> Sig.T y multiRelativeExtrapolationPad ip phase fs x =    extrapolationPad multiRelative ip phase x fs@@ -168,11 +169,11 @@ {-* All-in-one interpolation functions -}  multiRelativeZeroPadConstant ::-   (RealField.C t, Additive.C y) => t -> Sig.T t -> Sig.T y -> Sig.T y+   (RealRing.C t, Additive.C y) => t -> Sig.T t -> Sig.T y -> Sig.T y multiRelativeZeroPadConstant = multiRelativeZeroPad zero constant  multiRelativeZeroPadLinear ::-   (RealField.C t, Module.C t y) => t -> Sig.T t -> Sig.T y -> Sig.T y+   (RealRing.C t, Module.C t y) => t -> Sig.T t -> Sig.T y -> Sig.T y multiRelativeZeroPadLinear = multiRelativeZeroPad zero linear  multiRelativeZeroPadCubic ::
src/Synthesizer/Plain/LorenzAttractor.hs view
@@ -4,8 +4,8 @@ import qualified Algebra.Module as Module import qualified Algebra.Ring   as Ring -import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   computeDerivatives :: (Ring.C y) =>
− src/Synthesizer/Plain/Miscellaneous.hs 
@@ -1,25 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-module Synthesizer.Plain.Miscellaneous where--import qualified Algebra.NormedSpace.Euclidean as Euc-import qualified Algebra.Field                 as Field--- import qualified Algebra.Ring                  as Ring--- import qualified Algebra.Additive              as Additive--import qualified Prelude as P-import PreludeBase-import NumericPrelude---{- * Spatial effects -}--{-| simulate an moving sounding object-   convert the way of the object through 3D space-   into a delay and attenuation information,-   sonicDelay is the reciprocal of the sonic velocity -}-receive3Dsound :: (Field.C a, Euc.C a v) => a -> a -> v -> [v] -> ([a],[a])-receive3Dsound att sonicDelay ear way =-   let dists   = map (Euc.norm) (map (subtract ear) way)-       phase   = map (sonicDelay*) dists-       volumes = map (\x -> 1/(att+x)^2) dists-   in  (phase, volumes)
src/Synthesizer/Plain/Noise.hs view
@@ -4,16 +4,15 @@  import qualified Synthesizer.Plain.Signal as Sig -import qualified Algebra.Real                  as Real+import qualified Algebra.RealRing              as RealRing import qualified Algebra.Ring                  as Ring  import System.Random (Random, RandomGen, randomRs, mkStdGen, )  import Data.List.HT (sliceVertical, ) -import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   {-|@@ -38,14 +37,14 @@    map sum . sliceVertical 3 . randomRs (-1,1)  -randomPeeks :: (Real.C y, Random y) =>+randomPeeks :: (RealRing.C y, Random y) =>       Sig.T y    {- ^ momentary densities, @p@ means that there is about one peak                       in the time range of @1\/p@ samples -}    -> Sig.T Bool {- ^ Every occurence of 'True' represents a peak. -} randomPeeks =    randomPeeksGen (mkStdGen 876) -randomPeeksGen :: (Real.C y, Random y, RandomGen g) =>+randomPeeksGen :: (RealRing.C y, Random y, RandomGen g) =>       g    -> Sig.T y    -> Sig.T Bool
src/Synthesizer/Plain/Oscillator.hs view
@@ -23,66 +23,84 @@  import Synthesizer.Plain.ToneModulation (freqsToPhases, ) -{--import qualified Algebra.RealTranscendental    as RealTrans-import qualified Algebra.Module                as Module-import qualified Algebra.VectorSpace           as VectorSpace--import Algebra.Module((*>))--} import qualified Algebra.Transcendental        as Trans import qualified Algebra.RealField             as RealField--- import qualified Algebra.Field                 as Field-import qualified Algebra.Ring                  as Ring-import qualified Algebra.Additive              as Additive---- import qualified Number.NonNegative       as NonNeg+import qualified Algebra.RealRing              as RealRing  import Data.Tuple.HT (mapFst, mapSnd, ) -import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base --- import qualified Prelude as P-import PreludeBase +{- $setup+>>> import qualified Synthesizer.Plain.Oscillator as Osci+>>> import qualified Synthesizer.Basic.Wave       as Wave+>>>+>>> import qualified Test.QuickCheck as QC+>>>+>>> import qualified Number.Ratio as Ratio+>>> import NumericPrelude.Numeric+>>> import NumericPrelude.Base+>>> import Prelude ()+-} + type Phase a = a   {- * Oscillators with arbitrary but constant waveforms -}  {- | oscillator with constant frequency -}-static :: (RealField.C a) => Wave.T a b -> (Phase a -> a -> Sig.T b)+static :: (RealRing.C a) => Wave.T a b -> (Phase a -> a -> Sig.T b) static wave phase freq =     map (Wave.apply wave)         (iterate (Phase.increment freq) (Phase.fromRepresentative phase))  {- | oscillator with modulated frequency -}-freqMod :: (RealField.C a) => Wave.T a b -> Phase a -> Sig.T a -> Sig.T b+freqMod :: (RealRing.C a) => Wave.T a b -> Phase a -> Sig.T a -> Sig.T b freqMod wave phase freqs =     map (Wave.apply wave)         (freqsToPhases (Phase.fromRepresentative phase) freqs)  {- | oscillator with modulated phase -}-phaseMod :: (RealField.C a) => Wave.T a b -> a -> Sig.T (Phase a) -> Sig.T b+phaseMod :: (RealRing.C a) => Wave.T a b -> a -> Sig.T (Phase a) -> Sig.T b phaseMod wave freq phases =     map (Wave.apply wave) $     zipWith Phase.increment phases (iterate (Phase.increment freq) zero) -{- | oscillator with modulated shape -}-shapeMod :: (RealField.C a) => (c -> Wave.T a b) -> (Phase a) -> a -> Sig.T c -> Sig.T b+{- | oscillator with modulated shape++prop> :{+   let waves =+         ("saw", Wave.saw) :+         ("square", Wave.square) :+         ("triangle", Wave.triangle) :+         [] in+   QC.forAllShow (QC.elements waves) fst $+   \(_,wave) freq phases0 ->+   let phases = map (% Ratio.denominator (freq::Rational)) phases0+   in Osci.phaseMod wave freq phases ==+      Osci.shapeMod (Wave.phaseOffset wave) zero freq phases+:}+-}+shapeMod ::+    (RealRing.C a) => (c -> Wave.T a b) -> (Phase a) -> a -> Sig.T c -> Sig.T b shapeMod wave phase freq parameters =     zipWith (Wave.apply . wave) parameters $     iterate (Phase.increment freq) (Phase.fromRepresentative phase)  {- | oscillator with both phase and frequency modulation -}-phaseFreqMod :: (RealField.C a) => Wave.T a b -> Sig.T (Phase a) -> Sig.T a -> Sig.T b+phaseFreqMod ::+    (RealRing.C a) => Wave.T a b -> Sig.T (Phase a) -> Sig.T a -> Sig.T b phaseFreqMod wave phases freqs =     map (Wave.apply wave)         (zipWith Phase.increment phases (freqsToPhases zero freqs))  {- | oscillator with both shape and frequency modulation -}-shapeFreqMod :: (RealField.C a) => (c -> Wave.T a b) -> Phase a -> Sig.T c -> Sig.T a -> Sig.T b+shapeFreqMod ::+    (RealRing.C a) =>+    (c -> Wave.T a b) -> Phase a -> Sig.T c -> Sig.T a -> Sig.T b shapeFreqMod wave phase parameters freqs =     zipWith (Wave.apply . wave) parameters $     freqsToPhases (Phase.fromRepresentative phase) freqs@@ -90,13 +108,17 @@  {- | oscillator with a sampled waveform with constant frequency      This is essentially an interpolation with cyclic padding. -}-staticSample :: RealField.C a => Interpolation.T a b -> [b] -> Phase a -> a -> Sig.T b+staticSample ::+    (RealRing.C a) =>+    Interpolation.T a b -> [b] -> Phase a -> a -> Sig.T b staticSample ip wave phase freq =     freqModSample ip wave phase (repeat freq)  {- | oscillator with a sampled waveform with modulated frequency      Should behave homogenously for different types of interpolation. -}-freqModSample :: RealField.C a => Interpolation.T a b -> [b] -> Phase a -> Sig.T a -> Sig.T b+freqModSample ::+    (RealRing.C a) =>+    Interpolation.T a b -> [b] -> Phase a -> Sig.T a -> Sig.T b freqModSample ip wave phase freqs =     let len = fromIntegral (length wave)     in  Interpolation.multiRelativeCyclicPad@@ -121,8 +143,10 @@ because in the wave information for 'shapeFreqModSample' shape and phase are strictly separated. -}-shapeFreqModSample :: (RealField.C c, RealField.C b) =>-    Interpolation.T c (Wave.T b a) -> [Wave.T b a] -> c -> Phase b -> Sig.T c -> Sig.T b -> Sig.T a+shapeFreqModSample ::+    (RealRing.C c, RealRing.C b) =>+    Interpolation.T c (Wave.T b a) ->+    [Wave.T b a] -> c -> Phase b -> Sig.T c -> Sig.T b -> Sig.T a shapeFreqModSample ip waves shape0 phase shapes freqs =     zipWith Wave.apply        (Interpolation.multiRelativeConstantPad ip shape0 shapes waves)@@ -131,8 +155,10 @@ GNUPlot.plotList [] $ take 500 $ shapeFreqModSample Interpolation.cubic (map Wave.truncOddCosine [0..3]) (0.1::Double) (0::Double) (repeat 0.005) (repeat 0.02) -} -shapePhaseFreqModSample :: (RealField.C c, RealField.C b) =>-    Interpolation.T c (Wave.T b a) -> [Wave.T b a] -> c -> Sig.T c -> Sig.T (Phase b) -> Sig.T b -> Sig.T a+shapePhaseFreqModSample ::+    (RealRing.C c, RealRing.C b) =>+    Interpolation.T c (Wave.T b a) ->+    [Wave.T b a] -> c -> Sig.T c -> Sig.T (Phase b) -> Sig.T b -> Sig.T a shapePhaseFreqModSample ip waves shape0 shapes phases freqs =     zipWith Wave.apply        (Interpolation.multiRelativeConstantPad ip shape0 shapes waves)@@ -214,22 +240,37 @@  {- * Oscillators with specific waveforms -} +{- | impulse train with static frequency -}+staticImpulses :: (RealRing.C a) => a -> a -> Sig.T a+staticImpulses phase = freqModImpulses phase . repeat++{- | impulse train with modulated frequency -}+freqModImpulses :: (RealRing.C a) => a -> Sig.T a -> Sig.T a+freqModImpulses phase =+   Sig.crochetL+      (\freq p0 -> Just $+         let p1 = p0+freq+         in if p1>1+               then (1, fraction p1)+               else (0, p1))+      (fraction phase)+ {- | sine oscillator with static frequency -}-staticSine :: (Trans.C a, RealField.C a) => a -> a -> Sig.T a+staticSine :: (Trans.C a, RealRing.C a) => a -> a -> Sig.T a staticSine = static Wave.sine  {- | sine oscillator with modulated frequency -}-freqModSine :: (Trans.C a, RealField.C a) => a -> Sig.T a -> Sig.T a+freqModSine :: (Trans.C a, RealRing.C a) => a -> Sig.T a -> Sig.T a freqModSine = freqMod Wave.sine  {- | sine oscillator with modulated phase, useful for FM synthesis -}-phaseModSine :: (Trans.C a, RealField.C a) => a -> Sig.T a -> Sig.T a+phaseModSine :: (Trans.C a, RealRing.C a) => a -> Sig.T a -> Sig.T a phaseModSine = phaseMod Wave.sine -{- | saw tooth oscillator with modulated frequency -}-staticSaw :: RealField.C a => a -> a -> Sig.T a+{- | saw tooth oscillator with static frequency -}+staticSaw :: RealRing.C a => a -> a -> Sig.T a staticSaw = static Wave.saw  {- | saw tooth oscillator with modulated frequency -}-freqModSaw :: RealField.C a => a -> Sig.T a -> Sig.T a+freqModSaw :: RealRing.C a => a -> Sig.T a -> Sig.T a freqModSaw = freqMod Wave.saw
+ src/Synthesizer/Plain/Oscillator/BandLimited.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+Tone generators with measures for band-limitation.++They are not exactly band-limiting because this would cause infinite lag.+Instead we use only cubic interpolation polynomials.+This still incurs a small lag.++<https://youtu.be/lpM4Tawq-XU>+-}+module Synthesizer.Plain.Oscillator.BandLimited where++import qualified Synthesizer.Plain.Signal as Sig++import qualified Algebra.RealField as RealField++import NumericPrelude.Numeric+import NumericPrelude.Base++++{-+sinc approximation, that could be used for band-limited oscillators:++GP.plotFuncs [] (GP.linearScale 1000 (-2,2::Double)) [\x -> if x<0 then (if x< -1 then (x+1)*(x+2)*(x+2) else 1-x*x*2-x*x*x) else (if x<1 then 1-x*x*2+x*x*x else -(x-1)*(x-2)*(x-2)), \x -> if x==0 then 1 else sin (pi*x)/(pi*x)]++Has the same tangent as sinc-pi at point 1.++Cf.+DSP.Filter.FIR.PolyInterp+Integral Sine: gsl_sf_Si+-}++++{- | impulse train with static frequency -}+staticImpulses :: (RealField.C a) => a -> a -> Sig.T a+staticImpulses phase = freqModImpulses phase . repeat++{- | impulse train with modulated frequency -}+freqModImpulses :: (RealField.C a) => a -> Sig.T a -> Sig.T a+freqModImpulses phase =+   (\ ~(~(_,remaining),xs) -> xs ++ remaining) .+   Sig.mapAccumL+      (\freq (p0,xs0) ->+         let p1 = p0+freq+             (p2, xs1) =+               if p1>=1+               then+                  let p1frac=fraction p1+                      t=p1frac/freq+                      t_2  = t*t;         y0 =  t_2*(t-1)+                      t1_2 = (t-1)*(t-1); y3 = -t1_2*t+                  in (p1frac, xs0 + [y0, 1-t1_2+y3, 1-t_2+y0, y3])+               else (p1, xs0)+             (x3,xs3) =+               case xs1 of+                  [] -> (0,[])+                  x2:xs2 -> (x2,xs2)+         in Just $ (x3, (p2,xs3)))+      (phase,[])
src/Synthesizer/Plain/Play.hs view
@@ -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.RealField as RealField--import System.Exit (ExitCode, )+import qualified Algebra.RealRing as RealRing -import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   {- |@@ -31,20 +28,20 @@ -} render ::    (Storable int, Frame.C int, ToInteger.C int, Bounded int,-    RealField.C a, BinSmp.C v) =>+    RealRing.C a, BinSmp.C v) =>    Builder.Put int -> a -> (a -> [v]) -> IO ExitCode render put sampleRate renderer =    auto put sampleRate (renderer sampleRate) -renderToInt16 :: (RealField.C a, BinSmp.C v) => a -> (a -> [v]) -> IO ExitCode+renderToInt16 :: (RealRing.C a, BinSmp.C v) => a -> (a -> [v]) -> IO ExitCode renderToInt16 sampleRate renderer =    toInt16 sampleRate (renderer sampleRate) -renderMonoToInt16 :: (RealField.C a) => a -> (a -> [a]) -> IO ExitCode+renderMonoToInt16 :: (RealRing.C a) => a -> (a -> [a]) -> IO ExitCode renderMonoToInt16 sampleRate renderer =    monoToInt16 sampleRate (renderer sampleRate) -renderStereoToInt16 :: (RealField.C a) => a -> (a -> [(a,a)]) -> IO ExitCode+renderStereoToInt16 :: (RealRing.C a) => a -> (a -> [(a,a)]) -> IO ExitCode renderStereoToInt16 sampleRate renderer =    stereoToInt16 sampleRate (renderer sampleRate) @@ -54,7 +51,7 @@ -} auto ::    (Storable int, Frame.C int, ToInteger.C int, Bounded int,-    RealField.C a, BinSmp.C v) =>+    RealRing.C a, BinSmp.C v) =>    Builder.Put int -> a -> [v] -> IO ExitCode auto put sampleRate signal =    raw@@ -63,22 +60,22 @@       (Builder.run . mconcat . map (BinSmp.outputFromCanonical put) $        signal) -toInt16 :: (RealField.C a, BinSmp.C v) => a -> [v] -> IO ExitCode+toInt16 :: (RealRing.C a, BinSmp.C v) => a -> [v] -> IO ExitCode toInt16 =    auto (Builder.put :: Builder.Put Int16) -monoToInt16 :: (RealField.C a) => a -> [a] -> IO ExitCode+monoToInt16 :: (RealRing.C a) => a -> [a] -> IO ExitCode monoToInt16 sampleRate signal =    raw SoxOpt.none sampleRate       (map BinSmp.int16FromCanonical signal) -stereoToInt16 :: (RealField.C a) => a -> [(a,a)] -> IO ExitCode+stereoToInt16 :: (RealRing.C a) => a -> [(a,a)] -> IO ExitCode stereoToInt16 sampleRate signal =    raw SoxOpt.none sampleRate       (map (fmap BinSmp.int16FromCanonical . uncurry Stereo.cons) signal)  -raw :: (RealField.C a, Frame.C v, Storable v) =>+raw :: (RealRing.C a, Frame.C v, Storable v) =>    SoxOpt.T -> a -> [v] -> IO ExitCode raw opts sampleRate signal =    Play.extended SoxList.put opts SoxOpt.none (round sampleRate) signal
src/Synthesizer/Plain/Signal.hs view
@@ -1,7 +1,5 @@-{-# OPTIONS_GHC -fglasgow-exts #-}-{- glasgow-exts are for the rules -} {- |-Copyright   :  (c) Henning Thielemann 2008+Copyright   :  (c) Henning Thielemann 2008-2011 License     :  GPL  Maintainer  :  synthesizer@henning-thielemann.de@@ -15,12 +13,13 @@ import qualified Synthesizer.Plain.Modifier as Modifier  import qualified Data.List.Match as ListMatch+import qualified Data.List.HT    as ListHT import qualified Data.List       as List  import Data.Tuple.HT (forcePair, mapFst, mapSnd, )  -type T a = [a]+type T = []   {- * Generic routines that are useful for filters -}@@ -146,8 +145,9 @@ dropMarginRem :: Int -> Int -> T a -> (Int, T a) dropMarginRem n m =    head .-   dropMargin n m .-   zipWithTails (,) (iterate pred m)+   dropMargin (1+n) m .+   zip (iterate (max 0 . pred) m) .+   ListHT.tails  dropMargin :: Int -> Int -> T a -> T a dropMargin n m xs =@@ -170,7 +170,7 @@ zipWithTails ::    (y0 -> T y1 -> y2) -> T y0 -> T y1 -> T y2 zipWithTails f xs =-   zipWith f xs . init . List.tails+   zipWith f xs . init . ListHT.tails  zipWithRest ::    (y0 -> y0 -> y1) ->@@ -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
src/Synthesizer/Plain/ToneModulation.hs view
@@ -46,42 +46,63 @@ 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 qualified Data.Array as Array-import Data.Array (Array, (!), listArray, ) --- import qualified Algebra.Transcendental        as Trans-import qualified Algebra.RealField             as RealField-import qualified Algebra.Field                 as Field--- import qualified Algebra.Real                  as Real-import qualified Algebra.Ring                  as Ring-import qualified Algebra.Additive              as Additive--import qualified 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.Array (Array, (!), listArray, ) import Data.Tuple.HT (mapPair, mapSnd, forcePair, )+import Data.Ord.HT (limit, ) -import NumericPrelude+import qualified Algebra.RealField             as RealField+import qualified Algebra.RealRing              as RealRing+import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive --- import qualified Prelude as P-import PreludeBase+import qualified Number.NonNegative       as NonNeg+import qualified Number.NonNegativeChunky as Chunky +import NumericPrelude.Numeric+import NumericPrelude.Base  + -- * general helpers  type Cell y = Sig.T (Sig.T y)@@ -123,10 +144,7 @@        limits =           if lower > upper             then error "min>max"-            else-              (fromIntegral lower, fromIntegral upper)--       arr = listArray (0, pred len) tone+            else (fromIntegral lower, fromIntegral upper)     in  Prototype {           protoMarginLeap  = marginLeap,@@ -135,7 +153,7 @@           protoPeriod      = period,           protoPeriodInt   = periodInt,           protoShapeLimits = limits,-          protoArray       = arr+          protoArray       = listArray (0, pred len) tone        }  sampledToneCell :: (RealField.C t) =>@@ -343,7 +361,7 @@ phase is a number in the interval [0,1) freq contains the phase steps -}-freqsToPhases :: RealField.C a => Phase.T a -> Sig.T a -> Sig.T (Phase.T a)+freqsToPhases :: RealRing.C a => Phase.T a -> Sig.T a -> Sig.T (Phase.T a) freqsToPhases phase freq = scanl (flip Phase.increment) phase freq
src/Synthesizer/Plain/Tutorial.hs view
@@ -35,8 +35,8 @@ import qualified Algebra.Module as Module -- needed for Haddock  import System.Exit (ExitCode, )-import NumericPrelude-import PreludeBase+import NumericPrelude.Numeric+import NumericPrelude.Base import Prelude ()
src/Synthesizer/Plain/Wave.hs view
@@ -10,16 +10,11 @@ import qualified Synthesizer.Plain.Signal as Sig import Data.Array ((!), listArray) --- import qualified Synthesizer.Basic.Phase as Phase- import qualified Algebra.RealField             as RealField-import qualified Algebra.Ring                  as Ring-import qualified Algebra.Additive              as Additive -import NumericPrelude+import NumericPrelude.Numeric --- import qualified Prelude as P-import PreludeBase+import NumericPrelude.Base   sample :: (RealField.C a) =>
src/Synthesizer/RandomKnuth.hs view
@@ -25,7 +25,10 @@ modulus :: Int modulus = 2147483399 -- 2^31-249 --- we have to split the 32 bit integer in order to avoid overflow on multiplication+{-+We have to split the 32 bit integer in order to avoid overflow on multiplication.+'split' must be chosen, such that 'splitRem' is below 2^16.+-} {-# INLINE split #-} split :: Int split = succ $ div modulus factor
src/Synthesizer/State/Analysis.hs view
@@ -1,17 +1,43 @@ {-# 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-import qualified Algebra.Real                  as Real+import qualified Algebra.RealRing              as RealRing+import qualified Algebra.Absolute              as Absolute import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive @@ -19,18 +45,13 @@ import qualified Algebra.NormedSpace.Euclidean as NormedEuc import qualified Algebra.NormedSpace.Sum       as NormedSum -import qualified Data.Array as Array- import qualified Data.IntMap as IntMap---- import Algebra.Module((*>))+import qualified Data.Array as Array  import Data.Array (accumArray)--- import Data.List (foldl', ) -import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   {- * Notions of volume -}@@ -39,7 +60,7 @@ Volume based on Manhattan norm. -} {-# INLINE volumeMaximum #-}-volumeMaximum :: (Real.C y) => Sig.T y -> y+volumeMaximum :: (RealRing.C y) => Sig.T y -> y volumeMaximum =    Sig.foldL max zero . rectify --   maximum . rectify@@ -61,7 +82,7 @@ Volume based on Sum norm. -} {-# INLINE volumeSum #-}-volumeSum :: (Field.C y, Real.C y) => Sig.T y -> y+volumeSum :: (Field.C y, Absolute.C y) => Sig.T y -> y volumeSum = average . rectify  @@ -218,7 +239,7 @@    Sig.viewL x  {-# INLINE withAtLeast2 #-}-withAtLeast2 :: (RealField.C y) =>+withAtLeast2 :: (RealRing.C y) =>    String ->    (Sig.T y -> (Int, Sig.T y)) ->    Sig.T y ->@@ -251,7 +272,7 @@    histogramDiscreteIntMap . quantize binsPerUnit  {-# INLINE quantize #-}-quantize :: (RealField.C y) => y -> Sig.T y -> Sig.T Int+quantize :: (RealRing.C y) => y -> Sig.T y -> Sig.T Int quantize binsPerUnit = Sig.map (floor . (binsPerUnit*))  {-# INLINE attachOne #-}@@ -260,23 +281,7 @@  {-# INLINE meanValues #-} meanValues :: RealField.C y => Sig.T y -> [(Int,y)]-meanValues x = concatMap spread (Sig.toList (Sig.zapWith (,) 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.@@ -326,7 +331,7 @@    Sig.sum x / fromIntegral (Sig.length x)  {-# INLINE rectify #-}-rectify :: Real.C y => Sig.T y -> Sig.T y+rectify :: Absolute.C y => Sig.T y -> Sig.T y rectify = Sig.map abs  {- |@@ -342,7 +347,7 @@ {-# INLINE zeros #-} zeros :: (Ord y, Additive.C y) => Sig.T y -> Sig.T Bool zeros =-   Sig.zapWith (/=) . Sig.map (>=zero)+   Sig.mapAdjacent (/=) . Sig.map (>=zero)   @@ -351,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(x<lower)-            else x>upper)+   (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,@@ -369,7 +369,6 @@ chirpTransform :: Ring.C y =>    y -> Sig.T y -> Sig.T y chirpTransform z xs =-   let powers = Ctrl.curveMultiscaleNeutral (*) z one-       powerPowers =-          Sig.map (\zn -> Ctrl.curveMultiscaleNeutral (*) zn one) powers-   in  Sig.map (scalarProduct xs) powerPowers+   Sig.map (scalarProduct xs) $+   Sig.map (\zn -> Ctrl.curveMultiscaleNeutral (*) zn one) $+   Ctrl.curveMultiscaleNeutral (*) z one
src/Synthesizer/State/Control.hs view
@@ -9,31 +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.RealField             as RealField import qualified Algebra.Field                 as Field import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive -import Algebra.Module((*>))---- import Number.Complex (cis,real)--- import qualified Number.Complex as Complex--import Data.Ix (Ix, )--import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   {- * Control curve generation -}@@ -187,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 :: (RealField.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 :: (RealField.C a) =>-   Piecewise.T a a (a -> Sig.T a) -> Sig.T a-piecewise xs =-   Sig.concat $ zipWith-      (\(n, t) (Piecewise.PieceData c yi0 yi1 d) ->-           Sig.take n $ Piecewise.computePiece c yi0 yi1 d t)-      (splitDurations $ map Piecewise.pieceDur xs)-      xs---type Piece a =-   Piecewise.Piece a a-      (a {- fractional start time -} -> Sig.T a)---{-# INLINE stepPiece #-}-stepPiece :: Piece a-stepPiece =-   Piecewise.pieceFromFunction $ \ y0 _y1 _d _t0 ->-      constant y0--{-# INLINE linearPiece #-}-linearPiece :: (Field.C a) => Piece a-linearPiece =-   Piecewise.pieceFromFunction $ \ y0 y1 d t0 ->-      let s = (y1-y0)/d in linear s (y0-t0*s)--{-# INLINE exponentialPiece #-}-exponentialPiece :: (Trans.C a) => a -> Piece a-exponentialPiece saturation =-   Piecewise.pieceFromFunction $ \ y0 y1 d t0 ->-      let y0' = y0-saturation-          y1' = y1-saturation-          yd  = y0'/y1'-      in  raise saturation-             (exponential (d / log yd) (y0' * yd**(t0/d)))--{-# INLINE cosinePiece #-}-cosinePiece :: (Trans.C a) => Piece a-cosinePiece =-   Piecewise.pieceFromFunction $ \ y0 y1 d t0 ->-      Sig.map-         (\y -> ((1+y)*y0+(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
src/Synthesizer/State/Cut.hs view
@@ -11,6 +11,8 @@    {- * dissection -}    takeUntilPause,    takeUntilInterval,+   chopStorable,+   chopChunkySize,     {- * glueing -}    selectBool,@@ -21,23 +23,31 @@  import qualified Synthesizer.State.Signal as Sig +import qualified Synthesizer.Storable.Signal as SigSt+import qualified Synthesizer.Generic.CutChunky as CutChunky+import qualified Synthesizer.Generic.Cut as Cut+import Foreign.Storable (Storable)+ import qualified Data.EventList.Relative.TimeBody as EventList  import qualified MathObj.LaurentPolynomial as Laurent-import qualified Algebra.Real     as Real+import qualified Algebra.RealRing     as RealRing import qualified Algebra.Additive as Additive -import qualified Data.Array as Array-import Data.Array (Array, Ix, (!), elems, ) import Control.Applicative (Applicative, )-import Data.Traversable (sequenceA, ) -import Data.Tuple.HT (mapSnd, )+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 Number.NonNegative as NonNeg+import qualified Synthesizer.ChunkySize as ChunkySize+import qualified Number.NonNegative as NonNegW -import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   @@ -45,7 +55,7 @@ Take signal until it falls short of a certain amplitude for a given time. -} {-# INLINE takeUntilPause #-}-takeUntilPause :: (Real.C a) => a -> Int -> Sig.T a -> Sig.T a+takeUntilPause :: (RealRing.C a) => a -> Int -> Sig.T a -> Sig.T a takeUntilPause y =    takeUntilInterval ((<=y) . abs) @@ -98,7 +108,7 @@ -} {-# INLINE arrangeList #-} arrangeList :: (Additive.C v) =>-       EventList.T NonNeg.Int (Sig.T v)+       EventList.T NonNegW.Int (Sig.T v)             {-^ A list of pairs: (relative start time, signal part),                 The start time is relative to the start time                 of the previous event. -}@@ -106,7 +116,7 @@             {-^ The mixed signal. -} arrangeList evs =    let xs = map Sig.toList (EventList.getBodies evs)-   in  case map NonNeg.toNumber (EventList.getTimes evs) of+   in  case map NonNegW.toNumber (EventList.getTimes evs) of           t:ts -> Sig.replicate t zero `Sig.append`                   Sig.fromList (Laurent.addShiftedMany ts xs)           []   -> Sig.empty@@ -116,7 +126,7 @@  {-# INLINE arrange #-} arrange :: (Additive.C v) =>-       EventList.T NonNeg.Int (Sig.T v)+       EventList.T NonNegW.Int (Sig.T v)             {-^ A list of pairs: (relative start time, signal part),                 The start time is relative to the start time                 of the previous event. -}@@ -124,7 +134,7 @@             {-^ The mixed signal. -} arrange evs =    let xs = EventList.getBodies evs-   in  case map NonNeg.toNumber (EventList.getTimes evs) of+   in  case map NonNegW.toNumber (EventList.getTimes evs) of           t:ts -> Sig.replicate t zero `Sig.append`                   addShiftedMany ts xs           []   -> Sig.empty@@ -143,15 +153,89 @@    if del < 0      then error "State.Signal.addShifted: negative shift"      else-       Sig.unfoldR-          (\((d,ys0),xs0) ->-              -- d<0 cannot happen-              if d==zero-                then-                  fmap-                     (mapSnd (\(xs1,ys1) -> ((zero,ys1),xs1)))-                     (Sig.zipStep (+) (xs0, ys0))-                else-                  Just $ mapSnd ((,) (pred d, ys0)) $-                  Sig.switchL (zero, xs0) (,) xs0)-          ((del,ys),xs)+       Sig.runViewL xs (\nextX xs2 ->+       Sig.runViewL ys (\nextY ys2 ->+          Sig.unfoldR+             (\((d,ys0),xs0) ->+                 -- d<0 cannot happen+                 if d==zero+                   then+                     fmap+                        (mapSnd (\(xs1,ys1) -> ((zero,ys1),xs1)))+                        (Sig.zipStep nextX nextY (+) (xs0, ys0))+                   else+                     Just $ mapSnd ((,) (pred d, ys0)) $+                     fromMaybe (zero, xs0) $ nextX xs0)+             ((del,ys2),xs2)+       ))+++{- |+Split a storable signal into a sequence of signals.+A new piece is started whenever the Boolean signal contains a 'True'.+The first piece in the result is the part from the beginning until the first 'True'.+That is, if the signal 'Bool' starts with a 'True',+then the first result piece is empty.++When the control signal is at least as long as the storable signal+and if we neglect the chunking structure, then it holds++> concat (chopStorable bs xs) == xs+-}+chopStorable :: Storable a => Sig.T Bool -> SigSt.T a -> [SigSt.T a]+chopStorable = chop++chopChunkySize :: Sig.T Bool -> ChunkySize.T -> [ChunkySize.T]+chopChunkySize = chop+++chop :: CutChunky.C chunky => Sig.T Bool -> chunky -> [chunky]+chop bs =+   Sig.runViewL bs $ \f s ->+      let go _ [] = (Cut.empty, [])+          go s0 (chunk:chunks) =+             case chopChunk f chunk s0 of+                (split, ms) ->+                   prependChunks split $+                   case ms of+                      Nothing -> (CutChunky.fromChunks chunks, [])+                      Just s1 -> go s1 chunks+      in  uncurry (:) . go s . CutChunky.toChunks++prependChunks ::+   CutChunky.C chunky =>+   [CutChunky.Chunk chunky] ->+   (chunky, [chunky]) ->+   (chunky, [chunky])+prependChunks [] xs = xs+prependChunks (chunk:chunks) xs =+   let go c0 css =+          mapFst+             (\y ->+                if Cut.null c0+                  then y+                  else CutChunky.fromChunks $ c0 : CutChunky.toChunks y)+             (case css of+                [] -> xs+                (c1:cs) -> (Cut.empty, uncurry (:) (go c1 cs)))+   in  go chunk chunks++chopChunk ::+   Cut.Transform chunk =>+   (s -> Maybe (Bool, s)) ->+   chunk -> s -> ([chunk], Maybe s)+chopChunk f vs =+   let go j s0 =+          if j >= Cut.length vs+            then ([j], Just s0)+            else+              case f s0 of+                 Nothing -> ([j, Cut.length vs], Nothing)+                 Just (b,s1) ->+                    (if b+                       then mapFst (j:)+                       else id) $+                    go (succ j) s1+   in  mapFst+          (ListHT.mapAdjacent (\from to -> Cut.drop from $ Cut.take to vs) . (0:)) .+       go 0
src/Synthesizer/State/Displacement.hs view
@@ -3,18 +3,15 @@  import qualified Synthesizer.State.Signal as Sig --- 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.Transcendental        as Trans+import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive -import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base  -{- * Mixing -}+-- * Mixing  {-| Mix two signals.@@ -39,7 +36,8 @@ raise x = Sig.map ((+) x)  -{- * Distortion -}+-- * Distortion+ {-| In "Synthesizer.Basic.Distortion" you find a collection of appropriate distortion functions.@@ -47,3 +45,27 @@ {-# INLINE distort #-} distort :: (c -> a -> a) -> Sig.T c -> Sig.T a -> Sig.T a distort = Sig.zipWith+++-- * Preprocessing of control curves++{-# INLINE mapLinear #-}+mapLinear :: (Ring.C a) =>+   a ->+   a ->+   Sig.T a ->+   Sig.T a+mapLinear depth center =+   Sig.map (\x -> center*(one+x*depth))++{-# INLINE mapExponential #-}+mapExponential :: (Trans.C a) =>+   a ->+   a ->+   Sig.T a ->+   Sig.T a+mapExponential depth center =+   -- Sig.map ((center*) . (depth**))+   -- should be faster+   let logDepth = log depth+   in  Sig.map ((center*) . exp . (logDepth*))
src/Synthesizer/State/Filter/Delay.hs view
@@ -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,9 +14,7 @@ import qualified Algebra.RealField as RealField import qualified Algebra.Additive  as Additive --- import qualified Prelude as P--- import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric
src/Synthesizer/State/Filter/NonRecursive.hs view
@@ -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@@ -21,12 +38,11 @@ import qualified Algebra.Ring           as Ring import qualified Algebra.Additive       as Additive -import Algebra.Module( {- linearComb, -} (*>))- import Data.Function.HT (nest, )+import Data.Tuple.HT (mapFst, ) -import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   @@ -126,33 +142,9 @@    let width = ceiling (2 * ratioFreqToVariance ratio freq ^ 2)    in  Sig.drop width . nest (2*width) ((asTypeOf 0.5 freq *>) . binomial1) -{--exp (-(t/var)^2/2) / area *> cis (2*pi*f*t)-  == exp (-(t/var)^2/2 +: 2*pi*f*t) / area-  == exp ((-t^2 +: 2*var^2*2*pi*f*t) / (2*var^2)) / area-  == exp ((t^2 - i*2*var^2*2*pi*f*t) / (-2*var^2)) / area-  == exp (((t^2 - i*var^2*2*pi*f)^2 + (var^2*2*pi*f)^2) / (-2*var^2)) / area-  == exp (((t^2 - i*var^2*2*pi*f)^2 / (-2*var^2) - (var*2*pi*f)^2/2)) / area--sumMap (\t -> exp (-(t/var)^2/2) / area *> cis (2*pi*f*t))-       [-infinity..infinity]-  ~ sumMap (\t -> exp (-(t/var)^2/2)) [-infinity..infinity]-       * exp (-(var*2*pi*f)^2/2) / area-  = exp (-(var*2*pi*f)^2/2)--}-{- |-  Compute the variance of the Gaussian-  such that its Fourier transform has value @ratio@ at frequency @freq@.--}-{-# INLINE ratioFreqToVariance #-}-ratioFreqToVariance :: (Trans.C a) => a -> a -> a-ratioFreqToVariance ratio freq =-   sqrt (-2 * log ratio) / (2*pi*freq)-           -- inverse of the fourier transformed gaussian- {-# INLINE binomial1 #-} binomial1 :: (Additive.C v) => Sig.T v -> Sig.T v-binomial1 = Sig.zapWith (+)+binomial1 = Sig.mapAdjacent (+)   @@ -234,7 +226,72 @@ -}  +{- |+This is inverse to frequency modulation.+If all control values in @ctrl@ are above one, then it holds:+@ frequencyModulation ctrl (inverseFrequencyModulationFloor ctrl xs) == xs @.+Otherwise 'inverseFrequencyModulationFloor' is lossy.+For the precise property+we refer to "Test.Sound.Synthesizer.Plain.Interpolation".+The modulation uses constant interpolation.+Other interpolation types are tricky to implement,+since they would need interpolation on non-equidistant grids.+Ok, at least linear interpolation could be supported+with acceptable effort,+but perfect reconstruction would be hard to get.+The process is not causal in any of its inputs,+however control and input are aligned. +If you use interpolation for resampling or frequency modulation,+you may want to smooth the signal before resampling+according to the local resampling factor.+However you cannot simply use the resampling control+to also control the smoothing,+because of the subsequent distortion by resampling.+Instead you have to stretch the control inversely to the resampling factor.+This is the task of this function.+It may be applied like:++> frequencyModulation ctrl (smooth (inverseFrequencyModulationFloor ctrl ctrl) xs)+-}+{-# INLINE inverseFrequencyModulationFloor #-}+inverseFrequencyModulationFloor ::+   (Ord t, Ring.C t) =>+   Sig.T t -> Sig.T v -> Sig.T v+inverseFrequencyModulationFloor =+   inverseFrequencyModulationGen (<1)++{-+Also a sensible implementation,+but incompatible with relative interpolation / frequency modulation.+-}+{-# INLINE inverseFrequencyModulationCeiling #-}+inverseFrequencyModulationCeiling ::+   (Ord t, Ring.C t) =>+   Sig.T t -> Sig.T v -> Sig.T v+inverseFrequencyModulationCeiling =+   inverseFrequencyModulationGen (<=0)+++{-# INLINE inverseFrequencyModulationGen #-}+inverseFrequencyModulationGen ::+   (Ord t, Ring.C t) =>+   (t -> Bool) ->+   Sig.T t -> Sig.T v -> Sig.T v+inverseFrequencyModulationGen p ctrl xs =+   Sig.runSwitchL+      (Sig.zip ctrl xs)+      (\switch ->+         switch Sig.empty+            (curry $+             Sig.unfoldR+                (let go (c,x) cxs =+                        if p c+                          then switch Nothing (go . mapFst (c+)) cxs+                          else Just (x, ((c-1,x),cxs))+                 in  uncurry go)))++ {- * Filter operators from calculus -}  {- |@@ -246,7 +303,7 @@ -} {-# INLINE differentiate #-} differentiate :: Additive.C v => Sig.T v -> Sig.T v-differentiate x = Sig.zapWith subtract x+differentiate x = Sig.mapAdjacent subtract x  {- | Central difference quotient.@@ -261,12 +318,12 @@  ToDo: Vector variant -}-{- We use zapWith in order to avoid recomputation of the input signal -}+{- We use mapAdjacent in order to avoid recomputation of the input signal -} {-# INLINE differentiateCenter #-} differentiateCenter :: Field.C v => Sig.T v -> Sig.T v differentiateCenter =-   Sig.zapWith (\(x0,_) (_,x1) -> (x1 - x0) * (1/2)) .-   Sig.zapWith (,)+   Sig.mapAdjacent (\(x0,_) (_,x1) -> (x1 - x0) * (1/2)) .+   Sig.mapAdjacent (,) {- differentiateCenter :: Field.C v => Sig.T v -> Sig.T v differentiateCenter x =
src/Synthesizer/State/Filter/Recursive/Comb.hs view
@@ -20,15 +20,11 @@ import qualified Synthesizer.State.Filter.Delay as Delay  import qualified Algebra.Module                as Module--- import qualified Algebra.Field                 as Field import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive -import Algebra.Module((*>))--import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   {- |
src/Synthesizer/State/Filter/Recursive/Integration.hs view
@@ -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 PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base
src/Synthesizer/State/Filter/Recursive/MovingAverage.hs view
@@ -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 PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base
src/Synthesizer/State/Interpolation.hs view
@@ -1,28 +1,33 @@ {-# LANGUAGE NoImplicitPrelude #-}-module Synthesizer.State.Interpolation where+module Synthesizer.State.Interpolation (+   zeroPad,+   constantPad,+   cyclicPad,+   extrapolationPad, -import qualified Synthesizer.Interpolation as Interpolation-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.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 Synthesizer.Interpolation (T, offset, number, func, ) +import qualified Synthesizer.State.Signal  as Sig+ import Data.Maybe (fromMaybe) -import PreludeBase-import NumericPrelude+import qualified Algebra.RealRing  as RealRing +import NumericPrelude.Numeric+import NumericPrelude.Base + {-* Interpolation with various padding methods -}  {-# INLINE zeroPad #-}-zeroPad :: (RealField.C t) =>+zeroPad :: (RealRing.C t) =>    (T t y -> t -> Sig.T y -> a) ->    y -> T t y -> t -> Sig.T y -> a zeroPad interpolate z ip phase x =@@ -31,7 +36,7 @@           (delayPad z (offset ip - phInt) (Sig.append x (Sig.repeat z)))  {-# INLINE constantPad #-}-constantPad :: (RealField.C t) =>+constantPad :: (RealRing.C t) =>    (T t y -> t -> Sig.T y -> a) ->    T t y -> t -> Sig.T y -> a constantPad interpolate ip phase x =@@ -47,7 +52,7 @@ Only for finite input signals. -} {-# INLINE cyclicPad #-}-cyclicPad :: (RealField.C t) =>+cyclicPad :: (RealRing.C t) =>    (T t y -> t -> Sig.T y -> a) ->    T t y -> t -> Sig.T y -> a cyclicPad interpolate ip phase x =@@ -59,7 +64,7 @@ The extrapolation may miss some of the first and some of the last points -} {-# INLINE extrapolationPad #-}-extrapolationPad :: (RealField.C t) =>+extrapolationPad :: (RealRing.C t) =>    (T t y -> t -> Sig.T y -> a) ->    T t y -> t -> Sig.T y -> a extrapolationPad interpolate ip phase =@@ -73,7 +78,7 @@ {-* Helper methods for interpolation of multiple nodes -}  {-# INLINE skip #-}-skip :: (RealField.C t) =>+skip :: (RealRing.C t) =>    T t y -> (t, Sig.T y) -> (t, Sig.T y) skip ip (phase0, x0) =    let (n, frac) = splitFraction phase0@@ -81,7 +86,7 @@    in  (fromIntegral m + frac, x1)  {-# INLINE single #-}-single :: (RealField.C t) =>+single :: (RealRing.C t) =>    T t y -> t -> Sig.T y -> y single ip phase0 x0 =    uncurry (func ip) $ skip ip (phase0, x0)
− src/Synthesizer/State/Miscellaneous.hs 
@@ -1,30 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-module Synthesizer.State.Miscellaneous where--import qualified Synthesizer.State.Signal as Signal--import qualified Algebra.NormedSpace.Euclidean as Euc--- import qualified Algebra.Module                as Module--- import qualified Algebra.Transcendental        as Trans-import qualified Algebra.Field                 as Field--- import qualified Algebra.Ring                  as Ring--- import qualified Algebra.Additive              as Additive---- import qualified Prelude as P--- import PreludeBase-import NumericPrelude--{- * Spatial effects -}--{-| simulate an moving sounding object-   convert the way of the object through 3D space-   into a delay and attenuation information,-   sonicDelay is the reciprocal of the sonic velocity -}-{-# INLINE receive3Dsound #-}-receive3Dsound :: (Field.C a, Euc.C a v) =>-   a -> a -> v -> Signal.T v -> (Signal.T a,Signal.T a)-receive3Dsound att sonicDelay ear way =-   let dists   = Signal.map Euc.norm (Signal.map (subtract ear) way)-       phase   = Signal.map (sonicDelay*) dists-       volumes = Signal.map (\x -> 1/(att+x)^2) dists-   in  (phase, volumes)
src/Synthesizer/State/Noise.hs view
@@ -4,15 +4,14 @@  import qualified Synthesizer.State.Signal as Sig -import qualified Algebra.Real                  as Real+import qualified Algebra.RealRing              as RealRing import qualified Algebra.Ring                  as Ring  import System.Random (Random, RandomGen, randomR, mkStdGen, ) import qualified System.Random as Rnd -import qualified Prelude as P-import PreludeBase-import NumericPrelude+import NumericPrelude.Numeric+import NumericPrelude.Base   {-|@@ -48,7 +47,7 @@   {-# INLINE randomPeeks #-}-randomPeeks :: (Real.C y, Random y) =>+randomPeeks :: (RealRing.C y, Random y) =>       Sig.T y    {- ^ momentary densities, @p@ means that there is about one peak                       in the time range of @1\/p@ samples -}    -> Sig.T Bool {- ^ Every occurence of 'True' represents a peak. -}@@ -56,7 +55,7 @@    randomPeeksGen (mkStdGen 876)  {-# INLINE randomPeeksGen #-}-randomPeeksGen :: (Real.C y, Random y, RandomGen g) =>+randomPeeksGen :: (RealRing.C y, Random y, RandomGen g) =>       g    -> Sig.T y    -> Sig.T Bool
src/Synthesizer/State/NoiseCustom.hs view
@@ -8,17 +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 qualified Prelude as P-import PreludeBase-import NumericPrelude+import qualified Algebra.RealField             as RealField+import qualified Algebra.Field                 as Field++import NumericPrelude.Numeric+import NumericPrelude.Base   {-|
src/Synthesizer/State/Oscillator.hs view
@@ -12,24 +12,22 @@ module Synthesizer.State.Oscillator where  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--- import PreludeBase+import NumericPrelude.Numeric (Float, Double, )   @@ -40,56 +38,56 @@ Oscillator with constant frequency. It causes aliasing effects for sharp waveforms and high frequencies. -}-static :: (RealField.C a) => Wave.T a b -> (Phase.T a -> a -> Sig.T b)+static :: (RealRing.C a) => Wave.T a b -> (Phase.T a -> a -> Sig.T b) static wave phase freq =-    Sig.map (Wave.apply wave) (Osci.freqToPhases phase freq)+    Sig.map (Wave.apply wave) (OsciCore.static phase freq)  {-# INLINE staticAntiAlias #-} {- | Oscillator with constant frequency that suppresses aliasing effects using waveforms with controllable smoothness. -}-staticAntiAlias :: (RealField.C a) =>+staticAntiAlias :: (RealRing.C a) =>     WaveSmooth.T a b -> (Phase.T a -> a -> Sig.T b) staticAntiAlias wave phase freq =-    Sig.map (WaveSmooth.apply wave freq) (Osci.freqToPhases phase freq)+    Sig.map (WaveSmooth.apply wave freq) (OsciCore.static phase freq)  {-# INLINE phaseMod #-} {- | oscillator with modulated phase -}-phaseMod :: (RealField.C a) => Wave.T a b -> a -> Sig.T a -> Sig.T b+phaseMod :: (RealRing.C a) => Wave.T a b -> a -> Sig.T a -> Sig.T b phaseMod wave freq =     Causal.apply (Osci.phaseMod wave freq)  {-# INLINE shapeMod #-} {- | oscillator with modulated shape -}-shapeMod :: (RealField.C a) =>+shapeMod :: (RealRing.C a) =>     (c -> Wave.T a b) -> Phase.T a -> a -> Sig.T c -> Sig.T b shapeMod wave phase freq =     Causal.apply (Osci.shapeMod wave phase freq)  {-# INLINE freqMod #-} {- | oscillator with modulated frequency -}-freqMod :: (RealField.C a) => Wave.T a b -> Phase.T a -> Sig.T a -> Sig.T b+freqMod :: (RealRing.C a) => Wave.T a b -> Phase.T a -> Sig.T a -> Sig.T b freqMod wave phase =     Causal.apply (Osci.freqMod wave phase)  {-# INLINE freqModAntiAlias #-} {- | oscillator with modulated frequency -}-freqModAntiAlias :: (RealField.C a) =>+freqModAntiAlias :: (RealRing.C a) =>     WaveSmooth.T a b -> Phase.T a -> Sig.T a -> Sig.T b freqModAntiAlias wave phase =     Causal.apply (Osci.freqModAntiAlias wave phase)  {-# INLINE phaseFreqMod #-} {- | oscillator with both phase and frequency modulation -}-phaseFreqMod :: (RealField.C a) =>+phaseFreqMod :: (RealRing.C a) =>     Wave.T a b -> Sig.T a -> Sig.T a -> Sig.T b phaseFreqMod wave =     Causal.apply2 (Osci.phaseFreqMod wave)  {-# INLINE shapeFreqMod #-} {- | oscillator with both shape and frequency modulation -}-shapeFreqMod :: (RealField.C a) =>+shapeFreqMod :: (RealRing.C a) =>     (c -> Wave.T a b) -> Phase.T a -> Sig.T c -> Sig.T a -> Sig.T b shapeFreqMod wave phase =     Causal.apply2 (Osci.shapeFreqMod wave phase)@@ -98,7 +96,7 @@ {- | oscillator with a sampled waveform with constant frequency      This essentially an interpolation with cyclic padding. -} {-# INLINE staticSample #-}-staticSample :: RealField.C a =>+staticSample :: RealRing.C a =>     Interpolation.T a b -> Sig.T b -> Phase.T a -> a -> Sig.T b staticSample ip wave phase freq =     Causal.apply (Osci.freqModSample ip wave phase) (Sig.repeat freq)@@ -106,13 +104,13 @@ {- | oscillator with a sampled waveform with modulated frequency      Should behave homogenously for different types of interpolation. -} {-# INLINE freqModSample #-}-freqModSample :: RealField.C a =>+freqModSample :: RealRing.C a =>     Interpolation.T a b -> Sig.T b -> Phase.T a -> Sig.T a -> Sig.T b freqModSample ip wave phase =     Causal.apply (Osci.freqModSample ip wave phase)  {-# INLINE shapeFreqModSample #-}-shapeFreqModSample :: (RealField.C c, RealField.C a) =>+shapeFreqModSample :: (RealRing.C c, RealRing.C a) =>     Interpolation.T c (Wave.T a b) -> Sig.T (Wave.T a b) ->     c -> Phase.T a ->     Sig.T c -> Sig.T a -> Sig.T b@@ -152,26 +150,36 @@ {- * Oscillators with specific waveforms -}  {-# INLINE staticSine #-}+{-# SPECIALISE INLINE staticSine :: Phase.T Float -> Float -> Sig.T Float #-}+{-# SPECIALISE INLINE staticSine :: Phase.T Double -> Double -> Sig.T Double #-} {- | sine oscillator with static frequency -}-staticSine :: (Trans.C a, RealField.C a) => Phase.T a -> a -> Sig.T a+staticSine :: (Trans.C a, RealRing.C a) => Phase.T a -> a -> Sig.T a staticSine = static Wave.sine  {-# INLINE freqModSine #-}+{-# SPECIALISE INLINE freqModSine :: Phase.T Float -> Sig.T Float -> Sig.T Float #-}+{-# SPECIALISE INLINE freqModSine :: Phase.T Double -> Sig.T Double -> Sig.T Double #-} {- | sine oscillator with modulated frequency -}-freqModSine :: (Trans.C a, RealField.C a) => Phase.T a -> Sig.T a -> Sig.T a+freqModSine :: (Trans.C a, RealRing.C a) => Phase.T a -> Sig.T a -> Sig.T a freqModSine = freqMod Wave.sine  {-# INLINE phaseModSine #-}+{-# SPECIALISE INLINE phaseModSine :: Float -> Sig.T Float -> Sig.T Float #-}+{-# SPECIALISE INLINE phaseModSine :: Double -> Sig.T Double -> Sig.T Double #-} {- | sine oscillator with modulated phase, useful for FM synthesis -}-phaseModSine :: (Trans.C a, RealField.C a) => a -> Sig.T a -> Sig.T a+phaseModSine :: (Trans.C a, RealRing.C a) => a -> Sig.T a -> Sig.T a phaseModSine = phaseMod Wave.sine  {-# INLINE staticSaw #-}+{-# SPECIALISE INLINE staticSaw :: Phase.T Float -> Float -> Sig.T Float #-}+{-# SPECIALISE INLINE staticSaw :: Phase.T Double -> Double -> Sig.T Double #-} {- | saw tooth oscillator with modulated frequency -}-staticSaw :: RealField.C a => Phase.T a -> a -> Sig.T a+staticSaw :: RealRing.C a => Phase.T a -> a -> Sig.T a staticSaw = static Wave.saw  {-# INLINE freqModSaw #-}+{-# SPECIALISE INLINE freqModSaw :: Phase.T Float -> Sig.T Float -> Sig.T Float #-}+{-# SPECIALISE INLINE freqModSaw :: Phase.T Double -> Sig.T Double -> Sig.T Double #-} {- | saw tooth oscillator with modulated frequency -}-freqModSaw :: RealField.C a => Phase.T a -> Sig.T a -> Sig.T a+freqModSaw :: RealRing.C a => Phase.T a -> Sig.T a -> Sig.T a freqModSaw = freqMod Wave.saw
+ src/Synthesizer/State/Piece.hs view
@@ -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))
src/Synthesizer/State/Signal.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-} {- | ToDo: Better name for the module is certainly@@ -9,18 +10,20 @@ -} 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 +import qualified Data.EventList.Relative.BodyTime as EventList+import qualified Numeric.NonNegative.Class as NonNeg98+import Numeric.NonNegative.Class ((-|), )+ import Control.Monad.Trans.State           (runState, StateT(StateT), runStateT, ) import Control.Monad (Monad, mplus, msum,@@ -28,10 +31,15 @@            liftM2,            Functor, fmap, ) +import qualified Control.Applicative as App++import Data.Foldable (Foldable, foldr, ) import Data.Monoid (Monoid, mappend, mempty, )+import Data.Semigroup (Semigroup, (<>), )  import qualified Synthesizer.Storable.Signal as SigSt import qualified Data.StorableVector.Lazy.Pattern as SVL+import qualified Data.StorableVector.Lazy.Pointer as PtrSt import qualified Data.StorableVector as V import Foreign.Storable (Storable) @@ -39,15 +47,19 @@ import Data.Tuple.HT (mapFst, mapSnd, mapPair, fst3, snd3, thd3, ) import Data.Function.HT (nest, ) import Data.Maybe.HT (toMaybe, )-import NumericPrelude (fromInteger, )+import Data.Bool.HT (if', )+import NumericPrelude.Numeric (Float, Double, fromInteger, ) -import Text.Show (Show(showsPrec), showParen, showString, )+import Text.Show (Show(showsPrec), show, showParen, showString, ) import Data.Maybe (Maybe(Just, Nothing), maybe, fromMaybe, )+import qualified Prelude as P import Prelude-   ((.), ($), ($!), id, const, flip, curry, uncurry, fst, snd, error,-    (>), (>=), max, Ord,-    succ, pred, Bool(True,False), not, Int,+   ((.), ($), id, const, flip, curry, uncurry, fst, snd, error,+    (>), (>=), max, Ord, (==), Eq,+    succ, pred, Bool(True,False), (&&), not, Int, --    fromInteger,+    (++),+    seq,     )  @@ -63,14 +75,61 @@       showParen (p >= 10)          (showString "StateSignal.fromList " . showsPrec 11 (toList x)) +instance (Eq y) => Eq (T y) where+   (==) = equal+ instance Format.C T where    format = showsPrec  instance Functor T where-   fmap = map+   fmap g (Cons f s) = Cons (fmap g f) s +instance Foldable T where+   foldr = foldR +instance App.Applicative T where+   pure = singleton+   x <*> y = liftA2 ($) x y +instance Monad T where+   x >>= k =+      runViewL x $ \f s0 ->+      flip generate (fmap (mapFst k) $ f s0) $ \m ->+      m >>=+      let go (y,s) =+             mplus+                (fmap (\(y1,ys) -> (y1, Just (ys,s))) (viewL y))+                (fmap (mapFst k) (f s) >>= go)+      in  go+++{- |+It is a common pattern to use @switchL@ or @viewL@ in a loop+in order to traverse a signal.+However this needs repeated packing and unpacking+of the 'viewL' function and the state.+It seems that GHC is not clever enough to detect,+that the 'view' function does not change.+With 'runViewL' you can unpack a stream once+and use an efficient 'viewL' in the loop.+-}+{-# INLINE runViewL #-}+runViewL ::+   T y ->+   (forall s. (s -> Maybe (y, s)) -> s -> x) ->+   x+runViewL (Cons f s) cont =+   cont (runStateT f) s++{-# INLINE runSwitchL #-}+runSwitchL ::+   T y ->+   (forall s. (forall z. z -> (y -> s -> z) -> s -> z) -> s -> x) ->+   x+runSwitchL sig cont =+   runViewL sig (\next ->+      cont (\n j -> maybe n (uncurry j) . next))+ {-# INLINE generate #-} generate :: (acc -> Maybe (y, acc)) -> acc -> T y generate f = Cons (StateT f)@@ -98,8 +157,16 @@    (Storable a) =>    SigSt.T a -> T a fromStorableSignal =-   generate SigSt.viewL+   generate PtrSt.viewL .+   PtrSt.cons +{-# INLINE fromStrictStorableSignal #-}+fromStrictStorableSignal ::+   (Storable a) =>+   V.Vector a -> T a+fromStrictStorableSignal xs =+   map (V.index xs) $ take (V.length xs) $ iterate succ zero+ {-# INLINE toStorableSignal #-} toStorableSignal ::    (Storable a) =>@@ -122,6 +189,17 @@ toStorableSignalVary size (Cons f a) =    fst $ SVL.unfoldrN size (runStateT f) a +fromPiecewiseConstant ::+   (NonNeg98.C time, P.Integral time) =>+   EventList.T time a -> T a+fromPiecewiseConstant xs0 =+   generate+      (let go ((x,n),xs) =+             if' (n == P.fromInteger 0)+               (go =<< EventList.viewL xs)+               (Just (x, ((x, n -| P.fromInteger 1), xs)))+       in  go)+      ((error "if counter is zero, the sample value is invalid", P.fromInteger 0), xs0)   {-# INLINE iterate #-}@@ -165,7 +243,8 @@  {-# INLINE map #-} map :: (a -> b) -> (T a -> T b)-map f = crochetL (\x _ -> Just (f x, ())) ()+map = fmap+-- map f = crochetL (\x _ -> Just (f x, ())) ()   {- |@@ -198,7 +277,9 @@  {-# INLINE take #-} take :: Int -> T a -> T a-take = crochetL (\x n -> toMaybe (n>zero) (x, pred n))+take n =+   map snd . takeWhile ((>0) . fst) . zip (iterate pred n)+   -- crochetL (\x n -> toMaybe (n>zero) (x, pred n))  {-# INLINE takeWhile #-} takeWhile :: (a -> Bool) -> T a -> T a@@ -258,23 +339,58 @@  {-# INLINE foldL' #-} foldL' :: (x -> acc -> acc) -> acc -> T x -> acc+foldL' g b0 sig =+   runSwitchL sig (\next s0 ->+      let recurse b s =+             seq b (next b (\x -> recurse (g x b)) s)+      in  recurse b0 s0)+{- foldL' g b =-   switchL b (\ x xs -> foldL' g (g x $! b) xs)+   seq b . switchL b (\ x xs -> foldL' g (g x b) xs)+-}  {-# INLINE foldL #-} foldL :: (acc -> x -> acc) -> acc -> T x -> acc foldL f = foldL' (flip f) +{-# INLINE foldL1 #-}+foldL1 :: (x -> x -> x) -> T x -> x+foldL1 f =+   switchL+      (error "State.Signal.foldL1: empty signal")+      (foldL f)+ {-# INLINE length #-} length :: T a -> Int length = foldL' (const succ) zero +{-# INLINE equal #-}+equal :: (Eq a) => T a -> T a -> Bool+equal xs ys =+   runViewL xs (\nextX sx ->+   runViewL ys (\nextY sy ->+      let go px py =+             case (nextX px, nextY py) of+                (Nothing, Nothing) -> True+                (Just (x,xr), Just (y,yr)) ->+                   x==y && go xr yr+                _ -> False+      in  go sx sy+   )) + {- * functions based on 'foldR' -}  foldR :: (x -> acc -> acc) -> acc -> T x -> acc+foldR g b sig =+   runSwitchL sig (\next s0 ->+      let recurse =+             next b (\ x xs -> g x (recurse xs))+      in  recurse s0)+{- foldR g b =    switchL b (\ x xs -> g x (foldR g b xs))+-}   {- * Other functions -}@@ -317,52 +433,39 @@       (runStateT f a0)  {- iterated 'cons' is very inefficient+we could use an interim list+ viewR :: T a -> Maybe (T a, a) viewR =    foldR (\x mxs -> Just (maybe (empty,x) (mapFst (cons x)) mxs)) Nothing -} -{-# INLINE viewR #-}-viewR :: Storable a => T a -> Maybe (T a, a)-viewR = viewRSize SigSt.defaultChunkSize -{-# INLINE viewRSize #-}-viewRSize :: Storable a => SigSt.ChunkSize -> T a -> Maybe (T a, a)-viewRSize size =-   fmap (mapFst fromStorableSignal) .-   SigSt.viewR .-   toStorableSignal size-- {-# INLINE switchL #-} switchL :: b -> (a -> T a -> b) -> T a -> b switchL n j =    maybe n (uncurry j) . viewL -{-# INLINE switchR #-}-switchR :: Storable a => b -> (T a -> a -> b) -> T a -> b-switchR n j =-   maybe n (uncurry j) . viewR - {- | This implementation requires that the input generator has to check repeatedly whether it is finished. -} {-# INLINE extendConstant #-} extendConstant :: T a -> T a-extendConstant xt0 =-   switchL+extendConstant sig =+   runSwitchL sig (\switch s0 ->+   switch       empty       (\ x0 _ ->           generate-             (\xt1@(x1,xs1) ->-                 Just $ switchL+             (\xt1@(x1,s1) ->+                 Just $ switch                     (x1,xt1)-                    (\x xs -> (x, (x,xs)))-                    xs1)-             (x0,xt0)) $-      xt0+                    (\x s2 -> (x, (x,s2)))+                    s1)+             (x0,s0)) $+      s0)   {-@@ -388,9 +491,9 @@ -} dropMarginRem :: Int -> Int -> T a -> (Int, T a) dropMarginRem n m =-   switchL (error "StateSignal.dropMaringRem: length xs < n") const .-   dropMargin n m .-   zipWithTails (,) (iterate pred m)+   switchL (error $ "StateSignal.dropMaringRem: length xs < " ++ show n) const .+   dropMargin (succ n) m .+   zipWithTails1 (,) (iterate (max 0 . pred) m)  {-# INLINE dropMargin #-} dropMargin :: Int -> Int -> T a -> T a@@ -408,60 +511,49 @@  index :: Int -> T a -> a index n =-   switchL (error "State.Signal: index too large") const . drop n+   switchL (error $ "State.Signal: index " ++ show n ++ " too large") const . drop n  -{- splitAt :: Int -> T a -> (T a, T a)-splitAt n = mapPair (Cons, Cons) . List.splitAt n . decons--}--{-# INLINE splitAt #-}-splitAt :: Storable a =>-   Int -> T a -> (T a, T a)-splitAt = splitAtSize SigSt.defaultChunkSize--{-# INLINE splitAtSize #-}-splitAtSize :: Storable a =>-   SigSt.ChunkSize -> Int -> T a -> (T a, T a)-splitAtSize size n =-   mapPair (fromStorableSignal, fromStorableSignal) .-   SigSt.splitAt n .-   toStorableSignal size+splitAt n = mapPair (fromList, fromList) . List.splitAt n . toList   {-# INLINE dropWhile #-} dropWhile :: (a -> Bool) -> T a -> T a+dropWhile p (Cons f s0) =+   let recurse s =+          maybe empty (\(x,s1) -> if' (p x) (recurse s1) (Cons f s)) $+          runStateT f s+   in  recurse s0+{- dropWhile p xt =    switchL empty (\ x xs -> if p x then dropWhile p xs else xt) xt--{--span :: (a -> Bool) -> T a -> (T a, T a)-span p = mapPair (Cons, Cons) . List.span p . decons -} -{-# INLINE span #-}-span :: Storable a =>-   (a -> Bool) -> T a -> (T a, T a)-span = spanSize SigSt.defaultChunkSize--{-# INLINE spanSize #-}-spanSize :: Storable a =>-   SigSt.ChunkSize -> (a -> Bool) -> T a -> (T a, T a)-spanSize size p =-   mapPair (fromStorableSignal, fromStorableSignal) .-   SigSt.span p .-   toStorableSignal size+span :: (a -> Bool) -> T a -> (T a, T a)+span p = mapPair (fromList, fromList) . List.span p . toList   {-# INLINE cycle #-} cycle :: T a -> T a+cycle sig =+   runViewL sig+      (\next s ->+          maybe+             (error "StateSignal.cycle: empty input")+             (\yt -> generate (Just . fromMaybe yt . next) s) $+             next s)+{- cycle xs =-   switchL+   maybe       (error "StateSignal.cycle: empty input")-      (curry $ \yt -> generate (Just . fromMaybe yt . viewL) xs)-      xs+      (\yt -> generate (Just . fromMaybe yt . viewL) xs) $+      viewL xs+-} ++{-# SPECIALISE INLINE mix :: T Float -> T Float -> T Float #-}+{-# SPECIALISE INLINE mix :: T Double -> T Double -> T Double #-} {-# INLINE mix #-} mix :: Additive.C a => T a -> T a -> T a mix = zipWithAppend (Additive.+)@@ -491,28 +583,13 @@ append :: T a -> T a -> T a append xs ys =    generate-      (\(b,xs0) ->+      (\(b,xys) ->           mplus-             (fmap (mapSnd ((,) b)) $ viewL xs0)-             (if b-                then Nothing-                else fmap (mapSnd ((,) True)) $ viewL ys))+             (fmap (mapSnd ((,) b)) $ viewL xys)+             (if' b Nothing+                (fmap (mapSnd ((,) True)) $ viewL ys)))       (False,xs) -{-# INLINE appendStored #-}-appendStored :: Storable a =>-   T a -> T a -> T a-appendStored = appendStoredSize SigSt.defaultChunkSize--{-# INLINE appendStoredSize #-}-appendStoredSize :: Storable a =>-   SigSt.ChunkSize -> T a -> T a -> T a-appendStoredSize size xs ys =-   fromStorableSignal $-   SigSt.append-      (toStorableSignal size xs)-      (toStorableSignal size ys)- {-# INLINE concat #-} -- | certainly inefficient because of frequent list deconstruction concat :: [T a] -> T a@@ -526,18 +603,20 @@        List.init . List.tails)  -{-# INLINE concatStored #-}-concatStored :: Storable a =>-   [T a] -> T a-concatStored = concatStoredSize SigSt.defaultChunkSize--{-# INLINE concatStoredSize #-}-concatStoredSize :: Storable a =>-   SigSt.ChunkSize -> [T a] -> T a-concatStoredSize size =-   fromStorableSignal .-   SigSt.concat .-   List.map (toStorableSignal size)+{-+This should be faster than Monad.ap+if an empty signal as second operand is detected.+In this case an empty signal is returned without running a loop.+-}+liftA2 :: (a -> b -> c) -> (T a -> T b -> T c)+liftA2 p x y =+   runViewL x $ \f s0 ->+   runViewL y $ \g t0 ->+   flip generate (App.liftA2 (,) (f s0) (g t0)) $ \m ->+   flip fmap m $ \(as@(a,s), (b,t)) ->+   (p a b,+    fmap ((,) as) (g t) `mplus`+    App.liftA2 (,) (f s) (g t0))  {-# INLINE reverse #-} reverse ::@@ -545,20 +624,7 @@ reverse =    fromList . List.reverse . toList -{-# INLINE reverseStored #-}-reverseStored :: Storable a =>-   T a -> T a-reverseStored = reverseStoredSize SigSt.defaultChunkSize -{-# INLINE reverseStoredSize #-}-reverseStoredSize :: Storable a =>-   SigSt.ChunkSize -> T a -> T a-reverseStoredSize size =-   fromStorableSignal .-   SigSt.reverse .-   toStorableSignal size-- {-# INLINE sum #-} sum :: (Additive.C a) => T a -> a sum = foldL' (Additive.+) Additive.zero@@ -642,8 +708,15 @@    generate (\xs ->       do (_,ys) <- viewL xs          return (f xs, ys))+{-+mapTails f xs0 =+   runViewL xs0 (\next ->+      generate (\xs ->+         do (_,ys) <- next xs+            return (f xs, ys)))+-} --- only non-empty suffixes are processed+-- | only non-empty suffixes are processed {-# INLINE zipWithTails #-} zipWithTails ::    (y0 -> T y1 -> y2) -> T y0 -> T y1 -> T y2@@ -652,7 +725,37 @@       do (x,xs) <- viewL xs0          (_,ys) <- viewL ys0          return (f x ys0, (xs,ys)))+{-+zipWithTails f xs1 ys1 =+   runViewL xs1 (\nextX xs2 ->+   runViewL ys1 (\nextY ys2 ->+      generate (\(xs0,ys0) ->+         do (x,xs) <- nextX xs0+            (_,ys) <- nextY ys0+            return (f x ys0, (xs,ys)))+         (xs2,ys2)))+-} +-- | in contrast to 'zipWithTails' it also generates the empty suffix (once)+{-# INLINE zipWithTails1 #-}+zipWithTails1 ::+   (y0 -> T y1 -> y2) -> T y0 -> T y1 -> T y2+zipWithTails1 f xs ys =+   generate (\(xs0,ys0) ->+      do (x,xs1) <- viewL xs0+         ys1 <- ys0+         return (f x ys1, (xs1, fmap snd $ viewL ys1)))+      (xs, Just ys)++-- | in contrast to 'zipWithTails' it appends infinitely many empty suffixes+{-# INLINE zipWithTailsInf #-}+zipWithTailsInf ::+   (y0 -> T y1 -> y2) -> T y0 -> T y1 -> T y2+zipWithTailsInf f =+   curry $ generate (\(xs0,ys0) ->+      do (x,xs) <- viewL xs0+         return (f x ys0, (xs, switchL empty (flip const) ys0)))+ {- This can hardly be implemented in an efficient way. But this means, we cannot implement the Generic.Transform class.@@ -673,14 +776,19 @@ zipWithAppend ::    (y -> y -> y) ->    T y -> T y -> T y-zipWithAppend f =-   curry (unfoldR (zipStep f))+zipWithAppend f xs ys =+   runViewL xs (\nextX sx ->+   runViewL ys (\nextY sy ->+      unfoldR (zipStep nextX nextY f) (sx,sy)+   ))  {-# INLINE zipStep #-} zipStep ::-   (a -> a -> a) -> (T a, T a) -> Maybe (a, (T a, T a))-zipStep f (xt,yt) =-   case (viewL xt, viewL yt) of+   (s -> Maybe (a,s)) ->+   (t -> Maybe (a,t)) ->+   (a -> a -> a) -> (s, t) -> Maybe (a, (s, t))+zipStep nextX nextY f (xt,yt) =+   case (nextX xt, nextY yt) of       (Just (x,xs), Just (y,ys)) -> Just (f x y, (xs,ys))       (Nothing,     Just (y,ys)) -> Just (y,     (xt,ys))       (Just (x,xs), Nothing)     -> Just (x,     (xs,yt))@@ -730,12 +838,58 @@ {- | Counterpart to 'Data.Monoid.mconcat'. -}+fold :: Monoid m => T m -> m+fold = foldR mappend mempty++{-# DEPRECATED monoidConcat "Use foldMap instead." #-} monoidConcat :: Monoid m => T m -> m-monoidConcat = foldR mappend mempty+monoidConcat = fold ++foldMap :: Monoid m => (a -> m) -> T a -> m+foldMap f = monoidConcat . map f++{-# DEPRECATED monoidConcatMap "Use foldMap instead." #-} monoidConcatMap :: Monoid m => (a -> m) -> T a -> m-monoidConcatMap f = monoidConcat . map f+monoidConcatMap = foldMap ++instance Semigroup (T y) where+   (<>) = append+ instance Monoid (T y) where    mempty = empty-   mappend = append+++catMaybes :: T (Maybe a) -> T a+catMaybes sig =+   runViewL sig (\next ->+   generate (+      let go s0 =+             next s0 >>= \(ma,s1) ->+             fmap (flip (,) s1) ma `mplus`+             go s1+      in  go))++flattenPairs :: T (a,a) -> T a+flattenPairs sig =+   runViewL sig (\next t ->+   generate+      (\(carry,s0) ->+         fmap (\b -> (b, (Nothing, s0))) carry `mplus`+         fmap (\((a,b),s1) -> (a, (Just b, s1))) (next s0))+      (Nothing,t))++interleave, interleaveAlt ::+   T y -> T y -> T y+interleave xs ys =+   runViewL xs (\nextX sx ->+   runViewL ys (\nextY sy ->+   unfoldR+      (\(select,(sx0,sy0)) ->+         case select of+            False -> fmap (mapSnd (\sx1 -> (True,  (sx1,sy0)))) $ nextX sx0+            True  -> fmap (mapSnd (\sy1 -> (False, (sx0,sy1)))) $ nextY sy0)+      (False, (sx,sy))))++interleaveAlt xs ys = flattenPairs $ zip xs ys
+ src/Synthesizer/State/Storable.hs view
@@ -0,0 +1,88 @@+{- |+Variants of functions from "Synthesizer.State.Signal"+that use a 'StorableVector' for interim storage.+-}+module Synthesizer.State.Storable where++import Synthesizer.State.Signal (T, fromStorableSignal, toStorableSignal)++import qualified Synthesizer.Storable.Signal as SigSt+import Foreign.Storable (Storable)++import Data.Tuple.HT (mapFst, mapPair)+++{-# INLINE viewR #-}+viewR :: Storable a => T a -> Maybe (T a, a)+viewR = viewRSize SigSt.defaultChunkSize++{-# INLINE viewRSize #-}+viewRSize :: Storable a => SigSt.ChunkSize -> T a -> Maybe (T a, a)+viewRSize size =+   fmap (mapFst fromStorableSignal) . SigSt.viewR . toStorableSignal size++{-# INLINE switchR #-}+switchR :: Storable a => b -> (T a -> a -> b) -> T a -> b+switchR n j =+   maybe n (uncurry j) . viewR+++{-# INLINE splitAt #-}+splitAt :: Storable a => Int -> T a -> (T a, T a)+splitAt = splitAtSize SigSt.defaultChunkSize++{-# INLINE splitAtSize #-}+splitAtSize :: Storable a => SigSt.ChunkSize -> Int -> T a -> (T a, T a)+splitAtSize size n =+   mapPair (fromStorableSignal, fromStorableSignal) .+   SigSt.splitAt n .+   toStorableSignal size+++{-# INLINE span #-}+span :: Storable a => (a -> Bool) -> T a -> (T a, T a)+span = spanSize SigSt.defaultChunkSize++{-# INLINE spanSize #-}+spanSize :: Storable a => SigSt.ChunkSize -> (a -> Bool) -> T a -> (T a, T a)+spanSize size p =+   mapPair (fromStorableSignal, fromStorableSignal) .+   SigSt.span p .+   toStorableSignal size+++infixr 5 `append`++{-# INLINE append #-}+append :: Storable a =>+   T a -> T a -> T a+append = appendSize SigSt.defaultChunkSize++{-# INLINE appendSize #-}+appendSize :: Storable a => SigSt.ChunkSize -> T a -> T a -> T a+appendSize size xs ys =+   fromStorableSignal $+   SigSt.append+      (toStorableSignal size xs)+      (toStorableSignal size ys)+++{-# INLINE concat #-}+concat :: Storable a => [T a] -> T a+concat = concatSize SigSt.defaultChunkSize++{-# INLINE concatSize #-}+concatSize :: Storable a => SigSt.ChunkSize -> [T a] -> T a+concatSize size =+   fromStorableSignal . SigSt.concat . map (toStorableSignal size)+++{-# INLINE reverse #-}+reverse :: Storable a =>+   T a -> T a+reverse = reverseSize SigSt.defaultChunkSize++{-# INLINE reverseSize #-}+reverseSize :: Storable a => SigSt.ChunkSize -> T a -> T a+reverseSize size =+   fromStorableSignal . SigSt.reverse . toStorableSignal size
src/Synthesizer/State/ToneModulation.hs view
@@ -1,6 +1,25 @@-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  import qualified Synthesizer.Causal.Process as Causal import qualified Synthesizer.Interpolation as Interpolation@@ -11,26 +30,25 @@  import qualified Synthesizer.Basic.Phase as Phase --- import qualified Algebra.Transcendental        as Trans import qualified Algebra.RealField             as RealField--- import qualified Algebra.Field                 as Field--- import qualified Algebra.Real                  as Real--- import qualified Algebra.Ring                  as Ring import qualified Algebra.Additive              as Additive  import Data.Ord.HT (limit, ) -import NumericPrelude--- import qualified Prelude as P-import PreludeBase+import NumericPrelude.Numeric+import NumericPrelude.Base import Prelude ()   type Cell sig y = SigS.T (sig y) --- cells are organised in a transposed style, when compared with Plain.ToneModulation+{- |+cells are organised in a transposed style,+when compared with Plain.ToneModulation+-}+{-# INLINE interpolateCell #-} interpolateCell ::-   (SigG.Read sig y) =>+   (SigG.Consume sig y) =>    Interpolation.T a y ->    Interpolation.T b y ->    (a, b) ->@@ -54,7 +72,7 @@   makePrototype ::-   (RealField.C a, SigG.Read sig v) =>+   (RealField.C a, SigG.Consume sig v) =>    Interpolation.Margin ->    Interpolation.Margin ->    a -> sig v -> Prototype sig a v@@ -68,8 +86,7 @@        limits =           if lower > upper             then error "min>max"-            else-              (fromIntegral lower, fromIntegral upper)+            else (fromIntegral lower, fromIntegral upper)     in  Prototype {           protoMarginLeap  = marginLeap,@@ -81,6 +98,7 @@           protoSignal      = tone        } +{-# INLINE sampledToneCell #-} sampledToneCell ::    (RealField.C a, SigG.Transform sig v) =>    Prototype sig a v -> a -> Phase.T a -> ((a,a), Cell sig v)@@ -175,7 +193,7 @@                   SigS.viewL $                   SigS.map (\(n,_) -> fromIntegral n / period) $                   shapeOffsets-           in  freqsToPhases+           in  Osci.freqMod                   (Phase.decrement s phase)  -- phase - s                `Causal.apply`                   (SigS.zipWith (-) freqs ss)@@ -207,27 +225,3 @@ {- Test.QuickCheck.test (\x (y,zi) -> let z=List.map abs zi in  Data.Tuple.HT.mapSnd SigS.toList (limitMinRelativeValues x (y, SigS.fromList z)) == ToneMod.limitMinRelativeValues (x::Int) y z) -}---- * handling of phases as needed for oscillators--{-# INLINE freqsToPhases #-}-{- |-Convert a list of phase steps into a list of momentum phases.-phase is a number in the interval [0,1).-freq contains the phase steps.-The last element is omitted.--}-freqsToPhases :: RealField.C a =>-   Phase.T a -> Causal.T a (Phase.T a)-freqsToPhases =-   Causal.scanL (flip Phase.increment)--{- |-Like 'freqsToPhases' but the first element is omitted.--}-{-# INLINE freqsToPhasesSync #-}-freqsToPhasesSync :: RealField.C a =>-   Phase.T a -> Causal.T a (Phase.T a)-freqsToPhasesSync =-   Causal.crochetL-      (\f p0 -> let p1 = Phase.increment f p0 in Just (p1,p1))
src/Synthesizer/Storable/Cut.hs view
@@ -1,29 +1,75 @@-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 Control.Monad (mapM, ) import Data.Tuple.HT (mapSnd, ) --- import qualified Algebra.Real     as Real import qualified Algebra.Additive as Additive import qualified Number.NonNegative as NonNeg -import Foreign.Storable (Storable)+import NumericPrelude.Numeric+import NumericPrelude.Base+import Prelude () -import PreludeBase-import NumericPrelude +{- $setup+>>> import qualified Synthesizer.Storable.Cut as CutSt+>>> import qualified Synthesizer.Storable.Signal as SigSt+>>>+>>> import qualified Synthesizer.Plain.Cut as Cut+>>> import qualified Synthesizer.Plain.Signal as Sig+>>>+>>> import qualified Data.EventList.Relative.TimeBody  as EventList+>>> import qualified Data.List.HT as ListHT+>>>+>>> import qualified Number.NonNegative as NonNeg+>>>+>>> import qualified Test.QuickCheck as QC+>>>+>>> import NumericPrelude.Numeric+>>> import NumericPrelude.Base+>>> import Prelude ()+>>>+>>>+>>> genEventList :: QC.Gen (EventList.T NonNeg.Int (Sig.T Int))+>>> genEventList = fmap (EventList.mapTime (flip mod 1000)) QC.arbitrary+-} ++{- |+prop> :{+   \chunkSize ->+   QC.forAll genEventList $ \evs ->+   let sevs = EventList.mapBody (SigSt.fromList chunkSize) evs+   in  ListHT.allEqual $+       SigSt.fromList chunkSize (Cut.arrange evs) :+       CutSt.arrangeAdaptive chunkSize sevs :+       CutSt.arrangeList chunkSize sevs :+       CutSt.arrangeEquidist chunkSize sevs :+       []+:}+-} {-# INLINE arrange #-} arrange :: (Storable v, Additive.C v) =>        Sig.ChunkSize@@ -60,9 +106,14 @@                   put suffix                   return prefix)       (\body ->-           modify (Sig.mix body))+           modify (Sig.mixSndPattern body))  +{- |+This function also uses the time differences as chunk sizes,+but may occasionally use smaller chunk sizes due to the chunk structure+of an input signal until the next signal starts.+-} arrangeList :: (Storable v, Additive.C v) =>        Sig.ChunkSize     -> EventList.T NonNeg.Int (Sig.T v)@@ -94,17 +145,15 @@ addShifted size delNN px py =    let del = NonNeg.toNumber delNN    in  uncurry Sig.append $-       mapSnd (flip Sig.mix py) $+       mapSnd (flip Sig.mixSndPattern py) $        Sig.splitAtPad size del px  +{-+arrangeEquidist (Sig.chunkSize 2) (EventList.fromPairList [(10, SVL.pack SVL.defaultChunkSize [1..8::Double]), (2, SVL.pack (Sig.chunkSize 2) $ [4,3,2,1::Double] ++ undefined)])+-} {- | The result is a Lazy StorableVector with chunks of the given size.-The output is always infinite.-If the input is a finite list of finite length sounds,-then the output is padded with zeros.-Even if we try to terminate the output after the last sound,-we would not finish immediately but only at chunk boundaries. -} {-# INLINE arrangeEquidist #-} arrangeEquidist :: (Storable v, Additive.C v) =>@@ -131,42 +180,128 @@                         newAcc1 <-                            mapM (\(i,s) -> addToBuffer v (NonNeg.toNumber i) s) xs                         vf <- SVST.freeze v-                        return-                           (vf, filter (not . Sig.null) (newAcc0++newAcc1)))-          in  chunk : go newAcc future+                        return (vf, newAcc0++newAcc1))+              (ends, suffixes) = unzip $ newAcc+              prefix =+                 {- if there are more events to come,+                    we must pad with zeros -}+                 if EventList.null future+                   then SV.take (foldl max 0 ends) chunk+                   else chunk+          in  if SV.null prefix+                then []+                else prefix : go (filter (not . Sig.null) suffixes) future    in  Sig.fromChunks . go []  +{-+{-# INLINE addToBuffer #-}+addToBuffer :: (Storable a, Additive.C a) =>+   SVST.Vector s a -> Int -> Sig.T a -> ST s (Int, Sig.T a)+addToBuffer v start =+   let n = SVST.length v+       go i [] = return (i, [])+       go i (c:cs) =+          let end = i + SV.length c+          in  addChunkToBuffer v i c >>+              if end<n+                then go end cs+                else return (n, SV.drop (end-n) c : cs)+   in  fmap (mapSnd SigSt.fromChunks) . go start . SigSt.chunks +addChunkToBuffer :: (Storable a, Additive.C a) =>+   SVST.Vector s a -> Int -> SV.Vector a -> ST s ()+addChunkToBuffer v start xs =+   let n = SVST.length v+   in  SV.foldr+          (\x continue i ->+             SVST.modify v i (x +) >>+             continue (succ i))+          (\_i -> return ())+          (Sig.take (n Additive.- start) xs)+          start+-}++{-# INLINE addToBuffer #-} addToBuffer :: (Storable a, Additive.C a) =>-   SVST.Vector s a -> Int -> Sig.T a -> ST s (Sig.T a)+   SVST.Vector s a -> Int -> Sig.T a -> ST s (Int, Sig.T a) addToBuffer v start xs =    let n = SVST.length v        (now,future) = Sig.splitAt (n Additive.- start) xs+       go i [] = return i+       go i (c:cs) =+          unsafeAddChunkToBuffer v i c >>+          go (i + SV.length c) cs+   in  fmap (flip (,) future) . go start . Sig.chunks $ now++{-# INLINE addChunkToBuffer #-}+addChunkToBuffer :: (Storable a, Additive.C a) =>+   SVST.Vector s a -> Int -> SV.Vector a -> ST s ()+addChunkToBuffer v start xs =+   if start + SV.length xs <= SVST.length v+     then unsafeAddChunkToBuffer v start xs+     else error "Storable.addChunkToBuffer: chunk too large"++{- | chunk must fit into the buffer -}+{- This implementation will be faster as long as 'SV.foldr' is inefficient. -}+{-# INLINE unsafeAddChunkToBuffer #-}+unsafeAddChunkToBuffer :: (Storable a, Additive.C a) =>+   SVST.Vector s a -> Int -> SV.Vector a -> ST s ()+unsafeAddChunkToBuffer v start xs =+   let go i j =+          if j >= SV.length xs+            then return ()+            else+              SVST.unsafeModify v i (SV.index xs j +) >>+              go (i + 1) (j + 1)+   in  go start 0++{- | chunk must fit into the buffer -}+{-# INLINE _unsafeAddChunkToBufferFoldr #-}+_unsafeAddChunkToBufferFoldr :: (Storable a, Additive.C a) =>+   SVST.Vector s a -> Int -> SV.Vector a -> ST s ()+_unsafeAddChunkToBufferFoldr v start xs =+   SV.foldr+      (\x continue i ->+         SVST.unsafeModify v i (x +) >>+         continue (succ i))+      (\_i -> return ())+      xs start+++-- most elegant solution, but slow because StorableVector.foldr is slow+{-# INLINE _addToBufferFoldr #-}+_addToBufferFoldr :: (Storable a, Additive.C a) =>+   SVST.Vector s a -> Int -> Sig.T a -> ST s (Int, Sig.T a)+_addToBufferFoldr v start xs =+   let n = SVST.length v+       (now,future) = Sig.splitAt (n Additive.- start) xs    in  Sig.foldr           (\x continue i ->-             SVST.modify v i (x Additive.+) >>+             SVST.modify v i (x +) >>              continue (succ i))-          (const $ return ()) now start-        >> return future+          (\i -> return (i, future))+          now start   {- Using @Sig.switchL@ in an inner loop is slower than using @Sig.foldr@.+Using a StorableVectorPointer would be faster,+but I think still slower than @foldr@. -}-addToBufferSwitchL :: (Storable a, Additive.C a) =>-   SVST.Vector s a -> Int -> Sig.T a -> ST s (Sig.T a)-addToBufferSwitchL v start =+_addToBufferSwitchL :: (Storable a, Additive.C a) =>+   SVST.Vector s a -> Int -> Sig.T a -> ST s (Int, Sig.T a)+_addToBufferSwitchL v start =    let n = SVST.length v        {-# INLINE go #-}        go i =           if i>=n-            then return+            then return . (,) i             else               Sig.switchL-                 (return Sig.empty)+                 (return (i, Sig.empty))                  (\x xs ->-                     SVST.modify v i (x Additive.+) >>+                     SVST.modify v i (x +) >>                      go (succ i) xs)    in  go start
src/Synthesizer/Storable/Filter/NonRecursive.hs view
@@ -8,17 +8,38 @@ Stability   :  provisional Portability :  requires multi-parameter type classes -}-module Synthesizer.Storable.Filter.NonRecursive where+module Synthesizer.Storable.Filter.NonRecursive (+   delay,+   delayPad,+   delayPos,+   delayNeg, +   downsample2,+   sumsDownsample2,+   convolveDownsample2,+   inverseFrequencyModulationFloor,+   sumsPosModulatedPyramid,+   accumulatePosModulatedFromPyramid,+   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.Generic.Signal as SigG import qualified Synthesizer.State.Signal as SigS-import qualified Synthesizer.Plain.Filter.NonRecursive as Filt-import qualified Synthesizer.Generic.Filter.NonRecursive as FiltG+import qualified Synthesizer.Plain.Signal as Sig  import qualified Algebra.Module         as Module import qualified Algebra.Field          as Field@@ -28,45 +49,77 @@ import Foreign.Storable (Storable, ) import Foreign.Storable.Tuple () -import Algebra.Module( {- linearComb, -} (*>), )- import Control.Monad (mplus, )  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 PreludeBase-import NumericPrelude as NP-import qualified Prelude as P+import NumericPrelude.Numeric+import NumericPrelude.Base as NP  ++{-# INLINE delay #-}+delay :: (Additive.C y, Storable y) => Int -> SigSt.T y -> SigSt.T y+delay = delayPad zero++{-# INLINE delayPad #-}+delayPad :: (Storable y) => y -> Int -> SigSt.T y -> SigSt.T y+delayPad z n =+   if n<0+     then delayNeg (Additive.negate n)+     else delayPosPad z n++{-# INLINE delayPos #-}+delayPos :: (Additive.C y, Storable y) => Int -> SigSt.T y -> SigSt.T y+delayPos = delayPosPad zero++{-# INLINE delayPosPad #-}+delayPosPad :: (Storable v) => v -> Int -> SigSt.T v -> SigSt.T v+delayPosPad z n = SigSt.append (SigSt.replicate SigSt.defaultChunkSize n z)++{-# INLINE delayNeg #-}+delayNeg :: (Storable y) => Int -> SigSt.T y -> SigSt.T y+delayNeg = SigSt.drop++ {- | The Maybe type carries an unpaired value from one block to the next one. -}-sumsDownsample2Strict ::-   (Additive.C v, Storable v) =>+accumulateDownsample2Strict ::+   (Storable v) =>+   (v -> v -> v) ->    Maybe v -> V.Vector v -> (Maybe v, V.Vector v)-sumsDownsample2Strict carry ys =+accumulateDownsample2Strict acc carry ys =    mapFst (\v -> fmap fst $ V.viewL . snd =<< v) $ swap $    V.unfoldrN (div (V.length ys + maybe 0 (const 1) carry) 2) (\(carry0,xs0) ->       do (x0,xs1) <- mplus (fmap (\c -> (c, xs0)) carry0) (V.viewL xs0)          (x1,xs2) <- V.viewL xs1-         return (x0+x1, (Nothing, xs2)))+         return (acc x0 x1, (Nothing, xs2)))       (carry, ys) -sumsDownsample2 ::-   (Additive.C v, Storable v) =>+accumulateDownsample2 ::+   (Storable v) =>+   (v -> v -> v) ->    SigSt.T v -> SigSt.T v-sumsDownsample2 =+accumulateDownsample2 acc =    SigSt.fromChunks .    filter (not . V.null) .    (\(carry, chunks) ->       chunks ++ maybe [] (\cr -> [V.singleton cr]) carry) .-   List.mapAccumL sumsDownsample2Strict Nothing .+   List.mapAccumL (accumulateDownsample2Strict acc) Nothing .    SigSt.chunks +sumsDownsample2 ::+   (Additive.C v, Storable v) =>+   SigSt.T v -> SigSt.T v+sumsDownsample2 =+   accumulateDownsample2 (+)+ sumsDownsample2Alt ::    (Additive.C v, Storable v) =>    SigSt.T v -> SigSt.T v@@ -79,6 +132,32 @@             xs0)     . SigS.fromStorableSignal $ ys +{-+! - downsample++x ! 2+(y*x)    ! 2 = y    ! 2 * x ! 2  +  y->1 ! 2 * x<-1 ! 2+(y*x<-1) ! 2 = y<-1 ! 2 * x ! 2  +  y    ! 2 * x<-1 ! 2++(y^n*x) ! 2 can be implemented by matrix power and multiplication+where multiplication is convolution.+-}++convolveDownsample2 ::+   (Module.C a v, Storable a, Storable v) =>+   SigSt.T a -> SigSt.T v -> SigSt.T v+convolveDownsample2 ms ys =+   let mac =+          SigS.sum . SigS.zipWith (*>)+             (SigS.fromStorableSignal ms)+   in  fst .+       VP.unfoldrN (halfLazySize $ VP.length ys) (\xs ->+          toMaybe (not $ SigSt.null xs)+             (mac (SigS.fromStorableSignal xs),+              SigSt.drop 2 xs))+        $ ys++ halfLazySize :: NonNegChunky.T VP.ChunkSize -> NonNegChunky.T VP.ChunkSize halfLazySize =    NonNegChunky.fromChunks .@@ -88,6 +167,7 @@       mapSnd VL.ChunkSize $ swap $ divMod (c+l) 2) zero .    NonNegChunky.toChunks + {- | offset must be zero or one. -}@@ -121,70 +201,71 @@    SigSt.chunks  +{-+The laziness granularity of the input signal is maintained.+-} pyramid ::-   (Additive.C v, Storable v) =>+   (Storable v) =>+   (v -> v -> v) ->    Int -> SigSt.T v -> [SigSt.T v]-pyramid height =-   take (1+height) . iterate sumsDownsample2+pyramid acc height =+   take (1+height) . iterate (accumulateDownsample2 acc) -{--This function uses the efficient Storable.index function.-If @Generic.index@ becomes as fast as @Storable.index@-then we can replace this function by its generic counterpart.--}-sumRangeFromPyramid ::-   (Additive.C v, Storable v) =>-   [SigSt.T v] -> (Int,Int) -> v-sumRangeFromPyramid =-   Filt.sumRangePrepare $ \(l0,r0) pyr0 ->-   case pyr0 of-      [] -> error "empty pyramid"-      (ps0:pss) ->-         foldr-            (\psNext k (l,r) ps s ->-               case r-l of-                  0 -> s-                  1 -> s + VL.index ps l-                  _ ->-                     let (lh,ll) = NP.negate $ divMod (NP.negate l) 2-                         (rh,rl) = divMod r 2-                         {-# INLINE inc #-}-                         inc b x = if b==0 then id else (x+)-                     in  k (lh,rh) psNext $-                         inc ll (VL.index ps l) $-                         inc rl (VL.index ps (r-1)) $-                         s)-            (\(l,r) ps s ->-               s + (SigG.sum $ SigSt.take (r-l) $ SigSt.drop l ps))-            pss (l0,r0) ps0 zero + {- | Moving average, where window bounds must be always non-negative. -The laziness granularity of the input signal is maintained.+The laziness granularity is @2^height@.++This function is only slightly more efficient+than its counterpart from Generic.Filter,+since it generates strict blocks+and not one-block chunky signals. -}-sumsPosModulatedPyramid ::-   (Additive.C v, Storable (Int,Int), Storable v) =>-   Int -> SigSt.T (Int,Int) -> SigSt.T v -> SigSt.T v-sumsPosModulatedPyramid height ctrl xs =-   let pyr0 = pyramid height xs-       sizes =-          reverse $ take (1+height) $ iterate (2*) 1-       blockSize = head sizes-       pyrStarts =-          iterate (zipWith SigSt.drop sizes) pyr0-       ctrlBlocks =-          SigS.toList $-          SigG.sliceVertical blockSize ctrl+accumulatePosModulatedFromPyramid ::+   (Storable v) =>+   ([SigSt.T v] -> (Int,Int) -> v) ->+   ([Int], [SigSt.T v]) ->+   SigSt.T (Int,Int) -> SigSt.T v+accumulatePosModulatedFromPyramid accumulate (sizes,pyr0) ctrl =+   let blockSize = head sizes+       pyrStarts = iterate (zipWith SigSt.drop sizes) pyr0+       ctrlBlocks = SigS.toList $ SigG.sliceVertical blockSize ctrl    in  SigSt.fromChunks $        zipWith           (\pyr ->               SigS.toStrictStorableSignal blockSize .-              SigS.map (sumRangeFromPyramid pyr) .+              SigS.map (accumulate pyr) .               SigS.zipWith (\d -> mapPair ((d+), (d+))) (SigS.iterate (1+) 0) .               SigS.fromStorableSignal)           pyrStarts ctrlBlocks +sumsPosModulatedPyramid ::+   (Additive.C v, Storable v) =>+   Int -> SigSt.T (Int,Int) -> SigSt.T v -> SigSt.T v+sumsPosModulatedPyramid height ctrl xs =+   accumulatePosModulatedFromPyramid+      FiltG.sumRangeFromPyramid+      (addSizes $ pyramid (+) height xs)+      ctrl++accumulateBinPosModulatedPyramid ::+   (Storable v) =>+   (v -> v -> v) ->+   Int -> SigSt.T (Int,Int) -> SigSt.T v -> SigSt.T v+accumulateBinPosModulatedPyramid acc height ctrl xs =+   accumulatePosModulatedFromPyramid+      (\pyr ->+         fromMaybe (error "accumulateBinPosModulatedPyramid: empty window") .+         FiltG.maybeAccumulateRangeFromPyramid acc pyr)+      (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,@@ -192,11 +273,107 @@ 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 $-   sumsPosModulatedPyramid height-      (SigSt.map (\c -> (maxC - c, maxC + c)) ctrl)-      (FiltG.delay maxC xs)+movingAverageModulatedPyramid amp height maxC ctrl0 =+   withPaddedInput zero+      (\ctrl xs ->+         SigSt.zipWith (\c x -> (amp / fromIntegral (2*c+1)) *> x) ctrl0 $+         sumsPosModulatedPyramid height ctrl xs)+      maxC ctrl0+++movingAccumulateModulatedPyramid ::+   (Storable v) =>+   (v -> v -> v) ->+   v -> Int -> Int -> SigSt.T Int -> SigSt.T v -> SigSt.T v+movingAccumulateModulatedPyramid acc pad height =+   withPaddedInput pad $+   accumulateBinPosModulatedPyramid acc height+++withPaddedInput ::+   (Storable y) =>+   y -> (SigSt.T (Int, Int) -> SigSt.T y -> v) ->+   Int -> SigSt.T Int -> SigSt.T y -> v+withPaddedInput pad proc maxC ctrl xs =+   proc+      (SigSt.map (\c -> (maxC - c, maxC + c + 1)) ctrl)+      (delayPad pad maxC xs)+++{- |+The function is like that of+'Synthesizer.State.Filter.NonRecursive.inverseFrequencyModulationFloor',+but this function preserves in a sense the chunk structure.++The result will have laziness breaks at least+at the chunk boundaries that correspond to the breaks in the input signal.+However we insert more breaks,+such that a maximum chunk size can be warrented.+(Since control and input signal are aligned in time,+we might as well use the control chunk structure.+Currently I do not know what is better.+For the above example it doesn't matter.+We might implement a variant in Causal.Filter.NonRecursive.)++This function cannot be written using generic functions,+since we have to inspect the chunks individually.+-}+{-# INLINE inverseFrequencyModulationFloor #-}+inverseFrequencyModulationFloor ::+   (Storable v, SigG.Consume sig t, Ring.C t, Ord t) =>+   SigSt.ChunkSize ->+   sig t -> SigSt.T v -> SigSt.T v+inverseFrequencyModulationFloor chunkSize ctrl =+   SigG.runViewL ctrl (\nextC cst0 ->+      SigSt.concat .+      Sig.crochetL+         (\chunk ms -> flip fmap ms $ \ts ->+            inverseFrequencyModulationChunk chunkSize+               nextC ts chunk)+         (Just (0,cst0)) .+      SigSt.chunks)++{-# INLINE inverseFrequencyModulationChunk #-}+inverseFrequencyModulationChunk ::+   (Storable v, Ring.C t, Ord t) =>+   SigSt.ChunkSize ->+   (s -> Maybe (t,s)) -> (t,s) -> V.Vector v -> (SigSt.T v, Maybe (t,s))+inverseFrequencyModulationChunk chunkSize nextC (phase,cst0) chunk =+   let {-# INLINE switch #-}+       {-+       switch ::+          (Maybe (t, s) -> r) ->+          ((t, v) -> (s, VPtr.Pointer v) -> r) ->+          t ->+          (s, VPtr.Pointer v) -> r+       -}+       {-+       This is a combination of two switches,+       that simulate a switch on (zip ctrl xs).+       -}+       switch l r t (cp0,xp0) =+          maybe+             (l Nothing)+             (\(c1,cp1) ->+                VPtr.switchL+                   (l (Just (t,cp0)))+                   (\x1 xp1 -> r (t+c1,x1) (cp1,xp1))+                   xp0)+             (nextC cp0)++       {-# INLINE go #-}+       {-+       go ::+          (t,v) -> (s, VPtr.Pointer v) ->+          Either (Maybe (t,s)) (v, ((t,v), (s, VPtr.Pointer v)))+       -}+       go (c,x) cxp =+          if c<1+            then switch Left go c cxp+            else Right (x, ((c-1,x),cxp))++   in  switch ((,) SigSt.empty)+          (curry $ VL.unfoldrResult chunkSize (uncurry go))+          phase (cst0, VPtr.cons chunk)
+ src/Synthesizer/Storable/Generate.hs view
@@ -0,0 +1,36 @@+module Synthesizer.Storable.Generate where++import qualified Synthesizer.Storable.Oscillator as Osci+import qualified Synthesizer.Storable.Signal as SigSt++import qualified Algebra.Additive as Additive+import qualified Algebra.RealRing as RealRing+import qualified Algebra.Transcendental as Trans++import Foreign.Storable (Storable, )+++{- |+@clickTrack silenceChunkSize barBeepFreq beatBeepFreq beepDur beatsPerBar beatPeriod@+generates click track for one bar.+You may cycle it infinitely or replicate it as often as you want.+-}+clickTrack ::+   (RealRing.C a, Trans.C a, Storable a) =>+   SigSt.ChunkSize ->+   a -> a -> Int -> Int -> Int -> SigSt.T a+clickTrack chunkSize+      barBeepFreq beatBeepFreq beepDur beatsPerBar beatPeriod =+   let beep freq =+          SigSt.take beepDur+             (Osci.staticSine (SigSt.chunkSize beepDur) Additive.zero freq)+          `SigSt.append`+          SigSt.replicate chunkSize (beatPeriod-beepDur) Additive.zero+   in  SigSt.concat $+          beep barBeepFreq :+          replicate (beatsPerBar-1) (beep beatBeepFreq)++clickTrackExample :: SigSt.T Float+clickTrackExample =+   SigSt.concat $ replicate (3*8) $+   clickTrack SigSt.defaultChunkSize 0.04 0.02 500 4 (84*441)
src/Synthesizer/Storable/Oscillator.hs view
@@ -18,25 +18,11 @@ 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.RealField             as RealField--- import qualified Algebra.Field                 as Field--- import qualified Algebra.Ring                  as Ring-import qualified Algebra.Additive              as Additive--import NumericPrelude+import qualified Algebra.RealRing              as RealRing -import qualified Prelude as P-import PreludeBase+import NumericPrelude.Numeric+import NumericPrelude.Base   @@ -46,46 +32,46 @@ {- | Convert a list of phase steps into a list of momentum phases      phase is a number in the interval [0,1)      freq contains the phase steps -}-freqToPhase :: (RealField.C a, Storable a) =>+freqToPhase :: (RealRing.C a, Storable a) =>    Phase.T a -> Signal.T a -> Signal.T (Phase.T a) freqToPhase phase freq = Signal.scanL (flip Phase.increment) phase freq   {-# INLINE static #-}-{-# SPECULATE static :: Storable b => ChunkSize -> (Double -> b) -> (Double -> Double -> Signal.T b) #-}+{- disabled SPECIALISE static :: Storable b => ChunkSize -> (Double -> b) -> (Double -> Double -> Signal.T b) -} {- | oscillator with constant frequency -}-static :: (RealField.C a, Storable a, Storable b) =>+static :: (RealRing.C a, Storable a, Storable b) =>     ChunkSize -> Wave.T a b -> (Phase.T a -> a -> Signal.T b) static size wave phase freq =     Signal.map (Wave.apply wave) (Signal.iterate size (Phase.increment freq) phase)  {- | oscillator with modulated phase -}-phaseMod :: (RealField.C a, Storable a, Storable b) =>+phaseMod :: (RealRing.C a, Storable a, Storable b) =>     ChunkSize -> Wave.T a b -> a -> Signal.T a -> Signal.T b phaseMod size wave = shapeMod size (Wave.phaseOffset wave) zero -{-# ONLINE shapeMod #-}+{- disabled INLINE shapeMod -} {- | oscillator with modulated shape -}-shapeMod :: (RealField.C a, Storable a, Storable b, Storable c) =>+shapeMod :: (RealRing.C a, Storable a, Storable b, Storable c) =>     ChunkSize -> (c -> Wave.T a b) -> Phase.T a -> a -> Signal.T c -> Signal.T b shapeMod size wave phase freq parameters =     Signal.zipWith (Wave.apply . wave) parameters        (Signal.iterate size (Phase.increment freq) phase)  {- | oscillator with modulated frequency -}-freqMod :: (RealField.C a, Storable a, Storable b) =>+freqMod :: (RealRing.C a, Storable a, Storable b) =>     ChunkSize -> Wave.T a b -> Phase.T a -> Signal.T a -> Signal.T b freqMod _size wave phase freqs =     Signal.map (Wave.apply wave) (freqToPhase phase freqs)  {- | oscillator with both phase and frequency modulation -}-phaseFreqMod :: (RealField.C a, Storable a, Storable b) =>+phaseFreqMod :: (RealRing.C a, Storable a, Storable b) =>     ChunkSize -> Wave.T a b -> Signal.T a -> Signal.T a -> Signal.T b phaseFreqMod size wave =     shapeFreqMod size (Wave.phaseOffset wave) zero  {- | oscillator with both shape and frequency modulation -}-shapeFreqMod :: (RealField.C a, Storable a, Storable b, Storable c) =>+shapeFreqMod :: (RealRing.C a, Storable a, Storable b, Storable c) =>     ChunkSize -> (c -> Wave.T a b) ->     Phase.T a -> Signal.T c -> Signal.T a -> Signal.T b shapeFreqMod _size wave phase parameters freqs =@@ -95,13 +81,13 @@ {- {- | oscillator with a sampled waveform with constant frequency      This essentially an interpolation with cyclic padding. -}-staticSample :: RealField.C a => Interpolation.T a b -> Signal.T b -> a -> a -> Signal.T b+staticSample :: RealRing.C a => Interpolation.T a b -> Signal.T b -> a -> a -> Signal.T b staticSample ip wave phase freq =     freqModSample ip wave phase (repeat freq)  {- | oscillator with a sampled waveform with modulated frequency      Should behave homogenously for different types of interpolation. -}-freqModSample :: RealField.C a => Interpolation.T a b -> Signal.T b -> a -> Signal.T a -> Signal.T b+freqModSample :: RealRing.C a => Interpolation.T a b -> Signal.T b -> a -> Signal.T a -> Signal.T b freqModSample ip wave phase freqs =     let len = fromIntegral (length wave)     in  Interpolation.multiRelativeCyclicPad@@ -113,37 +99,37 @@ {- * Oscillators with specific waveforms -}  {-# INLINE staticSine #-}-{-# SPECULATE staticSine :: ChunkSize -> Double -> Double -> Signal.T Double #-}+{- disabled SPECIALISE staticSine :: ChunkSize -> Double -> Double -> Signal.T Double -} {- | sine oscillator with static frequency -}-staticSine :: (Trans.C a, RealField.C a, Storable a) =>+staticSine :: (Trans.C a, RealRing.C a, Storable a) =>    ChunkSize -> Phase.T a -> a -> Signal.T a staticSine size = static size Wave.sine  {-# INLINE freqModSine #-}-{-# SPECULATE freqModSine :: ChunkSize -> Double -> Signal.T Double -> Signal.T Double #-}+{- disabled SPECIALISE freqModSine :: ChunkSize -> Double -> Signal.T Double -> Signal.T Double -} {- | sine oscillator with modulated frequency -}-freqModSine :: (Trans.C a, RealField.C a, Storable a) =>+freqModSine :: (Trans.C a, RealRing.C a, Storable a) =>    ChunkSize -> Phase.T a -> Signal.T a -> Signal.T a freqModSine size = freqMod size Wave.sine  {-# INLINE phaseModSine #-}-{-# SPECULATE phaseModSine :: ChunkSize -> Double -> Signal.T Double -> Signal.T Double #-}+{- disabled SPECIALISE phaseModSine :: ChunkSize -> Double -> Signal.T Double -> Signal.T Double -} {- | sine oscillator with modulated phase, useful for FM synthesis -}-phaseModSine :: (Trans.C a, RealField.C a, Storable a) =>+phaseModSine :: (Trans.C a, RealRing.C a, Storable a) =>    ChunkSize -> a -> Signal.T a -> Signal.T a phaseModSine size = phaseMod size Wave.sine  {-# INLINE staticSaw #-}-{-# SPECULATE staticSaw :: ChunkSize -> Double -> Double -> Signal.T Double #-}+{- disabled SPECIALISE staticSaw :: ChunkSize -> Double -> Double -> Signal.T Double -} {- | saw tooth oscillator with modulated frequency -}-staticSaw :: (RealField.C a, Storable a) =>+staticSaw :: (RealRing.C a, Storable a) =>    ChunkSize -> Phase.T a -> a -> Signal.T a staticSaw size = static size Wave.saw  {-# INLINE freqModSaw #-}-{-# SPECULATE freqModSaw :: ChunkSize -> Double -> Signal.T Double -> Signal.T Double #-}+{- disabled SPECIALISE freqModSaw :: ChunkSize -> Double -> Signal.T Double -> Signal.T Double -} {- | saw tooth oscillator with modulated frequency -}-freqModSaw :: (RealField.C a, Storable a) =>+freqModSaw :: (RealRing.C a, Storable a) =>    ChunkSize -> Phase.T a -> Signal.T a -> Signal.T a freqModSaw size = freqMod size Wave.saw
+ src/Synthesizer/Storable/Play.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.Storable.Play where++import qualified Synthesizer.Basic.Binary as BinSmp++import qualified Sound.Sox.Option.Format as SoxOpt+import qualified Sound.Sox.Play as Play++import Foreign.Storable (Storable, )++import qualified Synthesizer.Storable.Signal as SigSt+import qualified Synthesizer.Frame.Stereo as Stereo++import System.Exit (ExitCode, )++import qualified Algebra.RealRing as RealRing++import NumericPrelude.Numeric+import NumericPrelude.Base+++{- |+Latency is high using Sox -+We can achieve better results using ALSA's sound output!+See synthesizer-alsa package.+-}+monoToInt16 ::+   (Storable a, RealRing.C a) =>+   a -> SigSt.T a -> IO ExitCode+monoToInt16 rate =+   Play.simple SigSt.hPut SoxOpt.none (round rate) .+   SigSt.map BinSmp.int16FromCanonical++stereoToInt16 ::+   (Storable a, RealRing.C a) =>+   a -> SigSt.T (Stereo.T a) -> IO ExitCode+stereoToInt16 rate =+   Play.simple SigSt.hPut SoxOpt.none (round rate) .+   SigSt.map (\y -> Stereo.cons+                       (BinSmp.int16FromCanonical $ Stereo.left y)+                       (BinSmp.int16FromCanonical $ Stereo.right y))
+ src/Synthesizer/Storable/Repair.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.Storable.Repair (removeClicks, ) where++import qualified Data.StorableVector.Lazy.Pattern as SVP+import qualified Data.StorableVector.Lazy as SVL+import qualified Data.StorableVector as SV++import Control.Monad (guard, )++import qualified Data.List as List+import Data.Tuple.HT (mapFst, mapSnd, )+import Data.Maybe.HT (toMaybe, )+import Data.Word (Word8, )++import Foreign.Storable (Storable, )++import qualified Algebra.RealField as RealField+import qualified Algebra.Field     as Field+import qualified Algebra.Additive  as Additive++import NumericPrelude.Numeric+import NumericPrelude.Base+++{-+could use Generic.Control.line+-}+ramp ::+   (Storable a, Field.C a) =>+   Int -> (a, a) -> SVL.Vector a+ramp n (y0, y1) =+   SVL.sampleN SVL.defaultChunkSize n $ \k ->+      (y0 * fromIntegral (n-k) + y1 * fromIntegral k)+         / fromIntegral n++svHead :: (Storable a) => SVL.Vector a -> a+svHead =+   SVL.switchL (error "head: empty storable vector") const++{- |+@less-than@ comparison where 'Nothing' means \"unbounded\".+-}+maybeLT :: Ord a => Maybe a -> a -> Bool+maybeLT mx y =+   maybe False (<y) mx+++type Jump = Word8++up, down, smooth :: Jump+up = 1+down = -1+smooth = 0++{- |+both @up@ and @down@ threshold must be positive numbers.+-}+splitAtJump ::+   (Storable a, Additive.C a, Ord a) =>+   Int ->+   Maybe a -> Maybe a ->+   SVL.Vector a -> (SVL.Vector a, (Jump, SVL.Vector a))+splitAtJump slopeDistance thresholdUp thresholdDown xs =+   (\(beforeJump, afterJump) ->+      mapSnd ((,) (SVL.switchL up (\d _ -> d) afterJump)) $+      SVP.splitAt (SVP.length beforeJump) xs) $+   SVL.span (smooth==) $+   SVL.zipWith+      (\x0 x1 ->+         case (maybeLT thresholdUp (x1-x0),+               maybeLT thresholdDown (x0-x1)) of+            (True, _) -> up+            (_, True) -> down+            _ -> smooth) xs $+   SVL.switchR SVL.empty+      (\ys y ->+         SVL.append ys $+         SVL.fromChunks [SV.replicate slopeDistance y]) $+   SVL.drop slopeDistance xs++chopAtJumps ::+   (Storable a, Additive.C a, Ord a) =>+   Int -> Int ->+   Maybe a -> Maybe a ->+   SVL.Vector a -> (SVL.Vector a, [(Jump, SVP.Vector a)])+chopAtJumps+      slopeDistance minSpikeDistance+      thresholdUp thresholdDown =+   mapSnd+      (List.unfoldr+          (\(dir,rest) ->+             toMaybe (not $ SVL.null rest)+                (let (ys,zs) = SVL.splitAt minSpikeDistance rest+                 in  mapFst ((,) dir . SVL.append ys) $+                     splitAtJump slopeDistance thresholdUp thresholdDown zs)))+   .+   splitAtJump slopeDistance thresholdUp thresholdDown+++{- |+Usage:+   @removeClicks+      slopeDistance maxSpikeWidth minSpikeDistance+      thresholdUp thresholdDown@++@slopeDistance@ is the distance of samples in which we analyse differences.+The smoother the spike slope the larger @slopeDistance@ must be.++@slopeDistance@ should be smaller than the _minimal_ spike width.+@maxSpikeWidth@ should be smaller than the minimal spike distance.+Spike distance is measured from one spike beginning to the next one.++@thresholdUp@ is the minimal difference of two samples at @slopeDistance@+that are to be considered an upward jump.+@thresholdDown@ is for downward jumps.+If a threshold is 'Nothing' then jumps in this direction are ignored.+You should only use this if you are very sure+that spikes with the according sign do not occur.+Otherwise the algorithm will be confused+by the jump in reverse direction at the end of the spike.++Example: @removeClicks 1 5 20 (Just 0.1) (Just 0.1)@.++The algorithm works as follows:+Chop the signal at jumps.+Then begin at a certain distance behind the jump+and search backwards for the matching jump at the end of the spike.+If the borders of a spike are found this way,+then they are connected by a linear ramp.+-}+removeClicks ::+   (Storable a, RealField.C a) =>+   Int -> Int -> Int ->+   Maybe a -> Maybe a ->+   SVL.Vector a -> SVL.Vector a+removeClicks+      slopeDistance maxSpikeWidth minSpikeDistance+      thresholdUp thresholdDown =+   SVL.concat+   .+   uncurry (:)+   .+   mapSnd+      (map+          (\(dir, chunk) ->+             uncurry SVL.append+             .+             mapFst+                ((\(ys, ~(_dir,click)) ->+                    SVL.append+                       (ramp (SVL.length click)+                           (svHead chunk, svHead click))+                       (SVL.reverse ys))+                 .+                 splitAtJump slopeDistance+                    (guard (dir==up)   >> thresholdUp)+                    (guard (dir==down) >> thresholdDown)+                 .+                 SVL.reverse)+             .+             SVL.splitAt maxSpikeWidth+             $+             chunk))+   .+   chopAtJumps+      slopeDistance minSpikeDistance+      thresholdUp thresholdDown
src/Synthesizer/Storable/Signal.hs view
@@ -1,1280 +1,320 @@-{- OPTIONS_GHC -fglasgow-exts -}-{- glasgow-exts are for the rules -}-{- |-Chunky signal stream build on StorableVector.--Hints for fusion:- - Higher order functions should always be inlined in the end-   in order to turn them into machine loops-   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-      splitAtPad,-      Vector.null,-      Vector.fromChunks,-      Vector.foldr,-      -- for Storable.Filter.Comb-      delay,-      delayLoop,-      delayLoopOverlap,-      -- for FusionTest-      mix, mixSize,-      Vector.empty,-      Vector.replicate,-      Vector.repeat,-      Vector.drop,-      Vector.take,-      takeCrochet,-      fromList,-      appendFromFusionList,-      appendFusionList,-      -- for Generic.Signal-      zipWithRest,-      zipWithAppend,-      -- for Storable.ALSA.MIDI-      Vector.switchR,-      -- for Test.Filter-      toList,-      -- for Storable.Filter.NonRecursive-      Vector.chunks,--      -- just for fun-      fromFusionList,-      genericLength,-   ) where---- import qualified Sound.Signal as Signal--import qualified Synthesizer.FusionList.Signal as FList--import qualified Data.List as List-import qualified Data.StorableVector.Lazy as Vector-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 qualified Synthesizer.Format as Format---- import Control.Arrow ((***))--- import Control.Monad (liftM, liftM2, {- guard, -} )--import qualified Algebra.Ring      as Ring-import qualified Algebra.Additive  as Additive-import qualified Algebra.ToInteger as ToInteger--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-import PreludeBase-import Prelude ()---{--import NumericPrelude-   (sum, (+), (-), divMod, fromIntegral, fromInteger, toInteger, isZero, zero, )--import Prelude hiding-   (length, (++), iterate, foldl, map, repeat, replicate, null,-    zip, zipWith, zipWith3, drop, take, splitAt, takeWhile, reverse)--}--{--import qualified Prelude as P-import Prelude-   (IO, ($), (.), fst, snd, id,-    Int, Double, Float,-    Char, Num, Show, showsPrec, FilePath,-    Bool(True,False), not,-    flip, curry, uncurry,-    Ord, (<), (>), (<=), {- (>=), (==), -} min, max,-    mapM_, fmap, (=<<), return,-    Enum, succ, pred, )--}----- this form is needed for Storable signal embed in amplitude signal-type T = Vector.Vector--- type T a = Vector.Vector a--instance (Show a, Storable a) => Show (Vector.Vector a) where-   showsPrec p = showsPrec p . Vector.unpack--{--instance (Storable a) => Format.C T where-   format = showsPrec--}---defaultChunkSize :: ChunkSize-defaultChunkSize = ChunkSize 1024---{--{- * Helper functions for StorableVector -}--cancelNullVector :: (Vector a, b) -> Maybe (Vector a, b)-cancelNullVector y =-   toMaybe (not (Vector.null (fst y))) y--viewLVector :: Storable a =>-   Vector a -> Maybe (a, Vector a)-viewLVector = Vector.viewL-{--   toMaybe-      (not (Vector.null x))-      (Vector.head x, Vector.tail x)--}--crochetLVector :: (Storable x, Storable y) =>-      (x -> acc -> Maybe (y, acc))-   -> acc-   -> Vector x-   -> (Vector y, Maybe acc)-crochetLVector f acc0 x0 =-   mapSnd (fmap fst) $-   Vector.unfoldrN-      (Vector.length x0)-      (\(acc,xt) ->-         do (x,xs) <- viewLVector xt-            (y,acc') <- f x acc-            return (y, (acc',xs)))-      (acc0, x0)--reduceLVector :: Storable x =>-   (x -> acc -> Maybe acc) -> acc -> Vector x -> (acc, Bool)-reduceLVector f acc0 x =-   let recourse i acc =-          if i < Vector.length x-            then (acc, True)-            else-               maybe-                  (acc, False)-                  (recourse (succ i))-                  (f (Vector.index x i) acc)-   in  recourse 0 acc0-----{- * Fundamental functions -}--{- |-Sophisticated implementation where chunks always have size bigger than 0.--}-{-# INLINE [0] unfoldr #-}-unfoldr :: (Storable b) =>-      ChunkSize-   -> (a -> Maybe (b,a))-   -> a-   -> T b-unfoldr (ChunkSize size) f =-   Cons .-   List.unfoldr-      (cancelNullVector . Vector.unfoldrN size f =<<) .-   Just--{- |-Simple implementation where chunks can have size 0 in the first run.-Then they are filtered out.-This separation might reduce laziness.--}-unfoldr0 :: (Storable b) =>-      ChunkSize-   -> (a -> Maybe (b,a))-   -> a-   -> T b-unfoldr0 (ChunkSize size) f =-   Cons .-   List.filter (not . Vector.null) .-   List.unfoldr (fmap (Vector.unfoldrN size f)) .-   Just---unfoldr1 :: (Storable b) =>-      ChunkSize-   -> (a -> (b, Maybe a))-   -> Maybe a-   -> T b-unfoldr1 size f = unfoldr size (liftM f)--{-# INLINE [0] crochetL #-}-crochetL :: (Storable x, Storable y) =>-      (x -> acc -> Maybe (y, acc))-   -> acc-   -> T x-   -> T y-crochetL f acc0 =-   Cons . List.unfoldr (\(xt,acc) ->-       do (x,xs) <- ListHT.viewL xt-          acc' <- acc-          return $ mapSnd ((,) xs) $ crochetLVector f acc' x) .-   flip (,) (Just acc0) .-   decons--{--Usage of 'unfoldr' seems to be clumsy but that covers all cases,-like different block sizes in source and destination list.--}-crochetLSize :: (Storable x, Storable y) =>-      ChunkSize-   -> (x -> acc -> Maybe (y, acc))-   -> acc-   -> T x-   -> T y-crochetLSize size f =-   curry (unfoldr size (\(acc,xt) ->-      do (x,xs) <- viewL xt-         (y,acc') <- f x acc-         return (y, (acc',xs))))--viewL :: Storable a => T a -> Maybe (a, T a)-viewL (Cons xs0) =-   -- dropWhile would be unnecessary if we require that all chunks are non-empty-   do (x,xs) <- ListHT.viewL (List.dropWhile Vector.null xs0)-      (y,ys) <- viewLVector x-      return (y, append (fromChunk ys) (Cons xs))--viewR :: Storable a => T a -> Maybe (T a, a)-viewR (Cons xs0) =-   -- dropWhile would be unnecessary if we require that all chunks are non-empty-   do (xs,x) <- ListHT.viewR (dropWhileRev Vector.null xs0)-      (ys,y) <- Vector.viewR x-      return (append (Cons xs) (fromChunk ys), y)--crochetListL :: (Storable y) =>-      ChunkSize-   -> (x -> acc -> Maybe (y, acc))-   -> acc-   -> [x]-   -> T y-crochetListL size f =-   curry (unfoldr size (\(acc,xt) ->-      do (x,xs) <- ListHT.viewL xt-         (y,acc') <- f x acc-         return (y, (acc',xs))))--}---{-# INLINE fromList #-}-fromList :: (Storable a) => ChunkSize -> [a] -> T a-fromList = Vector.pack--{-# INLINE toList #-}-toList :: (Storable a) => T a -> [a]-toList = Vector.unpack---{---- should start fusion-fromListCrochetL :: (Storable a) => ChunkSize -> [a] -> T a-fromListCrochetL size =-   crochetListL size (\x _ -> Just (x, ())) ()--fromListUnfoldr :: (Storable a) => ChunkSize -> [a] -> T a-fromListUnfoldr size = unfoldr size ListHT.viewL--fromListPack :: (Storable a) => ChunkSize -> [a] -> T a-fromListPack (ChunkSize size) =-   Cons .-   List.map Vector.pack .-   sliceVert size--toList :: (Storable a) => T a -> [a]-toList = List.concatMap Vector.unpack . decons---- if the chunk has length zero, an empty sequence is generated-fromChunk :: (Storable a) => Vector a -> T a-fromChunk x =-   if Vector.null x-     then empty-     else Cons [x]-----{-# NOINLINE [0] crochetFusionListL #-}-crochetFusionListL :: (Storable y) =>-      ChunkSize-   -> (x -> acc -> Maybe (y, acc))-   -> acc-   -> FList.T x-   -> T y-crochetFusionListL size f =-   curry (unfoldr size (\(acc,xt) ->-      do (x,xs) <- FList.viewL xt-         (y,acc') <- f x acc-         return (y, (acc',xs))))--}--{-# NOINLINE [0] fromFusionList #-}-fromFusionList :: (Storable a) => ChunkSize -> FList.T a -> T a-fromFusionList size = fromList size . FList.toList-   -- fromFusionListCrochetL--{--{-# INLINE fromFusionListCrochetL #-}-fromFusionListCrochetL :: (Storable a) => ChunkSize -> FList.T a -> T a-fromFusionListCrochetL size =-   crochetFusionListL size (\x _ -> Just (x, ())) ()--fromFusionListUnfoldr :: (Storable a) => ChunkSize -> FList.T a -> T a-fromFusionListUnfoldr size =-   unfoldr size FList.viewL---{-# NOINLINE [0] toFusionList #-}-toFusionList :: (Storable a) => T a -> FList.T a-toFusionList = FList.Cons . List.concatMap Vector.unpack . decons---{- |-Converts from and to 'FList.T'-in order to speedup computation,-especially because it tells the optimizer about the 'Storable' constraint-and thus allows for more fusion,-where fusion would break otherwise.--}-{-# INLINE chop #-}-chop :: (Storable a) => ChunkSize -> FList.T a -> FList.T a-chop size = toFusionList . fromFusionList size----{-# INLINE [0] reduceL #-}-reduceL :: Storable x =>-   (x -> acc -> Maybe acc) -> acc -> T x -> acc-reduceL f acc0 =-   let recourse acc xt =-          case xt of-             [] -> acc-             (x:xs) ->-                 let (acc',continue) = reduceLVector f acc x-                 in  if continue-                       then recourse acc' xs-                       else acc'-   in  recourse acc0 . decons----{- * Basic functions -}--empty :: Storable a => T a-empty = Cons []--null :: Storable a => T a -> Bool-null = List.null . decons---{-# NOINLINE [0] cons #-}-cons :: Storable a => a -> T a -> T a-cons x = Cons . (Vector.singleton x :) . decons---length :: T a -> Int-length = sum . List.map Vector.length . decons---reverse :: Storable a => T a -> T a-reverse =-   Cons . List.reverse . List.map Vector.reverse . decons---{-# INLINE [0] foldl #-}-foldl :: Storable b => (a -> b -> a) -> a -> T b -> a-foldl f x0 = List.foldl (Vector.foldl f) x0 . decons---{-# INLINE [0] map #-}-map :: (Storable x, Storable y) =>-      (x -> y)-   -> T x-   -> T y-map f = mapInline f -- Cons . List.map (Vector.map f) . decons--{-# INLINE mapInline #-}-mapInline :: (Storable x, Storable y) =>-      (x -> y)-   -> T x-   -> T y-mapInline f =-   let mapVec = Vector.map f-   in  Cons . List.map mapVec . decons----{-# NOINLINE [0] drop #-}-drop :: (Storable a) => Int -> T a -> T a-drop _ (Cons []) = empty-drop n (Cons (x:xs)) =-   let m = Vector.length x-   in  if m<=n-         then drop (n-m) (Cons xs)-         else Cons (Vector.drop n x : xs)--{-# NOINLINE [0] take #-}-take :: (Storable a) => Int -> T a -> T a-take _ (Cons []) = empty-take 0 _ = empty-take n (Cons (x:xs)) =-   let m = Vector.length x-   in  if m<=n-         then Cons $ (x:) $ decons $ take (n-m) $ Cons xs-         else fromChunk (Vector.take n x)----{-# NOINLINE [0] splitAt #-}-splitAt :: (Storable a) => Int -> T a -> (T a, T a)-splitAt n0 =-   let recourse _ [] = ([], [])-       recourse 0 xs = ([], xs)-       recourse n (x:xs) =-          let m = Vector.length x-          in  if m<=n-                then mapFst (x:) $ recourse (n-m) xs-                else mapPair ((:[]), (:xs)) $ Vector.splitAt n x-   in  mapPair (Cons, Cons) . recourse n0 . decons---dropMarginRem :: (Storable a) => Int -> Int -> T a -> (Int, T a)-dropMarginRem n m xs =-   List.foldl'-      (\(mi,xsi) k -> (mi-k, drop k xsi))-      (m,xs)-      (List.map Vector.length $ decons $ take m $ drop n xs)--{--This implementation does only walk once through the dropped prefix.-It is maximally lazy and minimally space consuming.--}-dropMargin :: (Storable a) => Int -> Int -> T a -> T a-dropMargin n m xs =-   List.foldl' (flip drop) xs-      (List.map Vector.length $ decons $ take m $ drop n xs)---{-# NOINLINE [0] dropWhile #-}-dropWhile :: (Storable a) => (a -> Bool) -> T a -> T a-dropWhile _ (Cons []) = empty-dropWhile p (Cons (x:xs)) =-   let y = Vector.dropWhile p x-   in  if Vector.null y-         then dropWhile p (Cons xs)-         else Cons (y:xs)--{-# NOINLINE [0] takeWhile #-}-takeWhile :: (Storable a) => (a -> Bool) -> T a -> T a-takeWhile _ (Cons []) = empty-takeWhile p (Cons (x:xs)) =-   let y = Vector.takeWhile p x-   in  if Vector.length y < Vector.length x-         then fromChunk y-         else Cons (x : decons (takeWhile p (Cons xs)))---{-# NOINLINE [0] span #-}-span :: (Storable a) => (a -> Bool) -> T a -> (T a, T a)-span p =-   let recourse [] = ([],[])-       recourse (x:xs) =-          let (y,z) = Vector.span p x-          in  if Vector.null z-                then mapFst (x:) (recourse xs)-                else (decons $ fromChunk y, (z:xs))-   in  mapPair (Cons, Cons) . recourse . decons-{--span _ (Cons []) = (empty, empty)-span p (Cons (x:xs)) =-   let (y,z) = Vector.span p x-   in  if Vector.length y == 0-         then mapFst (Cons . (x:) . decons) (span p (Cons xs))-         else (Cons [y], Cons (z:xs))--}--concat :: (Storable a) => [T a] -> T a-concat = Cons . List.concat . List.map decons---{- |-Ensure a minimal length of the list by appending pad values.--}-{-# NOINLINE [0] pad #-}-pad :: (Storable a) => ChunkSize -> a -> Int -> T a -> T a-pad size y n0 =-   let recourse n xt =-          if n<=0-            then xt-            else-              case xt of-                 [] -> decons $ replicate size n y-                 x:xs -> x : recourse (n - Vector.length x) xs-   in  Cons . recourse n0 . decons--padAlt :: (Storable a) => ChunkSize -> a -> Int -> T a -> T a-padAlt size x n xs =-   append xs-      (let m = length xs-       in  if n>m-             then replicate size (n-m) x-             else empty)---infixr 5 `append`--{-# NOINLINE [0] append #-}-append :: T a -> T a -> T a-append (Cons xs) (Cons ys)  =  Cons (xs List.++ ys)--}--{-# INLINE appendFromFusionList #-}-appendFromFusionList :: Storable a =>-   ChunkSize -> FList.T a -> FList.T a -> T a-appendFromFusionList size xs ys  =-   Vector.append (FList.toStorableSignal size xs) (FList.toStorableSignal size ys)--{- |-Like 'appendFromFusionList' but returns a 'FList.T'-for more flexible following processing.--}-{-# INLINE appendFusionList #-}-appendFusionList :: Storable a =>-   ChunkSize -> FList.T a -> FList.T a -> FList.T a-appendFusionList size xs ys  =-   FList.fromStorableSignal (appendFromFusionList size xs ys)---{--{-# INLINE iterate #-}-iterate :: Storable a => ChunkSize -> (a -> a) -> a -> T a-iterate size f = unfoldr size (\x -> Just (x, f x))--repeat :: Storable a => ChunkSize -> a -> T a-repeat (ChunkSize size) =-   Cons . List.repeat . Vector.replicate size--cycle :: Storable a => T a -> T a-cycle =-   Cons . List.cycle . decons--replicate :: Storable a => ChunkSize -> Int -> a -> T a-replicate (ChunkSize size) n x =-   let (numChunks, rest) = divMod n size-   in  append-          (Cons (List.replicate numChunks (Vector.replicate size x)))-          (fromChunk (Vector.replicate rest x))--}--{-# INLINE scanL #-}-scanL :: (Storable a, Storable b) =>-   (a -> b -> a) -> a -> T b -> T a-scanL = Vector.scanl---{--{-# INLINE [0] mapAccumL #-}-mapAccumL :: (Storable a, Storable b) =>-   (acc -> a -> (acc, b)) -> acc -> T a -> (acc, T b)-mapAccumL f start =-   mapSnd Cons .-   List.mapAccumL (Vector.mapAccumL f) start .-   decons--{-# INLINE [0] mapAccumR #-}-mapAccumR :: (Storable a, Storable b) =>-   (acc -> a -> (acc, b)) -> acc -> T a -> (acc, T b)-mapAccumR f start =-   mapSnd Cons .-   List.mapAccumR (Vector.mapAccumR f) start .-   decons--{-# RULEZ-  "Storable.append/repeat/repeat" forall size x.-      append (repeat size x) (repeat size x) = repeat size x ;--  "Storable.append/repeat/replicate" forall size n x.-      append (repeat size x) (replicate size n x) = repeat size x ;--  "Storable.append/replicate/repeat" forall size n x.-      append (replicate size n x) (repeat size x) = repeat size x ;--  "Storable.append/replicate/replicate" forall size n m x.-      append (replicate size n x) (replicate size m x) =-         replicate size (n+m) x ;--  "Storable.mix/repeat/repeat" forall size x y.-      mix (repeat size x) (repeat size y) = repeat size (x+y) ;--  #-}--{-# RULES-  "Storable.length/cons" forall x xs.-      length (cons x xs) = 1 + length xs ;--  "Storable.length/map" forall f xs.-      length (map f xs) = length xs ;--  "Storable.map/cons" forall f x xs.-      map f (cons x xs) = cons (f x) (map f xs) ;--  "Storable.map/repeat" forall size f x.-      map f (repeat size x) = repeat size (f x) ;--  "Storable.map/replicate" forall size f x n.-      map f (replicate size n x) = replicate size n (f x) ;--  "Storable.map/repeat" forall size f x.-      map f (repeat size x) = repeat size (f x) ;--  {--  This can make things worse, if 'map' is applied to replicate,-  since this can use of sharing.-  It can also destroy the more important map/unfoldr fusion in-    take n . map f . unfoldr g--  "Storable.take/map" forall n f x.-      take n (map f x) = map f (take n x) ;-  -}--  "Storable.take/repeat" forall size n x.-      take n (repeat size x) = replicate size n x ;--  "Storable.take/take" forall n m xs.-      take n (take m xs) = take (min n m) xs ;--  "Storable.drop/drop" forall n m xs.-      drop n (drop m xs) = drop (n+m) xs ;--  "Storable.drop/take" forall n m xs.-      drop n (take m xs) = take (max 0 (m-n)) (drop n xs) ;--  "Storable.map/mapAccumL/snd" forall g f acc0 xs.-      map g (snd (mapAccumL f acc0 xs)) =-         snd (mapAccumL (\acc a -> mapSnd g (f acc a)) acc0 xs) ;--  #-}--{- GHC says this is an orphaned rule-  "Storable.map/mapAccumL/mapSnd" forall g f acc0 xs.-      mapSnd (map g) (mapAccumL f acc0 xs) =-         mapAccumL (\acc a -> mapSnd g (f acc a)) acc0 xs ;--}--}--{-# SPECULATE mix :: T Double -> T Double -> T Double #-}-{-# SPECULATE mix :: T Float -> T Float -> T Float #-}-{-# SPECULATE mix :: T (Double,Double) -> T (Double,Double) -> T (Double,Double) #-}-{-# SPECULATE mix :: T (Float,Float) -> T (Float,Float) -> T (Float,Float) #-}-{--'mix' is more efficient-since it appends the rest of the longer signal without copying.-It also preserves the chunk structure of the second signal,-which is essential if you want to limit look-ahead.--}-mix :: (Additive.C x, Storable x) =>-      T x-   -> T x-   -> T x-mix = zipWithAppend (+)-{--List.map V.unpack $ Vector.chunks $ mix (fromList defaultChunkSize [1,2,3,4,5::P.Double]) (fromList defaultChunkSize [1,2,3,4])--}--zipWithAppend ::-   (Storable x) =>-   (x -> x -> x) ->-   T x -> T x -> T x-zipWithAppend f xs ys =-   uncurry Vector.append $ mapSnd snd $ zipWithRest f xs ys--zipWithRest ::-   (Storable c, Storable x) =>-   (x -> x -> c) ->-   T x ->-   T x ->-   (Vector.Vector c, (Bool, T x))-zipWithRest f xs ys =-   let len = min (lazyLength xs) (lazyLength ys) :: Chunky.T NonNeg.Int-       (prefixX,suffixX) = genericSplitAt len xs-       (prefixY,suffixY) = genericSplitAt len ys-       second = Vector.null suffixX-   in  (Vector.zipWith f prefixX prefixY,-        (second, if second then suffixY else suffixX))--{--We should move that to StorableVector package,-but we cannot, since that's Haskell 98.--}-genericSplitAt ::-   (Additive.C i, Ord i, ToInteger.C i, Storable x) =>-   i -> T x -> (T x, T x)-genericSplitAt n0 =-   let recourse n xs0 =-          forcePair $-          maybe-             ([], [])-             (\(x,xs) ->-                if isZero n-                  then ([], xs0)-                  else-                    let m = fromIntegral $ V.length x-                    in  if m<=n-                          then mapFst (x:) $ recourse (n-m) xs-                          else mapPair ((:[]), (:xs)) $-                               V.splitAt (fromInteger $ toInteger n) x)-           $ ListHT.viewL xs0-   in  mapPair (Vector.fromChunks, Vector.fromChunks) .-       recourse n0 . Vector.chunks----- cf. Data.StorableVector.Lazy.Pattern.length-lazyLength :: (Ring.C i) =>-   T x -> i-lazyLength =-   List.foldr (+) zero . List.map (fromIntegral . V.length) . Vector.chunks--genericLength :: (Ring.C i) =>-   T x -> i-genericLength =-   sum . List.map (fromIntegral . V.length) . Vector.chunks---splitAtPad ::-   (Additive.C x, Storable x) =>-   ChunkSize -> Int -> T x -> (T x, T x)-splitAtPad size n =-   mapFst (Vector.pad size Additive.zero n) . Vector.splitAt n---{-# SPECULATE mixSize :: ChunkSize -> T Double -> T Double -> T Double #-}-{-# SPECULATE mixSize :: ChunkSize -> T Float -> T Float -> T Float #-}-{-# SPECULATE mixSize :: ChunkSize -> T (Double,Double) -> T (Double,Double) -> T (Double,Double) #-}-{-# SPECULATE mixSize :: ChunkSize -> T (Float,Float) -> T (Float,Float) -> T (Float,Float) #-}-{-# INLINE mixSize #-}-mixSize :: (Additive.C x, Storable x) =>-      ChunkSize-   -> T x-   -> T x-   -> T x-mixSize size =-   curry (Vector.unfoldr size mixStep)---{-# INLINE mixStep #-}-mixStep :: (Additive.C x, Storable x) =>-   (T x, T x) ->-   Maybe (x, (T x, T x))-mixStep (xt,yt) =-   case (Vector.viewL xt, Vector.viewL yt) of-      (Just (x,xs), Just (y,ys)) -> Just (x+y, (xs,ys))-      (Nothing,     Just (y,ys)) -> Just (y,   (xt,ys))-      (Just (x,xs), Nothing)     -> Just (x,   (xs,yt))-      (Nothing,     Nothing)     -> Nothing----{-# INLINE delay #-}-delay :: (Storable y) =>-   ChunkSize -> y -> Int -> T y -> T y-delay size z n = Vector.append (Vector.replicate size n z)--{-# INLINE delayLoop #-}-delayLoop ::-   (Storable y) =>-      (T y -> T y)-            -- ^ processor that shall be run in a feedback loop-   -> T y   -- ^ prefix of the output, its length determines the delay-   -> T y-delayLoop proc prefix =-   let ys = Vector.append prefix (proc ys)-   in  ys---{-# INLINE delayLoopOverlap #-}-delayLoopOverlap ::-   (Additive.C y, Storable y) =>-      Int-   -> (T y -> T y)-            {- ^ Processor that shall be run in a feedback loop.-                 It's absolutely necessary that this function preserves the chunk structure-                 and that it does not look a chunk ahead.-                 That's guaranteed for processes that do not look ahead at all,-                 like 'Vector.map', 'Vector.crochetL' and-                 all of type @Causal.Process@. -}-   -> T y   -- ^ input-   -> T y   -- ^ output has the same length as the input-delayLoopOverlap time proc xs =-   let ys = Vector.zipWith (Additive.+) xs-               (delay (Vector.chunkSize time) Additive.zero time (proc ys))-   in  ys----{--{-# INLINE zip #-}-zip :: (Storable a, Storable b) =>-   ChunkSize -> (T a -> T b -> T (a,b))-zip size  =  zipWith size (,)--{-# INLINE zipWith3 #-}-zipWith3 :: (Storable a, Storable b, Storable c, Storable d) =>-   ChunkSize -> (a -> b -> c -> d) -> (T a -> T b -> T c -> T d)-zipWith3 size f s0 s1 =-   zipWith size (uncurry f) (zip size s0 s1)--{-# INLINE zipWith4 #-}-zipWith4 :: (Storable a, Storable b, Storable c, Storable d, Storable e) =>-   ChunkSize -> (a -> b -> c -> d -> e) -> (T a -> T b -> T c -> T d -> T e)-zipWith4 size f s0 s1 =-   zipWith3 size (uncurry f) (zip size s0 s1)---{- * Fusable functions -}--{-# INLINE [0] zipWith #-}-zipWith :: (Storable x, Storable y, Storable z) =>-      ChunkSize-   -> (x -> y -> z)-   -> T x-   -> T y-   -> T z-zipWith size f =-   curry (unfoldr size (\(xt,yt) ->-      liftM2-         (\(x,xs) (y,ys) -> (f x y, (xs,ys)))-         (viewL xt)-         (viewL yt)))----scanLCrochet :: (Storable a, Storable b) =>-   (a -> b -> a) -> a -> T b -> T a-scanLCrochet f start =-   cons start .-   crochetL (\x acc -> let y = f acc x in Just (y, y)) start--{-# INLINE mapCrochet #-}-mapCrochet :: (Storable a, Storable b) => (a -> b) -> (T a -> T b)-mapCrochet f = crochetL (\x _ -> Just (f x, ())) ()--}--{-# INLINE takeCrochet #-}-takeCrochet :: Storable a => Int -> T a -> T a-takeCrochet = Vector.crochetL (\x n -> toMaybe (n>0) (x, pred n))--{--{-# INLINE repeatUnfoldr #-}-repeatUnfoldr :: Storable a => ChunkSize -> a -> T a-repeatUnfoldr size = iterate size id--{-# INLINE replicateCrochet #-}-replicateCrochet :: Storable a => ChunkSize -> Int -> a -> T a-replicateCrochet size n = takeCrochet n . repeat size----{--crochetFusionListLGenerate size g b f a =-        unfoldr size (\(a0,b0) ->-            do (y0,a1) <- f a0-               (z0,b1) <- g y0 b0-               Just (z0, (a1,b1))) (a,b) ;---}---{-# RULES-  "Storable.crochetFusionListL/crochetL" forall size f g a b x.-     crochetFusionListL size g b (FList.crochetL f a x) =-        crochetFusionListL size (\x0 (a0,b0) ->-            do (y0,a1) <- f x0 a0-               (z0,b1) <- g y0 b0-               Just (z0, (a1,b1))) (a,b) x ;--  "Storable.crochetFusionListL/generate" forall size f g a b.-     crochetFusionListL size g b (FList.generate f a) =-        unfoldr size (\(a0,b0) ->-            do (y0,a1) <- f a0-               (z0,b1) <- g y0 b0-               Just (z0, (a1,b1))) (a,b) ;--{--  "Storable.fromFusionList/crochetL"-     forall size f a (x :: Storable a => FList.T a) .-     fromFusionList size (FList.crochetL f a x) =-        crochetL f a (fromFusionList size x) ;--}--  "Storable.fromFusionList/generate" forall size f a.-     fromFusionList size (FList.generate f a) =-        unfoldr size f a ;--  "Storable.fromFusionList/cons" forall size x xs.-     fromFusionList size (FList.cons x xs) =-        cons x (fromFusionList size xs) ;--  "Storable.fromFusionList/empty" forall size.-     fromFusionList size (FList.empty) =-        empty ;--  "Storable.fromFusionList/append" forall size xs ys.-     fromFusionList size (FList.append xs ys) =-        append (fromFusionList size xs) (fromFusionList size ys) ;--  "Storable.fromFusionList/maybe" forall size f x y.-     fromFusionList size (maybe x f y) =-        maybe (fromFusionList size x)-           (fromFusionList size . f) y ;--  "Storable.fromFusionList/fromMaybe" forall size x y.-     fromFusionList size (fromMaybe x y) =-        maybe (fromFusionList size x) (fromFusionList size) y ;-  #-}---{--The "fromList/drop" rule is not quite accurate-because the chunk borders are moved.-Maybe 'ChunkSize' better is a list of chunks sizes.--}--{-# RULEZ-  "fromList/zipWith"-    forall size f (as :: Storable a => [a]) (bs :: Storable a => [a]).-     fromList size (List.zipWith f as bs) =-        zipWith size f (fromList size as) (fromList size bs) ;--  "fromList/drop" forall as n size.-     fromList size (List.drop n as) =-        drop n (fromList size as) ;-  #-}----{- * Fused functions -}--type Unfoldr s a = (s -> Maybe (a,s), s)--{-# INLINE zipWithUnfoldr2 #-}-zipWithUnfoldr2 :: Storable z =>-      ChunkSize-   -> (x -> y -> z)-   -> Unfoldr a x-   -> Unfoldr b y-   -> T z-zipWithUnfoldr2 size h (f,a) (g,b) =-   unfoldr size-      (\(a0,b0) -> liftM2 (\(x,a1) (y,b1) -> (h x y, (a1,b1))) (f a0) (g b0))---      (uncurry (liftM2 (\(x,a1) (y,b1) -> (h x y, (a1,b1)))) . (f *** g))-      (a,b)--{- done by takeCrochet-{-# INLINE mapUnfoldr #-}-mapUnfoldr :: (Storable x, Storable y) =>-      ChunkSize-   -> (x -> y)-   -> Unfoldr a x-   -> T y-mapUnfoldr size g (f,a) =-   unfoldr size (fmap (mapFst g) . f) a--}--{-# INLINE dropUnfoldr #-}-dropUnfoldr :: Storable x =>-      ChunkSize-   -> Int-   -> Unfoldr a x-   -> T x-dropUnfoldr size n (f,a0) =-   maybe-      empty-      (unfoldr size f)-      (nest n (\a -> fmap snd . f =<< a) (Just a0))---{- done by takeCrochet-{-# INLINE takeUnfoldr #-}-takeUnfoldr :: Storable x =>-      ChunkSize-   -> Int-   -> Unfoldr a x-   -> T x-takeUnfoldr size n0 (f,a0) =-   unfoldr size-      (\(a,n) ->-         do guard (n>0)-            (x,a') <- f a-            return (x, (a', pred n)))-      (a0,n0)--}---lengthUnfoldr :: Storable x =>-      Unfoldr a x-   -> Int-lengthUnfoldr (f,a0) =-   let recourse n a =-          maybe n (recourse (succ n) . snd) (f a)-   in  recourse 0 a0---{-# INLINE zipWithUnfoldr #-}-zipWithUnfoldr ::-   (Storable b, Storable c) =>-      (acc -> Maybe (a, acc))-   -> (a -> b -> c)-   -> acc-   -> T b -> T c-zipWithUnfoldr f h a y =-   crochetL (\y0 a0 ->-       do (x0,a1) <- f a0-          Just (h x0 y0, a1)) a y--{-# INLINE zipWithCrochetL #-}-zipWithCrochetL ::-   (Storable x, Storable b, Storable c) =>-      ChunkSize-   -> (x -> acc -> Maybe (a, acc))-   -> (a -> b -> c)-   -> acc-   -> T x -> T b -> T c-zipWithCrochetL size f h a x y =-   crochetL (\(x0,y0) a0 ->-       do (z0,a1) <- f x0 a0-          Just (h z0 y0, a1))-      a (zip size x y)---{-# INLINE crochetLCons #-}-crochetLCons ::-   (Storable a, Storable b) =>-      (a -> acc -> Maybe (b, acc))-   -> acc-   -> a -> T a -> T b-crochetLCons f a0 x xs =-   maybe-      empty-      (\(y,a1) -> cons y (crochetL f a1 xs))-      (f x a0)--{-# INLINE reduceLCons #-}-reduceLCons ::-   (Storable a) =>-      (a -> acc -> Maybe acc)-   -> acc-   -> a -> T a -> acc-reduceLCons f a0 x xs =-   maybe a0 (flip (reduceL f) xs) (f x a0)------{-# RULES-  "Storable.zipWith/share" forall size (h :: a->a->b) (x :: T a).-     zipWith size h x x = map (\xi -> h xi xi) x ;----  "Storable.map/zipWith" forall size (f::c->d) (g::a->b->c) (x::T a) (y::T b).-  "Storable.map/zipWith" forall size f g x y.-     map f (zipWith size g x y) =-        zipWith size (\xi yi -> f (g xi yi)) x y ;--  -- this rule lets map run on a different block structure-  "Storable.zipWith/map,*" forall size f g x y.-     zipWith size g (map f x) y =-        zipWith size (\xi yi -> g (f xi) yi) x y ;--  "Storable.zipWith/*,map" forall size f g x y.-     zipWith size g x (map f y) =-        zipWith size (\xi yi -> g xi (f yi)) x y ;---  "Storable.drop/unfoldr" forall size f a n.-     drop n (unfoldr size f a) =-        dropUnfoldr size n (f,a) ;--  "Storable.take/unfoldr" forall size f a n.-     take n (unfoldr size f a) =---        takeUnfoldr size n (f,a) ;-        takeCrochet n (unfoldr size f a) ;--  "Storable.length/unfoldr" forall size f a.-     length (unfoldr size f a) = lengthUnfoldr (f,a) ;--  "Storable.map/unfoldr" forall size g f a.-     map g (unfoldr size f a) =---        mapUnfoldr size g (f,a) ;-        mapCrochet g (unfoldr size f a) ;--  "Storable.map/iterate" forall size g f a.-     map g (iterate size f a) =-        mapCrochet g (iterate size f a) ;--{--  "Storable.zipWith/unfoldr,unfoldr" forall sizeA sizeB f g h a b n.-     zipWith n h (unfoldr sizeA f a) (unfoldr sizeB g b) =-        zipWithUnfoldr2 n h (f,a) (g,b) ;--}--  -- block boundaries are changed here, so it changes lazy behaviour-  "Storable.zipWith/unfoldr,*" forall sizeA sizeB f h a y.-     zipWith sizeA h (unfoldr sizeB f a) y =-        zipWithUnfoldr f h a y ;--  -- block boundaries are changed here, so it changes lazy behaviour-  "Storable.zipWith/*,unfoldr" forall sizeA sizeB f h a y.-     zipWith sizeA h y (unfoldr sizeB f a) =-        zipWithUnfoldr f (flip h) a y ;--  "Storable.crochetL/unfoldr" forall size f g a b.-     crochetL g b (unfoldr size f a) =-        unfoldr size (\(a0,b0) ->-            do (y0,a1) <- f a0-               (z0,b1) <- g y0 b0-               Just (z0, (a1,b1))) (a,b) ;--  "Storable.reduceL/unfoldr" forall size f g a b.-     reduceL g b (unfoldr size f a) =-        snd-          (FList.recourse (\(a0,b0) ->-              do (y,a1) <- f a0-                 b1 <- g y b0-                 Just (a1, b1)) (a,b)) ;--  "Storable.crochetL/cons" forall g b x xs.-     crochetL g b (cons x xs) =-        crochetLCons g b x xs ;--  "Storable.reduceL/cons" forall g b x xs.-     reduceL g b (cons x xs) =-        reduceLCons g b x xs ;-----  "Storable.take/crochetL" forall f a x n.-     take n (crochetL f a x) =-        takeCrochet n (crochetL f a x) ;--  "Storable.length/crochetL" forall f a x.-     length (crochetL f a x) = length x ;--  "Storable.map/crochetL" forall g f a x.-     map g (crochetL f a x) =-        mapCrochet g (crochetL f a x) ;--  "Storable.zipWith/crochetL,*" forall size f h a x y.-     zipWith size h (crochetL f a x) y =-        zipWithCrochetL size f h a x y ;--  "Storable.zipWith/*,crochetL" forall size f h a x y.-     zipWith size h y (crochetL f a x) =-        zipWithCrochetL size f (flip h) a x y ;--  "Storable.crochetL/crochetL" forall f g a b x.-     crochetL g b (crochetL f a x) =-        crochetL (\x0 (a0,b0) ->-            do (y0,a1) <- f x0 a0-               (z0,b1) <- g y0 b0-               Just (z0, (a1,b1))) (a,b) x ;--  "Storable.reduceL/crochetL" forall f g a b x.-     reduceL g b (crochetL f a x) =-        snd-          (reduceL (\x0 (a0,b0) ->-              do (y,a1) <- f x0 a0-                 b1 <- g y b0-                 Just (a1, b1)) (a,b) x) ;-  #-}----{- * Fusion tests -}---fromMapList :: (Storable y) => ChunkSize -> (x -> y) -> [x] -> T y-fromMapList size f =-   unfoldr size (fmap (mapFst f) . ListHT.viewL)--{-# RULES-  "Storable.fromList/map" forall size f xs.-     fromList size (List.map f xs) = fromMapList size f xs ;-  #-}---fromMapFusionList :: (Storable y) =>-   ChunkSize -> (x -> y) -> FList.T x -> T y-fromMapFusionList size f =-   unfoldr size (fmap (mapFst f) . FList.viewL)--{-# RULES-  "Storable.fromFusionList/map" forall size f xs.-     fromFusionList size (FList.map f xs) = fromMapFusionList size f xs ;--  "Storable.fromFusionList/replicate" forall size n x.-     fromFusionList size (FList.replicate n x) = replicate size n x ;-  #-}-----testLength :: (Storable a, Enum a) => a -> Int-testLength x = length (map succ (fromList (ChunkSize 100) [x,x,x]))--testMapZip :: (Storable a, Enum a, Num a) =>-   ChunkSize -> T a -> T a -> T a--- testMapZip size x y = map snd (zipWith size (,) x y)-testMapZip size x y = map succ (zipWith size (P.+) x y)--testMapCons :: (Storable a, Enum a) =>-   a -> T a -> T a-testMapCons x xs = map succ (cons x xs)--{-# INLINE testMapIterate #-}-{-# SPECIALISE testMapIterate ::-   ChunkSize -> Char -> T Char #-}-testMapIterate :: (Storable a, Enum a) =>-   ChunkSize -> a -> T a-testMapIterate size y = map pred $ iterate size succ y--testMapIterateInt ::-   ChunkSize -> Int -> T Int-testMapIterateInt = testMapIterate---}+{-# OPTIONS_GHC -fenable-rewrite-rules #-}+{- |+Chunky signal stream build on StorableVector.++Hints for fusion:+ - Higher order functions should always be inlined in the end+   in order to turn them into machine loops+   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,++   -- just for fun+   genericLength,+   ) where++import qualified Data.List as List+import qualified Data.StorableVector.Lazy.Pointer as Pointer+import qualified Data.StorableVector.Lazy as Vector+import qualified Data.StorableVector as V+import Data.StorableVector.Lazy (ChunkSize(..))++import Foreign.Storable (Storable, )+import Foreign.Storable.Tuple ()++import qualified Synthesizer.Frame.Stereo as Stereo++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+import qualified Algebra.ToInteger as ToInteger++import qualified Number.NonNegativeChunky as Chunky+import qualified Number.NonNegative       as NonNeg++import NumericPrelude.Numeric+import NumericPrelude.Base+import Prelude ()+++-- this form is needed for Storable signal embed in amplitude signal+type T = Vector.Vector+++defaultChunkSize :: ChunkSize+defaultChunkSize = ChunkSize 1024+++{-# INLINE fromList #-}+fromList :: (Storable a) => ChunkSize -> [a] -> T a+fromList = Vector.pack++{-# INLINE toList #-}+toList :: (Storable a) => T a -> [a]+toList = Vector.unpack+++{-# INLINE scanL #-}+scanL :: (Storable a, Storable b) =>+   (a -> b -> a) -> a -> T b -> T a+scanL = Vector.scanl+++{- |+This implementation generates laziness breaks+whereever one of the original sequences has laziness breaks.+It should be commutative in this respect.++It is more efficient than 'mixSize'+since it appends the rest of the longer signal without copying.+-}+{-# SPECIALISE mix :: T Double -> T Double -> T Double #-}+{-# SPECIALISE mix :: T Float -> T Float -> T Float #-}+{-# SPECIALISE mix :: T (Double,Double) -> T (Double,Double) -> T (Double,Double) #-}+{-# SPECIALISE mix :: T (Float,Float) -> T (Float,Float) -> T (Float,Float) #-}+{-# SPECIALISE mix :: T (Stereo.T Double) -> T (Stereo.T Double) -> T (Stereo.T Double) #-}+{-# SPECIALISE mix :: T (Stereo.T Float) -> T (Stereo.T Float) -> T (Stereo.T Float) #-}+{-# INLINE mix #-}+mix :: (Additive.C x, Storable x) =>+   T x ->+   T x ->+   T x+mix = zipWithAppend (+)+{-+List.map V.unpack $ Vector.chunks $ mix (fromList defaultChunkSize [1,2,3,4,5::P.Double]) (fromList defaultChunkSize [1,2,3,4])+-}++{- |+Mix while maintaining the pattern of the second operand.+This is closer to the behavior of Vector.zipWithLastPattern.+-}+{-# INLINE mixSndPattern #-}+mixSndPattern :: (Additive.C x, Storable x) =>+   T x ->+   T x ->+   T x+mixSndPattern xs0 ys0 =+   let recourse xs (y:ys) =+              snd (V.mapAccumL+                 (\p0 yi ->+                    Pointer.switchL (p0,yi)+                       (\xi p1 -> (p1,xi+yi)) p0)+                 (Pointer.cons xs) y)+              :+              recourse (Vector.drop (V.length y) xs) ys+       recourse xs [] = Vector.chunks xs+   in  Vector.fromChunks $+       recourse xs0 (Vector.chunks ys0)+++{-# INLINE zipWithAppend #-}+zipWithAppend ::+   (Storable x) =>+   (x -> x -> x) ->+   T x -> T x -> T x+zipWithAppend f xs0 ys0 =+   let recourse xt@(x:_) yt@(y:_) =+          let z = V.zipWith f x y+              n = V.length z+          in  z : recourse+                     (Vector.chunks $ Vector.drop n $ Vector.fromChunks xt)+                     (Vector.chunks $ Vector.drop n $ Vector.fromChunks yt)+       recourse xs [] = xs+       recourse [] ys = ys+   in  Vector.fromChunks $+       recourse (Vector.chunks xs0) (Vector.chunks ys0)++{- |+It also preserves the chunk structure of the second signal,+which is essential if you want to limit look-ahead.++This implementation seems to have a memory leak!+-}+{-# INLINE _zipWithAppendRest #-}+_zipWithAppendRest ::+   (Storable x) =>+   (x -> x -> x) ->+   T x -> T x -> T x+_zipWithAppendRest f xs ys =+   uncurry Vector.append $ mapSnd snd $ zipWithRest f xs ys++{-# INLINE zipWithRest #-}+zipWithRest ::+   (Storable c, Storable x) =>+   (x -> x -> c) ->+   T x ->+   T x ->+   (Vector.Vector c, (Bool, T x))+zipWithRest f xs ys =+   let len = min (lazyLength xs) (lazyLength ys) :: Chunky.T NonNeg.Int+       (prefixX,suffixX) = genericSplitAt len xs+       (prefixY,suffixY) = genericSplitAt len ys+       second = Vector.null suffixX+   in  (Vector.zipWithLastPattern f prefixX prefixY,+        (second, if second then suffixY else suffixX))++{-+We should move that to StorableVector package,+but we cannot, since that's Haskell 98.+-}+genericSplitAt ::+   (Additive.C i, Ord i, ToInteger.C i, Storable x) =>+   i -> T x -> (T x, T x)+genericSplitAt n0 =+   let recourse n xs0 =+          forcePair $+          ListHT.switchL+             ([], [])+             (\x xs ->+                if isZero n+                  then ([], xs0)+                  else+                    let m = fromIntegral $ V.length x+                    in  if m<=n+                          then mapFst (x:) $ recourse (n-m) xs+                          else mapPair ((:[]), (:xs)) $+                               V.splitAt (fromInteger $ toInteger n) x)+             xs0+   in  mapPair (Vector.fromChunks, Vector.fromChunks) .+       recourse n0 . Vector.chunks+++-- cf. Data.StorableVector.Lazy.Pattern.length+lazyLength :: (Ring.C i) =>+   T x -> i+lazyLength =+   List.foldr (+) zero . List.map (fromIntegral . V.length) . Vector.chunks++genericLength :: (Ring.C i) =>+   T x -> i+genericLength =+   sum . List.map (fromIntegral . V.length) . Vector.chunks+++splitAtPad ::+   (Additive.C x, Storable x) =>+   ChunkSize -> Int -> T x -> (T x, T x)+splitAtPad size n =+   mapFst (Vector.pad size Additive.zero n) . Vector.splitAt n+++{- disabled SPECIALISE mixSize :: ChunkSize -> T Double -> T Double -> T Double -}+{- disabled SPECIALISE mixSize :: ChunkSize -> T Float -> T Float -> T Float -}+{- disabled SPECIALISE mixSize :: ChunkSize -> T (Double,Double) -> T (Double,Double) -> T (Double,Double) -}+{- disabled SPECIALISE mixSize :: ChunkSize -> T (Float,Float) -> T (Float,Float) -> T (Float,Float) -}+{-# INLINE mixSize #-}+mixSize :: (Additive.C x, Storable x) =>+      ChunkSize+   -> T x+   -> T x+   -> T x+mixSize size xs ys =+   Vector.unfoldr size mixStep+      (Pointer.cons xs, Pointer.cons ys)+++{-# INLINE mixStep #-}+mixStep :: (Additive.C x, Storable x) =>+   (Pointer.Pointer x, Pointer.Pointer x) ->+   Maybe (x, (Pointer.Pointer x, Pointer.Pointer x))+mixStep (xt,yt) =+   case (Pointer.viewL xt, Pointer.viewL yt) of+      (Just (x,xs), Just (y,ys)) -> Just (x+y, (xs,ys))+      (Nothing,     Just (y,ys)) -> Just (y,   (xt,ys))+      (Just (x,xs), Nothing)     -> Just (x,   (xs,yt))+      (Nothing,     Nothing)     -> Nothing++++{-# INLINE delay #-}+delay :: (Storable y) =>+   ChunkSize -> y -> Int -> T y -> T y+delay size z n = Vector.append (Vector.replicate size n z)++{-# INLINE delayLoop #-}+delayLoop ::+   (Storable y) =>+      (T y -> T y)+            -- ^ processor that shall be run in a feedback loop+   -> T y   -- ^ prefix of the output, its length determines the delay+   -> T y+delayLoop proc prefix =+   let ys = Vector.append prefix (proc ys)+   in  ys+++{-# INLINE delayLoopOverlap #-}+delayLoopOverlap ::+   (Additive.C y, Storable y) =>+      Int+   -> (T y -> T y)+            {- ^ Processor that shall be run in a feedback loop.+                 It's absolutely necessary that this function preserves the chunk structure+                 and that it does not look a chunk ahead.+                 That's guaranteed for processes that do not look ahead at all,+                 like 'Vector.map', 'Vector.crochetL' and+                 all of type @Causal.Process@. -}+   -> T y   -- ^ input+   -> T y   -- ^ output has the same length as the input+delayLoopOverlap time proc xs =+   let ys = Vector.zipWith (Additive.+) xs+               (delay (Vector.chunkSize time) Additive.zero time (proc ys))+   in  ys++++{-# INLINE takeCrochet #-}+takeCrochet :: Storable a => Int -> T a -> T a+takeCrochet = Vector.crochetL (\x n -> toMaybe (n>0) (x, pred n))
src/Synthesizer/Storage.hs view
@@ -19,7 +19,7 @@ but the compiler has no chance to find this out automatically. It can merge several operations on a list to a single operation by the fusion technique,-however even a single list operation is hard to get in real-time.+however even a single list operation is hard to perform in real-time.  How do real-time software synthesizer achieve real-time performance? They get the popular fast inner loops@@ -129,24 +129,11 @@ in a streaming way without 'unsafeInterleaveIO' as required e.g. in JACK plugins. -For historical reasons there is also "Synthesizer.FusionList.Signal"-which is a wrapper around lists.-I used this data type to disable GHC's default list optimizer rules-and use my own ones.-The fusion is based on @unfoldr@ and @crochetL@-which is quite similar to the @stream-fusion@ package.-The @stream-fusion@ uses internally a @Skip@ constructor,-which, as far as I understand,-is better for the @filter@ function.-We do not need it,-because the @filter@ function is very uncommon in signal processing.-I think, @FusionList@ can be replaced by @stream-fusion@ functions.- We have now a pretty big set of signal storage types that differ considerably in performance but not in the set of operations. This calls for a type class!-You find it in "Synthesizer.Generic.Signal"-and "Synthesizer.Generic.Signal2".+You find it in "Synthesizer.Generic.Cut"+and "Synthesizer.Generic.Signal". -} module Synthesizer.Storage where
src/Synthesizer/Utility.hs view
@@ -2,13 +2,14 @@  import qualified Algebra.Module    as Module import qualified Algebra.RealField as RealField+import qualified Algebra.Ring      as Ring import qualified Algebra.Field     as Field  import System.Random (Random, RandomGen, randomRs, ) +import NumericPrelude.Numeric+import NumericPrelude.Base import Prelude ()-import PreludeBase-import NumericPrelude   {-|@@ -43,9 +44,17 @@ --   y /= 0 ==>    fmod x y == fmodAlt x y +{- |+This one should be more precise than 'affineCombAlt' in floating computations+whenever @x1@ is small and @x0@ is big.+-} {-# INLINE affineComb #-} affineComb :: (Module.C t y) => t -> (y,y) -> y-affineComb phase (x0,x1) = x0 + phase *> (x1-x0)+affineComb phase (x0,x1) = (Ring.one-phase) *> x0 + phase *> x1++affineCombAlt :: (Module.C t y) => t -> (y,y) -> y+affineCombAlt phase (x0,x1) = x0 + phase *> (x1-x0)+  {-# INLINE balanceLevel #-} balanceLevel :: (Field.C y) =>
+ src/Synthesizer/Zip.hs view
@@ -0,0 +1,171 @@+module Synthesizer.Zip where++import qualified Synthesizer.Generic.Cut as CutG++import qualified Control.Arrow as Arrow+import Control.Arrow (Arrow, (<<<), (^<<), (<<^), )++import Data.Monoid (Monoid, mempty, )+import Data.Semigroup (Semigroup, (<>), )+++{- |+Parallel combination of two signals of equal length.+-}+data T a b = Cons {first :: a, second :: b}++{- |+Zip together two signals.+It is a checked error if their lengths differ.+-}+consChecked ::+   (CutG.Consume a, CutG.Consume b) =>+   String -> a -> b -> T a b+consChecked name a b =+   let lenA = CutG.length a+       lenB = CutG.length b+   in  if lenA == lenB+         then Cons a b+         else error $ "different lengths " +++              show lenA ++ " vs. " ++ show lenB ++ " in " ++ name++{- |+Zip together two signals+and shorten them to the length of the shorter one.+-}+consShorten ::+   (CutG.Transform a, CutG.Transform b) =>+   a -> b -> T a b+consShorten a b =+   let len = min (CutG.length a) (CutG.length b)+   in  Cons (CutG.take len a) (CutG.take len b)++++arrowFirst ::+   Arrow arrow =>+   arrow a b -> arrow (T a c) (T b c)+arrowFirst arrow =+   uncurry Cons+   ^<<+   Arrow.first arrow+   <<^+   (\(Cons a b) -> (a,b))++arrowSecond ::+   Arrow arrow =>+   arrow a b -> arrow (T c a) (T c b)+arrowSecond arrow =+   uncurry Cons+   ^<<+   Arrow.second arrow+   <<^+   (\(Cons a b) -> (a,b))++arrowFirstShorten ::+   (Arrow arrow, CutG.Transform b, CutG.Transform c) =>+   arrow a b -> arrow (T a c) (T b c)+arrowFirstShorten arrow =+   uncurry consShorten+   ^<<+   Arrow.first arrow+   <<^+   (\(Cons a b) -> (a,b))++arrowSecondShorten ::+   (Arrow arrow, CutG.Transform b, CutG.Transform c) =>+   arrow a b -> arrow (T c a) (T c b)+arrowSecondShorten arrow =+   uncurry consShorten+   ^<<+   Arrow.second arrow+   <<^+   (\(Cons a b) -> (a,b))+++arrowFanout ::+   Arrow arrow =>+   arrow a b -> arrow a c -> arrow a (T b c)+arrowFanout b c =+   uncurry Cons  Arrow.^<<  b Arrow.&&& c++arrowSplit ::+   Arrow arrow =>+   arrow a c -> arrow b d -> arrow (T a b) (T c d)+arrowSplit x y =+   uncurry Cons  Arrow.^<<  x Arrow.*** y  Arrow.<<^  (\(Cons a b) -> (a,b))+++arrowFanoutShorten ::+   (Arrow arrow, CutG.Transform a, CutG.Transform b, CutG.Transform c) =>+   arrow a b -> arrow a c -> arrow a (T b c)+arrowFanoutShorten a b =+   arrowSplitShorten a b <<^ (\x -> Cons x x)++arrowSplitShorten ::+   (Arrow arrow,+    CutG.Transform a, CutG.Transform b, CutG.Transform c, CutG.Transform d) =>+   arrow a c -> arrow b d -> arrow (T a b) (T c d)+arrowSplitShorten a b =+   arrowFirstShorten a <<< arrowSecondShorten b+++instance (Semigroup a, Semigroup b) => Semigroup (T a b) where+   Cons a0 b0 <> Cons a1 b1 = Cons (a0 <> a1) (b0 <> b1)++instance (Monoid a, Monoid b) => Monoid (T a b) where+   mempty = Cons mempty mempty++instance (CutG.Consume a, CutG.Consume b) => CutG.Consume (T a b) where+   {-# INLINE null #-}+   null (Cons a b) =+      case (CutG.null a, CutG.null b) of+         (False, False) -> False+         (True, True) -> True+         _ -> error "Zipped signals: one is empty and the other one is not"+   {-# INLINE length #-}+   length (Cons a b) =+      let lenA = CutG.length a+          lenB = CutG.length b+      in  if lenA == lenB+            then lenA+            else error "Zipped signals: the lengths differ"++{-+Parallel combination of two signals+where the combined signal has the length of the shorter member.+This is like in zipWith.++instance (CutG.Consume a, CutG.Consume b) => CutG.Consume (Parallel a b) where+   null (Parallel a b) = CutG.null a || CutG.null b+   length (Parallel a b) = min (CutG.length a) (CutG.length b)+-}++instance (CutG.NormalForm a, CutG.NormalForm b) => CutG.NormalForm (T a b) where+   {-# INLINE evaluateHead #-}+   evaluateHead (Cons a b) =+      case (CutG.evaluateHead a, CutG.evaluateHead b) of+         ((), ()) -> ()++instance (CutG.Transform a, CutG.Transform b) => CutG.Transform (T a b) where+   {-# INLINE take #-}+   take n (Cons a b) =+      Cons (CutG.take n a) (CutG.take n b)+   {-# INLINE drop #-}+   drop n (Cons a b) =+      Cons (CutG.drop n a) (CutG.drop n b)+   {-# INLINE splitAt #-}+   splitAt n (Cons a b) =+      let (a0,a1) = CutG.splitAt n a+          (b0,b1) = CutG.splitAt n b+      in  (Cons a0 b0, Cons a1 b1)+   {-# INLINE dropMarginRem #-}+   dropMarginRem n m (Cons a0 b0) =+      let (ka,a1) = CutG.dropMarginRem n m a0+          (kb,b1) = CutG.dropMarginRem n m b0+      in  if ka==kb+            then (ka, Cons a1 b1)+            else error "Zip.dropMarginRem: margins differ"+   {-# INLINE reverse #-}+   reverse (Cons a b) =+      Cons (CutG.reverse a) (CutG.reverse b)
− src/Test/Main.hs 
@@ -1,33 +0,0 @@-module Main where--import qualified Test.Sound.Synthesizer.Plain.Analysis       as Analysis-import qualified Test.Sound.Synthesizer.Plain.Control        as Control-import qualified Test.Sound.Synthesizer.Plain.Filter         as Filter-import qualified Test.Sound.Synthesizer.Plain.Interpolation  as Interpolation-import qualified Test.Sound.Synthesizer.Plain.Oscillator     as Oscillator-import qualified Test.Sound.Synthesizer.Plain.Wave           as Wave-import qualified Test.Sound.Synthesizer.Basic.ToneModulation as ToneModulation-import qualified Test.Sound.Synthesizer.Plain.ToneModulation as ToneModulationL-import qualified Test.Sound.Synthesizer.Generic.ToneModulation as ToneModulationG--import Data.Tuple.HT (mapFst, )---prefix :: String -> [(String, IO ())] -> [(String, IO ())]-prefix msg =-   map (mapFst (\str -> msg ++ "." ++ str))--main :: IO ()-main =-   mapM_ (\(msg,io) -> putStr (msg++": ") >> io) $-   concat $-      prefix "Plain.Analysis"       Analysis.tests :-      prefix "Plain.Control"        Control.tests :-      prefix "Plain.Filter"         Filter.tests :-      prefix "Plain.Interpolation"  Interpolation.tests :-      prefix "Plain.Oscillator"     Oscillator.tests :-      prefix "Plain.Wave"           Wave.tests :-      prefix "Basic.ToneModulation" ToneModulation.tests :-      prefix "Plain.ToneModulation" ToneModulationL.tests :-      prefix "Generic.ToneModulation" ToneModulationG.tests :-      []
− src/Test/Sound/Synthesizer/Basic/ToneModulation.hs 
@@ -1,98 +0,0 @@-module Test.Sound.Synthesizer.Basic.ToneModulation where--import qualified Synthesizer.Interpolation  as Interpolation-import Synthesizer.Interpolation (margin, )--import qualified Synthesizer.Basic.Phase          as Phase-import qualified Synthesizer.Basic.ToneModulation as ToneMod--import qualified Test.Sound.Synthesizer.Plain.Interpolation as InterpolationTest--import Test.QuickCheck (test, Property, (==>), Testable, )--- import Test.Utility--import qualified Number.NonNegative       as NonNeg--- import qualified Number.NonNegativeChunky as Chunky---- import qualified Algebra.RealTranscendental    as RealTrans--- import qualified Algebra.Module                as Module-import qualified Algebra.RealField             as RealField-import qualified Algebra.Field                 as Field--- import qualified Algebra.Ring                  as Ring-import qualified Algebra.Additive              as Additive---import NumericPrelude-import PreludeBase-import Prelude ()---untangleShapePhase :: (Field.C a, Eq a) =>-   Int -> a -> (a, a) -> Property-untangleShapePhase periodInt period c =-   period /= zero ==>-      ToneMod.untangleShapePhase periodInt period c ==-      ToneMod.untangleShapePhaseAnalytic periodInt period c--flattenShapePhase :: (RealField.C a) =>-   Int -> a -> (a, Phase.T a) -> Property-flattenShapePhase periodInt period c =-   period /= zero ==>-      ToneMod.flattenShapePhase periodInt period c ==-      ToneMod.flattenShapePhaseAnalytic periodInt period c----- * auxiliary test functions--{--Although that looks like a too small value, it is actually right,-because numberLeap counts intervals of size periodInt, not single elements.-So numberLeap=2 like in linear interpolation means 2*periodInt.--}-minLength ::-   Interpolation.T a v ->-   Interpolation.T a v ->-   Int -> NonNeg.Int -> Int-minLength ipLeap ipStep =-   minLengthMargin (margin ipLeap) (margin ipStep)--minLengthMargin ::-   Interpolation.Margin ->-   Interpolation.Margin ->-   Int -> NonNeg.Int -> Int-minLengthMargin marginLeap marginStep periodInt ext =-   ToneMod.interpolationNumber-      marginLeap marginStep periodInt +-   NonNeg.toNumber ext----shapeLimits ::-   Interpolation.T a v ->-   Interpolation.T a v ->-   Int -> Int -> (Int, Int)-shapeLimits ipLeap ipStep periodInt len =-   ToneMod.shapeLimits-      (margin ipLeap) (margin ipStep)-      periodInt len----testRationalLineIp :: Testable test =>-   (InterpolationTest.LinePreserving Rational Rational -> test) -> IO ()-testRationalLineIp f  =  test f--testRationalIp :: Testable test =>-   (InterpolationTest.T Rational Rational -> test) -> IO ()-testRationalIp f  =  test f---tests :: [(String, IO ())]-tests =-   ("untangleShapePhase",-      test (\periodInt period ->-                untangleShapePhase periodInt (period :: Rational))) :-   ("flattenShapePhase",-      test (\periodInt period ->-                flattenShapePhase periodInt (period :: Rational))) :-   []
− src/Test/Sound/Synthesizer/Generic/ToneModulation.hs 
@@ -1,313 +0,0 @@-module Test.Sound.Synthesizer.Generic.ToneModulation (tests) where--import Test.Sound.Synthesizer.Basic.ToneModulation (-   minLength,-   minLengthMargin,---   shapeLimits,---   testRationalLineIp,-   testRationalIp,-   )--import Test.Sound.Synthesizer.Plain.ToneModulation (-   InfiniteList,-   listFromInfinite,-   )--import qualified Synthesizer.Causal.ToneModulation as ToneModC-import qualified Synthesizer.Generic.Wave as WaveG--import qualified Synthesizer.Plain.Signal         as Sig-import qualified Synthesizer.Plain.Oscillator     as Osci-import qualified Synthesizer.Plain.Interpolation  as Interpolation-import qualified Synthesizer.Plain.ToneModulation as ToneModL-import qualified Synthesizer.Plain.Wave   as WaveL-import Synthesizer.Interpolation (marginNumber, )--import qualified Synthesizer.Causal.Oscillator as OsciC-import qualified Synthesizer.Causal.Process as Causal--import qualified Synthesizer.State.Signal as SigS--import qualified Synthesizer.Basic.Wave           as Wave-import qualified Synthesizer.Basic.Phase          as Phase--import qualified Test.Sound.Synthesizer.Plain.Interpolation as InterpolationTest--import Test.QuickCheck (test, Property, (==>), )-import Test.Utility (ArbChar, )--- import Debug.Trace (trace, )--import qualified Number.NonNegative       as NonNeg---- import qualified Algebra.RealTranscendental    as RealTrans--- import qualified Algebra.Module                as Module-import qualified Algebra.RealField             as RealField--- import qualified Algebra.Field                 as Field--- import qualified Algebra.Ring                  as Ring-import qualified Algebra.Additive              as Additive---import Data.List.HT (viewL, takeWhileJust, )-import Data.Tuple.HT (mapSnd, )-import qualified Data.List as List---import NumericPrelude-import PreludeBase-import Prelude ()---limitMinRelativeValues ::-   Int -> Int -> [NonNeg.Int] -> Bool-limitMinRelativeValues xMin x0 xsnn =-   let xs = map NonNeg.toNumber xsnn-       (y0,limiter) = ToneModC.limitMinRelativeValues xMin x0-   in  (y0, Causal.applyGeneric limiter xs) ==-          ToneModL.limitMinRelativeValues xMin x0 xs--integrateFractional :: (RealField.C t) =>-   NonNeg.T t -> t -> Phase.T t -> [NonNeg.T t] -> [t] -> Property-integrateFractional-     periodNN shape0 phase shapesNN freqs =-   let shapes = map NonNeg.toNumber shapesNN-       period    = NonNeg.toNumber periodNN-       (c0, coordinator) =-          ToneModC.integrateFractional-             period (shape0, phase)-       coords =-          ToneModL.integrateFractional-             period (shape0, shapes) (phase, freqs)-   in  period /= zero  ==>-          c0 : Causal.applyGeneric coordinator (zip shapes freqs) ==-          coords---- oscillatorCellSize :: (Show t, Show v, RealField.C t, Eq v) =>-oscillatorCellSize :: (RealField.C t, Eq v) =>-   Interpolation.Margin ->-   Interpolation.Margin ->-   NonNeg.Int -> NonNeg.T t ->-   NonNeg.Int -> InfiniteList v ->-   t -> t -> [NonNeg.T t] -> [t] ->-   Property-oscillatorCellSize-      marginLeap marginStep periodIntNN periodNN ext-      ixs shape0 phase shapesNN freqs =-   let shapes = map NonNeg.toNumber shapesNN-       period    = NonNeg.toNumber periodNN-       periodInt = NonNeg.toNumber periodIntNN-       len = minLengthMargin marginLeap marginStep periodInt ext-       tone = take len (listFromInfinite ixs)-       resampledTone =-          ToneModC.oscillatorCells-             marginLeap marginStep periodInt period tone-             (shape0, Phase.fromRepresentative phase)-          `Causal.applyGeneric`-          zip shapes freqs-   in  period /= zero  &&-       marginNumber marginLeap > zero &&-       marginNumber marginStep > zero  ==>-       all-          ((\cell ->-              Sig.lengthAtLeast (marginNumber marginLeap) cell &&-              all (Sig.lengthAtLeast (marginNumber marginStep))-                  (take (marginNumber marginLeap) cell))-           . SigS.toList . snd)-          resampledTone--oscillatorSuffixes :: (RealField.C t, Eq v) =>-   Interpolation.Margin ->-   Interpolation.Margin ->-   NonNeg.Int -> NonNeg.T t ->-   NonNeg.Int -> InfiniteList v ->-   t -> t -> [NonNeg.T t] -> [t] ->-   Property-oscillatorSuffixes-      marginLeap marginStep periodIntNN periodNN ext-      ixs shape0 phase shapesNN freqs =-   let shapes = map NonNeg.toNumber shapesNN-       period    = NonNeg.toNumber periodNN-       periodInt = NonNeg.toNumber periodIntNN-       len = minLengthMargin marginLeap marginStep periodInt ext-       tone = take len (listFromInfinite ixs)-       resampledToneA =-          init $-          map (\(sp,cell) ->-             (sp, takeWhileJust . map (fmap fst . viewL) $ cell)) $-          ToneModL.oscillatorSuffixes-             marginLeap marginStep periodInt period tone-             (shape0, shapes) (Phase.fromRepresentative phase, freqs)-       resampledToneB =-          ToneModC.oscillatorSuffixes-             marginLeap marginStep periodInt period tone-             (shape0, Phase.fromRepresentative phase)-          `Causal.applyGeneric`-          zip shapes freqs-   in  period /= zero  &&-       periodInt /= zero  &&-       marginNumber marginLeap > zero &&-       marginNumber marginStep > zero  ==>-          resampledToneA == resampledToneB--oscillatorCells :: (RealField.C t, Eq v) =>-   Interpolation.Margin ->-   Interpolation.Margin ->-   NonNeg.Int -> NonNeg.T t ->-   NonNeg.Int -> InfiniteList v ->-   t -> t -> [NonNeg.T t] -> [t] ->-   Property-oscillatorCells-      marginLeap marginStep periodIntNN periodNN ext-      ixs shape0 phase shapesNN freqs =-   let shapes = map NonNeg.toNumber shapesNN-       period    = NonNeg.toNumber periodNN-       periodInt = NonNeg.toNumber periodIntNN-       len = minLengthMargin marginLeap marginStep periodInt ext-       tone = take len (listFromInfinite ixs)-       resampledToneA =-          init $ map (mapSnd List.transpose) $-          ToneModL.oscillatorCells-             marginLeap marginStep periodInt period tone-             (shape0, shapes) (Phase.fromRepresentative phase, freqs)-       resampledToneB =-          map (mapSnd SigS.toList) $-          ToneModC.oscillatorCells-             marginLeap marginStep periodInt period tone-             (shape0, Phase.fromRepresentative phase)-          `Causal.applyGeneric`-          zip shapes freqs-   in  period /= zero  &&-       periodInt /= zero  &&-       marginNumber marginLeap > zero &&-       marginNumber marginStep > zero  ==>-          resampledToneA == resampledToneB-{--Margin {marginNumber = 1, marginOffset = 2}-Margin {marginNumber = 5, marginOffset = 5}-3 % 4-0-('\DEL',['~','~','"'])--2 % 5-2 % 5-[2 % 1,3 % 4]-[-5 % 2,-1 % 2]--}--{- |-'WaveL.sampledTone' and 'WaveG.sampledTone'-do not only differ in the signal types they process,-but also in the way they order the signal values.-The cells for 'WaveL.sampledTone' are transposed-with respect to 'WaveG.sampledTone'.--}-sampledTone :: (RealField.C a, Eq v) =>-   InterpolationTest.T a v ->-   InterpolationTest.T a v ->-   NonNeg.T a -> NonNeg.Int -> InfiniteList v ->-   a -> Phase.T a -> Property-sampledTone =-   InterpolationTest.use2 $ \ ipLeap ipStep-         periodNN ext ixs shape phase ->-   let period = NonNeg.toNumber periodNN-       periodInt = round period-       len = minLength ipLeap ipStep periodInt ext-       tone = take len (listFromInfinite ixs)-   in  period /= zero ==>-          WaveG.sampledTone ipLeap ipStep period tone shape `Wave.apply` phase ==-          WaveL.sampledTone ipLeap ipStep period tone shape `Wave.apply` phase----shapeFreqModFromSampledTone :: (RealField.C t, Eq v) =>-   InterpolationTest.T t v ->-   InterpolationTest.T t v ->-   NonNeg.T t ->-   NonNeg.Int -> InfiniteList v ->-   t -> Phase.T t -> [NonNeg.T t] -> [t] ->-   Property-shapeFreqModFromSampledTone =-   InterpolationTest.use2 $ \ ipLeap ipStep-         periodNN ext ixs shape0 phase shapesNN freqs ->-   let shapes = map NonNeg.toNumber shapesNN-       period = NonNeg.toNumber periodNN-       periodInt = round period-       len = minLength ipLeap ipStep periodInt ext-       tone = take len (listFromInfinite ixs)-       resampledToneA =-          init $-          Osci.shapeFreqModFromSampledTone ipLeap ipStep period tone-             shape0 (Phase.toRepresentative phase) shapes freqs-       resampledToneB =-          OsciC.shapeFreqModFromSampledTone-             ipLeap ipStep period tone shape0 phase-          `Causal.applyGeneric`-          zip shapes freqs-   in  period /= zero  ==>-          resampledToneA == resampledToneB---{--We have a problem here with the phase distortion signal,-because frequency and shape modulation control signals-are delayed by one element with respect to the phase distortion.-How can we cope with different lengths of the control signals,-without padding the phase control with zeros?-This one did not work:-   phaseDistorts = pd:pds-   resampledToneA =-      Osci.shapePhaseFreqModFromSampledTone ipLeap ipStep period tone-         shape0 (Phase.toRepresentative phase) shapes (init phaseDistorts) freqs--}-shapePhaseFreqModFromSampledTone :: (RealField.C t, Eq v) =>-   InterpolationTest.T t v ->-   InterpolationTest.T t v ->-   NonNeg.T t ->-   NonNeg.Int -> InfiniteList v ->-   t -> Phase.T t -> [NonNeg.T t] -> (t,[t]) -> [t] ->-   Property-shapePhaseFreqModFromSampledTone =-   InterpolationTest.use2 $ \ ipLeap ipStep-         periodNN ext ixs shape0 phase shapesNN (pd,pds) freqs ->-   let period = NonNeg.toNumber periodNN-       periodInt = round period-       len = minLength ipLeap ipStep periodInt ext-       tone = take len (listFromInfinite ixs)-       shapes = map NonNeg.toNumber shapesNN-       phaseDistorts = pd:pds ++ repeat zero-       resampledToneA =-          init $-          Osci.shapePhaseFreqModFromSampledTone ipLeap ipStep period tone-             shape0 (Phase.toRepresentative phase) shapes phaseDistorts freqs-       resampledToneB =-          OsciC.shapePhaseFreqModFromSampledTone-             ipLeap ipStep period tone shape0 phase-          `Causal.applyGeneric`-          zip3 shapes phaseDistorts freqs-   in  period /= zero  ==>-          resampledToneA == resampledToneB----tests :: [(String, IO ())]-tests =-   ("limitMinRelativeValues", test limitMinRelativeValues) :-   ("integrateFractional",-      test (\period -> integrateFractional (period :: NonNeg.Rational))) :-   ("oscillatorCellSize",-      test (\ml ms periodInt period ext ixs ->-               oscillatorCellSize ml ms periodInt (period :: NonNeg.Rational)-                  ext (ixs :: InfiniteList ArbChar))) :-   ("oscillatorSuffixes",-      test (\ml ms periodInt period ext ixs ->-               oscillatorSuffixes ml ms periodInt (period :: NonNeg.Rational)-                  ext (ixs :: InfiniteList ArbChar))) :-   ("oscillatorCells",-      test (\ml ms periodInt period ext ixs ->-               oscillatorCells ml ms periodInt (period :: NonNeg.Rational)-                  ext (ixs :: InfiniteList ArbChar))) :-   ("sampledTone",-      testRationalIp sampledTone) :-   ("shapeFreqModFromSampledTone",-      testRationalIp shapeFreqModFromSampledTone) :-   ("shapePhaseFreqModFromSampledTone",-      testRationalIp shapePhaseFreqModFromSampledTone) :-   []
− src/Test/Sound/Synthesizer/Plain/Analysis.hs 
@@ -1,150 +0,0 @@-module Test.Sound.Synthesizer.Plain.Analysis (tests) where--import qualified Synthesizer.Plain.Analysis as Analysis--import qualified Algebra.Algebraic             as Algebraic-import qualified Algebra.RealField             as RealField-import qualified Algebra.Field                 as Field--- import qualified Algebra.Real                  as Real-import qualified Algebra.Ring                  as Ring-import qualified Algebra.Additive              as Additive--import qualified Algebra.NormedSpace.Maximum   as NormedMax-import qualified Algebra.NormedSpace.Euclidean as NormedEuc-import qualified Algebra.NormedSpace.Sum       as NormedSum--import qualified MathObj.LaurentPolynomial as LPoly---- import Algebra.Module((*>))--import Data.List (genericLength)--import Test.QuickCheck (test, Property, (==>))-import Test.Utility (approxEqual)---- import qualified Algebra.Ring                  as Ring--- import qualified Algebra.Additive              as Additive--import NumericPrelude-import PreludeBase-import Prelude ()---volumeVectorMaximum :: (NormedMax.C y y, Ord y) => [y] -> Bool-volumeVectorMaximum xs =-   Analysis.volumeVectorMaximum xs == Analysis.volumeMaximum xs--volumeVectorEuclidean :: (NormedEuc.C y y, Algebraic.C y) => y -> [y] -> Bool-volumeVectorEuclidean x xs =-   let ys = x:xs-   in  Analysis.volumeVectorEuclidean ys == Analysis.volumeEuclidean ys--volumeVectorEuclideanSqr :: (NormedEuc.Sqr y y, Field.C y) => y -> [y] -> Bool-volumeVectorEuclideanSqr x xs =-   let ys = x:xs-   in  Analysis.volumeVectorEuclideanSqr ys == Analysis.volumeEuclideanSqr ys--volumeVectorSum :: (NormedSum.C y y, Field.C y) => y -> [y] -> Bool-volumeVectorSum x xs =-   let ys = x:xs-   in  Analysis.volumeVectorSum ys == Analysis.volumeSum ys----bounds :: Ord a => a -> [a] -> Bool-bounds x xs =-   let ys = x:xs-   in  Analysis.bounds ys  ==  (minimum ys, maximum ys)---spread :: RealField.C a => (a,a) -> Bool-spread b =-   sum (map snd (Analysis.spread b)) == one---histogramDiscrete :: Int -> [Int] -> Bool-histogramDiscrete x xs =-   let ys = x:xs-   in  Analysis.histogramDiscreteArray ys ==-       Analysis.histogramDiscreteIntMap ys--histogramDiscreteLength :: [Int] -> Bool-histogramDiscreteLength xs =-   sum (snd (Analysis.histogramDiscreteIntMap xs)) == length xs--histogramDiscreteConcat :: [Int] -> [Int] -> Bool-histogramDiscreteConcat xs ys =-   let xHist = Analysis.histogramDiscreteIntMap xs-       yHist = Analysis.histogramDiscreteIntMap ys-       xyHist0 =-          LPoly.add-             (uncurry LPoly.Cons xHist)-             (uncurry LPoly.Cons yHist)-       xyHist1 =-          uncurry LPoly.Cons-             (Analysis.histogramDiscreteIntMap (xs++ys))-   in  if null (LPoly.coeffs xyHist0)-         then LPoly.coeffs xyHist0 == LPoly.coeffs xyHist1-         else xyHist0 == xyHist1---histogramLinear :: Int -> [Int] -> Bool-histogramLinear x xs =-   let ys = map fromIntegral (x:xs) :: [Double]-   in  Analysis.histogramLinearArray ys ==-       Analysis.histogramLinearIntMap ys---histogramLinearLength :: Int -> [Int] -> Bool-histogramLinearLength x xs =-   let ys = map fromIntegral (x:xs) :: [Double]-   in  approxEqual 1e-10-          (genericLength ys)-          (sum (snd (Analysis.histogramLinearIntMap ys)) + 1)-{--With eps = 1e-15--Falsifiable, after 83 tests:--20-[32,-41,11,-25,-17,-27,32,-36,7,-36,38]--Falsifiable, after 78 tests:-10-[-35,-28,-28,-24,-4,-29,-14,-29,-20,7,33,-2,-14,-4,7,-40,-5,-12]--}----centroid :: (Field.C a, Eq a) => [a] -> Property-centroid xs =-   sum xs /= zero ==>-      Analysis.centroid xs == Analysis.centroidAlt xs--- Test.QuickCheck.test (\xs -> sum xs /= 0 Test.QuickCheck.==> propCentroid (xs::[Rational]))--histogramDCOffset :: Int -> Int -> [Int] -> Property-histogramDCOffset x0 x1 xs =-   let x = x0:x1:xs-       (offset, hist) = Analysis.histogramDiscreteArray x-   in  sum x /= 0 ==>-          fromIntegral offset + Analysis.centroid (map fromIntegral hist) ==-          (Analysis.directCurrentOffset (map fromIntegral x) :: Rational)----tests :: [(String, IO ())]-tests =-   ("volumeVectorMaximum", test (volumeVectorMaximum :: [Rational] -> Bool)) :-   -- test may fail due to rounding errors, but so far the computation is exactly the same-   ("volumeVectorEuclidean", test (volumeVectorEuclidean :: Double -> [Double] -> Bool)) :-   ("volumeVectorEuclideanSqr", test (volumeVectorEuclideanSqr :: Rational -> [Rational] -> Bool)) :-   ("volumeVectorSum", test (volumeVectorSum :: Rational -> [Rational] -> Bool)) :-   ("bounds", test (bounds :: Rational -> [Rational] -> Bool)) :-   ("spread", test (spread :: (Rational,Rational) -> Bool)) :-   ("histogramDiscrete", test (histogramDiscrete :: Int -> [Int] -> Bool)) :-   ("histogramDiscreteLength", test (histogramDiscreteLength :: [Int] -> Bool)) :-   ("histogramDiscreteConcat", test (histogramDiscreteConcat :: [Int] -> [Int] -> Bool)) :-   ("histogramLinear", test (histogramLinear :: Int -> [Int] -> Bool)) :-   ("histogramLinearLength", test (histogramLinearLength :: Int -> [Int] -> Bool)) :-   ("centroid", test (centroid :: [Rational] -> Property)) :-   ("histogramDCOffset", test (histogramDCOffset :: Int -> Int -> [Int] -> Property)) :-   []
− src/Test/Sound/Synthesizer/Plain/Control.hs 
@@ -1,112 +0,0 @@-module Test.Sound.Synthesizer.Plain.Control (tests) where--import qualified Synthesizer.Plain.Control as Control--import Test.QuickCheck (test, 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-import PreludeBase-import Prelude ()---linearRing :: Int -> Int -> Bool-linearRing d y0 =---   Control.linear d y0  ==  Control.linearMultiscale d y0-   all equalList $ take 100 $ transpose $-      Control.linear d y0 :-      Control.linearMultiscale d y0 :-      Control.linearStable d y0 :-      []--{--*Synthesizer.Plain.Control> propLinearApprox (-2/3) 2-False--Need a different definition of approximate equality.--}-linearApprox :: Double -> Double -> Bool-linearApprox d y0 =-   all (approxEqualListAbs (1e-10 * max (abs d) (abs y0))) $-   take 100 $ transpose $-      Control.linear d y0 :-      Control.linearMean d y0 :-      Control.linearMultiscale d y0 :-      Control.linearStable d y0 :-      []--linearExact :: Rational -> Rational -> Bool-linearExact d y0 =-   all equalList $ take 100 $ transpose $-      Control.linear d y0 :-      Control.linearMean d y0 :-      Control.linearMultiscale d y0 :-      Control.linearStable d y0 :-      []--{--Plain.Control.exponential: Falsifiable, after 88 tests:--8.333333333333326e-2-3.375--Plain.Control.exponential: Falsifiable, after 69 tests:-9.090909090909083e-2--10.0--Plain.Control.exponential: Falsifiable, after 73 tests:--0.125--1.1428571428571428--Plain.Control.exponential2: Falsifiable, after 33 tests:--7.692307692307687e-2-9.5--}-exponential :: Double -> Double -> Bool-exponential time y0 =-   all (approxEqualListRel (1e-10)) $ take 100 $ transpose $-      Control.exponential time y0 :-      Control.exponentialMultiscale time y0 :-      Control.exponentialStable time y0 :-      []--exponential2 :: Double -> Double -> Bool-exponential2 time y0 =-   all (approxEqualListRel (1e-10)) $ take 100 $ transpose $-      Control.exponential2 time y0 :-      Control.exponential2Multiscale time y0 :-      Control.exponential2Stable time y0 :-      []--cosine :: Double -> Double -> Property-cosine t0 t1  =  t0/=t1 ==>-   all (approxEqualListAbs (1e-10)) $-   take 100 $ transpose $-      Control.cosine t0 t1 :-      Control.cosineMultiscale t0 t1 :-      Control.cosineStable t0 t1 :-      []---cubic :: (Rational, (Rational, Rational)) ->-   (Rational, (Rational, Rational)) -> Property-cubic node0 node1  =  fst node0 /= fst node1 ==>-   take 100 (Control.cubicHermite node0 node1)  ==-   take 100 (Control.cubicHermiteStable node0 node1)----tests :: [(String, IO ())]-tests =-   ("linearRing", test linearRing) :-   ("linearApprox", test linearApprox) :-   ("linearExact", test linearExact) :-   ("exponential", test exponential) :-   ("exponential2", test exponential2) :-   ("cosine", test cosine) :-   ("cubic", test cubic) :-   []
− src/Test/Sound/Synthesizer/Plain/Filter.hs 
@@ -1,151 +0,0 @@-module Test.Sound.Synthesizer.Plain.Filter (tests) where--import qualified Synthesizer.Plain.Filter.Recursive.MovingAverage as MA-import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR-import qualified Synthesizer.Plain.Signal as Sig-import qualified Synthesizer.Generic.Filter.NonRecursive as FiltNRG-import qualified Synthesizer.Generic.Signal as SigG-import qualified Synthesizer.Storable.Filter.NonRecursive as FiltNRSt-import qualified Synthesizer.Storable.Signal as SigSt-import qualified Synthesizer.Frame.Stereo as Stereo--import qualified Data.StorableVector.Lazy.Pattern as VP--import Foreign.Storable.Tuple ()--import Test.QuickCheck (test, {- Property, (==>) -})-import Test.Utility (equalList, {- approxEqualListAbs, approxEqualListRel, -} )---- 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 Data.Tuple.HT (mapPair, )---- import Debug.Trace (trace, )--import NumericPrelude-import PreludeBase-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-       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,-       -- if one list is empty-       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)-   in  equalList $-       FiltNR.sumRange xs rng :-       FiltNR.sumRangeFromPyramid (take height (FiltNR.pyramid xs)) rng :-       FiltNR.sumRangeFromPyramidRec (take height (FiltNR.pyramid xs)) rng :-       FiltNRSt.sumRangeFromPyramid-          (FiltNRSt.pyramid height-             (SigSt.fromList SigSt.defaultChunkSize xs)) rng :-       []--sumsPosModulated ::-   NonNeg.Int -> Sig.T (NonNeg.Int,NonNeg.Int) -> (Int, Sig.T Int) -> Bool-sumsPosModulated nheight nctrl xsc =-   let ctrl = map (mapPair (NonNeg.toNumber, NonNeg.toNumber)) nctrl-       xs = cycle $ uncurry (:) xsc-       height = min 10 $ NonNeg.toNumber nheight-   in  -- trace (show (height, ctrl, xsc)) $-       equalList $-       FiltNR.sumsPosModulated ctrl xs :-       FiltNR.sumsPosModulatedPyramid height ctrl xs :-       FiltNRG.sumsPosModulatedPyramid height ctrl xs :-       SigSt.toList-          (FiltNRG.sumsPosModulatedPyramid-             height-             (SigSt.fromList SigSt.defaultChunkSize ctrl)-             (SigSt.fromList SigSt.defaultChunkSize xs)) :-       SigSt.toList-          (FiltNRSt.sumsPosModulatedPyramid-             height-             (SigSt.fromList SigSt.defaultChunkSize ctrl)-             (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 :-       []--{--sumsDownSample2 ::-   [VP.ChunkSize] -> (Int, Sig.T Int) -> Bool-sumsDownSample2 lazySize xsc =-   let len = Chunky.fromChunks $ filter (0/=) lazySize-       xs = VP.pack len $ cycle $ uncurry (:) xsc-   in  equalList $-       FiltNRG.sumsDownsample2 SigG.defaultLazySize xs :-       FiltNRSt.sumsDownsample2 xs :-       FiltNRSt.sumsDownsample2Alt xs :-       []--}--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-       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 $-       pack (FiltNR.movingAverageModulatedPyramid onegf-          height maxC ctrl (cycle xs)) :-       FiltNRG.movingAverageModulatedPyramid onegf-          height maxC (pack ctrl) (SigG.cycle $ pack xs) :-       FiltNRSt.movingAverageModulatedPyramid onegf-          height maxC (pack ctrl) (SigG.cycle $ pack xs) :-       []---tests :: [(String, IO ())]-tests =-   ("sums", test sums) :-   ("sumRange", test sumRange) :-   ("sumsPosModulated", test sumsPosModulated) :-   ("downSample2", test downSample2) :-   ("sumsDownSample2", test sumsDownSample2) :-   ("movingAverageModulatedPyramid", test movingAverageModulatedPyramid) :-   []
− src/Test/Sound/Synthesizer/Plain/Interpolation.hs 
@@ -1,142 +0,0 @@-module Test.Sound.Synthesizer.Plain.Interpolation (-   T, ip,-   LinePreserving, lpIp,-   tests,-   use, useLP, use2,-   ) where--import qualified Synthesizer.Plain.Interpolation as Interpolation-import qualified Synthesizer.Interpolation.Class as Interpol-import qualified Synthesizer.Interpolation.Custom as ExampleCustom-import qualified Synthesizer.Interpolation.Module as ExampleModule-import qualified Synthesizer.Interpolation as InterpolationCore--import Test.QuickCheck (test, Arbitrary(..), elements, {- Property, (==>), -} Testable, )--- import Test.Utility--import qualified Algebra.VectorSpace           as VectorSpace-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 (liftM2, )--import Test.Utility (equalList, )---import NumericPrelude-import PreludeBase-import Prelude ()----instance Arbitrary InterpolationCore.Margin where-   arbitrary =-      liftM2 InterpolationCore.Margin-         (fmap abs arbitrary)-         (fmap abs arbitrary)-   coarbitrary = undefined---use ::-   (Interpolation.T a v -> x) ->-   (T a v -> x)-use f ipt =-   f (ip ipt)--useLP ::-   (Interpolation.T a v -> x) ->-   (LinePreserving a v -> x)-useLP f ipt =-   f (lpIp ipt)--use2 ::-   (Interpolation.T a v ->-    Interpolation.T a v -> x) ->-   (T a v ->-    T a v -> x)-use2 f =-   use $ \ ipLeap ->-   use $ \ ipStep ->-      f ipLeap ipStep----data T a v = Cons {name :: String, ip :: Interpolation.T a v}--instance Show (T a v) where-   show x = name x--instance (Field.C a, Interpol.C a v) => Arbitrary (T a v) where-   arbitrary = elements $-      Cons "constant" ExampleCustom.constant :-      Cons "linear"   ExampleCustom.linear :-      Cons "cubic"    ExampleCustom.cubic :-      []-   coarbitrary = undefined----data LinePreserving a v =-   LPCons {lpName :: String, lpIp :: Interpolation.T a v}--instance Show (LinePreserving a v) where-   show x = lpName x--instance (Field.C a, Interpol.C a v) => Arbitrary (LinePreserving a v) where-   arbitrary = elements $-      LPCons "linear"   ExampleCustom.linear :-      LPCons "cubic"    ExampleCustom.cubic :-      []-   coarbitrary = undefined----constant ::-   (Interpol.C a v, Module.C a v, Eq v) =>-   a -> v -> [v] -> Bool-constant t x0 xs =-   equalList $ map ($(x0:xs)) $ map ($t) $-      Interpolation.func ExampleCustom.constant :-      Interpolation.func ExampleCustom.piecewiseConstant :-      Interpolation.func ExampleModule.constant :-      Interpolation.func ExampleModule.piecewiseConstant :-      []--linear ::-   (Interpol.C a v, Module.C a v, Eq v) =>-   a -> v -> v -> [v] -> Bool-linear t x0 x1 xs =-   equalList $ map ($(x0:x1:xs)) $ map ($t) $-      Interpolation.func ExampleCustom.linear :-      Interpolation.func ExampleCustom.piecewiseLinear :-      Interpolation.func ExampleModule.linear :-      Interpolation.func ExampleModule.piecewiseLinear :-      []--cubic ::-   (Interpol.C a v, VectorSpace.C a v, Eq v) =>-   a -> v -> v -> v -> v -> [v] -> Bool-cubic t x0 x1 x2 x3 xs =-   equalList $ map ($(x0:x1:x2:x3:xs)) $ map ($t) $-      Interpolation.func ExampleCustom.cubic :-      Interpolation.func ExampleCustom.piecewiseCubic :-      Interpolation.func ExampleModule.cubic :-      Interpolation.func ExampleModule.cubicAlt :-      Interpolation.func ExampleModule.piecewiseCubic :-      []---testRational ::-   (Testable t) =>-   (Rational -> Rational -> t) -> IO ()-testRational = test--tests :: [(String, IO ())]-tests =-   ("constant", testRational constant) :-   ("linear",   testRational linear  ) :-   ("cubic",    testRational cubic   ) :-   []
− src/Test/Sound/Synthesizer/Plain/Oscillator.hs 
@@ -1,47 +0,0 @@-module Test.Sound.Synthesizer.Plain.Oscillator (tests) where--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 Test.QuickCheck (test, {- Property, (==>), -} )--- import Test.Utility---- import qualified Number.NonNegative       as NonNeg---- import qualified Algebra.RealTranscendental    as RealTrans--- import qualified Algebra.Module                as Module-import qualified Algebra.RealField             as RealField--- import qualified Algebra.Field                 as Field--- import qualified Algebra.Ring                  as Ring-import qualified Algebra.Additive              as Additive---import NumericPrelude-import PreludeBase-import Prelude ()----phaseShapeMod :: (RealField.C a, Eq b) => (Wave.T a b) -> a -> [a] -> Bool-phaseShapeMod wave freq phases =-   Osci.phaseMod wave freq phases ==-   Osci.shapeMod (Wave.phaseOffset wave) zero freq phases--phaseShapeModRational ::-   WaveTest.Ring Rational -> Integer -> Integer -> [Integer] -> Bool-phaseShapeModRational w denom0 freq0 phases0 =-   let denom  = 1 + abs denom0-       freq   = freq0 % denom-       phases = map (% denom) phases0-   in  phaseShapeMod (WaveTest.ringWave w) freq phases----tests :: [(String, IO ())]-tests =-   ("phaseShapeModRational",  test phaseShapeModRational) :-   []
− src/Test/Sound/Synthesizer/Plain/ToneModulation.hs 
@@ -1,504 +0,0 @@-module Test.Sound.Synthesizer.Plain.ToneModulation (tests,-   listFromInfinite,-   InfiniteList,-   ) where--import Test.Sound.Synthesizer.Basic.ToneModulation (-   minLength,-   minLengthMargin,-   shapeLimits,-   testRationalLineIp,-   testRationalIp,-   )--import qualified Synthesizer.Plain.Oscillator     as Osci-import qualified Synthesizer.Plain.Interpolation  as Interpolation-import qualified Synthesizer.Plain.ToneModulation as ToneModL-import qualified Synthesizer.Plain.Wave           as WaveL-import Synthesizer.Interpolation (marginNumber, )--import qualified Synthesizer.Basic.Wave           as Wave-import qualified Synthesizer.Basic.Phase          as Phase--import qualified Test.Sound.Synthesizer.Plain.Interpolation as InterpolationTest--import Test.QuickCheck (test, Property, (==>), Arbitrary, arbitrary, coarbitrary, )-import Test.Utility (ArbChar, )--import qualified Number.NonNegative       as NonNeg-import qualified Number.NonNegativeChunky as Chunky--import qualified Algebra.RealTranscendental    as RealTrans-import qualified Algebra.Module                as Module-import qualified Algebra.RealField             as RealField-import qualified Algebra.Field                 as Field-import qualified Algebra.Ring                  as Ring-import qualified Algebra.Additive              as Additive--import Control.Monad (liftM2, )-import Data.List.HT (isAscending, )-import Data.Ord.HT (limit, )-import Data.Tuple.HT (mapPair, mapSnd, )-import qualified Data.List as List---import NumericPrelude-import PreludeBase-import Prelude ()---{--Properties that do not hold:-  commutativity of limitRelativeShapes and integrateFractional:-    Does not hold because when you clip the integral skips at the end,-    you would have to clear the fractional part, too.--}----data InfiniteList a =-   InfiniteList a [a]--listFromInfinite :: InfiniteList a -> [a]-listFromInfinite (InfiniteList x xs) =-   cycle (x:xs)--instance Functor InfiniteList where-   fmap f (InfiniteList x xs) =-      InfiniteList (f x) (map f xs)--instance Arbitrary a => Arbitrary (InfiniteList a) where-   arbitrary = liftM2 InfiniteList arbitrary arbitrary-   coarbitrary = undefined--instance Show a => Show (InfiniteList a) where-   showsPrec p (InfiniteList x xs) =-      showParen (p >= 10) $-      showString "cycle " .-      showsPrec 11 (x:xs)----absolutize :: (Additive.C a) => a -> [a] -> [a]-absolutize = scanl (+)--limitMinRelativeValues ::-   Int -> Int -> [NonNeg.Int] -> Bool-limitMinRelativeValues xMin x0 xsnn =-   let xs = map NonNeg.toNumber xsnn-   in  map (max xMin) (absolutize x0 xs) ==-          uncurry absolutize (ToneModL.limitMinRelativeValues xMin x0 xs)--limitMaxRelativeValues ::-   Int -> Int -> [NonNeg.Int] -> Bool-limitMaxRelativeValues xMax x0 xsnn =-   let xs = map NonNeg.toNumber xsnn-   in  map (min xMax) (absolutize x0 xs) ==-          uncurry absolutize (ToneModL.limitMaxRelativeValues xMax x0 xs)--limitMaxRelativeValuesNonNeg ::-   Int -> Int -> [NonNeg.Int] -> Bool-limitMaxRelativeValuesNonNeg xMax x0 xsnn =-   let xs = map NonNeg.toNumber xsnn-   in  map (min xMax) (absolutize x0 xs) ==-          uncurry absolutize (ToneModL.limitMaxRelativeValuesNonNeg xMax x0 xs)---- chunky type is not necessary here but testing it a little is not wrong-limitMinRelativeValuesIdentity ::-   Chunky.T NonNeg.Int -> [Chunky.T NonNeg.Int] -> Bool-limitMinRelativeValuesIdentity x0 xs =-   (x0,xs) == ToneModL.limitMinRelativeValues 0 x0 xs--limitMaxRelativeValuesIdentity ::-   Chunky.T NonNeg.Int -> [Chunky.T NonNeg.Int] -> Bool-limitMaxRelativeValuesIdentity x0 xs =-   let inf = 1 + inf-   in  (x0,xs) == ToneModL.limitMaxRelativeValues inf x0 xs--limitMaxRelativeValuesNonNegIdentity ::-   Chunky.T NonNeg.Int -> [Chunky.T NonNeg.Int] -> Bool-limitMaxRelativeValuesNonNegIdentity x0 xs =-   let inf = 1 + inf-   in  (x0,xs) == ToneModL.limitMaxRelativeValuesNonNeg inf x0 xs--limitMaxRelativeValuesInfinity ::-   Chunky.T NonNeg.Int -> InfiniteList (Chunky.T NonNeg.Int) -> Bool-limitMaxRelativeValuesInfinity x0 ixs =-   let inf = 1 + inf-       ys = listFromInfinite ixs-       (z0,zs) = ToneModL.limitMaxRelativeValues inf x0 ys-   in  (x0, take 100 ys) == (z0, take 100 zs)--limitMaxRelativeValuesNonNegInfinity ::-   Chunky.T NonNeg.Int -> InfiniteList (Chunky.T NonNeg.Int) -> Bool-limitMaxRelativeValuesNonNegInfinity x0 ixs =-   let inf = 1 + inf-       ys = listFromInfinite ixs-       (z0,zs) = ToneModL.limitMaxRelativeValuesNonNeg inf x0 ys-   in  (x0, take 100 ys) == (z0, take 100 zs)---dropRem :: Eq a => NonNeg.Int -> [a] -> Bool-dropRem nn xs =-   let n = NonNeg.toNumber nn-   in  map (flip ToneModL.dropRem xs) [0 .. n + length xs] ==-       map ((,) 0) (List.tails xs) ++ map (flip (,) []) [1..n]---sampledToneSine :: (RealTrans.C a, Module.C a a) =>-   NonNeg.T a -> NonNeg.Int -> a -> a -> a -> Bool-sampledToneSine periodNN ext phase0 shape phase =-   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))-   in  abs (WaveL.sampledTone ipLeap ipStep period tone shape `Wave.apply` (Phase.fromRepresentative phase) --            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 =-   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))-   in  all ((< ten ^- (-2)) . abs) $-       zipWith (-)-          (Osci.shapeFreqMod (WaveL.sampledTone ipLeap ipStep period tone)-               phase shapes freqs)-          (Osci.freqModSine (origPhase+phase) freqs)---sampledToneLinear :: (RealField.C a, Module.C a v, Eq v) =>-   InterpolationTest.LinePreserving a v ->-   InterpolationTest.LinePreserving a v ->-   NonNeg.T a -> NonNeg.Int -> (v,v) -> a -> Phase.T a -> Property-sampledToneLinear =-   InterpolationTest.useLP $ \ ipLeap ->-   InterpolationTest.useLP $ \ ipStep ->-         \ periodNN ext (i,d) shape phase ->-   let period = NonNeg.toNumber periodNN-       periodInt = round period-       len = minLength ipLeap ipStep periodInt ext-       ramp = take len (List.iterate (d+) i)-       limits =-          mapPair (fromIntegral, fromIntegral) $-             shapeLimits ipLeap ipStep periodInt len-   in  period /= zero ==>-          -- should be (fraction phase), right?-          WaveL.sampledTone ipLeap ipStep period ramp shape `Wave.apply` phase ==-             i + limit limits shape *> d-{--let len=100; period=1/0.06::Double; ip = Interpolation.linear in GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (0,fromIntegral len)) [\s -> WaveL.sampledTone ip ip period (take len $ iterate (1+) (0::Double)) s 0, limit (mapPair (fromIntegral, fromIntegral) $ shapeLimits ip ip (round period::Int) len)]--}--sampledToneStair :: (RealField.C a, Module.C a v, Eq v) =>-   InterpolationTest.LinePreserving a v ->-   NonNeg.Int -> NonNeg.Int -> (v,v) -> a -> Property-sampledToneStair =-   InterpolationTest.useLP $ \ ipLeap-         periodIntNN ext (i,d) shape ->-   let ipStep = Interpolation.constant-       periodInt = NonNeg.toNumber periodIntNN-       period    = fromIntegral periodInt-       len0 = minLength ipLeap ipStep periodInt ext-       (rep,rm) = divMod (negate len0) periodInt-       len   = len0 + rm-       stair =-          concatMap (replicate periodInt) $-          take (negate rep) (List.iterate (period*>d+) i)-       limits =-          mapPair (fromIntegral, fromIntegral) $-             shapeLimits ipLeap ipStep periodInt len-   in  periodInt /= zero ==>-          WaveL.sampledTone ipLeap ipStep period stair shape `Wave.apply` zero ==-             i + limit limits shape *> d-{--let len=periodInt*rep; rep=10; periodInt = 14::Int; period=fromIntegral periodInt; ipl = Interpolation.linear; ipc = Interpolation.constant in GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (-10,10+fromIntegral len)) [\s -> WaveL.sampledTone ipl ipc period (concatMap (replicate periodInt) $ take rep $ iterate (period+) (0::Double)) s 0, limit (mapPair (fromIntegral, fromIntegral) $ shapeLimits ipl ipc periodInt len)]--}--{--sampledToneSaw :: (RealField.C a, Module.C a v, Eq v) =>-   InterpolationTest.LinePreserving a v ->-   InterpolationTest.T a v ->-   NonNeg.Int -> NonNeg.Int -> (v,v) -> a -> a -> Property-sampledToneSaw iptLeap iptStep periodIntNN ext (i,d) shape phase =-   let ipLeap = InterpolationTest.lpIp iptLeap-       ipStep = InterpolationTest.ip   iptStep-       periodInt = NonNeg.toNumber periodIntNN-       period    = fromIntegral periodInt-       len0 = minLength ipLeap ipStep periodInt ext-       rep = negate $ div (negate len0) periodInt-       saw =-          concat $ replicate rep $-          take periodInt $ List.iterate (d+) i-   in  periodInt /= zero ==>-          WaveL.sampledTone ipLeap ipStep period saw shape phase ==-             i + fraction phase *> d--}--sampledToneStatic :: (RealField.C a, Eq v) =>-   InterpolationTest.T a v ->-   InterpolationTest.T a v ->-   NonNeg.Int -> (v,[v]) -> a -> a -> Property-sampledToneStatic =-   InterpolationTest.use2 $ \ ipLeap ipStep-         ext (x,xs) shape phase ->-   let wave = x:xs-       periodInt = length wave-       period    = fromIntegral periodInt-       len = minLength ipLeap ipStep periodInt ext-       rep = negate $ div (negate len) periodInt-       tone = concat $ replicate rep wave-   in  period /= zero ==>-          WaveL.sampledTone ipLeap ipStep period tone shape `Wave.apply` (Phase.fromRepresentative phase) ==-          Interpolation.cyclicPad Interpolation.single ipStep (phase*period) wave-{--let wave = [1,-1,0.5,-0.5::Double]; period = fromIntegral (length wave) :: Double; ip = Interpolation.linear in GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (-1,3)) [WaveL.sampledTone ip ip period (concat $ replicate 3 wave) 0.3, \phase -> Interpolation.cyclicPad Interpolation.single Interpolation.linear (phase*period) wave]--}----shapeFreqModFromSampledToneLimitIdentity :: (RealField.C t) =>-   Interpolation.Margin ->-   Interpolation.Margin ->-   NonNeg.Int -> InfiniteList y -> (t, InfiniteList (NonNeg.T t)) -> Bool-shapeFreqModFromSampledToneLimitIdentity-      marginLeap marginStep periodIntNN ixs (shape0,shapesNN) =-   let periodInt = NonNeg.toNumber periodIntNN-       shapes = fmap NonNeg.toNumber shapesNN-       a = snd-          (ToneModL.limitRelativeShapes-             marginLeap marginStep-             periodInt (listFromInfinite ixs)-             (shape0, listFromInfinite shapes)) !! 100-   in  a == a---oscillatorCoords :: (RealField.C t) =>-   NonNeg.Int -> NonNeg.T t -> t -> Phase.T t -> [NonNeg.T t] -> [t] -> Property-oscillatorCoords-     periodIntNN periodNN shape0 phase shapesNN freqs =-   let shapes = map NonNeg.toNumber shapesNN-       period    = NonNeg.toNumber periodNN-       periodInt = NonNeg.toNumber periodIntNN-       periodRound = fromIntegral periodInt-       coords =-          ToneModL.oscillatorCoords-             periodInt period-             (shape0, shapes) (phase, freqs)-   in  period /= zero  &&  periodInt /= zero  ==>-          all-             (\(skip,(k,(qShape,qWave))) ->-                  skip >= zero &&-                  isAscending [negate periodInt, k, zero] &&-                  isAscending [zero, qShape, one] &&-                  isAscending [zero, qWave, periodRound])-             (tail coords)---shapeFreqModFromSampledToneCoordsIdentity :: (RealField.C t) =>-   NonNeg.Int -> NonNeg.T t -> (t, [NonNeg.T t]) -> Property-shapeFreqModFromSampledToneCoordsIdentity-      periodIntNN periodNN (shape0,shapesNN) =-   let period    = NonNeg.toNumber periodNN-       periodInt = NonNeg.toNumber periodIntNN-       shapes = map NonNeg.toNumber shapesNN-       phase  = Phase.fromRepresentative $ shape0 / period-       freqs  = map (/period) shapes-   in  period /= zero  ==>-          all-             (isZero . fst . snd . snd)-             (ToneModL.oscillatorCoords-                 periodInt period (shape0, shapes) (phase, freqs))---shapeFreqModFromSampledTone :: (RealField.C t, Eq v) =>-   InterpolationTest.T t v ->-   InterpolationTest.T t v ->-   NonNeg.T t ->-   NonNeg.Int -> InfiniteList v ->-   t -> t -> [NonNeg.T t] -> [t] ->-   Property-shapeFreqModFromSampledTone =-   InterpolationTest.use2 $ \ ipLeap ipStep-         periodNN ext ixs shape0 phase shapesNN freqs ->-   let shapes = map NonNeg.toNumber shapesNN-       period = NonNeg.toNumber periodNN-       periodInt = round period-       len = minLength ipLeap ipStep periodInt ext-       tone = take len (listFromInfinite ixs)-       resampledToneA =-          Osci.shapeFreqModFromSampledTone ipLeap ipStep period tone-             shape0 phase shapes freqs-       resampledToneB =-          Osci.shapeFreqMod-             (WaveL.sampledTone ipLeap ipStep period tone)-             phase (scanl (+) shape0 shapes) freqs-   in  period /= zero  ==>-          resampledToneA == resampledToneB-{--let len=100; period=1/0.06::Double; ip = Interpolation.linear; tone = take len $ iterate (1+) (0::Double); shape0=0; shapes = replicate 100 1; in GNUPlot.plotLists [] [Osci.shapeFreqMod (WaveL.sampledTone ip ip period tone) 0 (scanl (+) shape0 shapes) (repeat 0), Osci.shapeFreqModFromSampledTone ip ip period tone shape0 0 shapes (repeat 0)]-*Test.Sound.Synthesizer.Plain.Oscillator> let len=100; period=1/0.06::Double; ip = Interpolation.linear; tone = take len $ iterate (1+) (0::Double); shape0=0; shapes = concat $ replicate 50 [1.5,0.5]; in GNUPlot.plotLists [] [Osci.shapeFreqMod (WaveL.sampledTone ip ip period tone) 0 (scanl (+) shape0 shapes) (repeat 0), Osci.shapeFreqModFromSampledTone ip ip period tone shape0 0 shapes (repeat 0)]-*Test.Sound.Synthesizer.Plain.Oscillator> let len=100; period=1/0.06::Rational; ipLeap = Interpolation.linear; ipStep = Interpolation.constant; tone = take len $ iterate (1+) (0::Rational); shape0=0; shapes = concat $ replicate 50 [1.5,0.5]; in GNUPlot.plotLists [] (map (map (\x -> fromRational' x :: Double)) [Osci.shapeFreqMod (WaveL.sampledTone ipLeap ipStep period tone) 0 (scanl (+) shape0 shapes) (repeat 0), Osci.shapeFreqModFromSampledTone ipLeap ipStep period tone shape0 0 shapes (repeat 0)])--}---shapePhaseFreqModFromSampledTone :: (RealField.C t, Eq v) =>-   InterpolationTest.T t v ->-   InterpolationTest.T t v ->-   NonNeg.T t ->-   NonNeg.Int -> InfiniteList v ->-   t -> t -> [NonNeg.T t] -> [t] -> [t] ->-   Property-shapePhaseFreqModFromSampledTone =-   InterpolationTest.use2 $ \ ipLeap ipStep-         periodNN ext ixs shape0 phase shapesNN phaseDistorts freqs ->-   let shapes = map NonNeg.toNumber shapesNN-       period = NonNeg.toNumber periodNN-       periodInt = round period-       len = minLength ipLeap ipStep periodInt ext-       tone = take len (listFromInfinite ixs)-       resampledToneA =-          Osci.shapePhaseFreqModFromSampledTone ipLeap ipStep period tone-             shape0 phase shapes phaseDistorts freqs-       resampledToneB =-          Osci.shapeFreqMod-             (uncurry $-                Wave.phaseOffset .-                WaveL.sampledTone ipLeap ipStep period tone)-             phase (zip (scanl (+) shape0 shapes) phaseDistorts) freqs-   in  period /= zero  ==>-          resampledToneA == resampledToneB---oscillatorCells :: (RealField.C t, Eq v) =>-   Interpolation.Margin ->-   Interpolation.Margin ->-   NonNeg.Int ->-   NonNeg.T t ->-   NonNeg.Int -> InfiniteList v ->-   t -> t -> [NonNeg.T t] -> [t] ->-   Property-oscillatorCells-      marginLeap marginStep periodIntNN periodNN ext ixs shape0 phase shapesNN freqs =-   let shapes = map NonNeg.toNumber shapesNN-       period    = NonNeg.toNumber periodNN-       periodInt = NonNeg.toNumber periodIntNN-       len = minLengthMargin marginLeap marginStep periodInt ext-       tone = take len (listFromInfinite ixs)-       crop = cropCell marginLeap marginStep-       resampledToneA =-          ToneModL.oscillatorCells-             marginLeap marginStep periodInt period tone-             (shape0, shapes) (Phase.fromRepresentative phase, freqs)-       resampledToneB =-          Osci.shapeFreqMod-             (Wave.Cons . ToneModL.sampledToneCell-                (ToneModL.makePrototype marginLeap marginStep-                    periodInt period tone))-             phase (scanl (+) shape0 shapes) freqs-   in  period /= zero  &&-       periodInt /= zero  &&-       marginNumber marginLeap > zero &&-       marginNumber marginStep > zero  ==>-          map crop resampledToneA == map crop resampledToneB--cropCell ::-   Interpolation.Margin ->-   Interpolation.Margin ->-   ((t,t), ToneModL.Cell v) -> ((t,t), ToneModL.Cell v)-cropCell ipLeap ipStep =-   mapSnd-      (take (marginNumber ipStep) .-       map (take (marginNumber ipLeap)))---shapeFreqModFromSampledToneIdentity :: (RealField.C t, Eq v) =>-   InterpolationTest.T t v ->-   InterpolationTest.T t v ->-   NonNeg.T t ->-   NonNeg.Int -> InfiniteList v ->-   Property-shapeFreqModFromSampledToneIdentity =-   InterpolationTest.use2 $ \ ipLeap ipStep-          periodNN ext ixs ->-   let period = NonNeg.toNumber periodNN-       periodInt = round period-       len = minLength ipLeap ipStep periodInt ext-       tone = take len (listFromInfinite ixs)-       shape0 = zero-       shapes = repeat one-       phase  = zero-       freqs  = repeat (recip period)-       (n0,n1) =-          shapeLimits ipLeap ipStep periodInt len--       resampledTone =-          Osci.shapeFreqModFromSampledTone ipLeap ipStep period tone-             shape0 phase shapes freqs-   in  period /= zero  ==>-          and (drop n0 (take (succ n1) (zipWith (==) resampledTone tone)))---tests :: [(String, IO ())]-tests =-   ("limitMinRelativeValues", test limitMinRelativeValues) :-   ("limitMaxRelativeValues", test limitMaxRelativeValues) :-   ("limitMaxRelativeValuesNonNeg",-                              test limitMaxRelativeValuesNonNeg) :-   ("limitMinRelativeValuesIdentity",-                              test limitMinRelativeValuesIdentity) :-   ("limitMaxRelativeValuesIdentity",-                              test limitMaxRelativeValuesIdentity) :-   ("limitMaxRelativeValuesNonNegIdentity",-                              test limitMaxRelativeValuesNonNegIdentity) :-   ("limitMaxRelativeValuesInfinity",-                              test limitMaxRelativeValuesInfinity) :-   ("limitMaxRelativeValuesNonNegInfinity",-                              test limitMaxRelativeValuesNonNegInfinity) :-   ("dropRem",                test (dropRem :: NonNeg.Int -> [ArbChar] -> Bool)) :-   ("sampledToneSine",-      test (\period -> sampledToneSine (period :: NonNeg.Double))) :-   ("sampledToneSineList",-      test (\period -> sampledToneSineList (period :: NonNeg.Double))) :-   ("sampledToneLinear",-      testRationalLineIp sampledToneLinear) :-   ("sampledToneStair",-      testRationalLineIp sampledToneStair) :-{--   ("sampledToneSaw",-      testRationalLineIp sampledToneSaw) :--}-   ("sampledToneStatic",-      testRationalIp sampledToneStatic) :-   ("shapeFreqModFromSampledToneLimitIdentity",-      test (\ml ms p ixs (t,ts) ->-          shapeFreqModFromSampledToneLimitIdentity ml ms p-             (ixs::InfiniteList Rational) (t::Rational,ts))) :-   ("oscillatorCoords",-      test (\periodInt period ->-               oscillatorCoords-                  periodInt (period :: NonNeg.Rational))) :-   ("shapeFreqModFromSampledToneCoordsIdentity",-      test (\periodInt period ->-               shapeFreqModFromSampledToneCoordsIdentity-                  periodInt (period :: NonNeg.Rational))) :-   ("shapeFreqModFromSampledTone",-      testRationalIp shapeFreqModFromSampledTone) :-   ("shapePhaseFreqModFromSampledTone",-      testRationalIp shapePhaseFreqModFromSampledTone) :-   ("oscillatorCells",-      test (\ml ms periodInt period ext ixs ->-               oscillatorCells ml ms periodInt (period :: NonNeg.Rational)-                  ext (ixs :: InfiniteList ArbChar))) :-   ("shapeFreqModFromSampledToneIdentity",-      testRationalIp shapeFreqModFromSampledToneIdentity) :-   []
− src/Test/Sound/Synthesizer/Plain/Wave.hs 
@@ -1,81 +0,0 @@-module Test.Sound.Synthesizer.Plain.Wave (Ring, ringWave, tests) where--import qualified Synthesizer.Basic.Wave       as Wave-import qualified Synthesizer.Basic.Phase      as Phase--import Test.QuickCheck (test, Arbitrary(..), elements, oneof, choose, {- Property, (==>), -} )--- import Test.Utility--import qualified Number.NonNegative       as NonNeg--import qualified Algebra.RealTranscendental    as RealTrans--- import qualified Algebra.Module                as Module--- import qualified Algebra.RealField             as RealField--- import qualified Algebra.Field                 as Field-import qualified Algebra.Ring                  as Ring-import qualified Algebra.Additive              as Additive--import Control.Monad (liftM, liftM2, )-import System.Random (Random)---import NumericPrelude-import PreludeBase-import Prelude ()-----data Ring a = Ring {ringName :: String, ringWave :: Wave.T a a}--instance Show (Ring a) where-   show = ringName--instance (Ord a, Ring.C a) => Arbitrary (Ring a) where-   arbitrary = elements $-      Ring "saw"      Wave.saw :-      Ring "square"   Wave.square :-      Ring "triangle" Wave.triangle :-      []-   coarbitrary = undefined-----data ZeroDCOffset a = ZeroDCOffset {zdcName :: String, zdcWave :: Wave.T a a}--instance Show (ZeroDCOffset a) where-   show = zdcName--instance (RealTrans.C a, Random a) => Arbitrary (ZeroDCOffset a) where-   arbitrary =-      let cons n w = return (ZeroDCOffset n w)-      in  oneof $-            cons "sine"     Wave.sine :-            cons "saw"      Wave.saw :-            cons "square"   Wave.square :-            cons "triangle" Wave.triangle :-            liftM-               (ZeroDCOffset "squareBalanced" . Wave.squareBalanced)-               (choose (negate one, one)) :-            liftM2-               (\w r -> ZeroDCOffset "trapezoidBalanced" (Wave.trapezoidBalanced w r))-               (choose (zero, one))-               (choose (negate one, one)) :-            []-   coarbitrary = undefined---zeroDCOffset :: ZeroDCOffset Double -> NonNeg.Int -> Bool-zeroDCOffset w periodIntNN =-   let periodInt = 100 + NonNeg.toNumber periodIntNN-       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---tests :: [(String, IO ())]-tests =-   ("zeroDCOffset",  test zeroDCOffset) :-   []
− src/Test/Utility.hs 
@@ -1,47 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-module Test.Utility where--import Test.QuickCheck (Arbitrary(..))--import qualified Algebra.Real                  as Real-import qualified Algebra.Ring                  as Ring--import qualified Data.Char as Char--import PreludeBase-import NumericPrelude---equalList :: Eq a => [a] -> Bool-equalList xs =-   -- 'drop 1' instead of 'take' for suppression of error-   and (zipWith (==) xs (drop 1 xs))---approxEqual :: (Real.C a) => a -> a -> a -> Bool-approxEqual eps x y =-   2 * abs (x-y) <= eps * (abs x + abs y)--approxEqualListRel :: (Real.C a) => a -> [a] -> Bool-approxEqualListRel eps xs =-   let n = fromIntegral $ length xs-   in  approxEqualListAbs (eps * n * sum (map abs xs)) xs--approxEqualListAbs :: (Real.C a) => a -> [a] -> Bool-approxEqualListAbs eps xs =-   let n = fromIntegral $ length xs-       s = sum xs-   in  sum (map (\x -> abs (n*x-s)) xs)  <=  eps----- see event-list--newtype ArbChar = ArbChar Char-   deriving (Eq, Ord)--instance Show ArbChar where-   showsPrec n (ArbChar c) = showsPrec n c--instance Arbitrary ArbChar where-   arbitrary = fmap (ArbChar . Char.chr . (32+) . flip mod 96) arbitrary-   coarbitrary = undefined
synthesizer-core.cabal view
@@ -1,5 +1,5 @@ Name:           synthesizer-core-Version:        0.2.1+Version:        0.9.0.1 License:        GPL License-File:   LICENSE Author:         Henning Thielemann <haskell@henning-thielemann.de>@@ -12,46 +12,34 @@    used by the other synthesizer packages.    The routines can be really fast    due to StorableVector, Stream-like list type and aggressive inlining.-   For an interface to Haskore see <http://darcs.haskell.org/haskore-synthesizer/>.+   For an interface to Haskore see <http://code.haskell.org/haskore/revised/synthesizer/>.    For introductory examples see "Synthesizer.Plain.Tutorial"    and "Synthesizer.Generic.Tutorial". -- the Overview module does not really fit into one of the part packages --   For an overview of the organization of the package --   and the discussion of various design issues see "Synthesizer.Overview".+   .+   Functions:+     Oscillators, Noise generators, Frequency filters,+     Fast Fourier transform for computation of frequency spectrum Stability:      Experimental-Tested-With:    GHC==6.4.1, GHC==6.8.2-Cabal-Version:  >=1.6+Tested-With:    GHC==6.4.1, GHC==6.8.2, GHC==6.10.4, GHC==6.12.3+Tested-With:    GHC==7.0.4, GHC==7.2.1, GHC==7.4.2, GHC==7.6.3+Cabal-Version:  1.14 Build-Type:     Simple  Extra-Source-Files:+  Changes.md   Makefile-  src-3/Synthesizer/Causal/Process.hs-  src-4/Synthesizer/Causal/Process.hs-  src-4/Synthesizer/Inference/DesignStudy/Applicative.hs-  src-4/Synthesizer/Inference/DesignStudy/Monad.hs-  src-4/Synthesizer/Inference/DesignStudy/Arrow.hs -Flag splitBase-  description: Choose the new smaller, split-up base package.--Flag category-  description: Check whether Arrow class is split into Arrow and Category.- Flag optimizeAdvanced   description: Enable advanced optimizations. They slow down compilation considerably.-  default:     True--Flag buildProfilers-  description: Build executables for investigating efficiency of code-  default:     False--Flag buildTests-  description: Build test suite+  manual:      True   default:     False   Source-Repository this-  Tag:         0.2.1+  Tag:         0.9.0.1   Type:        darcs   Location:    http://code.haskell.org/synthesizer/core/ @@ -61,41 +49,40 @@  Library   Build-Depends:-    transformers >=0.0.1 && <0.2,-    event-list >=0.0.8 && <0.1,-    non-negative >=0.0.5 && <0.1,-    numeric-prelude >=0.1.2 && <0.2,-    numeric-quest >= 0.1 && <0.2,-    utility-ht >=0.0.5 && <0.1,-    sox >=0.0 && <0.1,-    filepath >=1.1 && <1.2,-    bytestring >= 0.9 && <0.10,+    sample-frame-np >=0.0.5 && <0.1,+    sox >=0.1 && <0.3,+    transformers >=0.2 && <0.7,+    non-empty >=0.2 && <0.4,+    semigroups >=0.1 && <1,+    event-list >=0.1 && <0.2,+    non-negative >=0.1 && <0.2,+    explicit-exception >=0.1.6 && <0.3,+    numeric-prelude >=0.4.2 && <0.5,+    numeric-quest >=0.1 && <0.3,+    utility-ht >=0.0.14 && <0.1,+    filepath >=1.1 && <1.6,+    bytestring >=0.9 && <0.13,     binary >=0.1 && <1,-    storablevector >=0.2.4 && <0.3,+    deepseq >=1.1 && <1.7,+    storablevector >=0.2.12 && <0.3,     storable-record >=0.0.1 && <0.1,-    storable-tuple >=0.0.1 && <0.1,-    QuickCheck >=1 && <2+    storable-tuple >=0.0.1 && <0.2,+    QuickCheck >=1 && <3,+    array >=0.1 && <0.6,+    containers >=0.1 && <0.9,+    random >=1.0 && <1.4,+    process >=1.0 && <1.7,+    base >=4.11 && <5 -  If flag(splitBase)-    If flag(category)-      Hs-Source-Dirs: src-4-      Build-Depends: base >= 4 && <5-    Else-      Hs-Source-Dirs: src-3-      Build-Depends: base >= 3 && <4-    Build-Depends:-      array >=0.1 && <0.3,-      containers >=0.1 && <0.3,-      random >=1.0 && <2.0,-      process >=1.0 && <1.1-  Else-    Hs-Source-Dirs: src-3-    Build-Depends:-      base >= 1.0 && < 2,-      special-functors >= 1.0 && <1.1+  If impl(ghc>=7.0)+-- also warns about NumericPrelude import:  -fwarn-missing-import-lists+    GHC-Options: -fwarn-unused-do-bind+    CPP-Options: -DNoImplicitPrelude=RebindableSyntax+    Default-Extensions: CPP +  Default-Language: Haskell2010   GHC-Options:    -Wall-  Hs-source-dirs: src+  Hs-source-dirs: src, private   Exposed-modules:     Synthesizer.Storage @@ -103,6 +90,7 @@     Synthesizer.Format     Synthesizer.RandomKnuth     Synthesizer.Piecewise+    Synthesizer.Zip     Synthesizer.Basic.Binary     Synthesizer.Basic.Distortion     Synthesizer.Basic.DistortionControlled@@ -111,10 +99,14 @@     Synthesizer.Basic.Wave     Synthesizer.Basic.WaveSmoothed     Synthesizer.Interpolation+    Synthesizer.Interpolation.Core     Synthesizer.Interpolation.Class     Synthesizer.Interpolation.Module     Synthesizer.Interpolation.Custom     Synthesizer.Frame.Stereo+    Synthesizer.ChunkySize+    Synthesizer.ChunkySize.Cut+    Synthesizer.ChunkySize.Signal     Synthesizer.Plain.Signal     Synthesizer.Plain.Analysis     Synthesizer.Plain.Cut@@ -129,6 +121,7 @@     Synthesizer.Plain.Filter.Recursive.Comb     Synthesizer.Plain.Filter.Recursive.FirstOrder     Synthesizer.Plain.Filter.Recursive.FirstOrderComplex+    Synthesizer.Plain.Filter.Recursive.Hilbert     Synthesizer.Plain.Filter.Recursive.Integration     Synthesizer.Plain.Filter.Recursive.Moog     Synthesizer.Plain.Filter.Recursive.MovingAverage@@ -146,9 +139,9 @@     Synthesizer.Plain.Modifier     Synthesizer.Plain.Noise     Synthesizer.Plain.Oscillator+    Synthesizer.Plain.Oscillator.BandLimited     Synthesizer.Plain.ToneModulation     Synthesizer.Plain.Wave-    Synthesizer.Plain.Miscellaneous     Synthesizer.Plain.Instrument     Synthesizer.Plain.Effect     Synthesizer.Plain.Effect.Fly@@ -157,12 +150,11 @@     Synthesizer.Plain.IO     Synthesizer.Plain.File     Synthesizer.Plain.Play-    Synthesizer.FusionList.Control-    Synthesizer.FusionList.Filter.NonRecursive-    Synthesizer.FusionList.Oscillator-    Synthesizer.FusionList.Signal     Synthesizer.Storable.Cut+    Synthesizer.Storable.Generate     Synthesizer.Storable.Oscillator+    Synthesizer.Storable.Play+    Synthesizer.Storable.Repair     Synthesizer.Storable.Signal     Synthesizer.Storable.Filter.NonRecursive     Synthesizer.State.Analysis@@ -175,33 +167,51 @@     Synthesizer.State.Filter.Recursive.Integration     Synthesizer.State.Filter.Recursive.MovingAverage     Synthesizer.State.Interpolation-    Synthesizer.State.Miscellaneous     Synthesizer.State.Noise     Synthesizer.State.NoiseCustom     Synthesizer.State.Oscillator+    Synthesizer.State.Piece     Synthesizer.State.Signal+    Synthesizer.State.Storable     Synthesizer.State.ToneModulation     Synthesizer.Causal.Process+    Synthesizer.Causal.Class+    Synthesizer.Causal.Arrow+    Synthesizer.Causal.Utility+    Synthesizer.Causal.Analysis+    Synthesizer.Causal.Cut     Synthesizer.Causal.Displacement     Synthesizer.Causal.Interpolation     Synthesizer.Causal.Oscillator+    Synthesizer.Causal.Oscillator.Core     Synthesizer.Causal.ToneModulation+    Synthesizer.Causal.Spatial+    Synthesizer.Causal.Filter.NonRecursive+    Synthesizer.Causal.Filter.Recursive.Integration+    Synthesizer.CausalIO.Gate+    Synthesizer.CausalIO.Process     Synthesizer.Generic.Analysis     Synthesizer.Generic.Cut+    Synthesizer.Generic.CutChunky     Synthesizer.Generic.Control+    Synthesizer.Generic.Cyclic     Synthesizer.Generic.Displacement     Synthesizer.Generic.Filter.NonRecursive     Synthesizer.Generic.Filter.Delay     Synthesizer.Generic.Filter.Recursive.Integration     Synthesizer.Generic.Filter.Recursive.MovingAverage     Synthesizer.Generic.Filter.Recursive.Comb+    Synthesizer.Generic.Fourier     Synthesizer.Generic.Interpolation+    Synthesizer.Generic.Loop     Synthesizer.Generic.Noise     Synthesizer.Generic.Oscillator     Synthesizer.Generic.Piece     Synthesizer.Generic.Signal-    Synthesizer.Generic.Signal2     Synthesizer.Generic.Wave+    Synthesizer.PiecewiseConstant.Signal+    Synthesizer.PiecewiseConstant.Generic+    Synthesizer.PiecewiseConstant.Storable      -- that's only exposed for Haddock     Synthesizer.Plain.Tutorial@@ -211,88 +221,156 @@     Synthesizer.Utility    Other-Modules:-    Synthesizer.Filter.Basic-    Synthesizer.Filter.Composition-    Synthesizer.Filter.Example-    Synthesizer.Filter.Fix-    Synthesizer.Filter.Graph-    Synthesizer.Filter.Graphic-    Synthesizer.Filter.MonadFix-    Synthesizer.Filter.OneWay-    Synthesizer.Filter.TwoWay+    Synthesizer.Basic.Filter.NonRecursive+    Synthesizer.Basic.ComplexModule+    Synthesizer.Basic.NumberTheory+    Synthesizer.Generic.Permutation+    Synthesizer.Generic.LengthSignal+    Synthesizer.PiecewiseConstant.Private  -Executable test-  If !flag(buildTests)-    Buildable: False-  GHC-Options: -Wall-  Hs-Source-Dirs: src-  If flag(category)-    Hs-Source-Dirs: src-4-  Else-    Hs-Source-Dirs: src-3+Test-Suite test+  Type: exitcode-stdio-1.0+  Build-Depends:+    synthesizer-core,+    storablevector,+    storable-tuple,+    event-list,+    transformers,+    non-empty >=0.2.1 && <0.4,+    non-negative,+    utility-ht,+    numeric-prelude,+    doctest-exitcode-stdio >=0.0 && <0.1,+    doctest-lib >=0.1.1 && <0.1.2,+    QuickCheck,+    random,+    containers,+    base >=4 && <5+  Default-Language: Haskell2010+  GHC-Options: -Wall -fwarn-tabs -fwarn-incomplete-record-updates+  Hs-Source-Dirs: test, private++  If impl(ghc>=7.0)+    GHC-Options: -fwarn-unused-do-bind+    CPP-Options: -DNoImplicitPrelude=RebindableSyntax+    Default-Extensions: CPP+   Other-Modules:     Test.Utility     Test.Sound.Synthesizer.Plain.Analysis     Test.Sound.Synthesizer.Plain.Control     Test.Sound.Synthesizer.Plain.Filter+    Test.Sound.Synthesizer.Plain.Filter.Allpass+    Test.Sound.Synthesizer.Plain.Filter.Hilbert+    Test.Sound.Synthesizer.Plain.Filter.FirstOrder     Test.Sound.Synthesizer.Plain.Interpolation-    Test.Sound.Synthesizer.Plain.Oscillator+    Test.Sound.Synthesizer.Plain.NonEmpty     Test.Sound.Synthesizer.Plain.ToneModulation-    Test.Sound.Synthesizer.Plain.Wave     Test.Sound.Synthesizer.Basic.ToneModulation+    Test.Sound.Synthesizer.Basic.NumberTheory+    Test.Sound.Synthesizer.Generic.Cut     Test.Sound.Synthesizer.Generic.ToneModulation+    Test.Sound.Synthesizer.Generic.Permutation+    Test.Sound.Synthesizer.Generic.Fourier+    Test.Sound.Synthesizer.Generic.FourierInteger+    Test.Sound.Synthesizer.Generic.Filter+    Synthesizer.Basic.NumberTheory+    Synthesizer.Generic.Permutation+    DocTest.Main+    DocTest.Synthesizer.Basic.Wave+    DocTest.Synthesizer.Storable.Cut+    DocTest.Synthesizer.Plain.Oscillator+    DocTest.Synthesizer.Generic.Signal+    DocTest.Synthesizer.Causal.Analysis   Main-Is: Test/Main.hs -Executable fusiontest-  If !flag(buildProfilers)-    Buildable: False-  GHC-Options: -Wall -fexcess-precision-  If flag(optimizeAdvanced)-    GHC-Options: -ddump-simpl-stats-  Hs-Source-Dirs: speedtest, src-  If flag(category)-    Hs-Source-Dirs: src-4-  Else-    Hs-Source-Dirs: src-3-  Main-Is: FusionTest.hs -Executable speedtest-  If !flag(buildProfilers)-    Buildable: False+Benchmark fouriertest+  Type: exitcode-stdio-1.0+  Build-Depends:+    synthesizer-core,+    numeric-prelude,+    timeit >=1.0 && <3,+    storablevector >=0.2.7 && <0.3,+    storable-tuple,+    utility-ht >=0.0.5 && <0.1,+    base >=4 && <5++  If impl(ghc>=7.0)+    GHC-Options: -fwarn-unused-do-bind+    CPP-Options: -DNoImplicitPrelude=RebindableSyntax+    Default-Extensions: CPP++  Default-Language: Haskell2010+  GHC-Options:      -Wall+  GHC-Prof-Options: -auto-all+  Hs-Source-Dirs: speedtest+  Main-Is:        Fourier.hs++Benchmark speedtest+  Type: exitcode-stdio-1.0+  Build-Depends:+    synthesizer-core,+    numeric-prelude,+    old-time >= 1.0 && < 1.2,+    directory >= 1.0 && < 1.4,+    binary,+    bytestring,+    utility-ht,+    base >=4 && <5++  If impl(ghc>=7.0)+    GHC-Options: -fwarn-unused-do-bind+    CPP-Options: -DNoImplicitPrelude=RebindableSyntax+    Default-Extensions: CPP++  Default-Language: Haskell2010   GHC-Options: -Wall -fexcess-precision   If flag(optimizeAdvanced)     GHC-Options: -optc-ffast-math -optc-O3   --  -funfolding-use-threshold=20 -funfolding-creation-threshold=100   --  -optc-march=pentium4 -optc-mfpmath=sse-  Hs-Source-Dirs: speedtest, src-  If flag(category)-    Hs-Source-Dirs: src-4-  Else-    Hs-Source-Dirs: src-3+  Hs-Source-Dirs: speedtest   Main-Is: SpeedTest.hs -Executable speedtest-exp-  If !flag(buildProfilers)-    Buildable: False+Benchmark speedtest-exp+  Type: exitcode-stdio-1.0+  Build-Depends:+    synthesizer-core,+    storablevector,+    old-time,+    directory,+    binary,+    bytestring,+    array,+    base >=4 && <5++  If impl(ghc>=7.0)+    GHC-Options: -fwarn-unused-do-bind+    CPP-Options: -DNoImplicitPrelude=RebindableSyntax+    Default-Extensions: CPP++  Default-Language: Haskell2010   GHC-Options: -Wall -fexcess-precision-  Hs-Source-Dirs: speedtest, src-  If flag(category)-    Hs-Source-Dirs: src-4-  Else-    Hs-Source-Dirs: src-3+  Hs-Source-Dirs: speedtest   Main-Is: SpeedTestExp.hs-  If flag(splitBase)-    Build-Depends:-      old-time >= 1.0 && < 1.1, directory >= 1.0 && < 1.1 -Executable speedtest-simple-  If !flag(buildProfilers)-    Buildable: False+Benchmark speedtest-simple+  Type: exitcode-stdio-1.0+  Build-Depends:+    synthesizer-core,+    binary,+    bytestring,+    old-time,+    base >=4 && <5++  If impl(ghc>=7.0)+    GHC-Options: -fwarn-unused-do-bind+    CPP-Options: -DNoImplicitPrelude=RebindableSyntax+    Default-Extensions: CPP++  Default-Language: Haskell2010   GHC-Options: -Wall-  Hs-Source-Dirs: speedtest, src-  If flag(category)-    Hs-Source-Dirs: src-4-  Else-    Hs-Source-Dirs: src-3+  Hs-Source-Dirs: speedtest   Main-Is: SpeedTestSimple.hs
+ test/DocTest/Main.hs view
@@ -0,0 +1,18 @@+-- Do not edit! Automatically created with doctest-extract.+module DocTest.Main where++import qualified DocTest.Synthesizer.Basic.Wave+import qualified DocTest.Synthesizer.Storable.Cut+import qualified DocTest.Synthesizer.Plain.Oscillator+import qualified DocTest.Synthesizer.Generic.Signal+import qualified DocTest.Synthesizer.Causal.Analysis++import qualified Test.DocTest.Driver as DocTest++main :: DocTest.T ()+main = do+    DocTest.Synthesizer.Basic.Wave.test+    DocTest.Synthesizer.Storable.Cut.test+    DocTest.Synthesizer.Plain.Oscillator.test+    DocTest.Synthesizer.Generic.Signal.test+    DocTest.Synthesizer.Causal.Analysis.test
+ test/DocTest/Synthesizer/Basic/Wave.hs view
@@ -0,0 +1,102 @@+-- Do not edit! Automatically created with doctest-extract from src/Synthesizer/Basic/Wave.hs+{-# LINE 110 "src/Synthesizer/Basic/Wave.hs" #-}++module DocTest.Synthesizer.Basic.Wave where++import qualified Test.DocTest.Driver as DocTest++{-# LINE 111 "src/Synthesizer/Basic/Wave.hs" #-}+import     qualified Synthesizer.Basic.Wave  as Wave+import     qualified Synthesizer.Basic.Phase as Phase++import     qualified Test.QuickCheck as QC++import     NumericPrelude.Numeric+import     NumericPrelude.Base+import     Prelude ()++zeroDCOffset     :: Wave.T Double Double -> QC.Property+zeroDCOffset     wave =+       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 wave) xs))  <  period / fromInteger 100++test :: DocTest.T ()+test = do+ DocTest.printPrefix "Synthesizer.Basic.Wave:215: "+{-# LINE 215 "src/Synthesizer/Basic/Wave.hs" #-}+ DocTest.property(+{-# LINE 215 "src/Synthesizer/Basic/Wave.hs" #-}+      zeroDCOffset Wave.sine+  )+ DocTest.printPrefix "Synthesizer.Basic.Wave:224: "+{-# LINE 224 "src/Synthesizer/Basic/Wave.hs" #-}+ DocTest.property(+{-# LINE 224 "src/Synthesizer/Basic/Wave.hs" #-}+      zeroDCOffset Wave.cosine+  )+ DocTest.printPrefix "Synthesizer.Basic.Wave:239: "+{-# LINE 239 "src/Synthesizer/Basic/Wave.hs" #-}+ DocTest.property(+{-# LINE 239 "src/Synthesizer/Basic/Wave.hs" #-}+      zeroDCOffset Wave.fastSine2+  )+ DocTest.printPrefix "Synthesizer.Basic.Wave:261: "+{-# LINE 261 "src/Synthesizer/Basic/Wave.hs" #-}+ DocTest.property(+{-# LINE 261 "src/Synthesizer/Basic/Wave.hs" #-}+      zeroDCOffset Wave.fastSine3+  )+ DocTest.printPrefix "Synthesizer.Basic.Wave:283: "+{-# LINE 283 "src/Synthesizer/Basic/Wave.hs" #-}+ DocTest.property(+{-# LINE 283 "src/Synthesizer/Basic/Wave.hs" #-}+      zeroDCOffset Wave.fastSine4+  )+ DocTest.printPrefix "Synthesizer.Basic.Wave:417: "+{-# LINE 417 "src/Synthesizer/Basic/Wave.hs" #-}+ DocTest.property(+{-# LINE 417 "src/Synthesizer/Basic/Wave.hs" #-}+      zeroDCOffset Wave.saw+  )+ DocTest.printPrefix "Synthesizer.Basic.Wave:430: "+{-# LINE 430 "src/Synthesizer/Basic/Wave.hs" #-}+ DocTest.property(+{-# LINE 430 "src/Synthesizer/Basic/Wave.hs" #-}+      zeroDCOffset Wave.sawCos+  )+ DocTest.printPrefix "Synthesizer.Basic.Wave:535: "+{-# LINE 535 "src/Synthesizer/Basic/Wave.hs" #-}+ DocTest.property(+{-# LINE 535 "src/Synthesizer/Basic/Wave.hs" #-}+      zeroDCOffset Wave.square+  )+ DocTest.printPrefix "Synthesizer.Basic.Wave:594: "+{-# LINE 594 "src/Synthesizer/Basic/Wave.hs" #-}+ DocTest.property(+{-# LINE 594 "src/Synthesizer/Basic/Wave.hs" #-}+      zeroDCOffset Wave.triangle+  )+ DocTest.printPrefix "Synthesizer.Basic.Wave:1003: "+{-# LINE 1003 "src/Synthesizer/Basic/Wave.hs" #-}+ DocTest.property(+{-# LINE 1003 "src/Synthesizer/Basic/Wave.hs" #-}+      QC.forAll (QC.choose (-1,1)) $ zeroDCOffset . Wave.squareBalanced+  )+ DocTest.printPrefix "Synthesizer.Basic.Wave:1030: "+{-# LINE 1030 "src/Synthesizer/Basic/Wave.hs" #-}+ DocTest.property(+{-# LINE 1030 "src/Synthesizer/Basic/Wave.hs" #-}+      QC.forAll (QC.choose (0,1)) $ zeroDCOffset . Wave.trapezoid+  )+ DocTest.printPrefix "Synthesizer.Basic.Wave:1078: "+{-# LINE 1078 "src/Synthesizer/Basic/Wave.hs" #-}+ DocTest.property(+{-# LINE 1078 "src/Synthesizer/Basic/Wave.hs" #-}+        +   QC.forAll (QC.choose (0,1)) $ \w ->+   QC.forAll (QC.choose (-1,1)) $ \r ->+   zeroDCOffset $ Wave.trapezoidBalanced w r+  )
+ test/DocTest/Synthesizer/Causal/Analysis.hs view
@@ -0,0 +1,66 @@+-- Do not edit! Automatically created with doctest-extract from src/Synthesizer/Causal/Analysis.hs+{-# LINE 19 "src/Synthesizer/Causal/Analysis.hs" #-}++module DocTest.Synthesizer.Causal.Analysis where++import qualified Test.DocTest.Driver as DocTest++{-# LINE 20 "src/Synthesizer/Causal/Analysis.hs" #-}+import     qualified Synthesizer.Causal.Analysis as AnaC+import     qualified Synthesizer.Causal.Process as Causal+import     qualified Synthesizer.Plain.Analysis as Ana++import     Control.Arrow ((<<<))++import     qualified Data.NonEmpty.Class as NonEmptyC+import     qualified Data.NonEmpty as NonEmpty+import     qualified Data.List.Match as Match+import     qualified Data.List as List++import     qualified Test.QuickCheck as QC++import     NumericPrelude.Numeric+import     NumericPrelude.Base+import     Prelude ()++test :: DocTest.T ()+test = do+ DocTest.printPrefix "Synthesizer.Causal.Analysis:44: "+{-# LINE 44 "src/Synthesizer/Causal/Analysis.hs" #-}+ DocTest.property(+{-# LINE 44 "src/Synthesizer/Causal/Analysis.hs" #-}+        +   \xs ->+      Match.take xs (Ana.deltaSigmaModulation xs)+      ==+      Causal.apply AnaC.deltaSigmaModulation (xs::[Rational])+  )+ DocTest.printPrefix "Synthesizer.Causal.Analysis:61: "+{-# LINE 61 "src/Synthesizer/Causal/Analysis.hs" #-}+ DocTest.property(+{-# LINE 61 "src/Synthesizer/Causal/Analysis.hs" #-}+        +   \threshold xs ->+      Match.take xs (Ana.deltaSigmaModulationPositive threshold xs)+      ==+      Causal.apply+         (AnaC.deltaSigmaModulationPositive <<<+          Causal.feedConstFst threshold)+         (xs::[Rational])+  )+ DocTest.printPrefix "Synthesizer.Causal.Analysis:86: "+{-# LINE 86 "src/Synthesizer/Causal/Analysis.hs" #-}+ DocTest.property(+{-# LINE 86 "src/Synthesizer/Causal/Analysis.hs" #-}+        +   let movingMedian :: (Ord a) => Int -> [a] -> [a]+       movingMedian n =+         map (\xs -> List.sort xs !! div (length xs) 2) . NonEmpty.tail .+         NonEmptyC.zipWith (drop . max 0) (NonEmptyC.iterate succ (negate n)) .+         NonEmpty.inits++   in QC.forAll (QC.choose (1,20)) $ \n xs ->+         movingMedian n xs+         ==+         Causal.apply (AnaC.movingMedian n) (xs::[Char])+  )
+ test/DocTest/Synthesizer/Generic/Signal.hs view
@@ -0,0 +1,75 @@+-- Do not edit! Automatically created with doctest-extract from src/Synthesizer/Generic/Signal.hs+{-# LINE 72 "src/Synthesizer/Generic/Signal.hs" #-}++module DocTest.Synthesizer.Generic.Signal where++import Test.DocTest.Base+import qualified Test.DocTest.Driver as DocTest++{-# LINE 73 "src/Synthesizer/Generic/Signal.hs" #-}+import     qualified Synthesizer.Storable.Signal as SigSt+import     Synthesizer.Generic.Signal (delay, delayLoopOverlap)+import     Synthesizer.Generic.Filter.NonRecursive (amplify)+import     qualified Algebra.Additive as Additive+import     Data.Function (fix)+import     qualified Test.QuickCheck as QC++test :: DocTest.T ()+test = do+ DocTest.printPrefix "Synthesizer.Generic.Signal:749: "+{-# LINE 749 "src/Synthesizer/Generic/Signal.hs" #-}+ DocTest.example(+{-# LINE 749 "src/Synthesizer/Generic/Signal.hs" #-}+    delayLoopOverlap 5 (amplify 0.5) [1::Float]+  )+  [ExpectedLine [LineChunk "[1.0]"]]+ DocTest.printPrefix "Synthesizer.Generic.Signal:751: "+{-# LINE 751 "src/Synthesizer/Generic/Signal.hs" #-}+ DocTest.example(+{-# LINE 751 "src/Synthesizer/Generic/Signal.hs" #-}+    delayLoopOverlap 5 (amplify 0.5) [1,0,0,0,0::Float]+  )+  [ExpectedLine [LineChunk "[1.0,0.0,0.0,0.0,0.0]"]]+ DocTest.printPrefix "Synthesizer.Generic.Signal:753: "+{-# LINE 753 "src/Synthesizer/Generic/Signal.hs" #-}+ DocTest.example(+{-# LINE 753 "src/Synthesizer/Generic/Signal.hs" #-}+    delayLoopOverlap 5 (amplify 0.5) [1,0,0,0,0,0::Float]+  )+  [ExpectedLine [LineChunk "[1.0,0.0,0.0,0.0,0.0,0.5]"]]+ DocTest.printPrefix "Synthesizer.Generic.Signal:755: "+{-# LINE 755 "src/Synthesizer/Generic/Signal.hs" #-}+ DocTest.example(+{-# LINE 755 "src/Synthesizer/Generic/Signal.hs" #-}+    delayLoopOverlap 5 (amplify 0.5) [1,0,0,0,0,0,0,0,0::Float]+  )+  [ExpectedLine [LineChunk "[1.0,0.0,0.0,0.0,0.0,0.5,0.0,0.0,0.0]"]]+ DocTest.printPrefix "Synthesizer.Generic.Signal:758: "+{-# LINE 758 "src/Synthesizer/Generic/Signal.hs" #-}+ DocTest.property(+{-# LINE 758 "src/Synthesizer/Generic/Signal.hs" #-}+        +   QC.forAll (QC.choose (1,10)) $ \time ->+   QC.forAll (QC.choose (1,10)) $ \cs ->+   QC.forAll (QC.choose (0.5,1.0::Float)) $ \gain ->+   \xs ->+   delayLoopOverlap time (amplify gain) xs+   ==+   (SigSt.toList $+    delayLoopOverlap time (amplify gain) $+    SigSt.fromList (SigSt.chunkSize cs) xs)+  )+ DocTest.printPrefix "Synthesizer.Generic.Signal:770: "+{-# LINE 770 "src/Synthesizer/Generic/Signal.hs" #-}+ DocTest.property(+{-# LINE 770 "src/Synthesizer/Generic/Signal.hs" #-}+        +   let delayLoopOverlapProduce time proc xs =+         fix (zipWith (Additive.+) xs . delay Additive.zero time . proc)+   in QC.forAll (QC.choose (1,10)) $ \time ->+      QC.forAll (QC.choose (0.5,1.0)) $ \gain ->+      \xs ->+      delayLoopOverlap time (amplify gain) xs+      ==+      delayLoopOverlapProduce time (amplify gain) (xs :: [Float])+  )
+ test/DocTest/Synthesizer/Plain/Oscillator.hs view
@@ -0,0 +1,36 @@+-- Do not edit! Automatically created with doctest-extract from src/Synthesizer/Plain/Oscillator.hs+{-# LINE 36 "src/Synthesizer/Plain/Oscillator.hs" #-}++module DocTest.Synthesizer.Plain.Oscillator where++import qualified Test.DocTest.Driver as DocTest++{-# LINE 37 "src/Synthesizer/Plain/Oscillator.hs" #-}+import     qualified Synthesizer.Plain.Oscillator as Osci+import     qualified Synthesizer.Basic.Wave       as Wave++import     qualified Test.QuickCheck as QC++import     qualified Number.Ratio as Ratio+import     NumericPrelude.Numeric+import     NumericPrelude.Base+import     Prelude ()++test :: DocTest.T ()+test = do+ DocTest.printPrefix "Synthesizer.Plain.Oscillator:74: "+{-# LINE 74 "src/Synthesizer/Plain/Oscillator.hs" #-}+ DocTest.property(+{-# LINE 74 "src/Synthesizer/Plain/Oscillator.hs" #-}+        +   let waves =+         ("saw", Wave.saw) :+         ("square", Wave.square) :+         ("triangle", Wave.triangle) :+         [] in+   QC.forAllShow (QC.elements waves) fst $+   \(_,wave) freq phases0 ->+   let phases = map (% Ratio.denominator (freq::Rational)) phases0+   in Osci.phaseMod wave freq phases ==+      Osci.shapeMod (Wave.phaseOffset wave) zero freq phases+  )
+ test/DocTest/Synthesizer/Storable/Cut.hs view
@@ -0,0 +1,46 @@+-- Do not edit! Automatically created with doctest-extract from src/Synthesizer/Storable/Cut.hs+{-# LINE 36 "src/Synthesizer/Storable/Cut.hs" #-}++module DocTest.Synthesizer.Storable.Cut where++import qualified Test.DocTest.Driver as DocTest++{-# LINE 37 "src/Synthesizer/Storable/Cut.hs" #-}+import     qualified Synthesizer.Storable.Cut as CutSt+import     qualified Synthesizer.Storable.Signal as SigSt++import     qualified Synthesizer.Plain.Cut as Cut+import     qualified Synthesizer.Plain.Signal as Sig++import     qualified Data.EventList.Relative.TimeBody  as EventList+import     qualified Data.List.HT as ListHT++import     qualified Number.NonNegative as NonNeg++import     qualified Test.QuickCheck as QC++import     NumericPrelude.Numeric+import     NumericPrelude.Base+import     Prelude ()+++genEventList     :: QC.Gen (EventList.T NonNeg.Int (Sig.T Int))+genEventList     = fmap (EventList.mapTime (flip mod 1000)) QC.arbitrary++test :: DocTest.T ()+test = do+ DocTest.printPrefix "Synthesizer.Storable.Cut:61: "+{-# LINE 61 "src/Synthesizer/Storable/Cut.hs" #-}+ DocTest.property(+{-# LINE 61 "src/Synthesizer/Storable/Cut.hs" #-}+        +   \chunkSize ->+   QC.forAll genEventList $ \evs ->+   let sevs = EventList.mapBody (SigSt.fromList chunkSize) evs+   in  ListHT.allEqual $+       SigSt.fromList chunkSize (Cut.arrange evs) :+       CutSt.arrangeAdaptive chunkSize sevs :+       CutSt.arrangeList chunkSize sevs :+       CutSt.arrangeEquidist chunkSize sevs :+       []+  )
+ test/Test/Main.hs view
@@ -0,0 +1,50 @@+module Main where++import qualified DocTest.Main++import qualified Test.Sound.Synthesizer.Plain.Analysis       as Analysis+import qualified Test.Sound.Synthesizer.Plain.Control        as Control+import qualified Test.Sound.Synthesizer.Plain.Filter         as Filter+import qualified Test.Sound.Synthesizer.Plain.Filter.FirstOrder as Filt1+import qualified Test.Sound.Synthesizer.Plain.Interpolation  as Interpolation+import qualified Test.Sound.Synthesizer.Basic.NumberTheory   as NumberTheory+import qualified Test.Sound.Synthesizer.Basic.ToneModulation as ToneModulation+import qualified Test.Sound.Synthesizer.Plain.ToneModulation as ToneModulationL+import qualified Test.Sound.Synthesizer.Generic.ToneModulation as ToneModulationG+import qualified Test.Sound.Synthesizer.Generic.Permutation as Permutation+import qualified Test.Sound.Synthesizer.Generic.Fourier as Fourier+import qualified Test.Sound.Synthesizer.Generic.FourierInteger as FourierInteger+import qualified Test.Sound.Synthesizer.Generic.Filter  as FilterG+import qualified Test.Sound.Synthesizer.Generic.Cut  as CutG++import Data.Tuple.HT (mapFst, )++import qualified Test.QuickCheck as QC+import qualified Test.DocTest.Driver as DocTest+++prefix :: String -> [(String, QC.Property)] -> [(String, QC.Property)]+prefix msg =+   map (mapFst (\str -> msg ++ "." ++ str))++main :: IO ()+main =+   DocTest.run $+   (DocTest.Main.main >>) $+   mapM_ (\(msg,io) -> DocTest.printPrefix (msg++": ") >> DocTest.property io) $+   concat $+      prefix "Plain.Analysis"       Analysis.tests :+      prefix "Plain.Control"        Control.tests :+      prefix "Plain.Filter.FirstOrder" Filt1.tests :+      prefix "Plain.Filter"         Filter.tests :+      prefix "Plain.Interpolation"  Interpolation.tests :+      prefix "Generic.Cut"          CutG.tests :+      prefix "Basic.ToneModulation" ToneModulation.tests :+      prefix "Plain.ToneModulation" ToneModulationL.tests :+      prefix "Generic.ToneModulation" ToneModulationG.tests :+      prefix "Generic.Permutation"    Permutation.tests :+      prefix "Generic.Fourier"        Fourier.tests :+      prefix "Basic.NumberTheory"     NumberTheory.tests :+      prefix "Generic.FourierInteger" FourierInteger.tests :+      prefix "Generic.Filter"         FilterG.tests :+      []
+ test/Test/Sound/Synthesizer/Basic/NumberTheory.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Test.Sound.Synthesizer.Basic.NumberTheory (tests) where++import Synthesizer.Basic.NumberTheory (Order(Order), )+import qualified Synthesizer.Basic.NumberTheory as NT++import Control.Applicative ((<$>), )++import qualified Data.List.HT as ListHT+import qualified Data.Set as Set+import qualified Data.Bits as Bit++import qualified Test.QuickCheck as QC+import Test.QuickCheck (Testable, Arbitrary, arbitrary, property, )++import qualified Algebra.Absolute              as Absolute++import NumericPrelude.Numeric+import NumericPrelude.Base+import Prelude ()+++newtype Cardinal a = Cardinal a+   deriving (Show)++instance (Absolute.C a, Arbitrary a) => Arbitrary (Cardinal a) where+   arbitrary = fmap (Cardinal . abs) arbitrary+++newtype Positive a = Positive a+   deriving (Show)++instance (Absolute.C a, Arbitrary a) => Arbitrary (Positive a) where+   arbitrary = fmap (Positive . (1+) . abs) arbitrary+++newtype Prime = Prime Integer+   deriving (Show)++instance Arbitrary Prime where+   arbitrary = fmap Prime $ QC.suchThat (QC.choose (2,10000)) NT.isPrime+++newtype Big = Big Integer+   deriving (Show)++instance Arbitrary Big where+   arbitrary = do+      digits <- QC.listOf arbitrary+      -- negative digits yield numbers close to the maximum+      let maxi = 10^50+      return $ Big $+         foldl (\acc d -> mod (Bit.shiftL acc 16 + d) maxi) 0 digits+++simple ::+   (Testable t, Arbitrary (wrapper Integer), Show (wrapper Integer)) =>+   (wrapper Integer -> t) -> QC.Property+simple = property++tests :: [(String, QC.Property)]+tests =+   ("multiplicativeGenerator set vs. divisor",+      property $ \(Prime n) ->+         NT.multiplicativeGeneratorSet n+         ==+         NT.multiplicativeGeneratorDivisors n) :+   ("primitiveRootsOfUnity naive vs. power",+      simple $ \(Cardinal m) order ->+         NT.primitiveRootsOfUnityNaive m order+         ==+         NT.primitiveRootsOfUnityPower m order) :+   ("primitiveRootsOfUnity naive vs. fullorbit",+      simple $ \(Cardinal m) order ->+         NT.primitiveRootsOfUnityNaive m order+         ==+         (Set.toAscList $ Set.fromList $+          NT.primitiveRootsOfUnityFullOrbit m order)) :+   ("Carmichael theorem",+      simple $ \(Positive a) (Positive b) ->+         NT.getOrder (NT.maximumOrderOfPrimitiveRootsOfUnity (lcm a b))+         ==+         lcm+            (NT.getOrder (NT.maximumOrderOfPrimitiveRootsOfUnity a))+            (NT.getOrder (NT.maximumOrderOfPrimitiveRootsOfUnity b))) :+   ("maximumOrderOfPrimitiveRootsOfUnity naive vs. integer",+      simple $ \(Positive m) ->+         NT.maximumOrderOfPrimitiveRootsOfUnityNaive m+         ==+         NT.maximumOrderOfPrimitiveRootsOfUnityInteger m) :+   ("number of rootsOfUnityPower, lcm",+      simple $ \(Positive m) ao@(Order a) bo@(Order b) ->+         let g = length . NT.rootsOfUnityPower m+         in  g (Order $ lcm a b) == lcm (g ao) (g bo)) :+   ("ringsWithPrimitiveRootsOfUnityAndUnits: minimal modulus",+      property $ \order@(Order expo) ->+         {-+         Often equality holds, but not always.+         Smallest counter-example: expo=80.+         -}+         (head $ NT.ringsWithPrimitiveRootOfUnityAndUnit order)+         >=+         (head $ NT.ringsWithPrimitiveRootsOfUnityAndUnitsNaive+            [order] [expo])) :+   ("combine two rings with primitive roots of certain orders",+      property $ \m n ->+         let r = lcm+                   (head (NT.ringsWithPrimitiveRootOfUnityAndUnit m))+                   (head (NT.ringsWithPrimitiveRootOfUnityAndUnit n))+         in  NT.hasPrimitiveRootOfUnityInteger r m+             &&+             NT.hasPrimitiveRootOfUnityInteger r n) :+   ("combine many rings with primitive roots of certain orders",+      property $ 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)+             ==+             take 3 (NT.ringsWithPrimitiveRootsOfUnityAndUnitsNaive+                       [Order order] [order])) :+{-+Unfortunately rings with certain units cannot be combined+while maintaining these elements as units.++Counterexample:+   ringsWithPrimitiveRootOfUnityAndUnit 2 = 3:...+   ringsWithPrimitiveRootOfUnityAndUnit 3 = 7:...+   But in Z_{3·7} the number 3 is no unit.++   ("combine rings with certain units",+      property $ \(Positive m) (Positive n) ->+         let r = fromIntegral $ lcm+                (head (NT.ringsWithPrimitiveRootOfUnityAndUnit m))+                (head (NT.ringsWithPrimitiveRootOfUnityAndUnit n))+         in  PID.coprime r m && PID.coprime r n) :+-}+   ("number of roots of unity lcm",+      property $ \(Positive n) (Positive k) (Positive l) ->+         let orders = NT.ordersOfRootsOfUnityInteger !! (n-1)+         in  lcm (orders!!(k-1)) (orders!!(l-1))+             ==+             orders !! (lcm k l - 1)) :+   ("number of roots of unity vs. primitive roots",+      property $ \(Positive n) (Positive k) ->+         (sum $ map snd $+          filter (flip divides k . fst) $+          zip+             [1..]+             (NT.ordersOfPrimitiveRootsOfUnityInteger !! (n-1)))+         ==+         NT.ordersOfRootsOfUnityInteger !! (n-1) !! (k-1)) :+   ("divideByMaximumPower",+      QC.property $+         QC.forAll (QC.choose (2,10::Integer)) $ \b (Positive n) ->+         NT.divideByMaximumPower b n == NT.divideByMaximumPowerRecursive b n) :+   ("numbers3Smooth",+      QC.property $ ListHT.allEqual $ map (take 10000) $+         [NT.numbers3SmoothCorec, NT.numbers3SmoothFoldr, NT.numbers3SmoothSet]) :+   ("numbers5Smooth",+      QC.property $ ListHT.allEqual $ map (take 10000) $+         [NT.numbers5SmoothCorec, NT.numbers5SmoothFoldr, NT.numbers5SmoothSet]) :+   ("ceiling3Smooth vs. is3Smooth",+      property $ \(Positive n) -> NT.is3Smooth $ NT.ceiling3Smooth n) :+   ("ceiling5Smooth vs. is5Smooth",+      property $ \(Positive n) -> NT.is5Smooth $ NT.ceiling5Smooth n) :+   ("ceiling3Smooth vs. numbers3Smooth",+      property $ 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",+      property $ QC.forAll (QC.choose (0,500)) $ \k ->+         let (n0:n1:_) = drop k NT.numbers5Smooth+         in  NT.ceiling5Smooth n0 == n0+             &&+             NT.ceiling5Smooth (n0+1) == n1) :+   ("ceiling3Smooth naive vs. trace",+      property $ \(Positive n) ->+         NT.ceiling3SmoothNaive n == NT.ceiling3SmoothTrace n) :+   ("ceiling5Smooth naive vs. trace",+      property $ \(Positive n) ->+         NT.ceiling5SmoothNaive n == NT.ceiling5SmoothTrace n) :+   ("ceiling3Smooth scan vs. trace",+      property $ \(Big n) ->+         NT.ceiling3SmoothScan n == NT.ceiling3SmoothTrace n) :+   ("ceiling5Smooth scan vs. trace",+      property $ \(Big n) ->+         NT.ceiling5SmoothScan n == NT.ceiling5SmoothTrace n) :+   []
+ test/Test/Sound/Synthesizer/Basic/ToneModulation.hs view
@@ -0,0 +1,93 @@+module Test.Sound.Synthesizer.Basic.ToneModulation where++import qualified Synthesizer.Interpolation  as Interpolation+import Synthesizer.Interpolation (margin, )++import qualified Synthesizer.Basic.Phase          as Phase+import qualified Synthesizer.Basic.ToneModulation as ToneMod++import qualified Test.Sound.Synthesizer.Plain.Interpolation as InterpolationTest++import Test.QuickCheck (Property, property, Testable, (==>))++import qualified Number.NonNegative       as NonNeg++import qualified Algebra.RealField             as RealField+import qualified Algebra.Field                 as Field+++import NumericPrelude.Numeric+import NumericPrelude.Base+import Prelude ()+++untangleShapePhase :: (Field.C a, Eq a) =>+   Int -> a -> (a, a) -> Property+untangleShapePhase periodInt period c =+   period /= zero ==>+      ToneMod.untangleShapePhase periodInt period c ==+      ToneMod.untangleShapePhaseAnalytic periodInt period c++flattenShapePhase :: (RealField.C a) =>+   Int -> a -> (a, Phase.T a) -> Property+flattenShapePhase periodInt period c =+   period /= zero ==>+      ToneMod.flattenShapePhase periodInt period c ==+      ToneMod.flattenShapePhaseAnalytic periodInt period c+++-- * auxiliary property functions++{-+Although that looks like a too small value, it is actually right,+because numberLeap counts intervals of size periodInt, not single elements.+So numberLeap=2 like in linear interpolation means 2*periodInt.+-}+minLength ::+   Interpolation.T a v ->+   Interpolation.T a v ->+   Int -> NonNeg.Int -> Int+minLength ipLeap ipStep =+   minLengthMargin (margin ipLeap) (margin ipStep)++minLengthMargin ::+   Interpolation.Margin ->+   Interpolation.Margin ->+   Int -> NonNeg.Int -> Int+minLengthMargin marginLeap marginStep periodInt ext =+   ToneMod.interpolationNumber+      marginLeap marginStep periodInt ++   NonNeg.toNumber ext++++shapeLimits ::+   Interpolation.T a v ->+   Interpolation.T a v ->+   Int -> Int -> (Int, Int)+shapeLimits ipLeap ipStep periodInt len =+   ToneMod.shapeLimits+      (margin ipLeap) (margin ipStep)+      periodInt len++++testRationalLineIp :: Testable property =>+   (InterpolationTest.LinePreserving Rational Rational -> property) ->+   Property+testRationalLineIp f  =  property f++testRationalIp :: Testable property =>+   (InterpolationTest.T Rational Rational -> property) -> Property+testRationalIp f  =  property f+++tests :: [(String, Property)]+tests =+   ("untangleShapePhase",+      property $ \periodInt period ->+         untangleShapePhase periodInt (period :: Rational)) :+   ("flattenShapePhase",+      property $ \periodInt period ->+         flattenShapePhase periodInt (period :: Rational)) :+   []
+ test/Test/Sound/Synthesizer/Generic/Cut.hs view
@@ -0,0 +1,104 @@+module Test.Sound.Synthesizer.Generic.Cut (tests) where++import qualified Synthesizer.Generic.Cut as CutG+import qualified Synthesizer.Generic.Signal as SigG++import qualified Synthesizer.Storable.Signal as SigSt++import qualified Synthesizer.ChunkySize.Signal as SigChunky+import qualified Synthesizer.ChunkySize as ChunkySize++import qualified Data.StorableVector as SV+import qualified Data.StorableVector.Lazy.Pattern as SVP++import qualified Synthesizer.State.Signal as SigS++import qualified Data.EventList.Relative.BodyTime as EventList++import qualified Number.NonNegative as NonNeg+import qualified Number.NonNegativeChunky as Chunky++import qualified Numeric.NonNegative.Wrapper as NonNeg98++import Data.Tuple.HT (mapSnd, )++import Test.QuickCheck (Property, property)++import NumericPrelude.Numeric+import NumericPrelude.Base+import Prelude ()+++dropMarginRemLength :: NonNeg.Int -> NonNeg.Int -> [Int] -> Bool+dropMarginRemLength nn nm xs =+   let n = NonNeg.toNumber nn+       m = NonNeg.toNumber nm+       (k,ys) = CutG.dropMarginRem n m xs+   in  length xs - m == length ys - k++dropMarginRemState :: NonNeg.Int -> NonNeg.Int -> [Int] -> Bool+dropMarginRemState nn nm xs =+   let n = NonNeg.toNumber nn+       m = NonNeg.toNumber nm+   in  CutG.dropMarginRem n m (SigS.fromList xs)+       ==+       mapSnd SigS.fromList (CutG.dropMarginRem n m xs)++dropMarginRemSV :: NonNeg.Int -> NonNeg.Int -> [Int] -> Bool+dropMarginRemSV nn nm xs =+   let n = NonNeg.toNumber nn+       m = NonNeg.toNumber nm+   in  CutG.dropMarginRem n m (SV.pack xs)+       ==+       mapSnd SV.pack (CutG.dropMarginRem n m xs)++dropMarginRemSVL :: NonNeg.Int -> NonNeg.Int -> ChunkySize.T -> [Int] -> Bool+dropMarginRemSVL nn nm pat xs =+   let n = NonNeg.toNumber nn+       m = NonNeg.toNumber nm+   in  CutG.dropMarginRem n m+          (CutG.take (CutG.length pat) xs)+       ==+       mapSnd SigG.toList+          (CutG.dropMarginRem n m+             (SigChunky.fromState pat $+              SigG.toState xs :: SigSt.T Int))++dropMarginRemChunkySize ::+   NonNeg.Int -> NonNeg.Int -> ChunkySize.T -> Int -> Bool+dropMarginRemChunkySize nn nm pat x =+   let n = NonNeg.toNumber nn+       m = NonNeg.toNumber nm+   in  CutG.dropMarginRem n m pat+       ==+       mapSnd+          (ChunkySize.fromStorableVectorSize . SVP.length)+          (CutG.dropMarginRem n m+             (SVP.replicate (ChunkySize.toStorableVectorSize pat) x))++dropMarginRemPiecewise ::+   NonNeg.Int -> NonNeg.Int -> ChunkySize.T -> Int -> Bool+dropMarginRemPiecewise nn nm pat x =+   let n = NonNeg.toNumber nn+       m = NonNeg.toNumber nm+   in  CutG.dropMarginRem n m pat+       ==+       mapSnd+          (Chunky.fromChunks .+           map (\size -> ChunkySize.LazySize $ NonNeg98.toNumber size) .+           EventList.getTimes)+          (CutG.dropMarginRem n m+             (EventList.fromPairList $ map ((,) x) $+              map (\(ChunkySize.LazySize size) -> NonNeg98.fromNumber size) $+              Chunky.toChunks pat))+++tests :: [(String, Property)]+tests =+   ("dropMarginRemLength", property dropMarginRemLength) :+   ("dropMarginRemState", property dropMarginRemState) :+   ("dropMarginRemSV", property dropMarginRemSV) :+   ("dropMarginRemSVL", property dropMarginRemSVL) :+   ("dropMarginRemChunkySize", property dropMarginRemChunkySize) :+   ("dropMarginRemPiecewise", property dropMarginRemPiecewise) :+   []
+ test/Test/Sound/Synthesizer/Generic/Filter.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Test.Sound.Synthesizer.Generic.Filter (tests) where++import qualified Synthesizer.Generic.Filter.NonRecursive as FiltNRG+import qualified Synthesizer.Generic.Cyclic as Cyclic+import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.Generic.Cut as CutG+import qualified Synthesizer.Plain.Signal as Sig++import qualified Test.Sound.Synthesizer.Plain.NonEmpty as NonEmpty++import Test.QuickCheck (Testable, Property, property)++import qualified Algebra.Laws as Law++import NumericPrelude.Numeric+import NumericPrelude.Base+++simple ::+   (Testable t) =>+   (Sig.T Int -> t) -> Property+simple = property++(=|=) ::+   (Eq sig, CutG.Transform sig) =>+   sig -> sig -> Bool+x =|= y =+   CutG.take 100 x == CutG.take 100 y++tests :: [(String, Property)]+tests =+   ("identity",+      simple $ Law.identity FiltNRG.generic $ SigG.singleton one) :+   ("commutativity",+      simple $ Law.commutative FiltNRG.generic) :+   ("distributivity",+      simple $ Law.leftDistributive FiltNRG.generic SigG.mix) :+   ("karatsuba finite",+      simple $ \x y -> FiltNRG.generic x y == FiltNRG.karatsubaFinite (*) x y) :+   ("karatsuba finite-infinite",+      simple $ \x y -> FiltNRG.generic x y == FiltNRG.karatsubaFiniteInfinite (*) x y) :+   ("karatsuba infinite",+      simple $ \x y -> FiltNRG.generic x y == FiltNRG.karatsubaInfinite (*) x y) :+   ("karatsuba finite-infinite cycle",+      simple $ \x yn ->+         case NonEmpty.toInfiniteList yn of+            y -> FiltNRG.generic x y =|= FiltNRG.karatsubaFiniteInfinite (*) x y) :+   ("karatsuba infinite cycle",+      simple $ \x yn ->+         case NonEmpty.toInfiniteList yn of+            y -> FiltNRG.generic x y =|= FiltNRG.karatsubaInfinite (*) x y) :+   ("convolve triple",+      property $ \x y ->+         Cyclic.sumAndConvolveTriple x y ==+         Cyclic.sumAndConvolveTripleAlt x (y :: Cyclic.Triple Integer)) :+   ("periodic summation",+      simple $ \x y n ->+         let periodic = Cyclic.fromSignal (1 + abs n)+         in  Cyclic.convolve (periodic x) (periodic y) ==+             periodic (FiltNRG.generic x y)) :+   []
+ test/Test/Sound/Synthesizer/Generic/Fourier.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Test.Sound.Synthesizer.Generic.Fourier (tests) where++import qualified Synthesizer.Generic.Fourier as Fourier+import qualified Synthesizer.Generic.Cyclic as Cyclic+import qualified Synthesizer.Generic.Filter.NonRecursive as FiltNRG+import qualified Synthesizer.Generic.Analysis as AnaG+import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.Generic.Cut as CutG+import qualified Synthesizer.Storable.Signal as SigSt+import qualified Synthesizer.State.Signal as SigS++import qualified Test.QuickCheck as QC+import Test.QuickCheck (Testable, Arbitrary, arbitrary, property)+import Test.Utility (approxEqualAbs, approxEqualComplexAbs)++import qualified Number.Complex as Complex++import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive++import Control.Monad (liftM2, )++import NumericPrelude.Numeric+import NumericPrelude.Base+import Prelude ()+++tolerance :: Double+tolerance = 1e-10++normalize ::+   SigSt.T (Complex.T Double) -> SigSt.T (Complex.T Double)+normalize xs =+   FiltNRG.amplifyVector+      (recip $ max (0.1::Double) $ AnaG.volumeVectorMaximum xs) xs++newtype Normed = Normed (SigSt.T (Complex.T Double))+   deriving (Show)++instance Arbitrary Normed where+   arbitrary = fmap (Normed . normalize) arbitrary+++data Normed2 =+      Normed2+         (SigSt.T (Complex.T Double))+         (SigSt.T (Complex.T Double))+   deriving (Show)++instance Arbitrary Normed2 where+   arbitrary =+      liftM2+         (\x y ->+            let len = min (CutG.length x) (CutG.length y)+            in  Normed2+                   (normalize $ CutG.take len x)+                   (normalize $ CutG.take len y))+         arbitrary+         arbitrary+++-- could be moved to NumericPrelude+class Complex a where+   conjugate :: a -> a++instance (Additive.C a) => Complex (Complex.T a) where+   conjugate = Complex.conjugate++scalarProduct ::+   (SigG.Consume sig y, Ring.C y, Complex y) =>+   sig y -> sig y -> y+scalarProduct xs ys =+   SigS.sum $+   SigS.zipWith (*)+      (SigG.toState xs)+      (SigS.map conjugate $ SigG.toState ys)++(=~=) ::+   SigSt.T (Complex.T Double) ->+   SigSt.T (Complex.T Double) ->+   Bool+(=~=) xs ys =+   SigG.length xs == SigG.length ys &&+   (SigG.foldR (&&) True $+    SigG.zipWith (approxEqualComplexAbs tolerance) xs ys)++simple ::+   (Testable t) =>+   (SigSt.T (Complex.T Double) -> t) -> QC.Property+simple = property++tests :: [(String, QC.Property)]+tests =+   ("fourier inverse",+      property $ \(Normed x) ->+         x =~=+         (FiltNRG.amplify (recip $ fromIntegral $ SigG.length x) $+          Fourier.transformBackward $ Fourier.transformForward x)) :+   ("double fourier = reverse",+      property $ \(Normed x) ->+         x =~=+         (Cyclic.reverse $+          FiltNRG.amplify (recip $ fromIntegral $ SigG.length x) $+          Fourier.transformForward $+          Fourier.transformForward x)) :+   ("fourier of reverse",+      property $ \(Normed x) ->+         Cyclic.reverse (Fourier.transformForward x) =~=+         Fourier.transformForward (Cyclic.reverse x)) :+   ("fourier of conjugate",+      property $ \(Normed x) ->+         (SigG.map Complex.conjugate $ Fourier.transformForward x)+         =~=+         (Fourier.transformForward $+          SigG.map Complex.conjugate $ Cyclic.reverse x)) :+   ("additivity",+      property $ \(Normed2 x y) ->+         SigG.mix (Fourier.transformForward x) (Fourier.transformForward y)+         =~=+         Fourier.transformForward (SigG.mix x y)) :+   ("isometry",+      simple $ \xs x0 ->+         let x = normalize (SigG.cons x0 xs)+         in  approxEqualAbs tolerance+                (AnaG.volumeVectorEuclideanSqr $ Fourier.transformForward x)+                (fromIntegral (SigG.length x) *+                 AnaG.volumeVectorEuclideanSqr x)) :+   ("unitarity",+      property $ \(Normed2 x y) ->+         approxEqualComplexAbs tolerance+            (scalarProduct+               (Fourier.transformForward x) (Fourier.transformForward y))+            (fromIntegral (SigG.length x) * scalarProduct x y)) :+   ("convolution",+      property $ \(Normed2 x y) ->+         SigG.zipWith (*)+            (Fourier.transformForward x)+            (Fourier.transformForward y)+         =~=+         Fourier.transformForward (Cyclic.convolve x y)) :+   ("convolution cyclic",+      property $ \(Normed2 x y) ->+         Fourier.convolveCyclic x y+         =~=+         Cyclic.convolve x y) :+   ("convolution long",+      property $ \(Normed x) (Normed y) ->+         FiltNRG.karatsubaFinite (*) x y+         =~=+         Fourier.convolveWithWindow (Fourier.window x) y) :+   []
+ test/Test/Sound/Synthesizer/Generic/FourierInteger.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Test.Sound.Synthesizer.Generic.FourierInteger (tests) where++import qualified Synthesizer.Generic.Fourier as Fourier+import qualified Synthesizer.Generic.Cyclic as Cyclic+import qualified Synthesizer.Generic.Filter.NonRecursive as FiltNRG+import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.Generic.Cut as CutG+import qualified Synthesizer.State.Signal as SigS+import qualified Synthesizer.Plain.Signal as Sig++import Test.QuickCheck (Testable, Arbitrary, arbitrary, Property, property)++import qualified Synthesizer.Basic.NumberTheory as NT++import qualified Number.ResidueClass.Check as RC+import Number.ResidueClass.Check ((/:), )++import qualified Algebra.ToInteger             as ToInteger+import qualified Algebra.IntegralDomain        as Integral+import qualified Algebra.Ring                  as Ring++import Control.Monad (liftM2, )++import NumericPrelude.Numeric+import NumericPrelude.Base+import Prelude ()+++newtype Modulus a = Modulus a+   deriving (Show)++instance Ring.C a => Arbitrary (Modulus a) where+   arbitrary = fmap (Modulus . (2+) . fromInteger) arbitrary+++data ModularSignal =+      ModularSignal (Modulus Integer) (Sig.T (RC.T Integer))+   deriving (Show)++instance Arbitrary ModularSignal where+   arbitrary =+      fmap (uncurry ModularSignal . signal) arbitrary+++data ModularSignal2 =+      ModularSignal2+         (Modulus Integer) (Sig.T (RC.T Integer)) (Sig.T (RC.T Integer))+   deriving (Show)++instance Arbitrary ModularSignal2 where+   arbitrary =+      liftM2+         (\x y ->+            let len = min (CutG.length x) (CutG.length y)+                m = NT.fastFourierRing len+            in  ModularSignal2+                   (Modulus m)+                   (fmap (/: m) $ CutG.take len x)+                   (fmap (/: m) $ CutG.take len y))+         arbitrary+         arbitrary++scalarProduct ::+   Modulus Integer ->+   Sig.T (RC.T Integer) -> Sig.T (RC.T Integer) ->+   RC.T Integer+scalarProduct (Modulus m) xs ys =+   SigS.foldL (+) (RC.zero m) $+   SigS.zipWith (*)+      (SigG.toState xs)+      (SigG.toState ys)++signal ::+   Sig.T Integer -> (Modulus Integer, Sig.T (RC.T Integer))+signal xs =+   let m = NT.fastFourierRing $ length xs+   in  (Modulus m, fmap (/: m) xs)++modular ::+   (Integral.C a, ToInteger.C b) =>+   Modulus a -> b -> RC.T a+modular (Modulus m) =+   RC.fromRepresentative m . fromIntegral+++simple ::+   (Testable t) =>+   (Sig.T Integer -> t) -> Property+simple = property++tests :: [(String, Property)]+tests =+   ("fourier inverse",+      property $ \(ModularSignal m x) ->+         (Fourier.transformBackward $ Fourier.transformForward x)+         ==+         FiltNRG.amplify (modular m $ length x) x) :+   ("double fourier = reverse",+      property $ \(ModularSignal m x) ->+         (Cyclic.reverse $+          Fourier.transformForward $+          Fourier.transformForward x)+         ==+         FiltNRG.amplify (modular m $ length x) x) :+   ("fourier of reverse",+      property $ \(ModularSignal _m x) ->+         Cyclic.reverse (Fourier.transformForward x) ==+         Fourier.transformForward (Cyclic.reverse x)) :+   ("homogenity",+      property $ \(ModularSignal m x) y ->+         (FiltNRG.amplify (modular m (y::Integer)) $+          Fourier.transformForward x)+         ==+         (Fourier.transformForward $+          FiltNRG.amplify (modular m y) x)) :+   ("additivity",+      property $ \(ModularSignal2 _m x y) ->+         SigG.mix (Fourier.transformForward x) (Fourier.transformForward y)+         ==+         Fourier.transformForward (SigG.mix x y)) :+{-+   ("isometry",+      simple $ \xs x0 ->+         let (m,x) = signal (SigG.cons x0 xs)+         in  (AnaG.volumeVectorEuclideanSqr $ Fourier.transformForward x)+             ==+             (modular m (SigG.length x) *+              AnaG.volumeVectorEuclideanSqr x)) :+-}+   ("unitarity",+      property $ \(ModularSignal2 m x y) ->+         {-+         since there is no equivalent of a complex conjugate+         we have to take the scalar product with the backwards transform.+         -}+         scalarProduct m+            (Fourier.transformForward x) (Fourier.transformBackward y)+         ==+         modular m (length x) * scalarProduct m x y) :+   ("convolution",+      property $ \(ModularSignal2 _m x y) ->+         SigG.zipWith (*)+            (Fourier.transformForward x)+            (Fourier.transformForward y)+         ==+         Fourier.transformForward (Cyclic.convolve x y)) :+   ("convolution cyclic",+      property $ \(ModularSignal2 _m x y) ->+         Fourier.convolveCyclic x y+         ==+         Cyclic.convolve x y) :+   ("convolution long",+      simple $ \x0 y0 ->+         let m = Modulus $ NT.fastFourierRing $+                 2 * (NT.ceilingPowerOfTwo $ length x0)+             x = fmap (modular m) x0+             y = fmap (modular m) y0+         in  fmap (modular m) (FiltNRG.karatsubaFinite (*) x0 y0)+             ==+             Fourier.convolveWithWindow (Fourier.window x) y) :+   ("convolution long modular",+      simple $ \x0 y0 ->+         let m = Modulus $ NT.fastFourierRing $+                 2 * (NT.ceilingPowerOfTwo $ length x0)+             x = fmap (modular m) x0+             y = fmap (modular m) (y0 :: Sig.T Integer)+         in  FiltNRG.karatsubaFinite (*) x y+             ==+             Fourier.convolveWithWindow (Fourier.window x) y) :+   []
+ test/Test/Sound/Synthesizer/Generic/Permutation.hs view
@@ -0,0 +1,50 @@+{-+wish list:+ - custom Permutation type with Arbitrary instance+-}+{-# LANGUAGE NoImplicitPrelude #-}+module Test.Sound.Synthesizer.Generic.Permutation (tests) where++import qualified Synthesizer.Generic.Permutation as Permutation++import qualified Test.QuickCheck as QC+import Test.QuickCheck (property)++import NumericPrelude.Numeric+import NumericPrelude.Base+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, QC.Property)]+tests =+   ("inverse transposition",+      property $+      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",+      property $+      QC.forAll genRelPrime $ \(n,m) ->+         Permutation.inverse (Permutation.skewGrid n m)+         ==+         Permutation.skewGridInv n m) :+   ("inverse skewGridCRT",+      property $+      QC.forAll genRelPrime $ \(n,m) ->+         Permutation.inverse (Permutation.skewGridCRT n m)+         ==+         Permutation.skewGridCRTInv n m) :+   {-+   reverse (multiplicative (generator n) n)+   ==+   multiplicative (recip $ generator n) n+   -}+   []
+ test/Test/Sound/Synthesizer/Generic/ToneModulation.hs view
@@ -0,0 +1,303 @@+module Test.Sound.Synthesizer.Generic.ToneModulation (tests) where++import Test.Sound.Synthesizer.Basic.ToneModulation (+   minLength,+   minLengthMargin,+--   shapeLimits,+--   testRationalLineIp,+   testRationalIp,+   )++import qualified Synthesizer.Causal.ToneModulation as ToneModC+import qualified Synthesizer.Generic.Wave as WaveG++import qualified Synthesizer.Plain.Signal         as Sig+import qualified Synthesizer.Plain.Oscillator     as Osci+import qualified Synthesizer.Plain.Interpolation  as Interpolation+import qualified Synthesizer.Plain.ToneModulation as ToneModL+import qualified Synthesizer.Plain.Wave   as WaveL+import Synthesizer.Interpolation (marginNumber, )++import qualified Synthesizer.Causal.Oscillator as OsciC+import qualified Synthesizer.Causal.Process as Causal++import qualified Synthesizer.State.Signal as SigS++import qualified Synthesizer.Basic.Wave           as Wave+import qualified Synthesizer.Basic.Phase          as Phase++import qualified Test.Sound.Synthesizer.Plain.NonEmpty as NonEmpty+import qualified Test.Sound.Synthesizer.Plain.Interpolation as InterpolationTest++import Test.QuickCheck (Property, property, (==>))+import Test.Utility (ArbChar, )++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 NumericPrelude.Numeric+import NumericPrelude.Base+import Prelude ()+++limitMinRelativeValues ::+   Int -> Int -> [NonNeg.Int] -> Bool+limitMinRelativeValues xMin x0 xsnn =+   let xs = map NonNeg.toNumber xsnn+       (y0,limiter) = ToneModC.limitMinRelativeValues xMin x0+   in  (y0, Causal.apply limiter xs) ==+          ToneModL.limitMinRelativeValues xMin x0 xs++integrateFractional :: (RealField.C t) =>+   NonNeg.T t -> t -> Phase.T t -> [NonNeg.T t] -> [t] -> Property+integrateFractional+     periodNN shape0 phase shapesNN freqs =+   let shapes = map NonNeg.toNumber shapesNN+       period    = NonNeg.toNumber periodNN+       (c0, coordinator) =+          ToneModC.integrateFractional+             period (shape0, phase)+       coords =+          ToneModL.integrateFractional+             period (shape0, shapes) (phase, freqs)+   in  period /= zero  ==>+          c0 : Causal.apply coordinator (zip shapes freqs) ==+          coords++-- oscillatorCellSize :: (Show t, Show v, RealField.C t, Eq v) =>+oscillatorCellSize :: (RealField.C t, Eq v) =>+   Interpolation.Margin ->+   Interpolation.Margin ->+   NonNeg.Int -> NonNeg.T t ->+   NonNeg.Int -> NonEmpty.T v ->+   t -> t -> [NonNeg.T t] -> [t] ->+   Property+oscillatorCellSize+      marginLeap marginStep periodIntNN periodNN ext+      ixs shape0 phase shapesNN freqs =+   let shapes = map NonNeg.toNumber shapesNN+       period    = NonNeg.toNumber periodNN+       periodInt = NonNeg.toNumber periodIntNN+       len = minLengthMargin marginLeap marginStep periodInt ext+       tone = take len (NonEmpty.toInfiniteList ixs)+       resampledTone =+          ToneModC.oscillatorCells+             marginLeap marginStep periodInt period tone+             (shape0, Phase.fromRepresentative phase)+          `Causal.apply`+          zip shapes freqs+   in  period /= zero  &&+       marginNumber marginLeap > zero &&+       marginNumber marginStep > zero  ==>+       all+          ((\cell ->+              Sig.lengthAtLeast (marginNumber marginLeap) cell &&+              all (Sig.lengthAtLeast (marginNumber marginStep))+                  (take (marginNumber marginLeap) cell))+           . SigS.toList . snd)+          resampledTone++oscillatorSuffixes :: (RealField.C t, Eq v) =>+   Interpolation.Margin ->+   Interpolation.Margin ->+   NonNeg.Int -> NonNeg.T t ->+   NonNeg.Int -> NonEmpty.T v ->+   t -> t -> [NonNeg.T t] -> [t] ->+   Property+oscillatorSuffixes+      marginLeap marginStep periodIntNN periodNN ext+      ixs shape0 phase shapesNN freqs =+   let shapes = map NonNeg.toNumber shapesNN+       period    = NonNeg.toNumber periodNN+       periodInt = NonNeg.toNumber periodIntNN+       len = minLengthMargin marginLeap marginStep periodInt ext+       tone = take len (NonEmpty.toInfiniteList ixs)+       resampledToneA =+          init $+          map (\(sp,cell) ->+             (sp, takeWhileJust . map (fmap fst . viewL) $ cell)) $+          ToneModL.oscillatorSuffixes+             marginLeap marginStep periodInt period tone+             (shape0, shapes) (Phase.fromRepresentative phase, freqs)+       resampledToneB =+          ToneModC.oscillatorSuffixes+             marginLeap marginStep periodInt period tone+             (shape0, Phase.fromRepresentative phase)+          `Causal.apply`+          zip shapes freqs+   in  period /= zero  &&+       periodInt /= zero  &&+       marginNumber marginLeap > zero &&+       marginNumber marginStep > zero  ==>+          resampledToneA == resampledToneB++oscillatorCells :: (RealField.C t, Eq v) =>+   Interpolation.Margin ->+   Interpolation.Margin ->+   NonNeg.Int -> NonNeg.T t ->+   NonNeg.Int -> NonEmpty.T v ->+   t -> t -> [NonNeg.T t] -> [t] ->+   Property+oscillatorCells+      marginLeap marginStep periodIntNN periodNN ext+      ixs shape0 phase shapesNN freqs =+   let shapes = map NonNeg.toNumber shapesNN+       period    = NonNeg.toNumber periodNN+       periodInt = NonNeg.toNumber periodIntNN+       len = minLengthMargin marginLeap marginStep periodInt ext+       tone = take len (NonEmpty.toInfiniteList ixs)+       resampledToneA =+          init $ map (mapSnd List.transpose) $+          ToneModL.oscillatorCells+             marginLeap marginStep periodInt period tone+             (shape0, shapes) (Phase.fromRepresentative phase, freqs)+       resampledToneB =+          map (mapSnd SigS.toList) $+          ToneModC.oscillatorCells+             marginLeap marginStep periodInt period tone+             (shape0, Phase.fromRepresentative phase)+          `Causal.apply`+          zip shapes freqs+   in  period /= zero  &&+       periodInt /= zero  &&+       marginNumber marginLeap > zero &&+       marginNumber marginStep > zero  ==>+          resampledToneA == resampledToneB+{-+Margin {marginNumber = 1, marginOffset = 2}+Margin {marginNumber = 5, marginOffset = 5}+3 % 4+0+('\DEL',['~','~','"'])+-2 % 5+2 % 5+[2 % 1,3 % 4]+[-5 % 2,-1 % 2]+-}++{- |+'WaveL.sampledTone' and 'WaveG.sampledTone'+do not only differ in the signal types they process,+but also in the way they order the signal values.+The cells for 'WaveL.sampledTone' are transposed+with respect to 'WaveG.sampledTone'.+-}+sampledTone :: (RealField.C a, Eq v) =>+   InterpolationTest.T a v ->+   InterpolationTest.T a v ->+   NonNeg.T a -> NonNeg.Int -> NonEmpty.T v ->+   a -> Phase.T a -> Property+sampledTone =+   InterpolationTest.use2 $ \ ipLeap ipStep+         periodNN ext ixs shape phase ->+   let period = NonNeg.toNumber periodNN+       periodInt = round period+       len = minLength ipLeap ipStep periodInt ext+       tone = take len (NonEmpty.toInfiniteList ixs)+   in  period /= zero ==>+          WaveG.sampledTone ipLeap ipStep period tone shape `Wave.apply` phase ==+          WaveL.sampledTone ipLeap ipStep period tone shape `Wave.apply` phase++++shapeFreqModFromSampledTone :: (RealField.C t, Eq v) =>+   InterpolationTest.T t v ->+   InterpolationTest.T t v ->+   NonNeg.T t ->+   NonNeg.Int -> NonEmpty.T v ->+   t -> Phase.T t -> [NonNeg.T t] -> [t] ->+   Property+shapeFreqModFromSampledTone =+   InterpolationTest.use2 $ \ ipLeap ipStep+         periodNN ext ixs shape0 phase shapesNN freqs ->+   let shapes = map NonNeg.toNumber shapesNN+       period = NonNeg.toNumber periodNN+       periodInt = round period+       len = minLength ipLeap ipStep periodInt ext+       tone = take len (NonEmpty.toInfiniteList ixs)+       resampledToneA =+          init $+          Osci.shapeFreqModFromSampledTone ipLeap ipStep period tone+             shape0 (Phase.toRepresentative phase) shapes freqs+       resampledToneB =+          OsciC.shapeFreqModFromSampledTone+             ipLeap ipStep period tone shape0 phase+          `Causal.apply`+          zip shapes freqs+   in  period /= zero  ==>+          resampledToneA == resampledToneB+++{-+We have a problem here with the phase distortion signal,+because frequency and shape modulation control signals+are delayed by one element with respect to the phase distortion.+How can we cope with different lengths of the control signals,+without padding the phase control with zeros?+This one did not work:+   phaseDistorts = pd:pds+   resampledToneA =+      Osci.shapePhaseFreqModFromSampledTone ipLeap ipStep period tone+         shape0 (Phase.toRepresentative phase) shapes (init phaseDistorts) freqs+-}+shapePhaseFreqModFromSampledTone :: (RealField.C t, Eq v) =>+   InterpolationTest.T t v ->+   InterpolationTest.T t v ->+   NonNeg.T t ->+   NonNeg.Int -> NonEmpty.T v ->+   t -> Phase.T t -> [NonNeg.T t] -> (t,[t]) -> [t] ->+   Property+shapePhaseFreqModFromSampledTone =+   InterpolationTest.use2 $ \ ipLeap ipStep+         periodNN ext ixs shape0 phase shapesNN (pd,pds) freqs ->+   let period = NonNeg.toNumber periodNN+       periodInt = round period+       len = minLength ipLeap ipStep periodInt ext+       tone = take len (NonEmpty.toInfiniteList ixs)+       shapes = map NonNeg.toNumber shapesNN+       phaseDistorts = pd:pds ++ repeat zero+       resampledToneA =+          init $+          Osci.shapePhaseFreqModFromSampledTone ipLeap ipStep period tone+             shape0 (Phase.toRepresentative phase) shapes phaseDistorts freqs+       resampledToneB =+          OsciC.shapePhaseFreqModFromSampledTone+             ipLeap ipStep period tone shape0 phase+          `Causal.apply`+          zip3 shapes phaseDistorts freqs+   in  period /= zero  ==>+          resampledToneA == resampledToneB++++tests :: [(String, Property)]+tests =+   ("limitMinRelativeValues", property limitMinRelativeValues) :+   ("integrateFractional",+      property (\period -> integrateFractional (period :: NonNeg.Rational))) :+   ("oscillatorCellSize",+      property (\ml ms periodInt period ext ixs ->+               oscillatorCellSize ml ms periodInt (period :: NonNeg.Rational)+                  ext (ixs :: NonEmpty.T ArbChar))) :+   ("oscillatorSuffixes",+      property (\ml ms periodInt period ext ixs ->+               oscillatorSuffixes ml ms periodInt (period :: NonNeg.Rational)+                  ext (ixs :: NonEmpty.T ArbChar))) :+   ("oscillatorCells",+      property (\ml ms periodInt period ext ixs ->+               oscillatorCells ml ms periodInt (period :: NonNeg.Rational)+                  ext (ixs :: NonEmpty.T ArbChar))) :+   ("sampledTone",+      testRationalIp sampledTone) :+   ("shapeFreqModFromSampledTone",+      testRationalIp shapeFreqModFromSampledTone) :+   ("shapePhaseFreqModFromSampledTone",+      testRationalIp shapePhaseFreqModFromSampledTone) :+   []
+ test/Test/Sound/Synthesizer/Plain/Analysis.hs view
@@ -0,0 +1,168 @@+module Test.Sound.Synthesizer.Plain.Analysis (tests) where++import qualified Synthesizer.Plain.Analysis as Analysis++import qualified Algebra.Algebraic             as Algebraic+import qualified Algebra.RealField             as RealField+import qualified Algebra.Field                 as Field+import qualified Algebra.RealRing              as RealRing++import qualified Algebra.NormedSpace.Maximum   as NormedMax+import qualified Algebra.NormedSpace.Euclidean as NormedEuc+import qualified Algebra.NormedSpace.Sum       as NormedSum++import qualified MathObj.LaurentPolynomial as LPoly++import qualified Data.NonEmpty as NonEmpty+import Data.List (genericLength)++import qualified Test.QuickCheck as QC+import Test.QuickCheck (Property, property, (==>))+import Test.Utility (approxEqual)++import NumericPrelude.Numeric+import NumericPrelude.Base+import Prelude ()+++volumeVectorMaximum :: (NormedMax.C y y, RealRing.C y) => [y] -> Bool+volumeVectorMaximum xs =+   Analysis.volumeVectorMaximum xs == Analysis.volumeMaximum xs++volumeVectorEuclidean ::+   (NormedEuc.C y y, Algebraic.C y, Eq y) =>+   NonEmpty.T [] y -> Bool+volumeVectorEuclidean xs =+   let ys = NonEmpty.flatten xs+   in  Analysis.volumeVectorEuclidean ys == Analysis.volumeEuclidean ys++volumeVectorEuclideanSqr ::+   (NormedEuc.Sqr y y, Field.C y, Eq y) =>+   NonEmpty.T [] y -> Bool+volumeVectorEuclideanSqr xs =+   let ys = NonEmpty.flatten xs+   in  Analysis.volumeVectorEuclideanSqr ys == Analysis.volumeEuclideanSqr ys++volumeVectorSum ::+   (NormedSum.C y y, RealField.C y) =>+   NonEmpty.T [] y -> Bool+volumeVectorSum xs =+   let ys = NonEmpty.flatten xs+   in  Analysis.volumeVectorSum ys == Analysis.volumeSum ys++++bounds :: Ord a => NonEmpty.T [] a -> Bool+bounds xs =+   Analysis.bounds xs  ==  (NonEmpty.minimum xs, NonEmpty.maximum xs)+++spread :: RealField.C a => (a,a) -> Bool+spread b =+   sum (map snd (Analysis.spread b)) == one+++histogramDiscrete :: NonEmpty.T [] Int -> Bool+histogramDiscrete xs =+   Analysis.histogramDiscreteArray xs ==+   Analysis.histogramDiscreteIntMap xs++withEmptyHistogram ::+   (NonEmpty.T [] y -> (Int, [y])) ->+   [y] -> (Int, [y])+withEmptyHistogram f =+   maybe (error "no bounds", []) f . NonEmpty.fetch++histogramDiscreteLength :: [Int] -> Bool+histogramDiscreteLength xs =+   sum (snd (withEmptyHistogram Analysis.histogramDiscreteIntMap xs))+   ==+   length xs++histogramDiscreteConcat :: [Int] -> [Int] -> Bool+histogramDiscreteConcat xs ys =+   let xHist = withEmptyHistogram Analysis.histogramDiscreteIntMap xs+       yHist = withEmptyHistogram Analysis.histogramDiscreteIntMap ys+       xyHist0 =+          LPoly.add+             (uncurry LPoly.Cons xHist)+             (uncurry LPoly.Cons yHist)+       xyHist1 =+          uncurry LPoly.Cons+             (withEmptyHistogram Analysis.histogramDiscreteIntMap (xs++ys))+   in  if null (LPoly.coeffs xyHist0)+         then LPoly.coeffs xyHist0 == LPoly.coeffs xyHist1+         else xyHist0 == xyHist1+++histogramLinear :: NonEmpty.T [] Int -> Bool+histogramLinear xs =+   let ys = fmap fromIntegral xs :: NonEmpty.T [] Double+   in  Analysis.histogramLinearArray ys ==+       Analysis.histogramLinearIntMap ys+++histogramLinearLength :: NonEmpty.T [] Int -> Bool+histogramLinearLength xs =+   let ys = fmap fromIntegral xs :: NonEmpty.T [] Double+   in  approxEqual 1e-10+          (genericLength $ NonEmpty.tail ys)+          (sum (snd (Analysis.histogramLinearIntMap ys)))+{-+With eps = 1e-15++Falsifiable, after 83 tests:+-20+[32,-41,11,-25,-17,-27,32,-36,7,-36,38]++Falsifiable, after 78 tests:+10+[-35,-28,-28,-24,-4,-29,-14,-29,-20,7,33,-2,-14,-4,7,-40,-5,-12]+-}++++centroid :: (Field.C a, Eq a) => [a] -> Property+centroid xs =+   sum xs /= zero ==>+      Analysis.centroid xs == Analysis.centroidAlt xs+-- Test.QuickCheck.property (\xs -> sum xs /= 0 Test.QuickCheck.==> propCentroid (xs::[Rational]))++histogramDCOffset :: NonEmpty.T (NonEmpty.T []) Int -> Property+histogramDCOffset xs =+   let x1 = NonEmpty.flatten xs+       x  = NonEmpty.flatten x1+       (offset, hist) = Analysis.histogramDiscreteArray x1+   in  sum x /= 0 ==>+          fromIntegral offset + Analysis.centroid (map fromIntegral hist) ==+          (Analysis.directCurrentOffset (map fromIntegral x) :: Rational)+++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, Property)]+tests =+   ("volumeVectorMaximum", property (volumeVectorMaximum :: [Rational] -> Bool)) :+   -- property may fail due to rounding errors, but so far the computation is exactly the same+   ("volumeVectorEuclidean", property (volumeVectorEuclidean :: NonEmpty.T [] Double -> Bool)) :+   ("volumeVectorEuclideanSqr", property (volumeVectorEuclideanSqr :: NonEmpty.T [] Rational -> Bool)) :+   ("volumeVectorSum", property (volumeVectorSum :: NonEmpty.T [] Rational -> Bool)) :+   ("bounds", property (bounds :: NonEmpty.T [] Rational -> Bool)) :+   ("spread", property (spread :: (Rational,Rational) -> Bool)) :+   ("histogramDiscrete", property (forAllSmall histogramDiscrete)) :+   ("histogramDiscreteLength", property (forAllSmall histogramDiscreteLength)) :+   ("histogramDiscreteConcat",+      property $ forAllSmall $ \x -> forAllSmall $ \y ->+         histogramDiscreteConcat x y) :+   ("histogramLinear", property (forAllSmall histogramLinear)) :+   ("histogramLinearLength", property (forAllSmall histogramLinearLength)) :+   ("centroid", property (centroid :: [Rational] -> Property)) :+   ("histogramDCOffset", property (forAllSmall histogramDCOffset)) :+   []
+ test/Test/Sound/Synthesizer/Plain/Control.hs view
@@ -0,0 +1,96 @@+module Test.Sound.Synthesizer.Plain.Control (tests) where++import qualified Synthesizer.Plain.Control as Control++import qualified Test.QuickCheck as QC+import Test.QuickCheck (Property, property, (==>))+import Test.Utility (approxEqualListAbs, approxEqualListRel)++import qualified Data.List.HT as ListHT+import Data.List (transpose)++import NumericPrelude.Numeric+import NumericPrelude.Base+import Prelude ()+++linearRing :: Int -> Int -> Bool+linearRing d y0 =+--   Control.linear d y0  ==  Control.linearMultiscale d y0+   all ListHT.allEqual $ take 100 $ transpose $+      Control.linear d y0 :+      Control.linearMultiscale d y0 :+      Control.linearStable d y0 :+      []++{-+*Synthesizer.Plain.Control> propLinearApprox (-2/3) 2+False++Need a different definition of approximate equality.+-}+linearApprox :: Double -> Double -> Bool+linearApprox d y0 =+   all (approxEqualListAbs (1e-10 * max (abs d) (abs y0))) $+   take 100 $ transpose $+      Control.linear d y0 :+      Control.linearMean d y0 :+      Control.linearMultiscale d y0 :+      Control.linearStable d y0 :+      []++linearExact :: Rational -> Rational -> Bool+linearExact d y0 =+   all ListHT.allEqual $ take 100 $ transpose $+      Control.linear d y0 :+      Control.linearMean d y0 :+      Control.linearMultiscale d y0 :+      Control.linearStable d y0 :+      []++exponential :: Double -> Property+exponential y0 =+   QC.forAll (QC.choose (10,1000)) $ \time ->+   all (approxEqualListRel (1e-10)) $ take 100 $ transpose $+      Control.exponential time y0 :+      Control.exponentialMultiscale time y0 :+      Control.exponentialStable time y0 :+      []++exponential2 :: Double -> Property+exponential2 y0 =+   QC.forAll (QC.choose (10,1000)) $ \time ->+   all (approxEqualListRel (1e-10)) $ take 100 $ transpose $+      Control.exponential2 time y0 :+      Control.exponential2Multiscale time y0 :+      Control.exponential2Stable time y0 :+      []++cosine :: Double -> Double -> Property+cosine t0 t1  =  t0/=t1 ==>+   all (approxEqualListAbs (1e-10)) $+   take 100 $ transpose $+      Control.cosine t0 t1 :+      Control.cosineMultiscale t0 t1 :+      Control.cosineStable t0 t1 :+      []+++cubic :: (Rational, (Rational, Rational)) ->+   (Rational, (Rational, Rational)) -> Property+cubic node0 node1  =  fst node0 /= fst node1 ==>+   take 100 (Control.cubicHermite node0 node1)  ==+   take 100 (Control.cubicHermiteStable node0 node1)++++tests :: [(String, Property)]+tests =+   ("linearRing", property linearRing) :+   ("linearApprox", property linearApprox) :+   ("linearExact", property linearExact) :+   ("exponential", property exponential) :+   ("exponential2", property exponential2) :+   ("cosine", property cosine) :+   ("cubic", property cubic) :+   []
+ test/Test/Sound/Synthesizer/Plain/Filter.hs view
@@ -0,0 +1,202 @@+module Test.Sound.Synthesizer.Plain.Filter (tests) where++import qualified Synthesizer.Plain.Filter.Recursive.MovingAverage as MA+import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR+import qualified Synthesizer.Plain.Signal as Sig+import qualified Synthesizer.Generic.Filter.NonRecursive as FiltNRG+import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.Storable.Filter.NonRecursive as FiltNRSt+import qualified Synthesizer.Storable.Signal as SigSt+import qualified Synthesizer.Causal.Filter.NonRecursive as FiltNRC+import qualified Synthesizer.Causal.Process as Causal+import qualified Synthesizer.Frame.Stereo as Stereo++import qualified Data.StorableVector.Lazy.Typed as SVT++import Foreign.Storable.Tuple ()++import qualified Test.Sound.Synthesizer.Plain.NonEmpty as NonEmpty++import qualified Test.QuickCheck as QC+import Test.QuickCheck (Property, arbitrary, property, )+import Test.Utility (ArbChar)++import qualified Number.GaloisField2p32m5 as GF+import qualified Number.NonNegative       as NonNeg++import Control.Applicative ((<$>), )++import qualified Data.List.HT as ListHT+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 :: 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,+       -- if one list is empty+       and $ zipWith3 (\x y z -> x==y && y==z) naive rec pyramid+       -- ListHT.allEqual $ naive : pyramid : rec : []++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+             (SigSt.fromList SigSt.defaultChunkSize xs)+   in  ListHT.allEqual $+       FiltNR.sumRange xs rng :+       FiltNR.sumRangeFromPyramid pyr rng :+       FiltNR.sumRangeFromPyramidRec pyr rng :+       FiltNR.sumRangeFromPyramidFoldr pyr rng :+       FiltNRG.sumRangeFromPyramid pyrSt rng :+       FiltNRG.sumRangeFromPyramidFoldr pyrSt rng :+       FiltNRG.sumRangeFromPyramidReverse pyrSt rng :+       []++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  ListHT.allEqual $+       FiltNR.getRangeFromPyramid pyr rng :+       FiltNRG.consumeRangeFromPyramid (:) [] pyr rng :+       []++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+   in  ListHT.allEqual $+       FiltNR.sumsPosModulated ctrl xs :+       FiltNR.sumsPosModulatedPyramid height ctrl xs :+       FiltNRG.sumsPosModulatedPyramid height ctrl xs :+       SigSt.toList+          (vectorLazyFromTyped+             (FiltNRG.sumsPosModulatedPyramid+                height (SVT.pack ctrl) (SVT.pack xs))) :+       SigSt.toList+          (FiltNRSt.sumsPosModulatedPyramid+             height+             (SigSt.fromList SigSt.defaultChunkSize ctrl)+             (SigSt.fromList SigSt.defaultChunkSize xs)) :+       Causal.apply+          (FiltNRC.sumsPosModulatedFromPyramid $+           FiltNRSt.pyramid (+) height $+           SigSt.fromList SigSt.defaultChunkSize xs)+          ctrl :+       []++minPosModulated :: Sig.T (Size, Size) -> NonEmpty.T Int -> Property+minPosModulated nctrl xsc =+   QC.forAll (QC.choose (0,10)) $ \height ->+   let ctrl =+          map+             ((\(nl,nr) -> (nl, if nl==nr then nr+1 else nr))+              .+              mapPair (getSize, getSize))+             nctrl+       xs = NonEmpty.toInfiniteList xsc+   in  ListHT.allEqual $+       zipWith FiltNR.minRange (List.tails xs) ctrl :+       SigSt.toList+          (FiltNRSt.accumulateBinPosModulatedPyramid min height+             (SigSt.fromList SigSt.defaultChunkSize ctrl)+             (SigSt.fromList SigSt.defaultChunkSize xs)) :+       []+++genChunkyVector :: QC.Gen (SVT.DefaultVector Int)+genChunkyVector = SVT.fromChunks <$> arbitrary++vectorLazyFromTyped :: SVT.DefaultVector a -> SigSt.T a+vectorLazyFromTyped = SVT.toVectorLazy++downSample2 :: Property+downSample2 =+   QC.forAll genChunkyVector $ \xs ->+   ListHT.allEqual $+      vectorLazyFromTyped (FiltNRG.downsample2 xs) :+      FiltNRSt.downsample2 (vectorLazyFromTyped xs) :+      []++sumsDownSample2 :: Property+sumsDownSample2 =+   QC.forAll genChunkyVector $ \xs ->+   ListHT.allEqual $+      vectorLazyFromTyped (FiltNRG.sumsDownsample2 xs) :+      FiltNRSt.sumsDownsample2 (vectorLazyFromTyped xs) :+      FiltNRSt.sumsDownsample2Alt (vectorLazyFromTyped xs) :+      []++{-+sumsDownSample2 :: [VP.ChunkSize] -> NonEmpty.T Int -> Bool+sumsDownSample2 lazySize xsc =+   let len = Chunky.fromChunks $ filter (0/=) lazySize+       xs = VP.pack len $ NonEmpty.toInfiniteList xsc+   in  ListHT.allEqual $+       FiltNRG.sumsDownsample2 SigG.defaultLazySize xs :+       FiltNRSt.sumsDownsample2 xs :+       FiltNRSt.sumsDownsample2Alt xs :+       []+-}++movingAverageModulatedPyramid ::+   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+       onegf :: GF.T+       onegf = one+   in  ListHT.allEqual $+       pack (FiltNR.movingAverageModulatedPyramid onegf+          height maxC ctrl (cycle xs)) :+       vectorLazyFromTyped+          (FiltNRG.movingAverageModulatedPyramid onegf+             height maxC (SVT.pack ctrl) (SigG.cycle $ SVT.pack xs)) :+       FiltNRSt.movingAverageModulatedPyramid onegf+          height maxC (pack ctrl) (SigG.cycle $ pack xs) :+       []+++tests :: [(String, QC.Property)]+tests =+   ("sums", property sums) :+   ("sumRange", property sumRange) :+   ("getRange", property getRange) :+   ("sumsPosModulated", property sumsPosModulated) :+   ("minPosModulated", property minPosModulated):+   ("downSample2", property downSample2) :+   ("sumsDownSample2", property sumsDownSample2) :+   ("movingAverageModulatedPyramid", property movingAverageModulatedPyramid) :+   []
+ test/Test/Sound/Synthesizer/Plain/Filter/Allpass.hs view
@@ -0,0 +1,55 @@+module Test.Sound.Synthesizer.Plain.Filter.Allpass (tests) where++import qualified Synthesizer.Plain.Filter.Recursive.Allpass as Allpass+import qualified Synthesizer.Plain.Signal as Sig++import qualified Number.NonNegative as NonNeg++import Test.QuickCheck (Property, property)++import qualified Data.List.HT as ListHT++import Control.Monad.Trans.State (runState)++-- import qualified Algebra.Module                as Module+-- import qualified Algebra.RealField             as RealField+-- import qualified Algebra.Ring                  as Ring+-- import qualified Algebra.Additive              as Additive++import NumericPrelude.Numeric+import NumericPrelude.Base+import Prelude ()+++{- this will not work due to the poles+parameter :: Double -> Double -> Bool+parameter phase freq =+   approxEqual eps phase+      (Allpass.makePhase (Allpass.parameter phase freq) freq)+-}+++cascadeStep :: Rational -> Rational -> (Rational, Rational, [Rational]) -> Bool+cascadeStep k u (s0,s1,ns) =+   let p = Allpass.Parameter k+       s = s0:s1:ns+   in  ListHT.allEqual $+          runState (Allpass.cascadeStepStack p u) s :+          runState (Allpass.cascadeStepRec p u) s :+          runState (Allpass.cascadeStepScanl p u) s :+          []+++cascade :: NonNeg.Int -> Sig.T Rational -> Sig.T Rational -> Bool+cascade order ks xs =+   let ps = map Allpass.Parameter ks+       n = NonNeg.toNumber order+   in  Allpass.cascadeState n ps xs ==+       Allpass.cascadeIterative n ps xs+++tests :: [(String, Property)]+tests =+   ("cascadeStep", property cascadeStep) :+   ("cascade", property cascade) :+   []
+ test/Test/Sound/Synthesizer/Plain/Filter/FirstOrder.hs view
@@ -0,0 +1,73 @@+module Test.Sound.Synthesizer.Plain.Filter.FirstOrder (tests) where++import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1+import qualified Synthesizer.Plain.Signal as Sig+import qualified Synthesizer.Causal.Process as Causal++import Test.QuickCheck (Property, property)++import qualified Number.GaloisField2p32m5 as GF++import Control.Applicative ((<$), )++import NumericPrelude.Numeric+import NumericPrelude.Base+import Prelude ()++++addLowHighpass :: Sig.T (Filt1.Parameter GF.T, GF.T) -> Bool+addLowHighpass pxs =+   let (ps, xs) = unzip pxs+   in  Filt1.lowpass ps xs + Filt1.highpass ps xs == xs++combineLowHighpass :: Sig.T (Filt1.Parameter GF.T) -> Sig.T GF.T -> Bool+combineLowHighpass ps xs =+   zipWith Filt1.Result (Filt1.highpass ps xs) (Filt1.lowpass ps xs)+   ==+   Causal.apply Filt1.causal (zip ps xs)+++lowpassId :: Sig.T GF.T -> Bool+lowpassId xs =+   Filt1.lowpass (repeat $ Filt1.Parameter (zero::GF.T)) xs == xs++lowpassZero :: Sig.T GF.T -> Bool+lowpassZero xs =+   Filt1.lowpass (repeat $ Filt1.Parameter (one::GF.T)) xs == (zero <$ xs)+--   isZero $ Filt1.lowpass (repeat $ Filt1.Parameter (one::GF.T)) xs++highpassId :: Sig.T GF.T -> Bool+highpassId xs =+   Filt1.highpass (repeat $ Filt1.Parameter (one::GF.T)) xs == xs++highpassZero :: Sig.T GF.T -> Bool+highpassZero xs =+   Filt1.highpass (repeat $ Filt1.Parameter (zero::GF.T)) xs == (zero <$ xs)+++lowpassConst :: Sig.T GF.T -> GF.T -> Bool+lowpassConst ks x =+   Filt1.lowpassInit x (map Filt1.Parameter ks) (repeat x) == (x <$ ks)++highpassConst :: Sig.T GF.T -> GF.T -> Bool+highpassConst ks x =+   Filt1.highpassInit x (map Filt1.Parameter ks) (repeat x) == (zero <$ ks)++highpassInitAlt :: GF.T -> Sig.T (Filt1.Parameter GF.T) -> Sig.T GF.T -> Bool+highpassInitAlt x0 ps xs =+   Filt1.highpassInit x0 ps xs == Filt1.highpassInitAlt x0 ps xs+++tests :: [(String, Property)]+tests =+   ("addLowHighpass", property addLowHighpass) :+   ("combineLowHighpass", property combineLowHighpass) :+   ("lowpassId", property lowpassId) :+   ("lowpassZero", property lowpassZero) :+   ("highpassId", property highpassId) :+   ("highpassZero", property highpassZero) :+   ("lowpassConst", property lowpassConst) :+   ("highpassConst", property highpassConst) :+   ("highpassInitAlt", property highpassInitAlt) :+   []
+ test/Test/Sound/Synthesizer/Plain/Filter/Hilbert.hs view
@@ -0,0 +1,35 @@+module Test.Sound.Synthesizer.Plain.Filter.Hilbert (tests) where++import qualified Synthesizer.Plain.Filter.Recursive.Hilbert as Hilbert+import qualified Synthesizer.Plain.Filter.Recursive.Allpass as Allpass+import qualified Synthesizer.Plain.Signal as Sig++import qualified Synthesizer.Causal.Process as Causal++import qualified Test.Sound.Synthesizer.Plain.NonEmpty as NonEmpty++import Test.QuickCheck (Property, property)++import Data.Tuple.HT (mapPair)++import NumericPrelude.Numeric+import NumericPrelude.Base+import Prelude ()+++cascade :: NonEmpty.T (Rational, Rational) -> Sig.T Rational -> Bool+cascade ks xs =+   let p = uncurry Hilbert.Parameter $ unzip $+           map (mapPair (Allpass.Parameter, Allpass.Parameter)) $+           NonEmpty.toList ks+   in  Hilbert.run2 p xs ==+       Causal.apply (Hilbert.causal2 p) xs+{-+   in  map Complex.real (Hilbert.run2 p xs) == xs+-}+++tests :: [(String, Property)]+tests =+   ("hilbert", property cascade) :+   []
+ test/Test/Sound/Synthesizer/Plain/Interpolation.hs view
@@ -0,0 +1,314 @@+module Test.Sound.Synthesizer.Plain.Interpolation (+   T, ip,+   LinePreserving, lpIp,+   tests,+   use, useLP, use2,+   -- only for debugging+   frequencyModulationBackCompare,+   frequencyModulationForth0Compare,+   frequencyModulationStorableChunkSizeCompare,+   frequencyModulationStorableCompare,+   ) where++import qualified Synthesizer.Plain.Interpolation as Interpolation+import qualified Synthesizer.Interpolation.Class as Interpol+import qualified Synthesizer.Interpolation.Custom as ExampleCustom+import qualified Synthesizer.Interpolation.Module as ExampleModule++import qualified Synthesizer.Causal.Interpolation as InterpolC+import qualified Synthesizer.Causal.Process as Causal+import qualified Synthesizer.Generic.Filter.NonRecursive as FiltG+import qualified Synthesizer.State.Filter.NonRecursive as FiltS+import qualified Synthesizer.State.Signal as SigS++import qualified Synthesizer.Storable.Filter.NonRecursive as FiltSt+import qualified Synthesizer.Storable.Signal as SigSt++import Test.QuickCheck+         (Property, property, Arbitrary(arbitrary), elements, Testable)++import Foreign.Storable (Storable, )++import qualified Algebra.VectorSpace           as VectorSpace+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 Data.List.Match as Match+import qualified Data.List.HT as ListHT+import Data.Tuple.HT (mapSnd, )++import qualified Test.Sound.Synthesizer.Plain.NonEmpty as NonEmpty+import Test.Utility (ArbChar, unpackArbString)+++import NumericPrelude.Numeric+import NumericPrelude.Base+import Prelude ()++++use ::+   (Interpolation.T a v -> x) ->+   (T a v -> x)+use f ipt =+   f (ip ipt)++useLP ::+   (Interpolation.T a v -> x) ->+   (LinePreserving a v -> x)+useLP f ipt =+   f (lpIp ipt)++use2 ::+   (Interpolation.T a v ->+    Interpolation.T a v -> x) ->+   (T a v ->+    T a v -> x)+use2 f =+   use $ \ ipLeap ->+   use $ \ ipStep ->+      f ipLeap ipStep++++data T a v = Cons {name :: String, ip :: Interpolation.T a v}++instance Show (T a v) where+   show x = name x++instance (Field.C a, Interpol.C a v) => Arbitrary (T a v) where+   arbitrary = elements $+      Cons "constant" ExampleCustom.constant :+      Cons "linear"   ExampleCustom.linear :+      Cons "cubic"    ExampleCustom.cubic :+      []++++data LinePreserving a v =+   LPCons {lpName :: String, lpIp :: Interpolation.T a v}++instance Show (LinePreserving a v) where+   show x = lpName x++instance (Field.C a, Interpol.C a v) => Arbitrary (LinePreserving a v) where+   arbitrary = elements $+      LPCons "linear"   ExampleCustom.linear :+      LPCons "cubic"    ExampleCustom.cubic :+      []++++constant ::+   (Interpol.C a v, Module.C a v, Eq v) =>+   a -> v -> [v] -> Bool+constant t x0 xs =+   ListHT.allEqual $ map ($ (x0:xs)) $ map ($ t) $+      Interpolation.func ExampleCustom.constant :+      Interpolation.func ExampleCustom.piecewiseConstant :+      Interpolation.func ExampleModule.constant :+      Interpolation.func ExampleModule.piecewiseConstant :+      []++linear ::+   (Interpol.C a v, Module.C a v, Eq v) =>+   a -> v -> v -> [v] -> Bool+linear t x0 x1 xs =+   ListHT.allEqual $ map ($ (x0:x1:xs)) $ map ($ t) $+      Interpolation.func ExampleCustom.linear :+      Interpolation.func ExampleCustom.piecewiseLinear :+      Interpolation.func ExampleModule.linear :+      Interpolation.func ExampleModule.piecewiseLinear :+      []++cubic ::+   (Interpol.C a v, VectorSpace.C a v, Eq v) =>+   a -> v -> v -> v -> v -> [v] -> Bool+cubic t x0 x1 x2 x3 xs =+   ListHT.allEqual $ map ($ (x0:x1:x2:x3:xs)) $ map ($ t) $+      Interpolation.func ExampleCustom.cubic :+      Interpolation.func ExampleCustom.piecewiseCubic :+      Interpolation.func ExampleModule.cubic :+      Interpolation.func ExampleModule.cubicAlt :+      Interpolation.func ExampleModule.piecewiseCubic :+      []+++controlAboveOne :: (RealRing.C t) => [t] -> [t]+controlAboveOne =+   map ((one+) . abs)++frequencyModulationForth0 ::+   (RealField.C t, Eq v) =>+   [t] -> [v] -> Bool+frequencyModulationForth0 cs0 xs =+   let cs = controlAboveOne cs0+   in  Causal.apply+          (InterpolC.relative ExampleModule.constant zero+             (FiltS.inverseFrequencyModulationFloor+                (SigS.fromList cs) (SigS.fromList xs)))+          (Match.take xs cs)+        == Match.take cs xs++frequencyModulationForth0Compare ::+   (RealField.C t, Eq v) =>+   [t] -> [v] -> ([v], [v], [v])+frequencyModulationForth0Compare cs0 xs =+   let cs = controlAboveOne cs0+   in  (Match.take cs+          (Causal.apply+             (InterpolC.relative ExampleModule.constant zero+                (FiltS.inverseFrequencyModulationFloor+                   (SigS.fromList cs) (SigS.fromList xs)))+             (Match.take xs cs)),+        SigS.toList+           (FiltS.inverseFrequencyModulationFloor+              (SigS.fromList cs) (SigS.fromList xs)),+        Match.take cs xs)+++frequencyModulationForth1 ::+   (RealField.C t, Eq v) =>+   [t] -> [v] -> Bool+frequencyModulationForth1 cs0 xs =+   case controlAboveOne cs0 of+      [] -> True+      (c:cs) ->+         Causal.apply+            (InterpolC.relative ExampleModule.constant c+               (FiltS.inverseFrequencyModulationFloor+                  (SigS.fromList ((c+one):cs)) (SigS.fromList xs)))+            (Match.take xs cs)+          == Match.take cs xs++++controlBelowOne :: (RealField.C t) => [t] -> [t]+controlBelowOne =+   map fraction+++frequencyModulationBack ::+   (RealField.C t, Eq v) =>+   [t] -> NonEmpty.T v -> Bool+frequencyModulationBack cs0 xs0 =+   let cs = controlBelowOne cs0+       xs = NonEmpty.toInfiniteList xs0+   in  take (floor (sum cs)) xs ==+          (SigS.toList $+           FiltS.inverseFrequencyModulationFloor+             (SigS.fromList cs)+             (SigS.fromList $+              Causal.apply+                 (InterpolC.relative ExampleModule.constant zero+                    (SigS.fromList xs))+                 cs))+++frequencyModulationBackCompare ::+   (RealField.C t, Eq v) =>+   [t] -> [v] -> (SigS.T v, SigS.T v)+frequencyModulationBackCompare cs0 xs =+   let cs = controlBelowOne cs0+   in  (FiltS.inverseFrequencyModulationFloor+          (SigS.fromList cs)+          (SigS.fromList $+           Causal.apply+              (InterpolC.relative ExampleModule.constant zero+                 (SigS.fromList (cycle xs)))+              cs),+        SigS.fromList $+        Causal.apply+           (InterpolC.relative ExampleModule.constant zero+              (SigS.fromList (cycle xs)))+           cs)++frequencyModulationGeneric ::+   (RealField.C t, Eq v) =>+   [t] -> [v] -> Bool+frequencyModulationGeneric cs xs =+   SigS.toList+      (FiltS.inverseFrequencyModulationFloor+         (SigS.fromList cs) (SigS.fromList xs))+    == FiltG.inverseFrequencyModulationFloor cs xs+++{-+makeExactFraction :: (Int,Int) -> Double+makeExactFraction (n,d) =+   fromIntegral n * 2 ^- (- mod (fromIntegral d) 4)+-}++frequencyModulationStorableChunkSize ::+   (Storable v, RealField.C t, Eq v) =>+   SigSt.ChunkSize -> SigSt.ChunkSize ->+   SigSt.ChunkSize -> SigSt.ChunkSize ->+   [t] -> [v] ->+   Bool+frequencyModulationStorableChunkSize size0 size1 xsize0 xsize1 cs xs =+   uncurry (==) $+   frequencyModulationStorableChunkSizeCompare size0 size1 xsize0 xsize1 cs xs+++frequencyModulationStorableChunkSizeCompare ::+   (Storable v, RealField.C t, Eq v) =>+   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 size0 cs (SigSt.fromList xsize0 xs),+    FiltSt.inverseFrequencyModulationFloor size1 cs (SigSt.fromList xsize1 xs))+++frequencyModulationStorable ::+   (Storable v, RealField.C t, Eq v) =>+   SigSt.ChunkSize -> SigSt.ChunkSize ->+   [t] -> [v] ->+   Bool+frequencyModulationStorable size xsize cs xs =+   uncurry (==) $ mapSnd SigSt.toList $+   frequencyModulationStorableCompare size xsize cs xs++frequencyModulationStorableCompare ::+   (Storable v, RealField.C t, Eq v) =>+   SigSt.ChunkSize -> SigSt.ChunkSize ->+   [t] -> [v] ->+   ([v], SigSt.T v)+frequencyModulationStorableCompare size xsize cs xs =+   (FiltG.inverseFrequencyModulationFloor cs xs,+    FiltSt.inverseFrequencyModulationFloor size cs+       (SigSt.fromList xsize xs))++++testRational ::+   (Testable t) =>+   (Rational -> Rational -> t) -> Property+testRational = property++testFM ::+   (Testable t, Arbitrary (sigX ArbChar), Show (sigX ArbChar)) =>+   ([Rational] -> sigX ArbChar -> t) -> Property+testFM = property++tests :: [(String, Property)]+tests =+   ("constant", testRational constant) :+   ("linear",   testRational linear  ) :+   ("cubic",    testRational cubic   ) :+   ("frequencyModulationForth0",  testFM frequencyModulationForth0) :+   ("frequencyModulationForth1",  testFM frequencyModulationForth1) :+   ("frequencyModulationBack",    testFM frequencyModulationBack) :+   ("frequencyModulationGeneric", testFM frequencyModulationGeneric) :+   ("frequencyModulationStorableChunkSize",+      property (\size0 size1 xsize0 xsize1 cs xs ->+         frequencyModulationStorableChunkSize size0 size1 xsize0 xsize1+            (cs::[Rational]) (unpackArbString xs))) :+   ("frequencyModulationStorable",+      property (\size xsize cs xs ->+         frequencyModulationStorable size xsize+            (cs::[Rational]) (unpackArbString xs))) :+   []
+ test/Test/Sound/Synthesizer/Plain/NonEmpty.hs view
@@ -0,0 +1,34 @@+module Test.Sound.Synthesizer.Plain.NonEmpty where++import Test.QuickCheck (Arbitrary, arbitrary, )+import Control.Monad (liftM2, )+++data T a = Cons a [a]++toList :: T a -> [a]+toList (Cons x xs) =+   (x:xs)++toInfiniteList :: T a -> [a]+toInfiniteList =+   cycle . toList++instance Functor T where+   fmap f (Cons x xs) =+      Cons (f x) (map f xs)++instance Arbitrary a => Arbitrary (T a) where+   arbitrary = liftM2 Cons arbitrary arbitrary++instance Show a => Show (T a) where+   showsPrec p (Cons x xs) =+      showsPrec p (x:xs)++{-+instance Show a => Show (T a) where+   showsPrec p (Cons x xs) =+      showParen (p >= 10) $+      showString "cycle " .+      showsPrec 11 (x:xs)+-}
+ test/Test/Sound/Synthesizer/Plain/ToneModulation.hs view
@@ -0,0 +1,482 @@+module Test.Sound.Synthesizer.Plain.ToneModulation (tests, ) where++import Test.Sound.Synthesizer.Basic.ToneModulation (+   minLength,+   minLengthMargin,+   shapeLimits,+   testRationalLineIp,+   testRationalIp,+   )++import qualified Synthesizer.Plain.Oscillator     as Osci+import qualified Synthesizer.Plain.Interpolation  as Interpolation+import qualified Synthesizer.Plain.ToneModulation as ToneModL+import qualified Synthesizer.Plain.Wave           as WaveL+import Synthesizer.Interpolation (marginNumber, )++import qualified Synthesizer.Basic.Wave           as Wave+import qualified Synthesizer.Basic.Phase          as Phase++import qualified 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 (Property, property, (==>))+import Test.Utility (ArbChar, )++import qualified Number.NonNegative       as NonNeg+import qualified Number.NonNegativeChunky as Chunky++import qualified Algebra.RealTranscendental    as RealTrans+import qualified Algebra.Module                as Module+import qualified Algebra.RealField             as RealField+import qualified Algebra.Ring                  as Ring+import qualified Algebra.Additive              as Additive+import qualified Algebra.ZeroTestable          as ZeroTestable++import Data.List.HT (isAscending, )+import Data.Ord.HT (limit, )+import Data.Tuple.HT (mapPair, mapSnd, )+import qualified Data.List as List++import System.Random (Random, )+++import NumericPrelude.Numeric+import NumericPrelude.Base+import Prelude ()+++{-+Properties that do not hold:+  commutativity of limitRelativeShapes and integrateFractional:+    Does not hold because when you clip the integral skips at the end,+    you would have to clear the fractional part, too.+-}++++absolutize :: (Additive.C a) => a -> [a] -> [a]+absolutize = scanl (+)++limitMinRelativeValues ::+   Int -> Int -> [NonNeg.Int] -> Bool+limitMinRelativeValues xMin x0 xsnn =+   let xs = map NonNeg.toNumber xsnn+   in  map (max xMin) (absolutize x0 xs) ==+          uncurry absolutize (ToneModL.limitMinRelativeValues xMin x0 xs)++limitMaxRelativeValues ::+   Int -> Int -> [NonNeg.Int] -> Bool+limitMaxRelativeValues xMax x0 xsnn =+   let xs = map NonNeg.toNumber xsnn+   in  map (min xMax) (absolutize x0 xs) ==+          uncurry absolutize (ToneModL.limitMaxRelativeValues xMax x0 xs)++limitMaxRelativeValuesNonNeg ::+   Int -> Int -> [NonNeg.Int] -> Bool+limitMaxRelativeValuesNonNeg xMax x0 xsnn =+   let xs = map NonNeg.toNumber xsnn+   in  map (min xMax) (absolutize x0 xs) ==+          uncurry absolutize (ToneModL.limitMaxRelativeValuesNonNeg xMax x0 xs)++-- chunky type is not necessary here but testing it a little is not wrong+limitMinRelativeValuesIdentity ::+   Chunky.T NonNeg.Int -> [Chunky.T NonNeg.Int] -> Bool+limitMinRelativeValuesIdentity x0 xs =+   (x0,xs) == ToneModL.limitMinRelativeValues 0 x0 xs++limitMaxRelativeValuesIdentity ::+   Chunky.T NonNeg.Int -> [Chunky.T NonNeg.Int] -> Bool+limitMaxRelativeValuesIdentity x0 xs =+   let inf = 1 + inf+   in  (x0,xs) == ToneModL.limitMaxRelativeValues inf x0 xs++limitMaxRelativeValuesNonNegIdentity ::+   Chunky.T NonNeg.Int -> [Chunky.T NonNeg.Int] -> Bool+limitMaxRelativeValuesNonNegIdentity x0 xs =+   let inf = 1 + inf+   in  (x0,xs) == ToneModL.limitMaxRelativeValuesNonNeg inf x0 xs++limitMaxRelativeValuesInfinity ::+   Chunky.T NonNeg.Int -> NonEmpty.T (Chunky.T NonNeg.Int) -> Bool+limitMaxRelativeValuesInfinity x0 ixs =+   let inf = 1 + inf+       ys = NonEmpty.toInfiniteList ixs+       (z0,zs) = ToneModL.limitMaxRelativeValues inf x0 ys+   in  (x0, take 100 ys) == (z0, take 100 zs)++limitMaxRelativeValuesNonNegInfinity ::+   Chunky.T NonNeg.Int -> NonEmpty.T (Chunky.T NonNeg.Int) -> Bool+limitMaxRelativeValuesNonNegInfinity x0 ixs =+   let inf = 1 + inf+       ys = NonEmpty.toInfiniteList ixs+       (z0,zs) = ToneModL.limitMaxRelativeValuesNonNeg inf x0 ys+   in  (x0, take 100 ys) == (z0, take 100 zs)+++dropRem :: Eq a => NonNeg.Int -> [a] -> Bool+dropRem nn xs =+   let n = NonNeg.toNumber nn+   in  map (flip ToneModL.dropRem xs) [0 .. n + length xs] ==+       map ((,) 0) (List.tails xs) ++ map (flip (,) []) [1..n]++ten, hundred :: (Ring.C a) => a+ten = fromInteger 10; hundred = fromInteger 100++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+       periodInt = round period+       len = minLength ipLeap ipStep periodInt ext+       tone = take len (Osci.staticSine phase0 (recip period))+   in  abs (WaveL.sampledTone ipLeap ipStep period tone shape `Wave.apply` (Phase.fromRepresentative phase) -+            head (Osci.staticSine (phase0+phase) zero)) < ten ^- (-2)+++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+       periodInt = round period+       len = minLength ipLeap ipStep periodInt ext+       tone = take len (Osci.staticSine origPhase (recip period))+   in  all ((< ten ^- (-2)) . abs) $+       zipWith (-)+          (Osci.shapeFreqMod (WaveL.sampledTone ipLeap ipStep period tone)+               phase shapes freqs)+          (Osci.freqModSine (origPhase+phase) freqs)+++sampledToneLinear :: (RealField.C a, Module.C a v, Eq v) =>+   InterpolationTest.LinePreserving a v ->+   InterpolationTest.LinePreserving a v ->+   NonNeg.T a -> NonNeg.Int -> (v,v) -> a -> Phase.T a -> Property+sampledToneLinear =+   InterpolationTest.useLP $ \ ipLeap ->+   InterpolationTest.useLP $ \ ipStep ->+         \ periodNN ext (i,d) shape phase ->+   let period = NonNeg.toNumber periodNN+       periodInt = round period+       len = minLength ipLeap ipStep periodInt ext+       ramp = take len (List.iterate (d+) i)+       limits =+          mapPair (fromIntegral, fromIntegral) $+             shapeLimits ipLeap ipStep periodInt len+   in  period /= zero ==>+          -- should be (fraction phase), right?+          WaveL.sampledTone ipLeap ipStep period ramp shape `Wave.apply` phase ==+             i + limit limits shape *> d+{-+let len=100; period=1/0.06::Double; ip = Interpolation.linear in GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (0,fromIntegral len)) [\s -> WaveL.sampledTone ip ip period (take len $ iterate (1+) (0::Double)) s 0, limit (mapPair (fromIntegral, fromIntegral) $ shapeLimits ip ip (round period::Int) len)]+-}++sampledToneStair :: (RealField.C a, Module.C a v, Eq v) =>+   InterpolationTest.LinePreserving a v ->+   NonNeg.Int -> NonNeg.Int -> (v,v) -> a -> Property+sampledToneStair =+   InterpolationTest.useLP $ \ ipLeap+         periodIntNN ext (i,d) shape ->+   let ipStep = Interpolation.constant+       periodInt = NonNeg.toNumber periodIntNN+       period    = fromIntegral periodInt+       len0 = minLength ipLeap ipStep periodInt ext+       (rep,rm) = divMod (negate len0) periodInt+       len   = len0 + rm+       stair =+          concatMap (replicate periodInt) $+          take (negate rep) (List.iterate (period*>d+) i)+       limits =+          mapPair (fromIntegral, fromIntegral) $+             shapeLimits ipLeap ipStep periodInt len+   in  periodInt /= zero ==>+          WaveL.sampledTone ipLeap ipStep period stair shape `Wave.apply` zero ==+             i + limit limits shape *> d+{-+let len=periodInt*rep; rep=10; periodInt = 14::Int; period=fromIntegral periodInt; ipl = Interpolation.linear; ipc = Interpolation.constant in GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (-10,10+fromIntegral len)) [\s -> WaveL.sampledTone ipl ipc period (concatMap (replicate periodInt) $ take rep $ iterate (period+) (0::Double)) s 0, limit (mapPair (fromIntegral, fromIntegral) $ shapeLimits ipl ipc periodInt len)]+-}++{-+sampledToneSaw :: (RealField.C a, Module.C a v, Eq v) =>+   InterpolationTest.LinePreserving a v ->+   InterpolationTest.T a v ->+   NonNeg.Int -> NonNeg.Int -> (v,v) -> a -> a -> Property+sampledToneSaw iptLeap iptStep periodIntNN ext (i,d) shape phase =+   let ipLeap = InterpolationTest.lpIp iptLeap+       ipStep = InterpolationTest.ip   iptStep+       periodInt = NonNeg.toNumber periodIntNN+       period    = fromIntegral periodInt+       len0 = minLength ipLeap ipStep periodInt ext+       rep = negate $ div (negate len0) periodInt+       saw =+          concat $ replicate rep $+          take periodInt $ List.iterate (d+) i+   in  periodInt /= zero ==>+          WaveL.sampledTone ipLeap ipStep period saw shape phase ==+             i + fraction phase *> d+-}++sampledToneStatic :: (RealField.C a, Eq v) =>+   InterpolationTest.T a v ->+   InterpolationTest.T a v ->+   NonNeg.Int -> (v,[v]) -> a -> a -> Property+sampledToneStatic =+   InterpolationTest.use2 $ \ ipLeap ipStep+         ext (x,xs) shape phase ->+   let wave = x:xs+       periodInt = length wave+       period    = fromIntegral periodInt+       len = minLength ipLeap ipStep periodInt ext+       rep = negate $ div (negate len) periodInt+       tone = concat $ replicate rep wave+   in  period /= zero ==>+          WaveL.sampledTone ipLeap ipStep period tone shape `Wave.apply` (Phase.fromRepresentative phase) ==+          Interpolation.cyclicPad Interpolation.single ipStep (phase*period) wave+{-+let wave = [1,-1,0.5,-0.5::Double]; period = fromIntegral (length wave) :: Double; ip = Interpolation.linear in GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (-1,3)) [WaveL.sampledTone ip ip period (concat $ replicate 3 wave) 0.3, \phase -> Interpolation.cyclicPad Interpolation.single Interpolation.linear (phase*period) wave]+-}++++shapeFreqModFromSampledToneLimitIdentity :: (RealField.C t) =>+   Interpolation.Margin ->+   Interpolation.Margin ->+   NonNeg.Int -> NonEmpty.T y -> (t, NonEmpty.T (NonNeg.T t)) -> Bool+shapeFreqModFromSampledToneLimitIdentity+      marginLeap marginStep periodIntNN ixs (shape0,shapesNN) =+   let periodInt = NonNeg.toNumber periodIntNN+       shapes = fmap NonNeg.toNumber shapesNN+       a = snd+          (ToneModL.limitRelativeShapes+             marginLeap marginStep+             periodInt (NonEmpty.toInfiniteList ixs)+             (shape0, NonEmpty.toInfiniteList shapes)) !! 100+   in  a == a+++oscillatorCoords :: (RealField.C t) =>+   NonNeg.Int -> NonNeg.T t -> t -> Phase.T t -> [NonNeg.T t] -> [t] -> Property+oscillatorCoords+     periodIntNN periodNN shape0 phase shapesNN freqs =+   let shapes = map NonNeg.toNumber shapesNN+       period    = NonNeg.toNumber periodNN+       periodInt = NonNeg.toNumber periodIntNN+       periodRound = fromIntegral periodInt+       coords =+          ToneModL.oscillatorCoords+             periodInt period+             (shape0, shapes) (phase, freqs)+   in  period /= zero  &&  periodInt /= zero  ==>+          all+             (\(skip,(k,(qShape,qWave))) ->+                  skip >= zero &&+                  isAscending [negate periodInt, k, zero] &&+                  isAscending [zero, qShape, one] &&+                  isAscending [zero, qWave, periodRound])+             (tail coords)+++shapeFreqModFromSampledToneCoordsIdentity ::+   (RealField.C t, ZeroTestable.C t) =>+   NonNeg.Int -> NonNeg.T t -> (t, [NonNeg.T t]) -> Property+shapeFreqModFromSampledToneCoordsIdentity+      periodIntNN periodNN (shape0,shapesNN) =+   let period    = NonNeg.toNumber periodNN+       periodInt = NonNeg.toNumber periodIntNN+       shapes = map NonNeg.toNumber shapesNN+       phase  = Phase.fromRepresentative $ shape0 / period+       freqs  = map (/period) shapes+   in  period /= zero  ==>+          all+             (isZero . fst . snd . snd)+             (ToneModL.oscillatorCoords+                 periodInt period (shape0, shapes) (phase, freqs))+++shapeFreqModFromSampledTone :: (RealField.C t, Eq v) =>+   InterpolationTest.T t v ->+   InterpolationTest.T t v ->+   NonNeg.T t ->+   NonNeg.Int -> NonEmpty.T v ->+   t -> t -> [NonNeg.T t] -> [t] ->+   Property+shapeFreqModFromSampledTone =+   InterpolationTest.use2 $ \ ipLeap ipStep+         periodNN ext ixs shape0 phase shapesNN freqs ->+   let shapes = map NonNeg.toNumber shapesNN+       period = NonNeg.toNumber periodNN+       periodInt = round period+       len = minLength ipLeap ipStep periodInt ext+       tone = take len (NonEmpty.toInfiniteList ixs)+       resampledToneA =+          Osci.shapeFreqModFromSampledTone ipLeap ipStep period tone+             shape0 phase shapes freqs+       resampledToneB =+          Osci.shapeFreqMod+             (WaveL.sampledTone ipLeap ipStep period tone)+             phase (scanl (+) shape0 shapes) freqs+   in  period /= zero  ==>+          resampledToneA == resampledToneB+{-+let len=100; period=1/0.06::Double; ip = Interpolation.linear; tone = take len $ iterate (1+) (0::Double); shape0=0; shapes = replicate 100 1; in GNUPlot.plotLists [] [Osci.shapeFreqMod (WaveL.sampledTone ip ip period tone) 0 (scanl (+) shape0 shapes) (repeat 0), Osci.shapeFreqModFromSampledTone ip ip period tone shape0 0 shapes (repeat 0)]+*Test.Sound.Synthesizer.Plain.Oscillator> let len=100; period=1/0.06::Double; ip = Interpolation.linear; tone = take len $ iterate (1+) (0::Double); shape0=0; shapes = concat $ replicate 50 [1.5,0.5]; in GNUPlot.plotLists [] [Osci.shapeFreqMod (WaveL.sampledTone ip ip period tone) 0 (scanl (+) shape0 shapes) (repeat 0), Osci.shapeFreqModFromSampledTone ip ip period tone shape0 0 shapes (repeat 0)]+*Test.Sound.Synthesizer.Plain.Oscillator> let len=100; period=1/0.06::Rational; ipLeap = Interpolation.linear; ipStep = Interpolation.constant; tone = take len $ iterate (1+) (0::Rational); shape0=0; shapes = concat $ replicate 50 [1.5,0.5]; in GNUPlot.plotLists [] (map (map (\x -> fromRational' x :: Double)) [Osci.shapeFreqMod (WaveL.sampledTone ipLeap ipStep period tone) 0 (scanl (+) shape0 shapes) (repeat 0), Osci.shapeFreqModFromSampledTone ipLeap ipStep period tone shape0 0 shapes (repeat 0)])+-}+++shapePhaseFreqModFromSampledTone :: (RealField.C t, Eq v) =>+   InterpolationTest.T t v ->+   InterpolationTest.T t v ->+   NonNeg.T t ->+   NonNeg.Int -> NonEmpty.T v ->+   t -> t -> [NonNeg.T t] -> [t] -> [t] ->+   Property+shapePhaseFreqModFromSampledTone =+   InterpolationTest.use2 $ \ ipLeap ipStep+         periodNN ext ixs shape0 phase shapesNN phaseDistorts freqs ->+   let shapes = map NonNeg.toNumber shapesNN+       period = NonNeg.toNumber periodNN+       periodInt = round period+       len = minLength ipLeap ipStep periodInt ext+       tone = take len (NonEmpty.toInfiniteList ixs)+       resampledToneA =+          Osci.shapePhaseFreqModFromSampledTone ipLeap ipStep period tone+             shape0 phase shapes phaseDistorts freqs+       resampledToneB =+          Osci.shapeFreqMod+             (uncurry $+                Wave.phaseOffset .+                WaveL.sampledTone ipLeap ipStep period tone)+             phase (zip (scanl (+) shape0 shapes) phaseDistorts) freqs+   in  period /= zero  ==>+          resampledToneA == resampledToneB+++oscillatorCells :: (RealField.C t, Eq v) =>+   Interpolation.Margin ->+   Interpolation.Margin ->+   NonNeg.Int ->+   NonNeg.T t ->+   NonNeg.Int -> NonEmpty.T v ->+   t -> t -> [NonNeg.T t] -> [t] ->+   Property+oscillatorCells+      marginLeap marginStep periodIntNN periodNN ext ixs shape0 phase shapesNN freqs =+   let shapes = map NonNeg.toNumber shapesNN+       period    = NonNeg.toNumber periodNN+       periodInt = NonNeg.toNumber periodIntNN+       len = minLengthMargin marginLeap marginStep periodInt ext+       tone = take len (NonEmpty.toInfiniteList ixs)+       crop = cropCell marginLeap marginStep+       resampledToneA =+          ToneModL.oscillatorCells+             marginLeap marginStep periodInt period tone+             (shape0, shapes) (Phase.fromRepresentative phase, freqs)+       resampledToneB =+          Osci.shapeFreqMod+             (Wave.Cons . ToneModL.sampledToneCell+                (ToneModL.makePrototype marginLeap marginStep+                    periodInt period tone))+             phase (scanl (+) shape0 shapes) freqs+   in  period /= zero  &&+       periodInt /= zero  &&+       marginNumber marginLeap > zero &&+       marginNumber marginStep > zero  ==>+          map crop resampledToneA == map crop resampledToneB++cropCell ::+   Interpolation.Margin ->+   Interpolation.Margin ->+   ((t,t), ToneModL.Cell v) -> ((t,t), ToneModL.Cell v)+cropCell ipLeap ipStep =+   mapSnd+      (take (marginNumber ipStep) .+       map (take (marginNumber ipLeap)))+++shapeFreqModFromSampledToneIdentity :: (RealField.C t, Eq v) =>+   InterpolationTest.T t v ->+   InterpolationTest.T t v ->+   NonNeg.T t ->+   NonNeg.Int -> NonEmpty.T v ->+   Property+shapeFreqModFromSampledToneIdentity =+   InterpolationTest.use2 $ \ ipLeap ipStep+          periodNN ext ixs ->+   let period = NonNeg.toNumber periodNN+       periodInt = round period+       len = minLength ipLeap ipStep periodInt ext+       tone = take len (NonEmpty.toInfiniteList ixs)+       shape0 = zero+       shapes = repeat one+       phase  = zero+       freqs  = repeat (recip period)+       (n0,n1) =+          shapeLimits ipLeap ipStep periodInt len++       resampledTone =+          Osci.shapeFreqModFromSampledTone ipLeap ipStep period tone+             shape0 phase shapes freqs+   in  period /= zero  ==>+          and (drop n0 (take (succ n1) (zipWith (==) resampledTone tone)))+++tests :: [(String, Property)]+tests =+   ("limitMinRelativeValues", property limitMinRelativeValues) :+   ("limitMaxRelativeValues", property limitMaxRelativeValues) :+   ("limitMaxRelativeValuesNonNeg",+                              property limitMaxRelativeValuesNonNeg) :+   ("limitMinRelativeValuesIdentity",+                              property limitMinRelativeValuesIdentity) :+   ("limitMaxRelativeValuesIdentity",+                              property limitMaxRelativeValuesIdentity) :+   ("limitMaxRelativeValuesNonNegIdentity",+                              property limitMaxRelativeValuesNonNegIdentity) :+   ("limitMaxRelativeValuesInfinity",+                              property limitMaxRelativeValuesInfinity) :+   ("limitMaxRelativeValuesNonNegInfinity",+                              property limitMaxRelativeValuesNonNegInfinity) :+   ("dropRem",                property (dropRem :: NonNeg.Int -> [ArbChar] -> Bool)) :+   ("sampledToneSine",+      property (\ext phase0 -> sampledToneSine ext (phase0 :: Double))) :+   ("sampledToneSineList",+      property (\ext phase0 -> sampledToneSineList ext (phase0 :: Double))) :+   ("sampledToneLinear",+      testRationalLineIp sampledToneLinear) :+   ("sampledToneStair",+      testRationalLineIp sampledToneStair) :+{-+   ("sampledToneSaw",+      testRationalLineIp sampledToneSaw) :+-}+   ("sampledToneStatic",+      testRationalIp sampledToneStatic) :+   ("shapeFreqModFromSampledToneLimitIdentity",+      property (\ml ms p ixs (t,ts) ->+          shapeFreqModFromSampledToneLimitIdentity ml ms p+             (ixs::NonEmpty.T Rational) (t::Rational,ts))) :+   ("oscillatorCoords",+      property (\periodInt period ->+               oscillatorCoords+                  periodInt (period :: NonNeg.Rational))) :+   ("shapeFreqModFromSampledToneCoordsIdentity",+      property (\periodInt period ->+               shapeFreqModFromSampledToneCoordsIdentity+                  periodInt (period :: NonNeg.Rational))) :+   ("shapeFreqModFromSampledTone",+      testRationalIp shapeFreqModFromSampledTone) :+   ("shapePhaseFreqModFromSampledTone",+      testRationalIp shapePhaseFreqModFromSampledTone) :+   ("oscillatorCells",+      property (\ml ms periodInt period ext ixs ->+               oscillatorCells ml ms periodInt (period :: NonNeg.Rational)+                  ext (ixs :: NonEmpty.T ArbChar))) :+   ("shapeFreqModFromSampledToneIdentity",+      testRationalIp shapeFreqModFromSampledToneIdentity) :+   []
+ test/Test/Utility.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Test.Utility where++import qualified Test.QuickCheck as QC+import Test.QuickCheck (Arbitrary(arbitrary))++import qualified Number.Complex as Complex++import qualified Algebra.RealRing as RealRing++import qualified Data.Char as Char++import NumericPrelude.Base+import NumericPrelude.Numeric+++approxEqual :: (RealRing.C a) => a -> a -> a -> Bool+approxEqual eps x y =+   2 * abs (x-y) <= eps * (abs x + abs y)++approxEqualAbs :: (RealRing.C a) => a -> a -> a -> Bool+approxEqualAbs eps x y =+   abs (x-y) <= eps++approxEqualListRel :: (RealRing.C a) => a -> [a] -> Bool+approxEqualListRel eps xs =+   let n = fromIntegral $ length xs+   in  approxEqualListAbs (eps * n * sum (map abs xs)) xs++approxEqualListAbs :: (RealRing.C a) => a -> [a] -> Bool+approxEqualListAbs eps xs =+   let n = fromIntegral $ length xs+       s = sum xs+   in  sum (map (\x -> abs (n*x-s)) xs)  <=  eps+++approxEqualComplex ::+   (RealRing.C a) =>+   a -> Complex.T a -> Complex.T a -> Bool+approxEqualComplex eps x y =+   2 * Complex.magnitudeSqr (x-y)+      <= eps^2 * (Complex.magnitudeSqr x + Complex.magnitudeSqr y)++approxEqualComplexAbs ::+   (RealRing.C a) =>+   a -> Complex.T a -> Complex.T a -> Bool+approxEqualComplexAbs eps x y =+   Complex.magnitudeSqr (x-y) <= eps^2+++-- see event-list++newtype ArbChar = ArbChar Char+   deriving (Eq, Ord)++instance Show ArbChar where+   showsPrec n (ArbChar c) = showsPrec n c++instance Arbitrary ArbChar where+   arbitrary = fmap (ArbChar . Char.chr) (QC.choose (32,127))++unpackArbString :: [ArbChar] -> String+unpackArbString =+   map (\(ArbChar c) -> c)