diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -1,7 +1,14 @@ -MODULE_PATH = src:src-3 +MODULE_PATH = src:src-4 +# HIDE_SYNTH = -hide-package synthesizer + + ghci: - ghci -Wall -odirdist/build -hidirdist/build -hide-package synthesizer -i:$(MODULE_PATH) + ghci -Wall -odirdist/build -hidirdist/build $(HIDE_SYNTH) -i:$(MODULE_PATH) 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 diff --git a/speedtest/SpeedTestExp.hs b/speedtest/SpeedTestExp.hs --- a/speedtest/SpeedTestExp.hs +++ b/speedtest/SpeedTestExp.hs @@ -13,6 +13,7 @@ import Data.Word(Word8) +-- we could also use withBinaryFile import System.IO (openBinaryFile, hClose, hPutBuf, IOMode(WriteMode)) import Foreign (Int16, pokeElemOff, allocaBytes) import Control.Exception (bracket) diff --git a/src-3/Synthesizer/Causal/Process.hs b/src-3/Synthesizer/Causal/Process.hs --- a/src-3/Synthesizer/Causal/Process.hs +++ b/src-3/Synthesizer/Causal/Process.hs @@ -40,8 +40,7 @@ apply, applyFst, applySnd, - applyGeneric, - applyGenericSameType, + applySameType, applyConst, apply2, apply3, @@ -134,7 +133,6 @@ (***) = split (&&&) = fanout - {- I think we cannot define an ArrowApply instance, because we must extract the initial state somehow @@ -207,57 +205,61 @@ fanout = liftKleisli2 (&&&) -{-# INLINE getNext #-} -getNext :: StateT (Sig.T a) Maybe a -getNext = StateT Sig.viewL +{-# INLINE runViewL #-} +runViewL :: (SigG.Read 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 :: T a b -> Sig.T a -> Sig.T b +apply :: (SigG2.Transform sig a b) => + T a b -> sig a -> sig b apply (Cons f s) = - Sig.crochetL (runStateT . f) s + SigG2.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' :: T (a,b) c -> Sig.T a -> T b c +applyFst, applyFst' :: (SigG.Read 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,as) + (s,r)) {- | 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, applySnd' :: (SigG.Read 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,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 - + (s,r)) {- | applyConst c x == apply c (repeat x) @@ -277,27 +279,40 @@ {-# INLINE apply2 #-} -apply2 :: T (a,b) c -> Sig.T a -> Sig.T b -> Sig.T c +apply2 :: + (SigG.Read sig a, SigG2.Transform sig b c) => + T (a,b) c -> sig a -> sig b -> sig 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 :: + (SigG.Read sig a, SigG.Read sig b, SigG2.Transform sig c 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 {-# INLINE feed #-} -feed :: Sig.T a -> T () a -feed = fromStateMaybe (const getNext) +feed :: (SigG.Read sig a) => + sig a -> T () a +feed = + flip runViewL (\getNext -> + fromStateMaybe (const getNext)) {-# INLINE feedFst #-} -feedFst :: Sig.T a -> T b (a,b) -feedFst = fromStateMaybe (\b -> fmap (flip (,) b) getNext) +feedFst :: (SigG.Read sig a) => + sig a -> T b (a,b) +feedFst = + flip runViewL (\getNext -> + fromStateMaybe (\b -> fmap (flip (,) b) getNext)) {-# INLINE feedSnd #-} -feedSnd :: Sig.T a -> T b (b,a) -feedSnd = fromStateMaybe (\b -> fmap ((,) b) getNext) +feedSnd :: (SigG.Read sig a) => + sig a -> T b (b,a) +feedSnd = + flip runViewL (\getNext -> + fromStateMaybe (\b -> fmap ((,) b) getNext)) {-# INLINE feedConstFst #-} feedConstFst :: a -> T b (a,b) @@ -338,7 +353,8 @@ 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 :: (SigG.Read sig a) => + (a -> b -> c) -> sig a -> T b c zipWith f = applyFst (map (uncurry f)) {- | diff --git a/src-4/Synthesizer/Causal/Process.hs b/src-4/Synthesizer/Causal/Process.hs --- a/src-4/Synthesizer/Causal/Process.hs +++ b/src-4/Synthesizer/Causal/Process.hs @@ -40,8 +40,7 @@ apply, applyFst, applySnd, - applyGeneric, - applyGenericSameType, + applySameType, applyConst, apply2, apply3, @@ -212,57 +211,61 @@ fanout = liftKleisli2 (&&&) -{-# INLINE getNext #-} -getNext :: StateT (Sig.T a) Maybe a -getNext = StateT Sig.viewL +{-# INLINE runViewL #-} +runViewL :: (SigG.Read 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 :: T a b -> Sig.T a -> Sig.T b +apply :: (SigG2.Transform sig a b) => + T a b -> sig a -> sig b apply (Cons f s) = - Sig.crochetL (runStateT . f) s + SigG2.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' :: T (a,b) c -> Sig.T a -> T b c +applyFst, applyFst' :: (SigG.Read 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,as) + (s,r)) {- | 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, applySnd' :: (SigG.Read 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,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 - + (s,r)) {- | applyConst c x == apply c (repeat x) @@ -282,27 +285,40 @@ {-# INLINE apply2 #-} -apply2 :: T (a,b) c -> Sig.T a -> Sig.T b -> Sig.T c +apply2 :: + (SigG.Read sig a, SigG2.Transform sig b c) => + T (a,b) c -> sig a -> sig b -> sig 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 :: + (SigG.Read sig a, SigG.Read sig b, SigG2.Transform sig c 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 {-# INLINE feed #-} -feed :: Sig.T a -> T () a -feed = fromStateMaybe (const getNext) +feed :: (SigG.Read sig a) => + sig a -> T () a +feed = + flip runViewL (\getNext -> + fromStateMaybe (const getNext)) {-# INLINE feedFst #-} -feedFst :: Sig.T a -> T b (a,b) -feedFst = fromStateMaybe (\b -> fmap (flip (,) b) getNext) +feedFst :: (SigG.Read sig a) => + sig a -> T b (a,b) +feedFst = + flip runViewL (\getNext -> + fromStateMaybe (\b -> fmap (flip (,) b) getNext)) {-# INLINE feedSnd #-} -feedSnd :: Sig.T a -> T b (b,a) -feedSnd = fromStateMaybe (\b -> fmap ((,) b) getNext) +feedSnd :: (SigG.Read sig a) => + sig a -> T b (b,a) +feedSnd = + flip runViewL (\getNext -> + fromStateMaybe (\b -> fmap ((,) b) getNext)) {-# INLINE feedConstFst #-} feedConstFst :: a -> T b (a,b) @@ -343,7 +359,8 @@ 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 :: (SigG.Read sig a) => + (a -> b -> c) -> sig a -> T b c zipWith f = applyFst (map (uncurry f)) {- | diff --git a/src-4/Synthesizer/Inference/DesignStudy/Applicative.hs b/src-4/Synthesizer/Inference/DesignStudy/Applicative.hs deleted file mode 100644 --- a/src-4/Synthesizer/Inference/DesignStudy/Applicative.hs +++ /dev/null @@ -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 diff --git a/src-4/Synthesizer/Inference/DesignStudy/Arrow.hs b/src-4/Synthesizer/Inference/DesignStudy/Arrow.hs deleted file mode 100644 --- a/src-4/Synthesizer/Inference/DesignStudy/Arrow.hs +++ /dev/null @@ -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 -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" diff --git a/src-4/Synthesizer/Inference/DesignStudy/Monad.hs b/src-4/Synthesizer/Inference/DesignStudy/Monad.hs deleted file mode 100644 --- a/src-4/Synthesizer/Inference/DesignStudy/Monad.hs +++ /dev/null @@ -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 diff --git a/src/Synthesizer/Basic/Binary.hs b/src/Synthesizer/Basic/Binary.hs --- a/src/Synthesizer/Basic/Binary.hs +++ b/src/Synthesizer/Basic/Binary.hs @@ -100,10 +100,15 @@ {-# INLINE int16FromCanonical #-} int16FromCanonical :: (RealField.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) . truncate . (0.5+) . scale16 {-# INLINE int16FromFloat #-} int16FromFloat :: Float -> Int16 diff --git a/src/Synthesizer/Basic/ComplexModule.hs b/src/Synthesizer/Basic/ComplexModule.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Basic/ComplexModule.hs @@ -0,0 +1,34 @@ +{- +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 Algebra.Module ((*>), ) + +import qualified Prelude as P +-- import PreludeBase +import NumericPrelude + + +{-# 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 diff --git a/src/Synthesizer/Basic/Phase.hs b/src/Synthesizer/Basic/Phase.hs --- a/src/Synthesizer/Basic/Phase.hs +++ b/src/Synthesizer/Basic/Phase.hs @@ -19,10 +19,17 @@ import Foreign.Storable (Storable(..), ) import Foreign.Ptr (castPtr, ) +-- import Data.Function.HT (powerAssociative, ) import Data.Tuple.HT (mapFst, ) + import qualified NumericPrelude as NP +import NumericPrelude +import PreludeBase +import Prelude () +import qualified GHC.Float as GHC + newtype T a = Cons {decons :: a} deriving Eq @@ -45,10 +52,10 @@ 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) + arbitrary = fmap Cons $ choose (zero, one) coarbitrary = error "Phase.coarbitrary not implemented" @@ -61,30 +68,167 @@ 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 d = (+ Cons d) + +{-# INLINE decrement #-} +decrement :: RealField.C a => a -> T a -> T a +decrement d = Additive.subtract (Cons d) +-} + +{-# INLINE increment #-} +increment :: RealField.C a => a -> T a -> T a increment d = lift (d Additive.+) {-# INLINE decrement #-} decrement :: RealField.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 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 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. +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 :: (RealField.C a, ToInteger.C b) => b -> T a -> T a +multiplyPrecise n x = + if n 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 :: (RealField.C b) => + (a -> b) -> T a -> T b lift f = fromRepresentative . f . toRepresentative + +{- +{-# INLINE lift2 #-} +lift2 :: (RealField.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 nzero + 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 large 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 (-); + +-} diff --git a/src/Synthesizer/Basic/ToneModulation.hs b/src/Synthesizer/Basic/ToneModulation.hs --- a/src/Synthesizer/Basic/ToneModulation.hs +++ b/src/Synthesizer/Basic/ToneModulation.hs @@ -28,6 +28,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 +65,7 @@ -} +{-# INLINE flattenShapePhase #-} flattenShapePhase, flattenShapePhaseAnalytic :: RealField.C a => Int -> a diff --git a/src/Synthesizer/Basic/Wave.hs b/src/Synthesizer/Basic/Wave.hs --- a/src/Synthesizer/Basic/Wave.hs +++ b/src/Synthesizer/Basic/Wave.hs @@ -95,7 +95,7 @@ This way you express a phase modulated oscillator using a shape modulated oscillator. -} -{-# 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 (Cons wave) offset = @@ -109,7 +109,7 @@ {- ** unparameterized -} {- | map a phase to value of a sine wave -} -{-# SPECULATE sine :: Double -> Double #-} +{- disabled SPECIALISE sine :: Double -> Double -} {-# INLINE sine #-} sine :: Trans.C a => T a a sine = fromFunction $ \x -> sin (2*pi*x) @@ -163,7 +163,7 @@ {- | saw tooth, it's a ramp down in order to have a positive coefficient for the first partial sine -} -{-# SPECULATE saw :: Double -> Double #-} +{- disabled SPECIALISE saw :: Double -> Double -} {-# INLINE saw #-} saw :: Ring.C a => T a a saw = fromFunction $ \x -> 1-2*x @@ -210,7 +210,7 @@ {- | square -} -{-# SPECULATE square :: Double -> Double #-} +{- 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 @@ -258,7 +258,7 @@ {- | triangle -} -{-# SPECULATE triangle :: Double -> Double #-} +{- disabled SPECIALISE triangle :: Double -> Double -} {-# INLINE triangle #-} triangle :: (Ord a, Ring.C a) => T a a triangle = fromFunction $ \x -> @@ -565,7 +565,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,7 +578,7 @@ {- | triangle with space -} -{-# SPECULATE trianglePike :: Double -> Double -> Double #-} +{- disabled SPECIALISE trianglePike :: Double -> Double -> Double -} {-# INLINE trianglePike #-} trianglePike :: (Real.C a, Field.C a) => a {- ^ pike width ranging from 0 to 1, 1 yields 'triangle' -} @@ -591,7 +591,7 @@ {- | 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) => a {- ^ pike width ranging from 0 to 1 -} @@ -606,7 +606,7 @@ 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) => a {- ^ pike width ranging from 0 to 1, 1 yields 'square' -} @@ -619,7 +619,7 @@ {- | square with space and shift -} -{-# SPECULATE squarePikeShift :: Double -> Double -> Double -> Double #-} +{- disabled SPECIALISE squarePikeShift :: Double -> Double -> Double -> Double -} {-# INLINE squarePikeShift #-} squarePikeShift :: (Real.C a) => a {- ^ pike width ranging from 0 to 1 -} @@ -634,7 +634,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: @@ -649,7 +649,7 @@ It could be simulated by adding two saw oscillations with 180 degree phase difference and opposite sign. -} -{-# 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 +658,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: @@ -674,7 +674,7 @@ {- | Mixing 'trapezoid' and 'trianglePike' you can get back a triangle wave form -} -{-# SPECULATE trapezoid :: Double -> Double -> Double #-} +{- disabled SPECIALISE trapezoid :: Double -> Double -> Double -} {-# INLINE trapezoid #-} trapezoid :: (Real.C a, Field.C a) => a {- ^ width of the plateau ranging from 0 to 1: @@ -690,7 +690,7 @@ 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) => a {- ^ sum of the plateau widths ranging from 0 to 1: @@ -720,7 +720,7 @@ {- | trapezoid with distinct high and low time and zero direct current offset -} -{-# 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 w r = diff --git a/src/Synthesizer/Causal/Arrow.hs b/src/Synthesizer/Causal/Arrow.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Causal/Arrow.hs @@ -0,0 +1,17 @@ +module Synthesizer.Causal.Arrow where + +import qualified Synthesizer.Causal.Process as Causal +import qualified Synthesizer.Generic.Signal2 as SigG2 +import Control.Arrow (Arrow, ) + + +class Arrow arrow => C arrow where + apply :: + (SigG2.Transform sig a b) => + arrow a b -> sig a -> sig b + +instance C Causal.T where + apply = Causal.apply + +instance C (->) where + apply = SigG2.map diff --git a/src/Synthesizer/Causal/Cut.hs b/src/Synthesizer/Causal/Cut.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Causal/Cut.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Synthesizer.Causal.Cut where + +import qualified Synthesizer.Causal.Process as Causal + +import Data.Maybe.HT (toMaybe, ) + +import Control.Monad.Trans.State (StateT(StateT), ) + +-- import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{-# INLINE take #-} +take :: Int -> Causal.T a a +take = + Causal.fromStateMaybe (\x -> + StateT (\i -> toMaybe (i>0) (x, pred i))) diff --git a/src/Synthesizer/Causal/Filter/NonRecursive.hs b/src/Synthesizer/Causal/Filter/NonRecursive.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Causal/Filter/NonRecursive.hs @@ -0,0 +1,62 @@ +{-# 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.Plain.Filter.NonRecursive as Filt +import qualified Synthesizer.State.Signal as SigS + +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 PreludeBase +import NumericPrelude as NP +-- import qualified Prelude as P + + +{-# 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 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 diff --git a/src/Synthesizer/Causal/Filter/Recursive/Integration.hs b/src/Synthesizer/Causal/Filter/Recursive/Integration.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Causal/Filter/Recursive/Integration.hs @@ -0,0 +1,44 @@ +{-# 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.Field as Field +-- import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import PreludeBase +import NumericPrelude + + + +{- | +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 -} diff --git a/src/Synthesizer/ChunkySize.hs b/src/Synthesizer/ChunkySize.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/ChunkySize.hs @@ -0,0 +1,33 @@ +module Synthesizer.ChunkySize where + +import qualified Synthesizer.Generic.Signal as SigG +import qualified Number.NonNegativeChunky as Chunky +import qualified Numeric.NonNegative.Chunky as Chunky98 + +import qualified Data.StorableVector.Lazy as SigSt +import qualified Data.StorableVector.Lazy.Pattern as SigStV + +import qualified Data.List as List + + +type T = Chunky.T SigG.LazySize + + +fromStorableVectorSize :: + SigStV.LazySize -> T +fromStorableVectorSize = + Chunky.fromChunks . + List.map (\(SigSt.ChunkSize size) -> (SigG.LazySize size)) . + Chunky98.toChunks + +toStorableVectorSize :: + T -> SigStV.LazySize +toStorableVectorSize = + Chunky98.fromChunks . + List.map (\(SigG.LazySize size) -> (SigSt.ChunkSize size)) . + Chunky.toChunks + +toNullList :: T -> [()] +toNullList = + List.concatMap (\(SigG.LazySize n) -> List.replicate n ()) . + Chunky.toChunks diff --git a/src/Synthesizer/ChunkySize/Cut.hs b/src/Synthesizer/ChunkySize/Cut.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/ChunkySize/Cut.hs @@ -0,0 +1,244 @@ +{- | +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.Generic.Signal as SigG + +-- import qualified Synthesizer.Plain.Signal as Sig +import qualified Synthesizer.State.Signal as SigS +-- import qualified Synthesizer.FusionList.Signal as SigFL +-- import qualified Synthesizer.Storable.Signal as SigSt +import qualified Data.StorableVector.Lazy.Pattern as SigStV +import qualified Data.StorableVector.Lazy as Vector + + +import qualified Algebra.Ring as Ring +-- import qualified Algebra.ToInteger as ToInteger + +-- import qualified Number.NonNegative as NonNegW +-- import qualified Algebra.NonNegative as NonNeg +import qualified Number.NonNegativeChunky as Chunky + +{- +-- import qualified Numeric.NonNegative.Wrapper as NonNegW98 +import qualified Numeric.NonNegative.Class as NonNeg98 +import qualified Numeric.NonNegative.Chunky as Chunky98 +-} + +import Foreign.Storable (Storable) + +import qualified Data.List as List +import qualified Data.List.Match as Match +import Data.Tuple.HT (mapPair, ) + +import qualified Data.Monoid as Monoid +import Data.Monoid (Monoid, ) + +import qualified Prelude as P +import NumericPrelude +import PreludeBase hiding (splitAt, Read, ) +{- +import Prelude + (Bool, Int, String, (++), error, const, + pred, (<=), (>=), (<), (>), ($), + (.), not, (||), (&&), + Maybe(Just, Nothing), ) +-} + + +class Cut.Read sig => Read sig where + length :: sig -> ChunkySize.T + +class (Read 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 => Read SigSt.T y where +instance Storable y => Read (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 Read ([] y) where + {-# INLINE length #-} + length xs = + Chunky.fromChunks $ Match.replicate xs $ SigG.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 (SigG.LazySize n) -> List.drop n x) + xs (Chunky.toChunks ns) + {-# INLINE splitAt #-} + splitAt ns = + Match.splitAt (ChunkySize.toNullList ns) + +{- +instance Read (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 Read (SigS.T y) where + {-# INLINE length #-} + length = + Chunky.fromChunks . SigS.toList . + SigS.map (const (SigG.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 + SigG.LazySize m : ms -> Just (x, (pred m, ms)) + [] -> Nothing) + (zero, Chunky.toChunks $ Chunky.normalize size0) + {-# INLINE drop #-} + drop ns xs = + List.foldl + (\x (SigG.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) => Read (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 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) => Read (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) +-} diff --git a/src/Synthesizer/ChunkySize/Signal.hs b/src/Synthesizer/ChunkySize/Signal.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/ChunkySize/Signal.hs @@ -0,0 +1,73 @@ +{-# 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.Cut as CutG +import qualified Synthesizer.Generic.Signal as SigG + +-- import qualified Synthesizer.Plain.Signal as Sig +import qualified Synthesizer.State.Signal as SigS +-- import qualified Synthesizer.FusionList.Signal as SigFL +-- import qualified Synthesizer.Storable.Signal as SigSt +import qualified Data.StorableVector.Lazy.Pattern as SigStV +import qualified Data.StorableVector.Lazy as Vector + +-- import qualified Algebra.NonNegative as NonNeg +-- import qualified Algebra.Module as Module +-- import qualified Algebra.Additive as Additive + +import Foreign.Storable (Storable) + +import qualified Data.List.Match as Match + +import Control.Monad.Trans.State (runStateT, ) + +import qualified Data.List as List + +-- import NumericPrelude +import Prelude + (Bool, Int, Maybe(Just), fst, (.), id, ) + + +class (SigG.Write sig y, Cut.Transform (sig y)) => Write sig y where + unfoldRN :: ChunkySize.T -> (s -> Maybe (y,s)) -> s -> sig y + + +instance Storable y => Write Vector.Vector y where + {-# INLINE unfoldRN #-} + unfoldRN size f = + fst . + SigStV.unfoldrN + (ChunkySize.toStorableVectorSize size) f + +instance Write [] y where + {-# INLINE unfoldRN #-} + unfoldRN size f = + Match.take (ChunkySize.toNullList size) . + List.unfoldr f + +instance Write SigS.T y where + {-# INLINE unfoldRN #-} + unfoldRN size f = + Cut.take size . SigS.unfoldR f + + +{-# INLINE replicate #-} +replicate :: (Write sig y) => + ChunkySize.T -> y -> sig y +replicate = iterateN id + +{-# INLINE iterateN #-} +iterateN :: (Write sig y) => + (y -> y) -> ChunkySize.T -> y -> sig y +iterateN f size = + unfoldRN size (\y -> Just (y, f y)) + +{-# INLINE fromState #-} +fromState :: (Write sig y) => + ChunkySize.T -> SigS.T y -> sig y +fromState size (SigS.Cons f x) = + unfoldRN size (runStateT f) x diff --git a/src/Synthesizer/Frame/Stereo.hs b/src/Synthesizer/Frame/Stereo.hs --- a/src/Synthesizer/Frame/Stereo.hs +++ b/src/Synthesizer/Frame/Stereo.hs @@ -1,114 +1,8 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{- -This data type can be used as sample type for stereo signals. +{- | +We just re-export @Sound.Frame.NumericPrelude.Stereo@. -} 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) - -instance (Module.C a v) => Module.C a (T v) where - {-# INLINE (*>) #-} - s *> (Cons l r) = Cons (s *> l) (s *> r) - -instance Interpol.C a v => Interpol.C a (T v) where - {-# INLINE scaleAndAccumulate #-} - scaleAndAccumulate = - Interpol.makeMac2 Cons left right - - -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) - +import Sound.Frame.NumericPrelude.Stereo -instance Frame.C a => Frame.C (T a) where - numberOfChannels y = 2 * Frame.numberOfChannels (left y) - format y = Frame.format (left y) +import Prelude hiding (map, ) diff --git a/src/Synthesizer/FusionList/Filter/NonRecursive.hs b/src/Synthesizer/FusionList/Filter/NonRecursive.hs --- a/src/Synthesizer/FusionList/Filter/NonRecursive.hs +++ b/src/Synthesizer/FusionList/Filter/NonRecursive.hs @@ -176,7 +176,7 @@ {-# INLINE binomial1 #-} binomial1 :: (Additive.C v) => Sig.T v -> Sig.T v -binomial1 = Sig.zapWith (+) +binomial1 = Sig.mapAdjacent (+) @@ -270,7 +270,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. @@ -288,8 +288,8 @@ {-# 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 = diff --git a/src/Synthesizer/FusionList/Signal.hs b/src/Synthesizer/FusionList/Signal.hs --- a/src/Synthesizer/FusionList/Signal.hs +++ b/src/Synthesizer/FusionList/Signal.hs @@ -135,7 +135,7 @@ map :: (a -> b) -> (T a -> T b) map f = crochetL (\x _ -> Just (f x, ())) () -{-# RULEZ +{- disabled RULES "FusionList.map-crochetL" forall f. map f = crochetL (\x _ -> Just (f x, ())) () ; @@ -153,7 +153,7 @@ "FusionList.unfold-dot" forall f g. f . g = \x -> f (g x) ; - #-} + -} {-# INLINE unzip #-} unzip :: T (a,b) -> (T a, T b) @@ -278,7 +278,11 @@ lengthSlow :: T a -> Int lengthSlow = foldL' (const succ) zero +{-# INLINE foldR #-} +foldR :: (x -> acc -> acc) -> acc -> T x -> acc +foldR f acc = List.foldr f acc . toList + {- Do we still need rules for fusion of map f (repeat x) @@ -623,8 +627,8 @@ List.map (take n) . List.takeWhile (not . null) . List.iterate (drop n) -zapWith :: (a -> a -> b) -> T a -> T b -zapWith f xs0 = +mapAdjacent :: (a -> a -> b) -> T a -> T b +mapAdjacent f xs0 = let xs1 = maybe empty snd (viewL xs0) in zipWith f xs0 xs1 diff --git a/src/Synthesizer/Generic/Cut.hs b/src/Synthesizer/Generic/Cut.hs --- a/src/Synthesizer/Generic/Cut.hs +++ b/src/Synthesizer/Generic/Cut.hs @@ -13,18 +13,25 @@ -- import qualified Synthesizer.Storable.Signal as SigSt import qualified Data.StorableVector.Lazy as Vector --- import qualified Algebra.ToInteger as ToInteger --- import qualified Numeric.NonNegative.Wrapper as NonNegW -import qualified Numeric.NonNegative.Class as NonNeg -import qualified Numeric.NonNegative.Chunky as Chunky +import qualified Algebra.ToInteger as ToInteger +import qualified Algebra.Ring as Ring +-- import qualified Number.NonNegative as NonNegW +import qualified Algebra.NonNegative as NonNeg +import qualified Number.NonNegativeChunky as Chunky + +-- import qualified Numeric.NonNegative.Wrapper as NonNegW98 +import qualified Numeric.NonNegative.Class as NonNeg98 +import qualified Numeric.NonNegative.Chunky as Chunky98 + import Foreign.Storable (Storable) -import Data.Function (fix, ) import qualified Data.List as List +import Data.Function (fix, ) import Data.Tuple.HT (mapPair, ) + import qualified Data.Monoid as Monoid -import Data.Monoid (Monoid, ) +import Data.Monoid (Monoid, mempty, ) import qualified Prelude as P import NumericPrelude @@ -178,24 +185,26 @@ {- 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) => Read (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 -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 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 #-} @@ -206,14 +215,53 @@ Chunky.minMaxDiff (intToChunky "dropMargin/n" n) (x NonNeg.-| intToChunky "dropMargin/m" m) - in (if b then 0 else P.fromIntegral (Chunky.toNumber d), + 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) + in (z, if b then d else mempty) {-# INLINE reverse #-} - reverse = Chunky.fromChunks . P.reverse . Chunky.toChunks + reverse = Chunky.fromChunks . List.reverse . Chunky.toChunks + + + +instance (P.Integral a) => Read (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 {-# INLINE empty #-} diff --git a/src/Synthesizer/Generic/Filter/NonRecursive.hs b/src/Synthesizer/Generic/Filter/NonRecursive.hs --- a/src/Synthesizer/Generic/Filter/NonRecursive.hs +++ b/src/Synthesizer/Generic/Filter/NonRecursive.hs @@ -16,6 +16,7 @@ import qualified Synthesizer.Generic.Control as Ctrl import qualified Synthesizer.State.Signal as SigS import qualified Synthesizer.Plain.Filter.NonRecursive as Filt +import qualified Synthesizer.State.Filter.NonRecursive as FiltS import qualified Algebra.Transcendental as Trans import qualified Algebra.Module as Module @@ -26,8 +27,10 @@ import Algebra.Module( {- linearComb, -} (*>), ) +import Control.Monad (mplus, ) import Data.Function.HT (nest, ) import Data.Tuple.HT (mapSnd, mapPair, ) +import Data.Maybe.HT (toMaybe, ) import PreludeBase import NumericPrelude as NP @@ -151,6 +154,21 @@ +binomialMask :: + (Field.C a, SigG.Write sig a) => + SigG.LazySize -> + Int -> sig a +binomialMask size n = + SigG.unfoldR size + (\(x, a, b) -> + toMaybe (b>=0) + (x, (x * fromInteger b / fromInteger (a+1), a+1, b-1))) + (recip $ 2 ^ fromIntegral n, 0, fromIntegral n) + +{- +property: must sum up to 1 +-} + {-| Unmodulated non-recursive filter -} {-# INLINE generic #-} generic :: @@ -261,7 +279,14 @@ SigG.unfoldR cs (fmap (mapSnd SigG.laxTail) . SigG.viewL) +downsample :: + (SigG.Write sig v) => + SigG.LazySize -> Int -> sig v -> sig v +downsample cs n = + SigG.unfoldR cs + (\xs -> fmap (mapSnd (const (SigG.drop n xs))) $ SigG.viewL xs) + {- {- | Given a list of numbers @@ -335,11 +360,28 @@ in (sizes, scanl (flip sumsDownsample2) sig (map SigG.LazySize $ tail sizes)) +{-# 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,8 +401,56 @@ 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) => sig (Int,Int) -> sig v -> sig v @@ -373,12 +463,14 @@ 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 +{-# INLINE accumulatePosModulatedFromPyramid #-} +accumulatePosModulatedFromPyramid :: + (SigG.Transform sig (Int,Int), SigG.Write 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 = @@ -388,11 +480,31 @@ zipWith (\pyr -> SigG.fromState (SigG.LazySize blockSize) . - SigS.map (sumRangeFromPyramid pyr) . + 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.Write sig v) => + Int -> sig (Int,Int) -> sig v -> sig v +sumsPosModulatedPyramid height ctrl xs = + accumulatePosModulatedFromPyramid + sumRangeFromPyramid + (pyramid height xs) ctrl + +withPaddedInput :: + (SigG2.Transform sig Int (Int, Int), + SigG.Write sig y) => + y -> (sig (Int, Int) -> sig y -> v) -> + Int -> + sig Int -> + sig y -> v +withPaddedInput pad proc maxC ctrl xs = + proc + (SigG2.map (\c -> (maxC - c, maxC + c + 1)) ctrl) + (delayPad pad maxC xs) + {- | The first argument is the amplification. The main reason to introduce it, @@ -403,11 +515,23 @@ (Field.C a, Module.C a v, SigG2.Transform sig Int (Int,Int), SigG.Write 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.Write sig v, SigG.Read sig t) => + SigG.LazySize -> + sig t -> sig v -> sig v +inverseFrequencyModulationFloor chunkSize ctrl xs = + SigG.fromState chunkSize + (FiltS.inverseFrequencyModulationFloor + (SigG.toState ctrl) (SigG.toState xs)) diff --git a/src/Synthesizer/Generic/Filter/Recursive/MovingAverage.hs b/src/Synthesizer/Generic/Filter/Recursive/MovingAverage.hs --- a/src/Synthesizer/Generic/Filter/Recursive/MovingAverage.hs +++ b/src/Synthesizer/Generic/Filter/Recursive/MovingAverage.hs @@ -106,7 +106,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 diff --git a/src/Synthesizer/Generic/Loop.hs b/src/Synthesizer/Generic/Loop.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Generic/Loop.hs @@ -0,0 +1,140 @@ +{-# 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.Real as Real +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import NumericPrelude +import PreludeBase + + +{- | +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.Write sig yv, RealField.C q, Module.C q yv) => + SigG.LazySize -> + Interpolation.T q yv -> + Interpolation.T q yv -> + TimeControl q -> + q -> q -> (q, sig yv) -> (q, sig yv) +timeReverse lazySize 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 lazySize $ + 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 :: (Real.C a) => TimeControl a +timeControlZigZag = TimeControl 4 Wave.triangle diff --git a/src/Synthesizer/Generic/Oscillator.hs b/src/Synthesizer/Generic/Oscillator.hs --- a/src/Synthesizer/Generic/Oscillator.hs +++ b/src/Synthesizer/Generic/Oscillator.hs @@ -64,7 +64,7 @@ freqMod :: (RealField.C a, SigG2.Transform sig a 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) => @@ -76,7 +76,7 @@ shapeMod :: (RealField.C a, SigG2.Transform sig c b) => (c -> Wave.T a b) -> Phase.T a -> a -> sig c -> sig b shapeMod wave phase freq = - 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) => @@ -89,7 +89,7 @@ (RealField.C a, SigG.Read sig c, SigG2.Transform sig a b) => (c -> Wave.T a b) -> Phase.T a -> sig c -> sig a -> sig b shapeFreqMod wave phase parameters = - Causal.applyGeneric + Causal.apply (Causal.feedGenericFst parameters >>> OsciC.shapeFreqMod wave phase) @@ -119,7 +119,7 @@ in Interpolation.relativeCyclicPad ip (len * Phase.toRepresentative phase) (SigG.toState wave) - `Causal.applyGeneric` + `Causal.apply` SigG.map (* len) freqs @@ -140,13 +140,13 @@ 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) => @@ -159,4 +159,4 @@ 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) diff --git a/src/Synthesizer/Generic/Signal.hs b/src/Synthesizer/Generic/Signal.hs --- a/src/Synthesizer/Generic/Signal.hs +++ b/src/Synthesizer/Generic/Signal.hs @@ -1,5 +1,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} {- | Type classes that give a uniform interface to storable signals, stateful signals, lists, fusable lists. @@ -38,22 +40,27 @@ import qualified Synthesizer.Plain.Modifier as Modifier +import qualified Algebra.NonNegative as NonNeg + 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.Monoid (Monoid, mappend, mempty, ) import Data.Function (fix, ) import qualified Data.List.HT as ListHT import qualified Data.List as List import Data.Tuple.HT (mapPair, mapFst, ) +-- import NumericPrelude import Prelude (Bool, Int, Maybe(Just), maybe, snd, (<), flip, uncurry, const, (.), ($), id, (++), - fmap, return, error, show, ) + fmap, return, error, show, + Eq, Ord, Show, max, ) class Cut.Read (sig y) => Read sig y where @@ -61,9 +68,8 @@ 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) + foldR :: (y -> s -> s) -> s -> sig y -> s + index :: sig y -> Int -> y class (Read sig y, Cut.Transform (sig y)) => Transform sig y where {- | @@ -76,6 +82,16 @@ takeWhile :: (y -> Bool) -> sig y -> sig y dropWhile :: (y -> Bool) -> sig y -> sig y span :: (y -> Bool) -> sig y -> (sig y, sig y) + + {- | + 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. + -} + viewL :: sig y -> Maybe (y, sig y) + viewR :: sig y -> Maybe (sig y, 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 @@ -92,7 +108,12 @@ but we need control over packet size in applications with feedback. -} newtype LazySize = LazySize Int + deriving (Eq, Ord, Show, Additive.C) +instance NonNeg.C LazySize where + LazySize x -| LazySize y = + LazySize (max 0 (x Additive.- y)) + {- | This can be used for internal signals that have no observable effect on laziness. @@ -129,12 +150,12 @@ toList = Vector.unpack {-# INLINE toState #-} toState = SigS.fromStorableSignal - {-# INLINE viewL #-} - viewL = Vector.viewL - {-# INLINE viewR #-} - viewR = Vector.viewR {-# INLINE foldL #-} foldL = Vector.foldl + {-# INLINE foldR #-} + foldR = Vector.foldr + {-# INLINE index #-} + index = Vector.index instance Storable y => Transform Vector.Vector y where {-# INLINE cons #-} @@ -146,6 +167,11 @@ {-# INLINE span #-} span = Vector.span + {-# INLINE viewL #-} + viewL = Vector.viewL + {-# INLINE viewR #-} + viewR = Vector.viewR + {-# INLINE map #-} map = Vector.map {-# INLINE scanL #-} @@ -183,12 +209,12 @@ toList = id {-# INLINE toState #-} toState = SigS.fromList - {-# INLINE viewL #-} - viewL = ListHT.viewL - {-# INLINE viewR #-} - viewR = ListHT.viewR {-# INLINE foldL #-} foldL = List.foldl + {-# INLINE foldR #-} + foldR = List.foldr + {-# INLINE index #-} + index = (List.!!) instance Transform [] y where {-# INLINE cons #-} @@ -200,6 +226,11 @@ {-# INLINE span #-} span = List.span + {-# INLINE viewL #-} + viewL = ListHT.viewL + {-# INLINE viewR #-} + viewR = ListHT.viewR + {-# INLINE map #-} map = List.map {-# INLINE scanL #-} @@ -231,12 +262,12 @@ toList = SigFL.toList {-# INLINE toState #-} toState = SigS.fromList . SigFL.toList - {-# INLINE viewL #-} - viewL = SigFL.viewL - {-# INLINE viewR #-} - viewR = SigFL.viewR {-# INLINE foldL #-} foldL = SigFL.foldL + {-# INLINE foldR #-} + foldR = SigFL.foldR + {-# INLINE index #-} + index xs n = SigFL.toList xs List.!! n instance Transform SigFL.T y where {-# INLINE cons #-} @@ -248,6 +279,11 @@ {-# INLINE span #-} span = SigFL.span + {-# INLINE viewL #-} + viewL = SigFL.viewL + {-# INLINE viewR #-} + viewR = SigFL.viewR + {-# INLINE map #-} map = SigFL.map {-# INLINE scanL #-} @@ -279,15 +315,12 @@ toList = SigS.toList {-# INLINE toState #-} toState = id - {-# INLINE viewL #-} - viewL = SigS.viewL - {-# INLINE viewR #-} - viewR = - -- This implementation is slow. Better leave it unimplemented? - fmap (mapFst SigS.fromList) . - ListHT.viewR . SigS.toList {-# INLINE foldL #-} foldL = SigS.foldL + {-# INLINE foldR #-} + foldR = SigS.foldR + {-# INLINE index #-} + index = indexByDrop instance Transform SigS.T y where {-# INLINE cons #-} @@ -302,6 +335,14 @@ 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 = SigS.map {-# INLINE scanL #-} @@ -329,11 +370,36 @@ {-# 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 :: + (Read sig y) => + sig y -> + (forall s. (s -> Maybe (y, s)) -> s -> x) -> + x +runViewL = + SigS.runViewL . toState + +{-# INLINE runSwitchL #-} +runSwitchL :: + (Read sig y) => + sig y -> + (forall s. (forall z. z -> (y -> s -> z) -> s -> z) -> s -> x) -> + x +runSwitchL = + SigS.runSwitchL . toState + + {-# INLINE mix #-} mix :: (Additive.C y, Transform sig y) => sig y -> sig y -> sig y @@ -342,14 +408,28 @@ {-# 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 h = + flip runViewL (\next -> + crochetL + (\x0 a0 -> + do (y0,a1) <- next a0 + Just (h y0 x0, a1))) +{-# INLINE zipWithState #-} +zipWithState :: (Transform sig b) => + (a -> b -> b) -> SigS.T a -> sig b -> sig b +zipWithState f = + flip SigS.runViewL (\next -> + crochetL (\b as0 -> + do (a,as1) <- next as0 + Just (f a b, as1))) +{-# INLINE zipWithState3 #-} +zipWithState3 :: (Transform sig c) => + (a -> b -> c -> c) -> (SigS.T a -> SigS.T b -> sig c -> sig c) +zipWithState3 h a b = + zipWithState ($) (SigS.zipWith h a b) + {-# INLINE delay #-} delay :: (Write sig y) => LazySize -> y -> Int -> sig y -> sig y @@ -390,6 +470,12 @@ sum :: (Additive.C a, Read sig a) => sig a -> a sum = foldL (Additive.+) Additive.zero +{-# INLINE monoidConcatMap #-} +monoidConcatMap :: (Read sig a, Monoid m) => (a -> m) -> sig a -> m +monoidConcatMap f = + foldR (mappend . f) mempty + + {-# INLINE tails #-} tails :: (Transform sig y) => sig y -> SigS.T (sig y) tails = @@ -421,12 +507,13 @@ modifyModulated :: (Transform sig a, Read sig ctrl) => Modifier.Simple s ctrl a a -> sig ctrl -> sig a -> sig a modifyModulated (Modifier.Simple state proc) control = + 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 @@ -474,7 +561,7 @@ Thus we prefer crochetL, although we do not consume single elements of the input signal. -} mapTailsAlt :: - (Read sig a, Write sig b) => + (Transform sig a, Write sig b) => LazySize -> (sig a -> b) -> sig a -> sig b mapTailsAlt size f = unfoldR size (\xs -> @@ -492,7 +579,7 @@ but it is a bit more hassle to implement that. -} {-# INLINE zipWithTails #-} -zipWithTails :: (Read sig b, Transform sig a) => +zipWithTails :: (Transform sig b, Transform sig a) => (a -> sig b -> a) -> sig a -> sig b -> sig a zipWithTails f = flip (crochetL (\x ys0 -> @@ -506,12 +593,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 diff --git a/src/Synthesizer/Generic/Signal2.hs b/src/Synthesizer/Generic/Signal2.hs --- a/src/Synthesizer/Generic/Signal2.hs +++ b/src/Synthesizer/Generic/Signal2.hs @@ -32,7 +32,7 @@ import Data.Tuple.HT (fst3, snd3, thd3, ) import Prelude (Bool, Int, Maybe(Just), maybe, fst, snd, - flip, + flip, ($), (.), return, ) @@ -70,19 +70,14 @@ 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 +zipWith h = + zipWithState h . SigG.toState {-# INLINE mapAdjacent #-} -mapAdjacent :: (Read sig a, Transform sig a b) => +mapAdjacent :: (Transform sig a b) => (a -> a -> b) -> sig a -> sig b mapAdjacent f xs0 = let xs1 = maybe xs0 snd (viewL xs0) @@ -95,6 +90,20 @@ zip = zipWith (,) +{-# INLINE zipWith3 #-} +zipWith3 :: (Read sig a, Read sig b, Transform sig c d) => + (a -> b -> c -> d) -> (sig a -> sig b -> sig c -> sig d) +zipWith3 h a b = + zipWithState3 h + (SigG.toState a) + (SigG.toState b) + +{-# INLINE zip3 #-} +zip3 :: (Read sig a, Read sig b, Transform sig c (a,b,c)) => + sig a -> sig b -> sig c -> sig (a,b,c) +zip3 = zipWith3 (,,) + + {-# INLINE unzip #-} unzip :: (Transform sig (a,b) a, Transform sig (a,b) b) => sig (a,b) -> (sig a, sig b) @@ -120,12 +129,13 @@ 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 = + SigG.runViewL control (\next s0 -> 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, s0)) linearComb :: (Module.C t y, Read sig t, Transform sig y y) => @@ -142,7 +152,7 @@ x x {-# INLINE zipWithTails #-} -zipWithTails :: (Read sig b, Transform sig a c) => +zipWithTails :: (SigG.Transform sig b, Transform sig a c) => (a -> sig b -> c) -> sig a -> sig b -> sig c zipWithTails f = flip (crochetL (\x ys0 -> @@ -150,7 +160,7 @@ Just (f x ys0, ys))) {-# INLINE zipWith2Tails #-} -zipWith2Tails :: (Read sig b, Read sig c, Transform sig a d) => +zipWith2Tails :: (SigG.Transform sig b, SigG.Transform 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) -> @@ -159,9 +169,17 @@ Just (f x ys0 zs0, (ys1,zs1))) (bs,cs) as +{-# INLINE zipWithState #-} zipWithState :: (Transform sig b c) => (a -> b -> c) -> SigS.T a -> sig b -> sig c zipWithState f = + flip SigS.runViewL (\next -> crochetL (\b as0 -> - do (a,as1) <- SigS.viewL as0 - Just (f a b, as1)) + do (a,as1) <- next as0 + Just (f a b, as1))) + +{-# INLINE zipWithState3 #-} +zipWithState3 :: (Transform sig c 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) diff --git a/src/Synthesizer/Interpolation.hs b/src/Synthesizer/Interpolation.hs --- a/src/Synthesizer/Interpolation.hs +++ b/src/Synthesizer/Interpolation.hs @@ -83,7 +83,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 = diff --git a/src/Synthesizer/Interpolation/Class.hs b/src/Synthesizer/Interpolation/Class.hs --- a/src/Synthesizer/Interpolation/Class.hs +++ b/src/Synthesizer/Interpolation/Class.hs @@ -12,6 +12,7 @@ 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 @@ -95,6 +96,11 @@ instance (C a v, C a w, C a u) => C a (v, w, u) where {-# 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 diff --git a/src/Synthesizer/Plain/Control.hs b/src/Synthesizer/Plain/Control.hs --- a/src/Synthesizer/Plain/Control.hs +++ b/src/Synthesizer/Plain/Control.hs @@ -283,7 +283,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. :-( diff --git a/src/Synthesizer/Plain/Filter/NonRecursive.hs b/src/Synthesizer/Plain/Filter/NonRecursive.hs --- a/src/Synthesizer/Plain/Filter/NonRecursive.hs +++ b/src/Synthesizer/Plain/Filter/NonRecursive.hs @@ -22,10 +22,12 @@ import Algebra.Module(linearComb, (*>)) import Data.Function.HT (nest, ) -import Data.Tuple.HT (mapPair, ) +import Data.Tuple.HT (mapPair, swap, ) import Data.List.HT (sliceVertical, ) import Data.List (tails, ) +import qualified Data.List.Match as Match + -- import Control.Monad.Trans.State (StateT) -- import Control.Monad.Trans.Writer (WriterT) @@ -260,6 +262,10 @@ pyramid :: (Additive.C v) => Sig.T v -> [Sig.T v] pyramid = iterate sumsDownsample2 +unitSizesFromPyramid :: [signal] -> [Int] +unitSizesFromPyramid pyr = + reverse $ Match.take pyr $ iterate (2*) 1 + sumRangePrepare :: (Additive.C v) => ((Int,Int) -> source -> v) -> (source -> (Int,Int) -> v) @@ -277,8 +283,22 @@ -} sumRangeFromPyramid :: (Additive.C v) => [Sig.T v] -> (Int,Int) -> v sumRangeFromPyramid = - sumRangePrepare $ \(l0,r0) pyr0 -> - sum $ + sumRangePrepare $ \lr0 pyr0 -> + sum $ getRangeFromPyramid pyr0 lr0 + +symmetricRangePrepare :: + ((Int,Int) -> source -> v) -> + (source -> (Int,Int) -> v) +symmetricRangePrepare f pyr lr = + f (if uncurry (<) lr then lr else swap lr) pyr + +minRange :: (Ord v) => Sig.T v -> (Int,Int) -> v +minRange = + 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 +313,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 +342,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 +382,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 +399,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 +408,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) diff --git a/src/Synthesizer/Plain/Filter/Recursive/Allpass.hs b/src/Synthesizer/Plain/Filter/Recursive/Allpass.hs --- a/src/Synthesizer/Plain/Filter/Recursive/Allpass.hs +++ b/src/Synthesizer/Plain/Filter/Recursive/Allpass.hs @@ -29,6 +29,7 @@ import qualified Number.Complex as Complex import Data.Tuple.HT (mapSnd, ) import Data.Function.HT (nest, ) +import Data.List.HT (mapAdjacent, switchR, ) import Control.Monad.Trans.State (State, state, runState, evalState, ) @@ -55,26 +56,54 @@ -} {-# 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 in radians. -} -> 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 omega = frequency * 2 * pi + k = (cos phase - cos omega) / (1 - cos (phase - omega)) + in Parameter k -{-# INLINE flangerPhase #-} -flangerPhase :: Trans.C a => a -flangerPhase = -2*pi +{- +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) +-} +{-# INLINE parameterAlt #-} +parameterAlt :: Trans.C a => + a {- ^ The phase shift to be achieved for the given frequency. -} + -> a {- ^ The frequency we specified the phase shift for. -} + -> Parameter a +parameterAlt phase frequency = + let s = tan (frequency * pi) + r = tan (phase/2) + in Parameter $ (s+r) / (s-r) -{-# INLINE flangerParameter #-} -flangerParameter :: Trans.C a => Int -> a -> Parameter a -flangerParameter order frequency = - parameter order flangerPhase frequency +{- | +An approximation to 'parameter' for small phase and frequency values. +It needs only field operations, +however it also needs 'pi', thus the transcendental constraint. +-} +{-# 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 = + let omega = frequency * 2 * pi + k = (omega + phase) / (omega - phase) + in Parameter k + +-- * atomic first order allpass + {-# INLINE firstOrderStep #-} firstOrderStep :: (Ring.C a, Module.C a v) => Parameter a -> v -> State (v,v) v @@ -102,9 +131,49 @@ {-# INLINE makePhase #-} makePhase :: RealTrans.C a => Parameter a -> a -> a makePhase (Parameter k) frequency = - let omega = 2*pi * frequency - in 2 * Complex.phase ((k+cos omega)+:(- sin omega)) + omega + let omega = 2*pi * frequency + in 2 * Complex.phase ((k+cos omega)+:(- sin omega)) + omega + +-- * 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 in radians. -} + -> a {- ^ The frequency we specified the phase shift for. -} + -> Parameter a +cascadeParameter order phase = + parameter (phase / fromIntegral order) + +{-# INLINE cascadeParameterAlt #-} +cascadeParameterAlt :: Trans.C a => + Int {- ^ The number of equally designed 1st order allpasses. -} + -> a {- ^ The phase shift to be achieved for the given frequency in radians. -} + -> a {- ^ The frequency we specified the phase shift for. -} + -> Parameter a +cascadeParameterAlt order phase frequency = + let orderFloat = fromIntegral order + omega = frequency * 2 * pi + phi = phase / orderFloat + k = (cos phi - cos omega) / (1 - cos (phi - omega)) + in Parameter k + +{-# INLINE flangerPhase #-} +flangerPhase :: Trans.C a => a +flangerPhase = -2*pi + +{-# 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 -> State [v] v +cascadeStep = cascadeStepRec + {- internal storage is not very efficient because the second value of one pair is equal @@ -118,7 +187,10 @@ Modifier.stackStatesL (firstOrderStep k) {-# INLINE cascadeStepStack #-} -cascadeStepStack :: (Ring.C a, Module.C a v) => +{-# INLINE cascadeStepRec #-} +{-# INLINE cascadeStepScanl #-} +cascadeStepStack, cascadeStepRec, cascadeStepScanl :: + (Ring.C a, Module.C a v) => Parameter a -> v -> State [v] v cascadeStepStack k x = state $ @@ -133,35 +205,29 @@ {-# 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 = 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) + 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) -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 +cascadeStepScanl k x = state $ \s -> + let news = + scanl + (evalState . firstOrderStep k) + x (mapAdjacent (,) s) + in (switchR + (error "Allpass.cascade needs at least one element in the state list") + (flip const) news, + news) + {-# INLINE cascadeModifier #-} cascadeModifier :: (Ring.C a, Module.C a v) => Int -> Modifier.Simple [v] (Parameter a) v v @@ -200,3 +266,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 -> State [v] v +cascadeDiverseStep = cascadeDiverseStepScanl + +cascadeDiverseStepScanl ks x = state $ \s -> + let news = + scanl + (\u0 (k,uy1) -> 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) diff --git a/src/Synthesizer/Plain/Filter/Recursive/FirstOrderComplex.hs b/src/Synthesizer/Plain/Filter/Recursive/FirstOrderComplex.hs --- a/src/Synthesizer/Plain/Filter/Recursive/FirstOrderComplex.hs +++ b/src/Synthesizer/Plain/Filter/Recursive/FirstOrderComplex.hs @@ -32,8 +32,8 @@ 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 @@ -42,7 +42,7 @@ import qualified Algebra.Ring as Ring import qualified Algebra.Additive as Additive -import Algebra.Module((*>)) +-- import Algebra.Module((*>)) import Control.Monad.Trans.State (State, state, ) @@ -191,21 +191,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 #-} diff --git a/src/Synthesizer/Plain/Filter/Recursive/Hilbert.hs b/src/Synthesizer/Plain/Filter/Recursive/Hilbert.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Filter/Recursive/Hilbert.hs @@ -0,0 +1,245 @@ +{-# 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 where + +import qualified Synthesizer.Plain.Filter.Recursive.Allpass as Allpass + +import qualified Synthesizer.Plain.Signal as Sig +import qualified Synthesizer.Plain.Modifier as Modifier +import qualified Synthesizer.Causal.Process as Causal +import Control.Arrow ((<<<), (>>>), (&&&), (>>^), ) + +import qualified Synthesizer.Plain.Oscillator as Osci +import qualified Synthesizer.Basic.Wave as Wave + +{- +import qualified Synthesizer.Plain.Control as Ctrl +import qualified Graphics.Gnuplot.Simple as Gnuplot +-} + +import qualified Synthesizer.Basic.ComplexModule as CM + +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 qualified Number.Complex as Complex +import Number.Complex ((+:), ) + +import Control.Monad.Trans.State (State, state, runState, ) + +import qualified Data.List.Match as Match + +import PreludeBase +import NumericPrelude + + + +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 (-2/15) . (/rate)) polesCosine) + (map (Allpass.parameterApprox (-2/15) . (/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] +-} diff --git a/src/Synthesizer/Plain/Filter/Recursive/Integration.hs b/src/Synthesizer/Plain/Filter/Recursive/Integration.hs --- a/src/Synthesizer/Plain/Filter/Recursive/Integration.hs +++ b/src/Synthesizer/Plain/Filter/Recursive/Integration.hs @@ -35,7 +35,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 diff --git a/src/Synthesizer/State/Analysis.hs b/src/Synthesizer/State/Analysis.hs --- a/src/Synthesizer/State/Analysis.hs +++ b/src/Synthesizer/State/Analysis.hs @@ -260,7 +260,7 @@ {-# INLINE meanValues #-} meanValues :: RealField.C y => Sig.T y -> [(Int,y)] -meanValues x = concatMap spread (Sig.toList (Sig.zapWith (,) x)) +meanValues x = concatMap spread (Sig.toList (Sig.mapAdjacent (,) x)) {-# INLINE spread #-} spread :: RealField.C y => (y,y) -> [(Int,y)] @@ -342,7 +342,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) diff --git a/src/Synthesizer/State/Cut.hs b/src/Synthesizer/State/Cut.hs --- a/src/Synthesizer/State/Cut.hs +++ b/src/Synthesizer/State/Cut.hs @@ -33,6 +33,7 @@ import Data.Traversable (sequenceA, ) import Data.Tuple.HT (mapSnd, ) +import Data.Maybe (fromMaybe, ) import qualified Number.NonNegative as NonNeg @@ -143,15 +144,18 @@ 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) + )) diff --git a/src/Synthesizer/State/Filter/NonRecursive.hs b/src/Synthesizer/State/Filter/NonRecursive.hs --- a/src/Synthesizer/State/Filter/NonRecursive.hs +++ b/src/Synthesizer/State/Filter/NonRecursive.hs @@ -24,6 +24,7 @@ import Algebra.Module( {- linearComb, -} (*>)) import Data.Function.HT (nest, ) +import Data.Tuple.HT (mapFst, ) import PreludeBase import NumericPrelude @@ -152,7 +153,7 @@ {-# INLINE binomial1 #-} binomial1 :: (Additive.C v) => Sig.T v -> Sig.T v -binomial1 = Sig.zapWith (+) +binomial1 = Sig.mapAdjacent (+) @@ -234,7 +235,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 +312,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 +327,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 = diff --git a/src/Synthesizer/State/Oscillator.hs b/src/Synthesizer/State/Oscillator.hs --- a/src/Synthesizer/State/Oscillator.hs +++ b/src/Synthesizer/State/Oscillator.hs @@ -28,7 +28,7 @@ import qualified Algebra.RealField as RealField -- import qualified Prelude as P --- import NumericPrelude +import NumericPrelude (Float, Double, ) -- import PreludeBase @@ -152,26 +152,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 = 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 = 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 = 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 = 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 = freqMod Wave.saw diff --git a/src/Synthesizer/State/Signal.hs b/src/Synthesizer/State/Signal.hs --- a/src/Synthesizer/State/Signal.hs +++ b/src/Synthesizer/State/Signal.hs @@ -2,6 +2,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE RankNTypes #-} {- | ToDo: Better name for the module is certainly @@ -28,10 +29,13 @@ liftM2, Functor, fmap, ) +import qualified Control.Applicative as App + import Data.Monoid (Monoid, mappend, mempty, ) 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 +43,17 @@ import Data.Tuple.HT (mapFst, mapSnd, mapPair, fst3, snd3, thd3, ) import Data.Function.HT (nest, ) import Data.Maybe.HT (toMaybe, ) -import NumericPrelude (fromInteger, ) +import NumericPrelude (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 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 +69,59 @@ 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 +instance App.Applicative T where + pure = singleton + x <*> y = liftA2 ($) x y +instance Monad T where + return = singleton + 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,7 +149,8 @@ (Storable a) => SigSt.T a -> T a fromStorableSignal = - generate SigSt.viewL + generate PtrSt.viewL . + PtrSt.cons {-# INLINE toStorableSignal #-} toStorableSignal :: @@ -258,8 +310,15 @@ {-# INLINE foldL' #-} foldL' :: (x -> acc -> acc) -> acc -> T x -> acc +foldL' g b0 = + flip runSwitchL (\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 @@ -269,12 +328,33 @@ 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 = + flip runSwitchL (\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 -} @@ -351,18 +431,19 @@ -} {-# INLINE extendConstant #-} extendConstant :: T a -> T a -extendConstant xt0 = - switchL +extendConstant = + flip runSwitchL (\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,7 +469,7 @@ -} dropMarginRem :: Int -> Int -> T a -> (Int, T a) dropMarginRem n m = - switchL (error "StateSignal.dropMaringRem: length xs < n") const . + switchL (error $ "StateSignal.dropMaringRem: length xs < " ++ show n) const . dropMargin n m . zipWithTails (,) (iterate pred m) @@ -408,7 +489,7 @@ 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 {- @@ -432,8 +513,15 @@ {-# INLINE dropWhile #-} dropWhile :: (a -> Bool) -> T a -> T a +dropWhile p (Cons f s0) = + let recurse s = + maybe empty (\(x,s1) -> if p x then recurse s1 else 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) @@ -456,12 +544,24 @@ {-# INLINE cycle #-} cycle :: T a -> T a +cycle = + flip runViewL + (\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.+) @@ -539,6 +639,21 @@ 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 :: T a -> T a @@ -642,6 +757,13 @@ 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 {-# INLINE zipWithTails #-} @@ -652,6 +774,16 @@ 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))) +-} {- This can hardly be implemented in an efficient way. @@ -673,14 +805,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)) @@ -739,3 +876,23 @@ instance Monoid (T y) where mempty = empty mappend = append + + +catMaybes :: T (Maybe a) -> T a +catMaybes = + flip runViewL (\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 = + flip runViewL (\next t -> + generate + (\(carry,s0) -> + fmap (\b -> (b, (Nothing, s0))) carry `mplus` + fmap (\((a,b),s1) -> (a, (Just b, s1))) (next s0)) + (Nothing,t)) diff --git a/src/Synthesizer/State/ToneModulation.hs b/src/Synthesizer/State/ToneModulation.hs --- a/src/Synthesizer/State/ToneModulation.hs +++ b/src/Synthesizer/State/ToneModulation.hs @@ -29,6 +29,7 @@ type Cell sig y = SigS.T (sig y) -- cells are organised in a transposed style, when compared with Plain.ToneModulation +{-# INLINE interpolateCell #-} interpolateCell :: (SigG.Read sig y) => Interpolation.T a y -> @@ -81,6 +82,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) diff --git a/src/Synthesizer/Storable/Cut.hs b/src/Synthesizer/Storable/Cut.hs --- a/src/Synthesizer/Storable/Cut.hs +++ b/src/Synthesizer/Storable/Cut.hs @@ -2,6 +2,7 @@ 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 @@ -60,7 +61,7 @@ put suffix return prefix) (\body -> - modify (Sig.mix body)) + modify (Sig.mixSndPattern body)) arrangeList :: (Storable v, Additive.C v) => @@ -94,17 +95,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,41 +130,104 @@ 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 + 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 Additive.+) >> + 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) = + addChunkToBuffer v i c >> + go (i Additive.+ SV.length c) cs + in fmap (flip (,) future) . go start . Sig.chunks $ now + +{- chunk must fit into the buffer -} +{-# INLINE addChunkToBuffer #-} +addChunkToBuffer :: (Storable a, Additive.C a) => + SVST.Vector s a -> Int -> SV.Vector a -> ST s () +addChunkToBuffer v start xs = + SV.foldr + (\x continue i -> + SVST.unsafeModify v i (x Additive.+) >> + continue (succ i)) + (\_i -> return ()) + xs start + + +{-# 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.+) >> 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) + 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.+) >> go (succ i) xs) diff --git a/src/Synthesizer/Storable/Filter/NonRecursive.hs b/src/Synthesizer/Storable/Filter/NonRecursive.hs --- a/src/Synthesizer/Storable/Filter/NonRecursive.hs +++ b/src/Synthesizer/Storable/Filter/NonRecursive.hs @@ -12,13 +12,15 @@ 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.Generic.Filter.NonRecursive as FiltG +import qualified Synthesizer.Plain.Filter.NonRecursive as Filt import qualified Synthesizer.Generic.Signal as SigG import qualified Synthesizer.State.Signal as SigS -import qualified Synthesizer.Plain.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 @@ -31,6 +33,8 @@ import Algebra.Module( {- linearComb, -} (*>), ) import Control.Monad (mplus, ) +import Data.Maybe.HT (toMaybe, ) +import Data.Maybe (fromMaybe, ) import qualified Data.List as List import Data.Tuple.HT (mapFst, mapSnd, mapPair, swap, ) @@ -45,28 +49,36 @@ {- | 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 +91,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 +126,7 @@ mapSnd VL.ChunkSize $ swap $ divMod (c+l) 2) zero . NonNegChunky.toChunks + {- | offset must be zero or one. -} @@ -121,56 +160,35 @@ 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 +accumulatePosModulatedPyramid :: + (Storable v) => + ([SigSt.T v] -> (Int,Int) -> v) -> + ([Int], [SigSt.T v]) -> + SigSt.T (Int,Int) -> SigSt.T v +accumulatePosModulatedPyramid accumulate (sizes,pyr0) ctrl = + let blockSize = head sizes pyrStarts = iterate (zipWith SigSt.drop sizes) pyr0 ctrlBlocks = @@ -180,11 +198,37 @@ 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 = + FiltG.accumulatePosModulatedFromPyramid + FiltG.sumRangeFromPyramid + (let pyr0 = pyramid (+) height xs + sizes = Filt.unitSizesFromPyramid pyr0 + in (sizes, pyr0)) + ctrl + +accumulateBinPosModulatedPyramid :: + (Storable v) => + (v -> v -> v) -> + Int -> SigSt.T (Int,Int) -> SigSt.T v -> SigSt.T v +accumulateBinPosModulatedPyramid acc height ctrl xs = + FiltG.accumulatePosModulatedFromPyramid + (\pyr -> + fromMaybe (error "accumulateBinPosModulatedPyramid: empty window") . + FiltG.maybeAccumulateRangeFromPyramid acc pyr) + (let pyr0 = pyramid acc height xs + sizes = Filt.unitSizesFromPyramid pyr0 + in (sizes, pyr0)) + ctrl + + {- | The first argument is the amplification. The main reason to introduce it, @@ -198,5 +242,89 @@ 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) + (SigSt.map (\c -> (maxC - c, maxC + c + 1)) ctrl) (FiltG.delay maxC xs) + + +movingAccumulateModulatedPyramid :: + (Storable v) => + (v -> v -> v) -> + v -> Int -> Int -> SigSt.T Int -> SigSt.T v -> SigSt.T v +movingAccumulateModulatedPyramid acc pad height = + FiltG.withPaddedInput pad $ + accumulateBinPosModulatedPyramid acc height + + +{- | +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.) + +This function cannot be written using generic functions, +since we have to inspect the chunks individually. +-} +{-# INLINE inverseFrequencyModulationFloor #-} +inverseFrequencyModulationFloor :: + (Storable v, SigG.Read 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 s -> r) -> + ((t,v) -> (s, VPtr.Pointer v) -> r) -> + (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 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) diff --git a/src/Synthesizer/Storable/Oscillator.hs b/src/Synthesizer/Storable/Oscillator.hs --- a/src/Synthesizer/Storable/Oscillator.hs +++ b/src/Synthesizer/Storable/Oscillator.hs @@ -52,7 +52,7 @@ {-# 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) => ChunkSize -> Wave.T a b -> (Phase.T a -> a -> Signal.T b) @@ -64,7 +64,7 @@ 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) => ChunkSize -> (c -> Wave.T a b) -> Phase.T a -> a -> Signal.T c -> Signal.T b @@ -113,35 +113,35 @@ {- * 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) => 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) => 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) => 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) => 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) => ChunkSize -> Phase.T a -> Signal.T a -> Signal.T a diff --git a/src/Synthesizer/Storable/Play.hs b/src/Synthesizer/Storable/Play.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Storable/Play.hs @@ -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 qualified Algebra.RealField as RealField + +import System.Exit (ExitCode, ) + +import PreludeBase +import NumericPrelude + + +{- | +Latency is high using Sox - +We can achieve better results using ALSA's sound output! +See synthesizer-alsa package. +-} +monoToInt16 :: + (Storable a, RealField.C a) => + a -> SigSt.T a -> IO ExitCode +monoToInt16 rate = + Play.simple SigSt.hPut SoxOpt.none (round rate) . + SigSt.map BinSmp.int16FromCanonical + +stereoToInt16 :: + (Storable a, RealField.C a) => + 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)) diff --git a/src/Synthesizer/Storable/Signal.hs b/src/Synthesizer/Storable/Signal.hs --- a/src/Synthesizer/Storable/Signal.hs +++ b/src/Synthesizer/Storable/Signal.hs @@ -31,6 +31,7 @@ -- for Dimensional.File Vector.writeFile, -- for Storable.Cut + mix, mixSndPattern, mixAppend, mixSize, splitAtPad, Vector.null, Vector.fromChunks, @@ -40,7 +41,6 @@ delayLoop, delayLoopOverlap, -- for FusionTest - mix, mixSize, Vector.empty, Vector.replicate, Vector.repeat, @@ -70,6 +70,7 @@ import qualified Synthesizer.FusionList.Signal as FList import qualified Data.List as List +import qualified Data.StorableVector.Lazy.Pointer as Pointer import qualified Data.StorableVector.Lazy as Vector import qualified Data.StorableVector as V import Data.StorableVector.Lazy (ChunkSize(..)) @@ -77,8 +78,10 @@ -- import Data.Maybe (Maybe(Just,Nothing), maybe, fromMaybe) -- import Data.StorableVector(Vector) -import Foreign.Storable (Storable) +import Foreign.Storable (Storable, ) +import Foreign.Storable.Tuple () +import qualified Synthesizer.Frame.Stereo as Stereo -- import qualified Synthesizer.Format as Format -- import Control.Arrow ((***)) @@ -133,15 +136,7 @@ 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 @@ -624,7 +619,7 @@ List.mapAccumR (Vector.mapAccumR f) start . decons -{-# RULEZ +{- disabled RULES "Storable.append/repeat/repeat" forall size x. append (repeat size x) (repeat size x) = repeat size x ; @@ -641,9 +636,9 @@ "Storable.mix/repeat/repeat" forall size x y. mix (repeat size x) (repeat size y) = repeat size (x+y) ; - #-} + -} -{-# RULES +{- disabled RULES "Storable.length/cons" forall x xs. length (cons x xs) = 1 + length xs ; @@ -688,7 +683,7 @@ 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. @@ -697,25 +692,77 @@ -} -} -{-# 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 + +{- | +This implementation generates laziness breaks +whereever one of the original sequences has laziness breaks. +It should be commutative in this respect. +-} +{-# 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 xs0 ys0 = + let recourse xt@(x:_) yt@(y:_) = + let z = V.zipWith (+) x y + n = V.length z + in z : recourse + (Vector.chunks $ Vector.drop n $ Vector.fromChunks xt) + (Vector.chunks $ Vector.drop n $ Vector.fromChunks yt) + recourse xs [] = xs + recourse [] ys = ys + in Vector.fromChunks $ + recourse (Vector.chunks xs0) (Vector.chunks ys0) + +{- | +Mix while maintaining the pattern of the second operand. +This is closer to the behavior of Vector.zipWith. +-} +{-# 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) + + +{- | +'mixAppend' is more efficient than 'mixSize' since it appends the rest of the longer signal without copying. It also preserves the chunk structure of the second signal, which is essential if you want to limit look-ahead. + +It seems that this implementation has a memory leak! -} -mix :: (Additive.C x, Storable x) => - T x - -> T x - -> T x -mix = zipWithAppend (+) +{-# INLINE mixAppend #-} +mixAppend :: (Additive.C x, Storable x) => + T x -> + T x -> + T x +mixAppend = zipWithAppend (+) {- List.map V.unpack $ Vector.chunks $ mix (fromList defaultChunkSize [1,2,3,4,5::P.Double]) (fromList defaultChunkSize [1,2,3,4]) -} +{-# INLINE zipWithAppend #-} zipWithAppend :: (Storable x) => (x -> x -> x) -> @@ -723,6 +770,7 @@ zipWithAppend f xs ys = uncurry Vector.append $ mapSnd snd $ zipWithRest f xs ys +{-# INLINE zipWithRest #-} zipWithRest :: (Storable c, Storable x) => (x -> x -> c) -> @@ -747,9 +795,9 @@ genericSplitAt n0 = let recourse n xs0 = forcePair $ - maybe + ListHT.switchL ([], []) - (\(x,xs) -> + (\x xs -> if isZero n then ([], xs0) else @@ -758,7 +806,7 @@ then mapFst (x:) $ recourse (n-m) xs else mapPair ((:[]), (:xs)) $ V.splitAt (fromInteger $ toInteger n) x) - $ ListHT.viewL xs0 + xs0 in mapPair (Vector.fromChunks, Vector.fromChunks) . recourse n0 . Vector.chunks @@ -782,26 +830,27 @@ 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) #-} +{- 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 = - curry (Vector.unfoldr size mixStep) +mixSize size xs ys = + Vector.unfoldr size mixStep + (Pointer.cons xs, Pointer.cons ys) {-# INLINE mixStep #-} mixStep :: (Additive.C x, Storable x) => - (T x, T x) -> - Maybe (x, (T x, T x)) + (Pointer.Pointer x, Pointer.Pointer x) -> + Maybe (x, (Pointer.Pointer x, Pointer.Pointer x)) mixStep (xt,yt) = - case (Vector.viewL xt, Vector.viewL yt) of + 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)) @@ -974,7 +1023,7 @@ Maybe 'ChunkSize' better is a list of chunks sizes. -} -{-# RULEZ +{- disabled RULES "fromList/zipWith" forall size f (as :: Storable a => [a]) (bs :: Storable a => [a]). fromList size (List.zipWith f as bs) = @@ -983,7 +1032,7 @@ "fromList/drop" forall as n size. fromList size (List.drop n as) = drop n (fromList size as) ; - #-} + -} diff --git a/src/Test/Main.hs b/src/Test/Main.hs --- a/src/Test/Main.hs +++ b/src/Test/Main.hs @@ -9,6 +9,7 @@ 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.Storable.Cut as Cut import Data.Tuple.HT (mapFst, ) @@ -27,6 +28,7 @@ prefix "Plain.Interpolation" Interpolation.tests : prefix "Plain.Oscillator" Oscillator.tests : prefix "Plain.Wave" Wave.tests : + prefix "Storable.Cut" Cut.tests : prefix "Basic.ToneModulation" ToneModulation.tests : prefix "Plain.ToneModulation" ToneModulationL.tests : prefix "Generic.ToneModulation" ToneModulationG.tests : diff --git a/src/Test/Sound/Synthesizer/Generic/ToneModulation.hs b/src/Test/Sound/Synthesizer/Generic/ToneModulation.hs --- a/src/Test/Sound/Synthesizer/Generic/ToneModulation.hs +++ b/src/Test/Sound/Synthesizer/Generic/ToneModulation.hs @@ -8,11 +8,6 @@ testRationalIp, ) -import Test.Sound.Synthesizer.Plain.ToneModulation ( - InfiniteList, - listFromInfinite, - ) - import qualified Synthesizer.Causal.ToneModulation as ToneModC import qualified Synthesizer.Generic.Wave as WaveG @@ -31,6 +26,7 @@ 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 (test, Property, (==>), ) @@ -62,7 +58,7 @@ limitMinRelativeValues xMin x0 xsnn = let xs = map NonNeg.toNumber xsnn (y0,limiter) = ToneModC.limitMinRelativeValues xMin x0 - in (y0, Causal.applyGeneric limiter xs) == + in (y0, Causal.apply limiter xs) == ToneModL.limitMinRelativeValues xMin x0 xs integrateFractional :: (RealField.C t) => @@ -78,7 +74,7 @@ ToneModL.integrateFractional period (shape0, shapes) (phase, freqs) in period /= zero ==> - c0 : Causal.applyGeneric coordinator (zip shapes freqs) == + c0 : Causal.apply coordinator (zip shapes freqs) == coords -- oscillatorCellSize :: (Show t, Show v, RealField.C t, Eq v) => @@ -86,7 +82,7 @@ Interpolation.Margin -> Interpolation.Margin -> NonNeg.Int -> NonNeg.T t -> - NonNeg.Int -> InfiniteList v -> + NonNeg.Int -> NonEmpty.T v -> t -> t -> [NonNeg.T t] -> [t] -> Property oscillatorCellSize @@ -96,12 +92,12 @@ period = NonNeg.toNumber periodNN periodInt = NonNeg.toNumber periodIntNN len = minLengthMargin marginLeap marginStep periodInt ext - tone = take len (listFromInfinite ixs) + tone = take len (NonEmpty.toInfiniteList ixs) resampledTone = ToneModC.oscillatorCells marginLeap marginStep periodInt period tone (shape0, Phase.fromRepresentative phase) - `Causal.applyGeneric` + `Causal.apply` zip shapes freqs in period /= zero && marginNumber marginLeap > zero && @@ -118,7 +114,7 @@ Interpolation.Margin -> Interpolation.Margin -> NonNeg.Int -> NonNeg.T t -> - NonNeg.Int -> InfiniteList v -> + NonNeg.Int -> NonEmpty.T v -> t -> t -> [NonNeg.T t] -> [t] -> Property oscillatorSuffixes @@ -128,7 +124,7 @@ period = NonNeg.toNumber periodNN periodInt = NonNeg.toNumber periodIntNN len = minLengthMargin marginLeap marginStep periodInt ext - tone = take len (listFromInfinite ixs) + tone = take len (NonEmpty.toInfiniteList ixs) resampledToneA = init $ map (\(sp,cell) -> @@ -140,7 +136,7 @@ ToneModC.oscillatorSuffixes marginLeap marginStep periodInt period tone (shape0, Phase.fromRepresentative phase) - `Causal.applyGeneric` + `Causal.apply` zip shapes freqs in period /= zero && periodInt /= zero && @@ -152,7 +148,7 @@ Interpolation.Margin -> Interpolation.Margin -> NonNeg.Int -> NonNeg.T t -> - NonNeg.Int -> InfiniteList v -> + NonNeg.Int -> NonEmpty.T v -> t -> t -> [NonNeg.T t] -> [t] -> Property oscillatorCells @@ -162,7 +158,7 @@ period = NonNeg.toNumber periodNN periodInt = NonNeg.toNumber periodIntNN len = minLengthMargin marginLeap marginStep periodInt ext - tone = take len (listFromInfinite ixs) + tone = take len (NonEmpty.toInfiniteList ixs) resampledToneA = init $ map (mapSnd List.transpose) $ ToneModL.oscillatorCells @@ -173,7 +169,7 @@ ToneModC.oscillatorCells marginLeap marginStep periodInt period tone (shape0, Phase.fromRepresentative phase) - `Causal.applyGeneric` + `Causal.apply` zip shapes freqs in period /= zero && periodInt /= zero && @@ -202,7 +198,7 @@ sampledTone :: (RealField.C a, Eq v) => InterpolationTest.T a v -> InterpolationTest.T a v -> - NonNeg.T a -> NonNeg.Int -> InfiniteList v -> + NonNeg.T a -> NonNeg.Int -> NonEmpty.T v -> a -> Phase.T a -> Property sampledTone = InterpolationTest.use2 $ \ ipLeap ipStep @@ -210,7 +206,7 @@ let period = NonNeg.toNumber periodNN periodInt = round period len = minLength ipLeap ipStep periodInt ext - tone = take len (listFromInfinite ixs) + 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 @@ -221,7 +217,7 @@ InterpolationTest.T t v -> InterpolationTest.T t v -> NonNeg.T t -> - NonNeg.Int -> InfiniteList v -> + NonNeg.Int -> NonEmpty.T v -> t -> Phase.T t -> [NonNeg.T t] -> [t] -> Property shapeFreqModFromSampledTone = @@ -231,7 +227,7 @@ period = NonNeg.toNumber periodNN periodInt = round period len = minLength ipLeap ipStep periodInt ext - tone = take len (listFromInfinite ixs) + tone = take len (NonEmpty.toInfiniteList ixs) resampledToneA = init $ Osci.shapeFreqModFromSampledTone ipLeap ipStep period tone @@ -239,7 +235,7 @@ resampledToneB = OsciC.shapeFreqModFromSampledTone ipLeap ipStep period tone shape0 phase - `Causal.applyGeneric` + `Causal.apply` zip shapes freqs in period /= zero ==> resampledToneA == resampledToneB @@ -261,7 +257,7 @@ InterpolationTest.T t v -> InterpolationTest.T t v -> NonNeg.T t -> - NonNeg.Int -> InfiniteList v -> + NonNeg.Int -> NonEmpty.T v -> t -> Phase.T t -> [NonNeg.T t] -> (t,[t]) -> [t] -> Property shapePhaseFreqModFromSampledTone = @@ -270,7 +266,7 @@ let period = NonNeg.toNumber periodNN periodInt = round period len = minLength ipLeap ipStep periodInt ext - tone = take len (listFromInfinite ixs) + tone = take len (NonEmpty.toInfiniteList ixs) shapes = map NonNeg.toNumber shapesNN phaseDistorts = pd:pds ++ repeat zero resampledToneA = @@ -280,7 +276,7 @@ resampledToneB = OsciC.shapePhaseFreqModFromSampledTone ipLeap ipStep period tone shape0 phase - `Causal.applyGeneric` + `Causal.apply` zip3 shapes phaseDistorts freqs in period /= zero ==> resampledToneA == resampledToneB @@ -295,15 +291,15 @@ ("oscillatorCellSize", test (\ml ms periodInt period ext ixs -> oscillatorCellSize ml ms periodInt (period :: NonNeg.Rational) - ext (ixs :: InfiniteList ArbChar))) : + ext (ixs :: NonEmpty.T ArbChar))) : ("oscillatorSuffixes", test (\ml ms periodInt period ext ixs -> oscillatorSuffixes ml ms periodInt (period :: NonNeg.Rational) - ext (ixs :: InfiniteList ArbChar))) : + ext (ixs :: NonEmpty.T ArbChar))) : ("oscillatorCells", test (\ml ms periodInt period ext ixs -> oscillatorCells ml ms periodInt (period :: NonNeg.Rational) - ext (ixs :: InfiniteList ArbChar))) : + ext (ixs :: NonEmpty.T ArbChar))) : ("sampledTone", testRationalIp sampledTone) : ("shapeFreqModFromSampledTone", diff --git a/src/Test/Sound/Synthesizer/Plain/Filter.hs b/src/Test/Sound/Synthesizer/Plain/Filter.hs --- a/src/Test/Sound/Synthesizer/Plain/Filter.hs +++ b/src/Test/Sound/Synthesizer/Plain/Filter.hs @@ -7,14 +7,18 @@ 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.Pattern as VP import Foreign.Storable.Tuple () +import qualified Test.Sound.Synthesizer.Plain.NonEmpty as NonEmpty + import Test.QuickCheck (test, {- Property, (==>) -}) -import Test.Utility (equalList, {- approxEqualListAbs, approxEqualListRel, -} ) +import Test.Utility (equalList, ArbChar, ) -- import qualified Algebra.Module as Module -- import qualified Algebra.RealField as RealField @@ -26,6 +30,7 @@ import qualified Numeric.NonNegative.Chunky as Chunky +import qualified Data.List as List import Data.Tuple.HT (mapPair, ) -- import Debug.Trace (trace, ) @@ -52,20 +57,36 @@ let wrap n = mod (NonNeg.toNumber n) (length xs + 1) height = 1 + NonNeg.toNumber nheight rng = (wrap nl, wrap nr) + pyr = take height (FiltNR.pyramid xs) + pyrSt = + FiltNRSt.pyramid (+) height + (SigSt.fromList SigSt.defaultChunkSize xs) 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 : + FiltNR.sumRangeFromPyramid pyr rng : + FiltNR.sumRangeFromPyramidRec pyr rng : + FiltNR.sumRangeFromPyramidFoldr pyr rng : + FiltNRG.sumRangeFromPyramid pyrSt rng : + FiltNRG.sumRangeFromPyramidFoldr pyrSt rng : + FiltNRG.sumRangeFromPyramidReverse pyrSt rng : [] +getRange :: (NonNeg.Int, NonNeg.Int) -> NonEmpty.T (NonEmpty.T ArbChar) -> Bool +getRange (nl,nr) pyr0 = + let l = NonNeg.toNumber nl + r = NonNeg.toNumber nr + rng = if l<=r then (l,r) else (r,l) + pyr = map NonEmpty.toInfiniteList $ NonEmpty.toList pyr0 + in equalList $ + FiltNR.getRangeFromPyramid pyr rng : + FiltNRG.consumeRangeFromPyramid (:) [] pyr rng : + [] + sumsPosModulated :: - NonNeg.Int -> Sig.T (NonNeg.Int,NonNeg.Int) -> (Int, Sig.T Int) -> Bool + NonNeg.Int -> Sig.T (NonNeg.Int,NonNeg.Int) -> NonEmpty.T Int -> Bool sumsPosModulated nheight nctrl xsc = let ctrl = map (mapPair (NonNeg.toNumber, NonNeg.toNumber)) nctrl - xs = cycle $ uncurry (:) xsc + xs = NonEmpty.toInfiniteList xsc height = min 10 $ NonNeg.toNumber nheight in -- trace (show (height, ctrl, xsc)) $ equalList $ @@ -82,8 +103,33 @@ 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 :: + NonNeg.Int -> Sig.T (NonNeg.Int,NonNeg.Int) -> NonEmpty.T Int -> Bool +minPosModulated nheight nctrl xsc = + let ctrl = + map (\(nl,nr) -> + if nl==nr + then (NonNeg.toNumber nl, NonNeg.toNumber nr+1) + else (NonNeg.toNumber nl, NonNeg.toNumber nr)) + nctrl + xs = NonEmpty.toInfiniteList xsc + height = min 10 $ NonNeg.toNumber nheight + in -- trace (show (height, ctrl, xsc)) $ + equalList $ + zipWith FiltNR.minRange (List.tails xs) ctrl : + SigSt.toList + (FiltNRSt.accumulateBinPosModulatedPyramid min height + (SigSt.fromList SigSt.defaultChunkSize ctrl) + (SigSt.fromList SigSt.defaultChunkSize xs)) : + [] + downSample2 :: [Int] -> (Int, Sig.T Int) -> Bool downSample2 lazySize xsc = @@ -144,7 +190,9 @@ tests = ("sums", test sums) : ("sumRange", test sumRange) : + ("getRange", test getRange) : ("sumsPosModulated", test sumsPosModulated) : + ("minPosModulated", test minPosModulated): ("downSample2", test downSample2) : ("sumsDownSample2", test sumsDownSample2) : ("movingAverageModulatedPyramid", test movingAverageModulatedPyramid) : diff --git a/src/Test/Sound/Synthesizer/Plain/Filter/Allpass.hs b/src/Test/Sound/Synthesizer/Plain/Filter/Allpass.hs new file mode 100644 --- /dev/null +++ b/src/Test/Sound/Synthesizer/Plain/Filter/Allpass.hs @@ -0,0 +1,48 @@ +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 Test.Sound.Synthesizer.Plain.NonEmpty as NonEmpty + +import Test.QuickCheck (test, {- Property, (==>) -}) +import Test.Utility (equalList, ) + +-- import qualified Algebra.Module as Module +-- import qualified Algebra.RealField as RealField +-- import qualified Algebra.Ring as Ring +-- import qualified Algebra.Additive as Additive + +import Control.Monad.Trans.State (runState, ) + +-- import Debug.Trace (trace, ) + +import NumericPrelude +import PreludeBase +import Prelude () + + +cascadeStep :: Rational -> Rational -> (Rational, Rational, [Rational]) -> Bool +cascadeStep k u (s0,s1,ns) = + let p = Allpass.Parameter k + s = s0:s1:ns + in equalList $ + 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, IO ())] +tests = + ("cascadeStep", test cascadeStep) : + ("cascade", test cascade) : + [] diff --git a/src/Test/Sound/Synthesizer/Plain/Filter/Hilbert.hs b/src/Test/Sound/Synthesizer/Plain/Filter/Hilbert.hs new file mode 100644 --- /dev/null +++ b/src/Test/Sound/Synthesizer/Plain/Filter/Hilbert.hs @@ -0,0 +1,44 @@ +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 (test, {- Property, (==>) -}) +-- import Test.Utility (equalList, ) + +-- 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.Complex as Complex + +import Data.Tuple.HT (mapPair, ) + +-- import Debug.Trace (trace, ) + +import NumericPrelude +import PreludeBase +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, IO ())] +tests = + ("hilbert", test cascade) : + [] diff --git a/src/Test/Sound/Synthesizer/Plain/Interpolation.hs b/src/Test/Sound/Synthesizer/Plain/Interpolation.hs --- a/src/Test/Sound/Synthesizer/Plain/Interpolation.hs +++ b/src/Test/Sound/Synthesizer/Plain/Interpolation.hs @@ -3,6 +3,11 @@ LinePreserving, lpIp, tests, use, useLP, use2, + -- only for debugging + frequencyModulationBackCompare, + frequencyModulationForth0Compare, + frequencyModulationStorableChunkSizeCompare, + frequencyModulationStorableCompare, ) where import qualified Synthesizer.Plain.Interpolation as Interpolation @@ -11,19 +16,34 @@ import qualified Synthesizer.Interpolation.Module as ExampleModule import qualified Synthesizer.Interpolation as InterpolationCore +import qualified Synthesizer.Causal.Interpolation as InterpolC +import qualified Synthesizer.Causal.Process as Causal +import qualified Synthesizer.Generic.Filter.NonRecursive as FiltG +import qualified Synthesizer.Generic.Signal as SigG +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 (test, Arbitrary(..), elements, {- Property, (==>), -} Testable, ) -- import Test.Utility +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.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 Test.Sound.Synthesizer.Plain.NonEmpty as NonEmpty +import qualified Data.List.Match as Match import Control.Monad (liftM2, ) -import Test.Utility (equalList, ) +import Test.Utility (equalList, ArbChar, unpackArbString, ) import NumericPrelude @@ -129,14 +149,198 @@ [] +controlAboveOne :: (Real.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 + SigG.defaultLazySize cs xs + + +makeChunkSize :: Int -> SigSt.ChunkSize +makeChunkSize size = + SigSt.chunkSize (1 + abs size) + +{- +makeExactFraction :: (Int,Int) -> Double +makeExactFraction (n,d) = + fromIntegral n * 2 ^- (- mod (fromIntegral d) 4) +-} + +frequencyModulationStorableChunkSize :: + (Storable v, RealField.C t, Eq v) => + Int -> Int -> + Int -> Int -> + [t] -> [v] -> + Bool +frequencyModulationStorableChunkSize size0 size1 xsize0 xsize1 cs xs = + FiltSt.inverseFrequencyModulationFloor + (makeChunkSize size0) cs + (SigSt.fromList (makeChunkSize xsize0) xs) + == + FiltSt.inverseFrequencyModulationFloor + (makeChunkSize size1) cs + (SigSt.fromList (makeChunkSize xsize1) xs) + + +frequencyModulationStorableChunkSizeCompare :: + (Storable v, RealField.C t, Eq v) => + Int -> Int -> + Int -> Int -> + [t] -> [v] -> + (SigSt.T v, SigSt.T v) +frequencyModulationStorableChunkSizeCompare size0 size1 xsize0 xsize1 cs xs = + (FiltSt.inverseFrequencyModulationFloor + (makeChunkSize size0) cs + (SigSt.fromList (makeChunkSize xsize0) xs), + FiltSt.inverseFrequencyModulationFloor + (makeChunkSize size1) cs + (SigSt.fromList (makeChunkSize xsize1) xs)) + + +frequencyModulationStorable :: + (Storable v, RealField.C t, Eq v) => + Int -> Int -> + [t] -> [v] -> + Bool +frequencyModulationStorable size xsize cs xs = + SigSt.toList + (FiltSt.inverseFrequencyModulationFloor (makeChunkSize size) cs + (SigSt.fromList (makeChunkSize xsize) xs)) + == FiltG.inverseFrequencyModulationFloor + SigG.defaultLazySize cs xs + + +frequencyModulationStorableCompare :: + (Storable v, RealField.C t, Eq v) => + Int -> Int -> + [t] -> [v] -> + ([v], SigSt.T v) +frequencyModulationStorableCompare size xsize cs xs = + (FiltG.inverseFrequencyModulationFloor + SigG.defaultLazySize cs xs, + FiltSt.inverseFrequencyModulationFloor (makeChunkSize size) cs + (SigSt.fromList (makeChunkSize xsize) xs)) + + + testRational :: (Testable t) => (Rational -> Rational -> t) -> IO () testRational = test +testFM :: + (Testable t, Arbitrary (sigX ArbChar), Show (sigX ArbChar)) => + ([Rational] -> sigX ArbChar -> t) -> IO () +testFM = test + tests :: [(String, IO ())] tests = ("constant", testRational constant) : ("linear", testRational linear ) : ("cubic", testRational cubic ) : + ("frequencyModulationForth0", testFM frequencyModulationForth0) : + ("frequencyModulationForth1", testFM frequencyModulationForth1) : + ("frequencyModulationBack", testFM frequencyModulationBack) : + ("frequencyModulationGeneric", testFM frequencyModulationGeneric) : + ("frequencyModulationStorableChunkSize", + test (\size0 size1 xsize0 xsize1 cs xs -> + frequencyModulationStorableChunkSize size0 size1 xsize0 xsize1 + (cs::[Rational]) (unpackArbString xs))) : + ("frequencyModulationStorable", + test (\size xsize cs xs -> + frequencyModulationStorable size xsize + (cs::[Rational]) (unpackArbString xs))) : [] diff --git a/src/Test/Sound/Synthesizer/Plain/NonEmpty.hs b/src/Test/Sound/Synthesizer/Plain/NonEmpty.hs new file mode 100644 --- /dev/null +++ b/src/Test/Sound/Synthesizer/Plain/NonEmpty.hs @@ -0,0 +1,35 @@ +module Test.Sound.Synthesizer.Plain.NonEmpty where + +import Test.QuickCheck (Arbitrary, arbitrary, coarbitrary, ) +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 + coarbitrary = undefined + +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) +-} diff --git a/src/Test/Sound/Synthesizer/Plain/ToneModulation.hs b/src/Test/Sound/Synthesizer/Plain/ToneModulation.hs --- a/src/Test/Sound/Synthesizer/Plain/ToneModulation.hs +++ b/src/Test/Sound/Synthesizer/Plain/ToneModulation.hs @@ -1,7 +1,4 @@ -module Test.Sound.Synthesizer.Plain.ToneModulation (tests, - listFromInfinite, - InfiniteList, - ) where +module Test.Sound.Synthesizer.Plain.ToneModulation (tests, ) where import Test.Sound.Synthesizer.Basic.ToneModulation ( minLength, @@ -20,6 +17,7 @@ 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 (test, Property, (==>), Arbitrary, arbitrary, coarbitrary, ) @@ -56,29 +54,6 @@ -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 (+) @@ -122,18 +97,18 @@ in (x0,xs) == ToneModL.limitMaxRelativeValuesNonNeg inf x0 xs limitMaxRelativeValuesInfinity :: - Chunky.T NonNeg.Int -> InfiniteList (Chunky.T NonNeg.Int) -> Bool + Chunky.T NonNeg.Int -> NonEmpty.T (Chunky.T NonNeg.Int) -> Bool limitMaxRelativeValuesInfinity x0 ixs = let inf = 1 + inf - ys = listFromInfinite ixs + 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 -> InfiniteList (Chunky.T NonNeg.Int) -> Bool + Chunky.T NonNeg.Int -> NonEmpty.T (Chunky.T NonNeg.Int) -> Bool limitMaxRelativeValuesNonNegInfinity x0 ixs = let inf = 1 + inf - ys = listFromInfinite ixs + ys = NonEmpty.toInfiniteList ixs (z0,zs) = ToneModL.limitMaxRelativeValuesNonNeg inf x0 ys in (x0, take 100 ys) == (z0, take 100 zs) @@ -269,7 +244,7 @@ shapeFreqModFromSampledToneLimitIdentity :: (RealField.C t) => Interpolation.Margin -> Interpolation.Margin -> - NonNeg.Int -> InfiniteList y -> (t, InfiniteList (NonNeg.T t)) -> Bool + NonNeg.Int -> NonEmpty.T y -> (t, NonEmpty.T (NonNeg.T t)) -> Bool shapeFreqModFromSampledToneLimitIdentity marginLeap marginStep periodIntNN ixs (shape0,shapesNN) = let periodInt = NonNeg.toNumber periodIntNN @@ -277,8 +252,8 @@ a = snd (ToneModL.limitRelativeShapes marginLeap marginStep - periodInt (listFromInfinite ixs) - (shape0, listFromInfinite shapes)) !! 100 + periodInt (NonEmpty.toInfiniteList ixs) + (shape0, NonEmpty.toInfiniteList shapes)) !! 100 in a == a @@ -324,7 +299,7 @@ InterpolationTest.T t v -> InterpolationTest.T t v -> NonNeg.T t -> - NonNeg.Int -> InfiniteList v -> + NonNeg.Int -> NonEmpty.T v -> t -> t -> [NonNeg.T t] -> [t] -> Property shapeFreqModFromSampledTone = @@ -334,7 +309,7 @@ period = NonNeg.toNumber periodNN periodInt = round period len = minLength ipLeap ipStep periodInt ext - tone = take len (listFromInfinite ixs) + tone = take len (NonEmpty.toInfiniteList ixs) resampledToneA = Osci.shapeFreqModFromSampledTone ipLeap ipStep period tone shape0 phase shapes freqs @@ -355,7 +330,7 @@ InterpolationTest.T t v -> InterpolationTest.T t v -> NonNeg.T t -> - NonNeg.Int -> InfiniteList v -> + NonNeg.Int -> NonEmpty.T v -> t -> t -> [NonNeg.T t] -> [t] -> [t] -> Property shapePhaseFreqModFromSampledTone = @@ -365,7 +340,7 @@ period = NonNeg.toNumber periodNN periodInt = round period len = minLength ipLeap ipStep periodInt ext - tone = take len (listFromInfinite ixs) + tone = take len (NonEmpty.toInfiniteList ixs) resampledToneA = Osci.shapePhaseFreqModFromSampledTone ipLeap ipStep period tone shape0 phase shapes phaseDistorts freqs @@ -384,7 +359,7 @@ Interpolation.Margin -> NonNeg.Int -> NonNeg.T t -> - NonNeg.Int -> InfiniteList v -> + NonNeg.Int -> NonEmpty.T v -> t -> t -> [NonNeg.T t] -> [t] -> Property oscillatorCells @@ -393,7 +368,7 @@ period = NonNeg.toNumber periodNN periodInt = NonNeg.toNumber periodIntNN len = minLengthMargin marginLeap marginStep periodInt ext - tone = take len (listFromInfinite ixs) + tone = take len (NonEmpty.toInfiniteList ixs) crop = cropCell marginLeap marginStep resampledToneA = ToneModL.oscillatorCells @@ -425,7 +400,7 @@ InterpolationTest.T t v -> InterpolationTest.T t v -> NonNeg.T t -> - NonNeg.Int -> InfiniteList v -> + NonNeg.Int -> NonEmpty.T v -> Property shapeFreqModFromSampledToneIdentity = InterpolationTest.use2 $ \ ipLeap ipStep @@ -433,7 +408,7 @@ let period = NonNeg.toNumber periodNN periodInt = round period len = minLength ipLeap ipStep periodInt ext - tone = take len (listFromInfinite ixs) + tone = take len (NonEmpty.toInfiniteList ixs) shape0 = zero shapes = repeat one phase = zero @@ -482,7 +457,7 @@ ("shapeFreqModFromSampledToneLimitIdentity", test (\ml ms p ixs (t,ts) -> shapeFreqModFromSampledToneLimitIdentity ml ms p - (ixs::InfiniteList Rational) (t::Rational,ts))) : + (ixs::NonEmpty.T Rational) (t::Rational,ts))) : ("oscillatorCoords", test (\periodInt period -> oscillatorCoords @@ -498,7 +473,7 @@ ("oscillatorCells", test (\ml ms periodInt period ext ixs -> oscillatorCells ml ms periodInt (period :: NonNeg.Rational) - ext (ixs :: InfiniteList ArbChar))) : + ext (ixs :: NonEmpty.T ArbChar))) : ("shapeFreqModFromSampledToneIdentity", testRationalIp shapeFreqModFromSampledToneIdentity) : [] diff --git a/src/Test/Sound/Synthesizer/Storable/Cut.hs b/src/Test/Sound/Synthesizer/Storable/Cut.hs new file mode 100644 --- /dev/null +++ b/src/Test/Sound/Synthesizer/Storable/Cut.hs @@ -0,0 +1,43 @@ +module Test.Sound.Synthesizer.Storable.Cut (tests) where + +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 Algebra.Real as Real +-- import qualified Algebra.Ring as Ring +-- import qualified Algebra.Additive as Additive + +import qualified Number.NonNegative as NonNeg + +import Test.QuickCheck (test, ) +import Test.Utility (equalList, ) + +-- import qualified Algebra.Ring as Ring +-- import qualified Algebra.Additive as Additive + +import NumericPrelude +import PreludeBase +import Prelude () + + +arrange :: NonNeg.Int -> EventList.T NonNeg.Int (Sig.T Int) -> Bool +arrange nnChunkSize evs = + let chunkSize = SigSt.chunkSize $ 1 + NonNeg.toNumber nnChunkSize + sevs = EventList.mapBody (SigSt.fromList chunkSize) evs + in equalList $ + SigSt.fromList chunkSize (Cut.arrange evs) : + CutSt.arrangeAdaptive chunkSize sevs : + CutSt.arrangeList chunkSize sevs : + CutSt.arrangeEquidist chunkSize sevs : + [] + + +tests :: [(String, IO ())] +tests = + ("arrange", test arrange) : + [] diff --git a/src/Test/Utility.hs b/src/Test/Utility.hs --- a/src/Test/Utility.hs +++ b/src/Test/Utility.hs @@ -45,3 +45,7 @@ instance Arbitrary ArbChar where arbitrary = fmap (ArbChar . Char.chr . (32+) . flip mod 96) arbitrary coarbitrary = undefined + +unpackArbString :: [ArbChar] -> String +unpackArbString = + map (\(ArbChar c) -> c) diff --git a/synthesizer-core.cabal b/synthesizer-core.cabal --- a/synthesizer-core.cabal +++ b/synthesizer-core.cabal @@ -1,5 +1,5 @@ Name: synthesizer-core -Version: 0.2.1 +Version: 0.3 License: GPL License-File: LICENSE Author: Henning Thielemann @@ -19,7 +19,7 @@ -- For an overview of the organization of the package -- and the discussion of various design issues see "Synthesizer.Overview". Stability: Experimental -Tested-With: GHC==6.4.1, GHC==6.8.2 +Tested-With: GHC==6.4.1, GHC==6.8.2, GHC==6.10.4 Cabal-Version: >=1.6 Build-Type: Simple @@ -27,9 +27,6 @@ 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. @@ -51,7 +48,7 @@ Source-Repository this - Tag: 0.2.1 + Tag: 0.3 Type: darcs Location: http://code.haskell.org/synthesizer/core/ @@ -61,17 +58,18 @@ Library Build-Depends: + sample-frame-np >=0.0.1 && <0.1, + sox >=0.1 && <0.2, 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, binary >=0.1 && <1, - storablevector >=0.2.4 && <0.3, + storablevector >=0.2.5 && <0.3, storable-record >=0.0.1 && <0.1, storable-tuple >=0.0.1 && <0.1, QuickCheck >=1 && <2 @@ -115,6 +113,9 @@ 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 +130,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 @@ -163,6 +165,7 @@ Synthesizer.FusionList.Signal Synthesizer.Storable.Cut Synthesizer.Storable.Oscillator + Synthesizer.Storable.Play Synthesizer.Storable.Signal Synthesizer.Storable.Filter.NonRecursive Synthesizer.State.Analysis @@ -182,10 +185,14 @@ Synthesizer.State.Signal Synthesizer.State.ToneModulation Synthesizer.Causal.Process + Synthesizer.Causal.Arrow + Synthesizer.Causal.Cut Synthesizer.Causal.Displacement Synthesizer.Causal.Interpolation Synthesizer.Causal.Oscillator Synthesizer.Causal.ToneModulation + Synthesizer.Causal.Filter.NonRecursive + Synthesizer.Causal.Filter.Recursive.Integration Synthesizer.Generic.Analysis Synthesizer.Generic.Cut Synthesizer.Generic.Control @@ -196,6 +203,7 @@ Synthesizer.Generic.Filter.Recursive.MovingAverage Synthesizer.Generic.Filter.Recursive.Comb Synthesizer.Generic.Interpolation + Synthesizer.Generic.Loop Synthesizer.Generic.Noise Synthesizer.Generic.Oscillator Synthesizer.Generic.Piece @@ -211,6 +219,8 @@ Synthesizer.Utility Other-Modules: + Synthesizer.Basic.ComplexModule + Synthesizer.Filter.Basic Synthesizer.Filter.Composition Synthesizer.Filter.Example @@ -236,12 +246,16 @@ 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.Interpolation + Test.Sound.Synthesizer.Plain.NonEmpty Test.Sound.Synthesizer.Plain.Oscillator Test.Sound.Synthesizer.Plain.ToneModulation Test.Sound.Synthesizer.Plain.Wave Test.Sound.Synthesizer.Basic.ToneModulation Test.Sound.Synthesizer.Generic.ToneModulation + Test.Sound.Synthesizer.Storable.Cut Main-Is: Test/Main.hs Executable fusiontest