packages feed

synthesizer-core 0.8.0.2 → 0.8.1

raw patch · 23 files changed

+397/−920 lines, 23 filesdep ~directory

Dependency ranges changed: directory

Files

+ Changes.md view
@@ -0,0 +1,11 @@+# Change log for the `synthesizer-core` package++## 8.1++* `Plain.Filter.Recursive.FirstOrder.highpassInit`,+  `Plain.Filter.Recursive.FirstOrder.highpassModifierInit`+  and derived functions change the meaning of the initial parameter.+  The previous meaning was pretty unclear and useless+  such that I consider it a bug.+  We do no longer negate the initial value.+  This is consistent with `lowpassInit`.
private/Synthesizer/Basic/NumberTheory.hs view
@@ -115,6 +115,7 @@    primitiveRootsOfUnityFullOrbitTest,    maximumOrderOfPrimitiveRootsOfUnityNaive,    maximumOrderOfPrimitiveRootsOfUnityInteger,+   divideByMaximumPowerRecursive,    numbers3SmoothCorec,    numbers3SmoothFoldr,    numbers3SmoothSet,@@ -759,11 +760,11 @@    last $    n : unfoldr (\m -> case divMod m b of (q,r) -> toMaybe (isZero r) (q,q)) n -_divideByMaximumPowerRecursive ::+divideByMaximumPowerRecursive ::    (Integral.C a, Eq a, ZeroTestable.C a) => a -> a -> a-_divideByMaximumPowerRecursive b =+divideByMaximumPowerRecursive b =    let recourse n =-          case divMod b n of+          case divMod n b of              (q,0) -> recourse q              _ -> n    in  recourse
speedtest/SpeedTestExp.hs view
@@ -105,6 +105,7 @@    withBinaryFile name WriteMode $ \h ->    newArray_ (0,2*num-1) >>= \arr ->       let k = 0.5**(1/hl)+          loop :: Int -> Double -> IO ()           loop i y =              if i<num                then writeArray (arr :: IOUArray Int Int16)
src/Synthesizer/Basic/Distortion.hs view
@@ -11,12 +11,14 @@    zigZag, sine,    oddChebyshev, {- swing, -}    quantize,+   powerSigned,    ) where  import qualified Algebra.Transcendental        as Trans import qualified Algebra.RealField             as RealField import qualified Algebra.Field                 as Field import qualified Algebra.RealRing              as RealRing+import qualified Algebra.Absolute              as Absolute import qualified Algebra.Ring                  as Ring  import Data.List.HT (mapAdjacent, )@@ -142,3 +144,14 @@  quantize :: (RealField.C a) => a -> a quantize x = fromIntegral (round x :: Int)+++{- * other -}++{- |+Power function.+Roughly the map @\p x -> x**p@ but retains the sign of @x@.+-}+{-# INLINE powerSigned #-}+powerSigned :: (Absolute.C a, Trans.C a) => a -> a -> a+powerSigned p x = signum x * abs x ** p
src/Synthesizer/Basic/Wave.hs view
@@ -51,6 +51,7 @@    truncCosine,    truncTriangle,    powerNormed,+   powerNormed2,    logitSaw,    logitSine,    sineSquare,@@ -78,6 +79,7 @@    ) where  import qualified Synthesizer.Basic.Phase as Phase+import qualified Synthesizer.Basic.Distortion as Distort  import qualified Algebra.RealTranscendental    as RealTrans import qualified Algebra.Transcendental        as Trans@@ -590,19 +592,20 @@ The sign is flipped with respect to 'saw' and 'sine' which is an historical artifact. -}+{-# DEPRECATED powerNormed "Use powerNormed2 instead." #-} {-# INLINE powerNormed #-} powerNormed :: (Absolute.C a, Trans.C a) => a -> T a a-powerNormed p = distort (negate . power01Normed p) saw---- | auxiliary-{-# INLINE power01Normed #-}-power01Normed :: (Absolute.C a, Trans.C a) => a -> a -> a-power01Normed p x = (p+0.5) * powerSigned p x+powerNormed p = amplify (-p-0.5) $ distort (Distort.powerSigned p) saw --- | auxiliary-{-# INLINE powerSigned #-}-powerSigned :: (Absolute.C a, Trans.C a) => a -> a -> a-powerSigned p x = signum x * abs x ** p+{- |+Power function.+Roughly the map @\p x -> x**p@+but retains the sign of @x@ and+normalizes the mapping over @[0,1]@ to an L2 norm of 1.+-}+{-# INLINE powerNormed2 #-}+powerNormed2 :: (Absolute.C a, Trans.C a) => a -> T a a+powerNormed2 p = amplify (sqrt (1+2*p)) $ distort (Distort.powerSigned p) saw   {- |@@ -633,7 +636,7 @@       a {- ^ 0 for 'sine', 1 for 'square' -}    -> T a a sineSquare c =-   distort (powerSigned (1-c)) sine+   distort (Distort.powerSigned (1-c)) sine
src/Synthesizer/Generic/Filter/NonRecursive.hs view
@@ -392,8 +392,7 @@    (Additive.C v, SigG.Write sig v) =>    Int -> sig v -> ([Int], [sig v]) pyramid height sig =-   let sizes =-          reverse $ take (1+height) $ iterate (2*) 1+   let sizes = reverse $ take (1+height) $ iterate (2*) 1    in  (sizes,         scanl (flip sumsDownsample2) sig (map SigG.LazySize $ tail sizes)) @@ -508,11 +507,8 @@    sig (Int,Int) -> sig v accumulatePosModulatedFromPyramid accumulate (sizes,pyr0) ctrl =    let blockSize = head sizes-       pyrStarts =-          iterate (zipWith SigG.drop sizes) pyr0-       ctrlBlocks =-          SigS.toList $-          SigG.sliceVertical blockSize ctrl+       pyrStarts = iterate (zipWith SigG.drop sizes) pyr0+       ctrlBlocks = SigS.toList $ SigG.sliceVertical blockSize ctrl    in  SigG.concat $        zipWith           (\pyr ->@@ -561,8 +557,7 @@   inverseFrequencyModulationFloor ::-   (Ord t, Ring.C t,-    SigG.Write sig v, SigG.Read sig t) =>+   (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 =
src/Synthesizer/Generic/Filter/Recursive/MovingAverage.hs view
@@ -155,7 +155,7 @@ -} {-# INLINE sumsModulatedHalf #-} sumsModulatedHalf ::-   (RealField.C a, Module.C a v, SigG.Transform sig a, SigG.Transform sig v, SigG.Write sig v) =>+   (RealField.C a, Module.C a v, SigG.Transform sig a, SigG.Write sig v) =>    Int -> sig a -> sig v -> sig v sumsModulatedHalf maxDInt ds xs =    let maxD  = fromIntegral maxDInt@@ -167,7 +167,7 @@  {-# INLINE modulatedFrac #-} modulatedFrac ::-   (RealField.C a, Module.C a v, SigG.Transform sig a, SigG.Transform sig v, SigG.Write sig v) =>+   (RealField.C a, Module.C a v, SigG.Transform sig a, SigG.Write sig v) =>    Int -> sig a -> sig v -> sig v modulatedFrac maxDInt ds xs =    SigG.zipWith (\d y -> recip (2*d) *> y) ds $
src/Synthesizer/Generic/Fourier.hs view
@@ -681,7 +681,7 @@ -} {- suffers from big inefficiency of repeated 'append'    SigG.takeStateMatch sig $-   SigS.monoidConcat $+   SigS.fold $    SigS.map (SigS.take (fromIntegral n) . powers sig) $    SigS.take (fromIntegral m) $ -- necessary for strict storable vectors    powers sig z@@ -706,7 +706,7 @@        Permutation.apply transposeNM . --       concatRechunk sig .        SigG.zipWith (*) twiddle .-       SigS.monoidConcat .+       SigS.fold .        SigS.map (transformWithCache subCacheN) .        SigG.sliceVertical (fromInteger n) .        Permutation.apply transposeMN $@@ -786,7 +786,7 @@ concatRechunk pattern =    SigG.takeStateMatch pattern .    SigG.toState .-   SigS.monoidConcat+   SigS.fold   data LevelPrime =
src/Synthesizer/Generic/Oscillator.hs view
@@ -71,7 +71,8 @@  {- | oscillator with both shape and frequency modulation -} shapeFreqMod ::-   (RealField.C a, SigG.Read sig c, SigG.Transform sig a, SigG.Transform sig b) =>+   (RealField.C a,+    SigG.Read sig c, SigG.Transform sig a, SigG.Transform sig b) =>    (c -> Wave.T a b) -> Phase.T a -> sig c -> sig a -> sig b shapeFreqMod wave phase parameters =    Causal.apply@@ -97,7 +98,9 @@ {- | oscillator with a sampled waveform with modulated frequency Should behave homogenously for different types of interpolation. -}-freqModSample :: (RealField.C a, SigG.Read wave b, SigG.Transform sig a, SigG.Transform sig b) =>+freqModSample ::+   (RealField.C a,+    SigG.Read wave b, SigG.Transform sig a, SigG.Transform sig b) =>    Interpolation.T a b -> wave b -> Phase.T a -> sig a -> sig b freqModSample ip wave phase freqs =    let len = fromIntegral $ SigG.length wave
src/Synthesizer/Generic/Signal.hs view
@@ -798,10 +798,15 @@       (foldL (Additive.+)) -} ++{-# INLINE foldMap #-}+foldMap :: (Read sig a, Monoid m) => (a -> m) -> sig a -> m+foldMap f = foldR (mappend . f) mempty++{-# DEPRECATED monoidConcatMap "Use foldMap instead." #-} {-# INLINE monoidConcatMap #-} monoidConcatMap :: (Read sig a, Monoid m) => (a -> m) -> sig a -> m-monoidConcatMap f =-   foldR (mappend . f) mempty+monoidConcatMap = foldMap   {-# INLINE tails #-}
+ src/Synthesizer/PiecewiseConstant/Generic.hs view
@@ -0,0 +1,44 @@+module Synthesizer.PiecewiseConstant.Generic (+   toSignal,+   toSignalInit,+   toSignalInitWith,+   ) where++import qualified Synthesizer.PiecewiseConstant.Private as PC+import Synthesizer.PiecewiseConstant.Private (StrictTime)++import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.Generic.Cut    as CutG++import qualified Data.EventList.Relative.BodyTime as EventListBT+import qualified Data.EventList.Relative.TimeBody as EventList++import qualified Numeric.NonNegative.Wrapper as NonNegW++++replicateLong ::+   (SigG.Write sig y) =>+   StrictTime -> y -> sig y+replicateLong tl y =+   CutG.concat $+   map (\t ->+      SigG.replicate+--         (SigG.LazySize $ fromIntegral $ maxBound::Int)+         SigG.defaultLazySize+         (NonNegW.toNumber t) y) $+   PC.chopLongTime tl++{-# INLINE toSignal #-}+toSignal :: (SigG.Write sig y) => EventListBT.T StrictTime y -> sig y+toSignal = PC.toSignal replicateLong++{-# INLINE toSignalInit #-}+toSignalInit :: (SigG.Write sig y) => y -> EventList.T StrictTime y -> sig y+toSignalInit = PC.toSignalInit replicateLong++{-# INLINE toSignalInitWith #-}+toSignalInitWith ::+   (SigG.Write sig c) =>+   (y -> c) -> c -> EventList.T StrictTime [y] -> sig c+toSignalInitWith = PC.toSignalInitWith replicateLong
+ src/Synthesizer/PiecewiseConstant/Private.hs view
@@ -0,0 +1,75 @@+module Synthesizer.PiecewiseConstant.Private where++import qualified Synthesizer.Generic.Signal as SigG++import qualified Data.EventList.Relative.BodyTime  as EventListBT+import qualified Data.EventList.Relative.TimeBody  as EventList++import qualified Numeric.NonNegative.Wrapper as NonNegW++import Control.Monad.Trans.State (evalState, get, put, )++import qualified Data.List as List+import Data.Traversable (traverse, )+import Data.Foldable (traverse_, )++++type StrictTime = NonNegW.Integer+type ShortStrictTime = NonNegW.Int+++{-# INLINE toSignal #-}+toSignal ::+   (SigG.Transform sig y) =>+   (StrictTime -> y -> sig y) ->+   EventListBT.T StrictTime y -> sig y+toSignal replicateLong =+   EventListBT.foldrPair+      (\y t -> SigG.append (replicateLong t y))+      SigG.empty++{-# INLINE toSignalInit #-}+toSignalInit ::+   (SigG.Transform sig y) =>+   (StrictTime -> y -> sig y) ->+   y -> EventList.T StrictTime y -> sig y+toSignalInit replicateLong initial =+   (\ ~(t,rest) -> SigG.append (replicateLong t initial) rest)+   .+   EventList.foldr+      (,)+      (\y ~(t,rest) -> SigG.append (replicateLong t y) rest)+      (0, SigG.empty)+{-+   toSignal .+--   EventListBM.switchBodyR const .+--   EventListBM.snocTime NonNeg.zero .+--   EventListMB.consBody initial .+   -- switchBodyR causes a space leak+   EventListTM.switchBodyR EventListBT.empty+      (\xs _ -> EventListMT.consBody initial xs)+-}++{-# INLINE toSignalInitWith #-}+toSignalInitWith ::+   (SigG.Transform sig c) =>+   (StrictTime -> c -> sig c) ->+   (y -> c) -> c -> EventList.T StrictTime [y] -> sig c+toSignalInitWith replicateLong f initial =+   toSignalInit replicateLong initial .+   flip evalState initial .+   traverse (\evs -> traverse_ (put . f) evs >> get)+++{- |+Returns a list of non-zero times.+-}+{-# INLINE chopLongTime #-}+chopLongTime :: StrictTime -> [ShortStrictTime]+chopLongTime n =+   let d = fromIntegral (maxBound :: Int)+       (q,r) = divMod (NonNegW.toNumber n) d+   in  map (NonNegW.fromNumberMsg "chopLongTime" . fromInteger) $+       List.genericReplicate q d +++       if r/=0 then [r] else []
src/Synthesizer/PiecewiseConstant/Signal.hs view
@@ -12,6 +12,9 @@    zipWith,    ) where +import Synthesizer.PiecewiseConstant.Private+         (StrictTime, ShortStrictTime, chopLongTime)+ import qualified Data.EventList.Relative.TimeTime  as EventListTT import qualified Data.EventList.Relative.MixedTime as EventListMT import qualified Data.EventList.Relative.BodyTime  as EventListBT@@ -32,8 +35,6 @@ import qualified Prelude as P  -type StrictTime = NonNegW.Integer-type ShortStrictTime = NonNegW.Int type LazyTime = NonNegChunky.T StrictTime  type T = EventListBT.T StrictTime@@ -67,18 +68,6 @@       (NonNegChunky.fromChunks .        List.concatMap chopLongTime .        NonNegChunky.toChunks)--{- |-Returns a list of non-zero times.--}-{-# INLINE chopLongTime #-}-chopLongTime :: StrictTime -> [ShortStrictTime]-chopLongTime n =-   let d = fromIntegral (maxBound :: Int)-       (q,r) = P.divMod (NonNegW.toNumber n) d-   in  map (NonNegW.fromNumberMsg "chopLongTime" . fromInteger) $-       List.genericReplicate q d ++-       if not $ isZero r then [r] else []  {-# INLINE longFromShortTime #-} longFromShortTime :: ShortStrictTime -> StrictTime
+ src/Synthesizer/PiecewiseConstant/Storable.hs view
@@ -0,0 +1,47 @@+module Synthesizer.PiecewiseConstant.Storable (+   toSignal,+   toSignalInit,+   toSignalInitWith,+   ) where++import qualified Synthesizer.PiecewiseConstant.Private as PC+import Synthesizer.PiecewiseConstant.Private (StrictTime)++import qualified Synthesizer.Storable.Signal     as SigSt+import qualified Data.StorableVector.Lazy.Pattern as SigStV+import qualified Data.StorableVector.Lazy        as SVL++import qualified Data.EventList.Relative.BodyTime  as EventListBT+import qualified Data.EventList.Relative.TimeBody  as EventList++import Foreign.Storable (Storable, )++import qualified Numeric.NonNegative.Wrapper as NonNegW+import qualified Numeric.NonNegative.Chunky as NonNegChunky++++chunkSizesFromStrictTime :: StrictTime -> NonNegChunky.T SigSt.ChunkSize+chunkSizesFromStrictTime =+   NonNegChunky.fromChunks .+   map (SVL.ChunkSize . NonNegW.toNumber) .+   PC.chopLongTime+++replicateLong :: (Storable y) => StrictTime -> y -> SigSt.T y+replicateLong t y =+   SigStV.replicate (chunkSizesFromStrictTime t) y++{-# INLINE toSignal #-}+toSignal :: (Storable y) => EventListBT.T StrictTime y -> SigSt.T y+toSignal = PC.toSignal replicateLong++{-# INLINE toSignalInit #-}+toSignalInit :: (Storable y) => y -> EventList.T StrictTime y -> SigSt.T y+toSignalInit = PC.toSignalInit replicateLong++{-# INLINE toSignalInitWith #-}+toSignalInitWith ::+   (Storable c) =>+   (y -> c) -> c -> EventList.T StrictTime [y] -> SigSt.T c+toSignalInitWith = PC.toSignalInitWith replicateLong
src/Synthesizer/Plain/Filter/Recursive/FirstOrder.hs view
@@ -30,6 +30,8 @@ import qualified Foreign.Storable.Traversable as StoreTrav import Foreign.Storable (Storable(sizeOf, alignment, peek, poke)) +import qualified Test.QuickCheck as QC+ import qualified Algebra.Module                as Module import qualified Algebra.Transcendental        as Trans import qualified Algebra.Ring                  as Ring@@ -41,7 +43,7 @@   newtype Parameter a = Parameter {getParameter :: a}-   deriving Show+   deriving (Eq, Show)   instance Functor Parameter where@@ -74,7 +76,10 @@    peek = Store.peek Parameter    poke = Store.poke getParameter +instance QC.Arbitrary a => QC.Arbitrary (Parameter a) where+   arbitrary = fmap Parameter QC.arbitrary + {-| Convert cut-off frequency to feedback factor. -} {-# INLINE parameter #-} parameter :: Trans.C a => a -> Parameter a@@ -129,7 +134,7 @@ highpassModifierInit :: (Ring.C a, Module.C a v) =>    Modifier.Initialized v v (Parameter a) v v highpassModifierInit =-   Modifier.Initialized negate highpassStep+   Modifier.Initialized id highpassStep  {-# INLINE highpassModifier #-} highpassModifier :: (Ring.C a, Module.C a v) =>@@ -146,7 +151,7 @@ highpassInitAlt :: (Ring.C a, Module.C a v) =>    v -> Sig.T (Parameter a) -> Sig.T v -> Sig.T v highpassInitAlt y0 control x =-   x - lowpassInit (-y0) control x+   zipWith (-) x $ lowpassInit y0 control x  {-# INLINE highpass #-} highpass :: (Ring.C a, Module.C a v) =>@@ -156,6 +161,7 @@   data Result a = Result {highpass_, lowpass_ :: !a}+   deriving (Eq)  instance Functor Result where    {-# INLINE fmap #-}@@ -203,6 +209,9 @@    alignment = StoreTrav.alignment    peek      = StoreTrav.peekApplicative    poke      = StoreTrav.poke++instance QC.Arbitrary a => QC.Arbitrary (Result a) where+   arbitrary = liftA2 Result QC.arbitrary QC.arbitrary   {-# INLINE step #-}
src/Synthesizer/Plain/Instrument.hs view
@@ -254,7 +254,7 @@ osciSharp sampleRate freq =    let --control = iterate (+ (-1/sampleRate)) 4        control = exponential2 (0.01*sampleRate) 10-   in  Osci.shapeMod Wave.powerNormed 0 (freq/sampleRate) control+   in  Osci.shapeMod Wave.powerNormed2 0 (freq/sampleRate) control  {-| Build a saw sound from its harmonics and modulate it.     Different to normal modulation
src/Synthesizer/State/Signal.hs view
@@ -922,11 +922,21 @@ {- | Counterpart to 'Data.Monoid.mconcat'. -}+fold :: Monoid m => T m -> m+fold = foldR mappend mempty++{-# DEPRECATED monoidConcat "Use foldMap instead." #-} monoidConcat :: Monoid m => T m -> m-monoidConcat = foldR mappend mempty+monoidConcat = fold ++foldMap :: Monoid m => (a -> m) -> T a -> m+foldMap f = monoidConcat . map f++{-# DEPRECATED monoidConcatMap "Use foldMap instead." #-} monoidConcatMap :: Monoid m => (a -> m) -> T a -> m-monoidConcatMap f = monoidConcat . map f+monoidConcatMap = foldMap+  instance Monoid (T y) where    mempty = empty
src/Synthesizer/Storable/Filter/NonRecursive.hs view
@@ -9,6 +9,11 @@ Portability :  requires multi-parameter type classes -} module Synthesizer.Storable.Filter.NonRecursive (+   delay,+   delayPad,+   delayPos,+   delayNeg,+    downsample2,    sumsDownsample2,    convolveDownsample2,@@ -57,6 +62,31 @@ import NumericPrelude.Base as NP  ++{-# INLINE delay #-}+delay :: (Additive.C y, Storable y) => Int -> SigSt.T y -> SigSt.T y+delay = delayPad zero++{-# INLINE delayPad #-}+delayPad :: (Storable y) => y -> Int -> SigSt.T y -> SigSt.T y+delayPad z n =+   if n<0+     then delayNeg (Additive.negate n)+     else delayPosPad z n++{-# INLINE delayPos #-}+delayPos :: (Additive.C y, Storable y) => Int -> SigSt.T y -> SigSt.T y+delayPos = delayPosPad zero++{-# INLINE delayPosPad #-}+delayPosPad :: (Storable v) => v -> Int -> SigSt.T v -> SigSt.T v+delayPosPad z n = SigSt.append (SigSt.replicate SigSt.defaultChunkSize n z)++{-# INLINE delayNeg #-}+delayNeg :: (Storable y) => Int -> SigSt.T y -> SigSt.T y+delayNeg = SigSt.drop++ {- | The Maybe type carries an unpaired value from one block to the next one. -}@@ -215,7 +245,7 @@    (Additive.C v, Storable v) =>    Int -> SigSt.T (Int,Int) -> SigSt.T v -> SigSt.T v sumsPosModulatedPyramid height ctrl xs =-   FiltG.accumulatePosModulatedFromPyramid+   accumulatePosModulatedPyramid       FiltG.sumRangeFromPyramid       (addSizes $ pyramid (+) height xs)       ctrl@@ -225,7 +255,7 @@    (v -> v -> v) ->    Int -> SigSt.T (Int,Int) -> SigSt.T v -> SigSt.T v accumulateBinPosModulatedPyramid acc height ctrl xs =-   FiltG.accumulatePosModulatedFromPyramid+   accumulatePosModulatedPyramid       (\pyr ->          fromMaybe (error "accumulateBinPosModulatedPyramid: empty window") .          FiltG.maybeAccumulateRangeFromPyramid acc pyr)@@ -245,11 +275,12 @@ movingAverageModulatedPyramid ::    (Field.C a, Module.C a v, Storable Int, Storable v) =>    a -> Int -> Int -> SigSt.T Int -> SigSt.T v -> SigSt.T v-movingAverageModulatedPyramid amp height maxC ctrl xs =-   SigSt.zipWith (\c x -> (amp / fromIntegral (2*c+1)) *> x) ctrl $-   sumsPosModulatedPyramid height-      (SigSt.map (\c -> (maxC - c, maxC + c + 1)) ctrl)-      (FiltG.delay maxC xs)+movingAverageModulatedPyramid amp height maxC ctrl0 =+   withPaddedInput zero+      (\ctrl xs ->+         SigSt.zipWith (\c x -> (amp / fromIntegral (2*c+1)) *> x) ctrl0 $+         sumsPosModulatedPyramid height ctrl xs)+      maxC ctrl0   movingAccumulateModulatedPyramid ::@@ -257,10 +288,20 @@    (v -> v -> v) ->    v -> Int -> Int -> SigSt.T Int -> SigSt.T v -> SigSt.T v movingAccumulateModulatedPyramid acc pad height =-   FiltG.withPaddedInput pad $+   withPaddedInput pad $    accumulateBinPosModulatedPyramid acc height  +withPaddedInput ::+   (Storable y) =>+   y -> (SigSt.T (Int, Int) -> SigSt.T y -> v) ->+   Int -> SigSt.T Int -> SigSt.T y -> v+withPaddedInput pad proc maxC ctrl xs =+   proc+      (SigSt.map (\c -> (maxC - c, maxC + c + 1)) ctrl)+      (delayPad pad maxC xs)++ {- | The function is like that of 'Synthesizer.State.Filter.NonRecursive.inverseFrequencyModulationFloor',@@ -273,7 +314,8 @@ (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.)+For the above example it doesn't matter.+We might implement a variant in Causal.Filter.NonRecursive.)  This function cannot be written using generic functions, since we have to inspect the chunks individually.
src/Synthesizer/Storable/Signal.hs view
@@ -89,186 +89,14 @@ import Prelude ()  -{--import NumericPrelude.Numeric-   (sum, (+), (-), divMod, fromIntegral, fromInteger, toInteger, isZero, zero, )--import Prelude hiding-   (length, (++), iterate, foldl, map, repeat, replicate, null,-    zip, zipWith, zipWith3, drop, take, splitAt, takeWhile, reverse)--}--{--import qualified Prelude as P-import Prelude-   (IO, ($), (.), fst, snd, id,-    Int, Double, Float,-    Char, Num, Show, showsPrec, FilePath,-    Bool(True,False), not,-    flip, curry, uncurry,-    Ord, (<), (>), (<=), {- (>=), (==), -} min, max,-    mapM_, fmap, (=<<), return,-    Enum, succ, pred, )--}-- -- this form is needed for Storable signal embed in amplitude signal type T = Vector.Vector--- type T a = Vector.Vector a   defaultChunkSize :: ChunkSize defaultChunkSize = ChunkSize 1024  -{--{- * Helper functions for StorableVector -}--cancelNullVector :: (Vector a, b) -> Maybe (Vector a, b)-cancelNullVector y =-   toMaybe (not (Vector.null (fst y))) y--viewLVector :: Storable a =>-   Vector a -> Maybe (a, Vector a)-viewLVector = Vector.viewL-{--   toMaybe-      (not (Vector.null x))-      (Vector.head x, Vector.tail x)--}--crochetLVector :: (Storable x, Storable y) =>-      (x -> acc -> Maybe (y, acc))-   -> acc-   -> Vector x-   -> (Vector y, Maybe acc)-crochetLVector f acc0 x0 =-   mapSnd (fmap fst) $-   Vector.unfoldrN-      (Vector.length x0)-      (\(acc,xt) ->-         do (x,xs) <- viewLVector xt-            (y,acc') <- f x acc-            return (y, (acc',xs)))-      (acc0, x0)--}--{--reduceLVector :: Storable x =>-   (x -> acc -> Maybe acc) -> acc -> Vector x -> (acc, Bool)-reduceLVector f acc0 x =-   let recourse i acc =-          if i < Vector.length x-            then (acc, True)-            else-               maybe-                  (acc, False)-                  (recourse (succ i))-                  (f (Vector.index x i) acc)-   in  recourse 0 acc0-----{- * Fundamental functions -}--{- |-Sophisticated implementation where chunks always have size bigger than 0.--}-{-# INLINE [0] unfoldr #-}-unfoldr :: (Storable b) =>-      ChunkSize-   -> (a -> Maybe (b,a))-   -> a-   -> T b-unfoldr (ChunkSize size) f =-   Cons .-   List.unfoldr-      (cancelNullVector . Vector.unfoldrN size f =<<) .-   Just--{- |-Simple implementation where chunks can have size 0 in the first run.-Then they are filtered out.-This separation might reduce laziness.--}-unfoldr0 :: (Storable b) =>-      ChunkSize-   -> (a -> Maybe (b,a))-   -> a-   -> T b-unfoldr0 (ChunkSize size) f =-   Cons .-   List.filter (not . Vector.null) .-   List.unfoldr (fmap (Vector.unfoldrN size f)) .-   Just---unfoldr1 :: (Storable b) =>-      ChunkSize-   -> (a -> (b, Maybe a))-   -> Maybe a-   -> T b-unfoldr1 size f = unfoldr size (liftM f)--{-# INLINE [0] crochetL #-}-crochetL :: (Storable x, Storable y) =>-      (x -> acc -> Maybe (y, acc))-   -> acc-   -> T x-   -> T y-crochetL f acc0 =-   Cons . List.unfoldr (\(xt,acc) ->-       do (x,xs) <- ListHT.viewL xt-          acc' <- acc-          return $ mapSnd ((,) xs) $ crochetLVector f acc' x) .-   flip (,) (Just acc0) .-   decons--{--Usage of 'unfoldr' seems to be clumsy but that covers all cases,-like different block sizes in source and destination list.--}-crochetLSize :: (Storable x, Storable y) =>-      ChunkSize-   -> (x -> acc -> Maybe (y, acc))-   -> acc-   -> T x-   -> T y-crochetLSize size f =-   curry (unfoldr size (\(acc,xt) ->-      do (x,xs) <- viewL xt-         (y,acc') <- f x acc-         return (y, (acc',xs))))--viewL :: Storable a => T a -> Maybe (a, T a)-viewL (Cons xs0) =-   -- dropWhile would be unnecessary if we require that all chunks are non-empty-   do (x,xs) <- ListHT.viewL (List.dropWhile Vector.null xs0)-      (y,ys) <- viewLVector x-      return (y, append (fromChunk ys) (Cons xs))--viewR :: Storable a => T a -> Maybe (T a, a)-viewR (Cons xs0) =-   -- dropWhile would be unnecessary if we require that all chunks are non-empty-   do (xs,x) <- ListHT.viewR (dropWhileRev Vector.null xs0)-      (ys,y) <- Vector.viewR x-      return (append (Cons xs) (fromChunk ys), y)--crochetListL :: (Storable y) =>-      ChunkSize-   -> (x -> acc -> Maybe (y, acc))-   -> acc-   -> [x]-   -> T y-crochetListL size f =-   curry (unfoldr size (\(acc,xt) ->-      do (x,xs) <- ListHT.viewL xt-         (y,acc') <- f x acc-         return (y, (acc',xs))))--}-- {-# INLINE fromList #-} fromList :: (Storable a) => ChunkSize -> [a] -> T a fromList = Vector.pack@@ -278,334 +106,12 @@ toList = Vector.unpack  -{---- should start fusion-fromListCrochetL :: (Storable a) => ChunkSize -> [a] -> T a-fromListCrochetL size =-   crochetListL size (\x _ -> Just (x, ())) ()--fromListUnfoldr :: (Storable a) => ChunkSize -> [a] -> T a-fromListUnfoldr size = unfoldr size ListHT.viewL--fromListPack :: (Storable a) => ChunkSize -> [a] -> T a-fromListPack (ChunkSize size) =-   Cons .-   List.map Vector.pack .-   sliceVert size--toList :: (Storable a) => T a -> [a]-toList = List.concatMap Vector.unpack . decons---- if the chunk has length zero, an empty sequence is generated-fromChunk :: (Storable a) => Vector a -> T a-fromChunk x =-   if Vector.null x-     then empty-     else Cons [x]---{-# INLINE [0] reduceL #-}-reduceL :: Storable x =>-   (x -> acc -> Maybe acc) -> acc -> T x -> acc-reduceL f acc0 =-   let recourse acc xt =-          case xt of-             [] -> acc-             (x:xs) ->-                 let (acc',continue) = reduceLVector f acc x-                 in  if continue-                       then recourse acc' xs-                       else acc'-   in  recourse acc0 . decons----{- * Basic functions -}--empty :: Storable a => T a-empty = Cons []--null :: Storable a => T a -> Bool-null = List.null . decons---{-# NOINLINE [0] cons #-}-cons :: Storable a => a -> T a -> T a-cons x = Cons . (Vector.singleton x :) . decons---length :: T a -> Int-length = sum . List.map Vector.length . decons---reverse :: Storable a => T a -> T a-reverse =-   Cons . List.reverse . List.map Vector.reverse . decons---{-# INLINE [0] foldl #-}-foldl :: Storable b => (a -> b -> a) -> a -> T b -> a-foldl f x0 = List.foldl (Vector.foldl f) x0 . decons---{-# INLINE [0] map #-}-map :: (Storable x, Storable y) =>-      (x -> y)-   -> T x-   -> T y-map f = mapInline f -- Cons . List.map (Vector.map f) . decons--{-# INLINE mapInline #-}-mapInline :: (Storable x, Storable y) =>-      (x -> y)-   -> T x-   -> T y-mapInline f =-   let mapVec = Vector.map f-   in  Cons . List.map mapVec . decons----{-# NOINLINE [0] drop #-}-drop :: (Storable a) => Int -> T a -> T a-drop _ (Cons []) = empty-drop n (Cons (x:xs)) =-   let m = Vector.length x-   in  if m<=n-         then drop (n-m) (Cons xs)-         else Cons (Vector.drop n x : xs)--{-# NOINLINE [0] take #-}-take :: (Storable a) => Int -> T a -> T a-take _ (Cons []) = empty-take 0 _ = empty-take n (Cons (x:xs)) =-   let m = Vector.length x-   in  if m<=n-         then Cons $ (x:) $ decons $ take (n-m) $ Cons xs-         else fromChunk (Vector.take n x)----{-# NOINLINE [0] splitAt #-}-splitAt :: (Storable a) => Int -> T a -> (T a, T a)-splitAt n0 =-   let recourse _ [] = ([], [])-       recourse 0 xs = ([], xs)-       recourse n (x:xs) =-          let m = Vector.length x-          in  if m<=n-                then mapFst (x:) $ recourse (n-m) xs-                else mapPair ((:[]), (:xs)) $ Vector.splitAt n x-   in  mapPair (Cons, Cons) . recourse n0 . decons---dropMarginRem :: (Storable a) => Int -> Int -> T a -> (Int, T a)-dropMarginRem n m xs =-   List.foldl'-      (\(mi,xsi) k -> (mi-k, drop k xsi))-      (m,xs)-      (List.map Vector.length $ decons $ take m $ drop n xs)--{--This implementation does only walk once through the dropped prefix.-It is maximally lazy and minimally space consuming.--}-dropMargin :: (Storable a) => Int -> Int -> T a -> T a-dropMargin n m xs =-   List.foldl' (flip drop) xs-      (List.map Vector.length $ decons $ take m $ drop n xs)---{-# NOINLINE [0] dropWhile #-}-dropWhile :: (Storable a) => (a -> Bool) -> T a -> T a-dropWhile _ (Cons []) = empty-dropWhile p (Cons (x:xs)) =-   let y = Vector.dropWhile p x-   in  if Vector.null y-         then dropWhile p (Cons xs)-         else Cons (y:xs)--{-# NOINLINE [0] takeWhile #-}-takeWhile :: (Storable a) => (a -> Bool) -> T a -> T a-takeWhile _ (Cons []) = empty-takeWhile p (Cons (x:xs)) =-   let y = Vector.takeWhile p x-   in  if Vector.length y < Vector.length x-         then fromChunk y-         else Cons (x : decons (takeWhile p (Cons xs)))---{-# NOINLINE [0] span #-}-span :: (Storable a) => (a -> Bool) -> T a -> (T a, T a)-span p =-   let recourse [] = ([],[])-       recourse (x:xs) =-          let (y,z) = Vector.span p x-          in  if Vector.null z-                then mapFst (x:) (recourse xs)-                else (decons $ fromChunk y, (z:xs))-   in  mapPair (Cons, Cons) . recourse . decons-{--span _ (Cons []) = (empty, empty)-span p (Cons (x:xs)) =-   let (y,z) = Vector.span p x-   in  if Vector.length y == 0-         then mapFst (Cons . (x:) . decons) (span p (Cons xs))-         else (Cons [y], Cons (z:xs))--}--concat :: (Storable a) => [T a] -> T a-concat = Cons . List.concat . List.map decons---{- |-Ensure a minimal length of the list by appending pad values.--}-{-# NOINLINE [0] pad #-}-pad :: (Storable a) => ChunkSize -> a -> Int -> T a -> T a-pad size y n0 =-   let recourse n xt =-          if n<=0-            then xt-            else-              case xt of-                 [] -> decons $ replicate size n y-                 x:xs -> x : recourse (n - Vector.length x) xs-   in  Cons . recourse n0 . decons--padAlt :: (Storable a) => ChunkSize -> a -> Int -> T a -> T a-padAlt size x n xs =-   append xs-      (let m = length xs-       in  if n>m-             then replicate size (n-m) x-             else empty)---infixr 5 `append`--{-# NOINLINE [0] append #-}-append :: T a -> T a -> T a-append (Cons xs) (Cons ys)  =  Cons (xs List.++ ys)--{-# INLINE iterate #-}-iterate :: Storable a => ChunkSize -> (a -> a) -> a -> T a-iterate size f = unfoldr size (\x -> Just (x, f x))--repeat :: Storable a => ChunkSize -> a -> T a-repeat (ChunkSize size) =-   Cons . List.repeat . Vector.replicate size--cycle :: Storable a => T a -> T a-cycle =-   Cons . List.cycle . decons--replicate :: Storable a => ChunkSize -> Int -> a -> T a-replicate (ChunkSize size) n x =-   let (numChunks, rest) = divMod n size-   in  append-          (Cons (List.replicate numChunks (Vector.replicate size x)))-          (fromChunk (Vector.replicate rest x))--}- {-# INLINE scanL #-} scanL :: (Storable a, Storable b) =>    (a -> b -> a) -> a -> T b -> T a scanL = Vector.scanl  -{--{-# INLINE [0] mapAccumL #-}-mapAccumL :: (Storable a, Storable b) =>-   (acc -> a -> (acc, b)) -> acc -> T a -> (acc, T b)-mapAccumL f start =-   mapSnd Cons .-   List.mapAccumL (Vector.mapAccumL f) start .-   decons--{-# INLINE [0] mapAccumR #-}-mapAccumR :: (Storable a, Storable b) =>-   (acc -> a -> (acc, b)) -> acc -> T a -> (acc, T b)-mapAccumR f start =-   mapSnd Cons .-   List.mapAccumR (Vector.mapAccumR f) start .-   decons--{- disabled RULES-  "Storable.append/repeat/repeat" forall size x.-      append (repeat size x) (repeat size x) = repeat size x ;--  "Storable.append/repeat/replicate" forall size n x.-      append (repeat size x) (replicate size n x) = repeat size x ;--  "Storable.append/replicate/repeat" forall size n x.-      append (replicate size n x) (repeat size x) = repeat size x ;--  "Storable.append/replicate/replicate" forall size n m x.-      append (replicate size n x) (replicate size m x) =-         replicate size (n+m) x ;--  "Storable.mix/repeat/repeat" forall size x y.-      mix (repeat size x) (repeat size y) = repeat size (x+y) ;--  -}--{- disabled RULES-  "Storable.length/cons" forall x xs.-      length (cons x xs) = 1 + length xs ;--  "Storable.length/map" forall f xs.-      length (map f xs) = length xs ;--  "Storable.map/cons" forall f x xs.-      map f (cons x xs) = cons (f x) (map f xs) ;--  "Storable.map/repeat" forall size f x.-      map f (repeat size x) = repeat size (f x) ;--  "Storable.map/replicate" forall size f x n.-      map f (replicate size n x) = replicate size n (f x) ;--  "Storable.map/repeat" forall size f x.-      map f (repeat size x) = repeat size (f x) ;--  {--  This can make things worse, if 'map' is applied to replicate,-  since this can use of sharing.-  It can also destroy the more important map/unfoldr fusion in-    take n . map f . unfoldr g--  "Storable.take/map" forall n f x.-      take n (map f x) = map f (take n x) ;-  -}--  "Storable.take/repeat" forall size n x.-      take n (repeat size x) = replicate size n x ;--  "Storable.take/take" forall n m xs.-      take n (take m xs) = take (min n m) xs ;--  "Storable.drop/drop" forall n m xs.-      drop n (drop m xs) = drop (n+m) xs ;--  "Storable.drop/take" forall n m xs.-      drop n (take m xs) = take (max 0 (m-n)) (drop n xs) ;--  "Storable.map/mapAccumL/snd" forall g f acc0 xs.-      map g (snd (mapAccumL f acc0 xs)) =-         snd (mapAccumL (\acc a -> mapSnd g (f acc a)) acc0 xs) ;--  -}--{- GHC says this is an orphaned rule-  "Storable.map/mapAccumL/mapSnd" forall g f acc0 xs.-      mapSnd (map g) (mapAccumL f acc0 xs) =-         mapAccumL (\acc a -> mapSnd g (f acc a)) acc0 xs ;--}--}-- {- | This implementation generates laziness breaks whereever one of the original sequences has laziness breaks.@@ -809,367 +315,6 @@   -{--{-# INLINE zip #-}-zip :: (Storable a, Storable b) =>-   ChunkSize -> (T a -> T b -> T (a,b))-zip size  =  zipWith size (,)--{-# INLINE zipWith3 #-}-zipWith3 :: (Storable a, Storable b, Storable c, Storable d) =>-   ChunkSize -> (a -> b -> c -> d) -> (T a -> T b -> T c -> T d)-zipWith3 size f s0 s1 =-   zipWith size (uncurry f) (zip size s0 s1)--{-# INLINE zipWith4 #-}-zipWith4 :: (Storable a, Storable b, Storable c, Storable d, Storable e) =>-   ChunkSize -> (a -> b -> c -> d -> e) -> (T a -> T b -> T c -> T d -> T e)-zipWith4 size f s0 s1 =-   zipWith3 size (uncurry f) (zip size s0 s1)---{- * Fusable functions -}--{-# INLINE [0] zipWith #-}-zipWith :: (Storable x, Storable y, Storable z) =>-      ChunkSize-   -> (x -> y -> z)-   -> T x-   -> T y-   -> T z-zipWith size f =-   curry (unfoldr size (\(xt,yt) ->-      liftM2-         (\(x,xs) (y,ys) -> (f x y, (xs,ys)))-         (viewL xt)-         (viewL yt)))----scanLCrochet :: (Storable a, Storable b) =>-   (a -> b -> a) -> a -> T b -> T a-scanLCrochet f start =-   cons start .-   crochetL (\x acc -> let y = f acc x in Just (y, y)) start--{-# INLINE mapCrochet #-}-mapCrochet :: (Storable a, Storable b) => (a -> b) -> (T a -> T b)-mapCrochet f = crochetL (\x _ -> Just (f x, ())) ()--}- {-# INLINE takeCrochet #-} takeCrochet :: Storable a => Int -> T a -> T a takeCrochet = Vector.crochetL (\x n -> toMaybe (n>0) (x, pred n))--{--{-# INLINE repeatUnfoldr #-}-repeatUnfoldr :: Storable a => ChunkSize -> a -> T a-repeatUnfoldr size = iterate size id--{-# INLINE replicateCrochet #-}-replicateCrochet :: Storable a => ChunkSize -> Int -> a -> T a-replicateCrochet size n = takeCrochet n . repeat size---{--The "fromList/drop" rule is not quite accurate-because the chunk borders are moved.-Maybe 'ChunkSize' better is a list of chunks sizes.--}--{- disabled RULES-  "fromList/zipWith"-    forall size f (as :: Storable a => [a]) (bs :: Storable a => [a]).-     fromList size (List.zipWith f as bs) =-        zipWith size f (fromList size as) (fromList size bs) ;--  "fromList/drop" forall as n size.-     fromList size (List.drop n as) =-        drop n (fromList size as) ;-  -}----{- * Fused functions -}--type Unfoldr s a = (s -> Maybe (a,s), s)--{-# INLINE zipWithUnfoldr2 #-}-zipWithUnfoldr2 :: Storable z =>-      ChunkSize-   -> (x -> y -> z)-   -> Unfoldr a x-   -> Unfoldr b y-   -> T z-zipWithUnfoldr2 size h (f,a) (g,b) =-   unfoldr size-      (\(a0,b0) -> liftM2 (\(x,a1) (y,b1) -> (h x y, (a1,b1))) (f a0) (g b0))---      (uncurry (liftM2 (\(x,a1) (y,b1) -> (h x y, (a1,b1)))) . (f *** g))-      (a,b)--{- done by takeCrochet-{-# INLINE mapUnfoldr #-}-mapUnfoldr :: (Storable x, Storable y) =>-      ChunkSize-   -> (x -> y)-   -> Unfoldr a x-   -> T y-mapUnfoldr size g (f,a) =-   unfoldr size (fmap (mapFst g) . f) a--}--{-# INLINE dropUnfoldr #-}-dropUnfoldr :: Storable x =>-      ChunkSize-   -> Int-   -> Unfoldr a x-   -> T x-dropUnfoldr size n (f,a0) =-   maybe-      empty-      (unfoldr size f)-      (nest n (\a -> fmap snd . f =<< a) (Just a0))---{- done by takeCrochet-{-# INLINE takeUnfoldr #-}-takeUnfoldr :: Storable x =>-      ChunkSize-   -> Int-   -> Unfoldr a x-   -> T x-takeUnfoldr size n0 (f,a0) =-   unfoldr size-      (\(a,n) ->-         do guard (n>0)-            (x,a') <- f a-            return (x, (a', pred n)))-      (a0,n0)--}---lengthUnfoldr :: Storable x =>-      Unfoldr a x-   -> Int-lengthUnfoldr (f,a0) =-   let recourse n a =-          maybe n (recourse (succ n) . snd) (f a)-   in  recourse 0 a0---{-# INLINE zipWithUnfoldr #-}-zipWithUnfoldr ::-   (Storable b, Storable c) =>-      (acc -> Maybe (a, acc))-   -> (a -> b -> c)-   -> acc-   -> T b -> T c-zipWithUnfoldr f h a y =-   crochetL (\y0 a0 ->-       do (x0,a1) <- f a0-          Just (h x0 y0, a1)) a y--{-# INLINE zipWithCrochetL #-}-zipWithCrochetL ::-   (Storable x, Storable b, Storable c) =>-      ChunkSize-   -> (x -> acc -> Maybe (a, acc))-   -> (a -> b -> c)-   -> acc-   -> T x -> T b -> T c-zipWithCrochetL size f h a x y =-   crochetL (\(x0,y0) a0 ->-       do (z0,a1) <- f x0 a0-          Just (h z0 y0, a1))-      a (zip size x y)---{-# INLINE crochetLCons #-}-crochetLCons ::-   (Storable a, Storable b) =>-      (a -> acc -> Maybe (b, acc))-   -> acc-   -> a -> T a -> T b-crochetLCons f a0 x xs =-   maybe-      empty-      (\(y,a1) -> cons y (crochetL f a1 xs))-      (f x a0)--{-# INLINE reduceLCons #-}-reduceLCons ::-   (Storable a) =>-      (a -> acc -> Maybe acc)-   -> acc-   -> a -> T a -> acc-reduceLCons f a0 x xs =-   maybe a0 (flip (reduceL f) xs) (f x a0)------{-# RULES-  "Storable.zipWith/share" forall size (h :: a->a->b) (x :: T a).-     zipWith size h x x = map (\xi -> h xi xi) x ;----  "Storable.map/zipWith" forall size (f::c->d) (g::a->b->c) (x::T a) (y::T b).-  "Storable.map/zipWith" forall size f g x y.-     map f (zipWith size g x y) =-        zipWith size (\xi yi -> f (g xi yi)) x y ;--  -- this rule lets map run on a different block structure-  "Storable.zipWith/map,*" forall size f g x y.-     zipWith size g (map f x) y =-        zipWith size (\xi yi -> g (f xi) yi) x y ;--  "Storable.zipWith/*,map" forall size f g x y.-     zipWith size g x (map f y) =-        zipWith size (\xi yi -> g xi (f yi)) x y ;---  "Storable.drop/unfoldr" forall size f a n.-     drop n (unfoldr size f a) =-        dropUnfoldr size n (f,a) ;--  "Storable.take/unfoldr" forall size f a n.-     take n (unfoldr size f a) =---        takeUnfoldr size n (f,a) ;-        takeCrochet n (unfoldr size f a) ;--  "Storable.length/unfoldr" forall size f a.-     length (unfoldr size f a) = lengthUnfoldr (f,a) ;--  "Storable.map/unfoldr" forall size g f a.-     map g (unfoldr size f a) =---        mapUnfoldr size g (f,a) ;-        mapCrochet g (unfoldr size f a) ;--  "Storable.map/iterate" forall size g f a.-     map g (iterate size f a) =-        mapCrochet g (iterate size f a) ;--{--  "Storable.zipWith/unfoldr,unfoldr" forall sizeA sizeB f g h a b n.-     zipWith n h (unfoldr sizeA f a) (unfoldr sizeB g b) =-        zipWithUnfoldr2 n h (f,a) (g,b) ;--}--  -- block boundaries are changed here, so it changes lazy behaviour-  "Storable.zipWith/unfoldr,*" forall sizeA sizeB f h a y.-     zipWith sizeA h (unfoldr sizeB f a) y =-        zipWithUnfoldr f h a y ;--  -- block boundaries are changed here, so it changes lazy behaviour-  "Storable.zipWith/*,unfoldr" forall sizeA sizeB f h a y.-     zipWith sizeA h y (unfoldr sizeB f a) =-        zipWithUnfoldr f (flip h) a y ;--  "Storable.crochetL/unfoldr" forall size f g a b.-     crochetL g b (unfoldr size f a) =-        unfoldr size (\(a0,b0) ->-            do (y0,a1) <- f a0-               (z0,b1) <- g y0 b0-               Just (z0, (a1,b1))) (a,b) ;--  "Storable.reduceL/unfoldr" forall size f g a b.-     reduceL g b (unfoldr size f a) =-        snd-          (untilNothing (\(a0,b0) ->-              do (y,a1) <- f a0-                 b1 <- g y b0-                 Just (a1, b1)) (a,b)) ;--  "Storable.crochetL/cons" forall g b x xs.-     crochetL g b (cons x xs) =-        crochetLCons g b x xs ;--  "Storable.reduceL/cons" forall g b x xs.-     reduceL g b (cons x xs) =-        reduceLCons g b x xs ;-----  "Storable.take/crochetL" forall f a x n.-     take n (crochetL f a x) =-        takeCrochet n (crochetL f a x) ;--  "Storable.length/crochetL" forall f a x.-     length (crochetL f a x) = length x ;--  "Storable.map/crochetL" forall g f a x.-     map g (crochetL f a x) =-        mapCrochet g (crochetL f a x) ;--  "Storable.zipWith/crochetL,*" forall size f h a x y.-     zipWith size h (crochetL f a x) y =-        zipWithCrochetL size f h a x y ;--  "Storable.zipWith/*,crochetL" forall size f h a x y.-     zipWith size h y (crochetL f a x) =-        zipWithCrochetL size f (flip h) a x y ;--  "Storable.crochetL/crochetL" forall f g a b x.-     crochetL g b (crochetL f a x) =-        crochetL (\x0 (a0,b0) ->-            do (y0,a1) <- f x0 a0-               (z0,b1) <- g y0 b0-               Just (z0, (a1,b1))) (a,b) x ;--  "Storable.reduceL/crochetL" forall f g a b x.-     reduceL g b (crochetL f a x) =-        snd-          (reduceL (\x0 (a0,b0) ->-              do (y,a1) <- f x0 a0-                 b1 <- g y b0-                 Just (a1, b1)) (a,b) x) ;-  #-}----- maybe candidate for Utility, cf. FusionList.Signal.recourse--{-# INLINE untilNothing #-}-untilNothing :: (acc -> Maybe acc) -> acc -> acc-untilNothing f =-   let aux x = maybe x aux (f x)-   in  aux---{- * Fusion tests -}---fromMapList :: (Storable y) => ChunkSize -> (x -> y) -> [x] -> T y-fromMapList size f =-   unfoldr size (fmap (mapFst f) . ListHT.viewL)--{-# RULES-  "Storable.fromList/map" forall size f xs.-     fromList size (List.map f xs) = fromMapList size f xs ;-  #-}---testLength :: (Storable a, Enum a) => a -> Int-testLength x = length (map succ (fromList (ChunkSize 100) [x,x,x]))--testMapZip :: (Storable a, Enum a, Num a) =>-   ChunkSize -> T a -> T a -> T a--- testMapZip size x y = map snd (zipWith size (,) x y)-testMapZip size x y = map succ (zipWith size (P.+) x y)--testMapCons :: (Storable a, Enum a) =>-   a -> T a -> T a-testMapCons x xs = map succ (cons x xs)--{-# INLINE testMapIterate #-}-{-# SPECIALISE testMapIterate ::-   ChunkSize -> Char -> T Char #-}-testMapIterate :: (Storable a, Enum a) =>-   ChunkSize -> a -> T a-testMapIterate size y = map pred $ iterate size succ y--testMapIterateInt ::-   ChunkSize -> Int -> T Int-testMapIterateInt = testMapIterate---}
synthesizer-core.cabal view
@@ -1,5 +1,5 @@ Name:           synthesizer-core-Version:        0.8.0.2+Version:        0.8.1 License:        GPL License-File:   LICENSE Author:         Henning Thielemann <haskell@henning-thielemann.de>@@ -29,6 +29,7 @@ Build-Type:     Simple  Extra-Source-Files:+  Changes.md   Makefile  Flag optimizeAdvanced@@ -37,7 +38,7 @@   Source-Repository this-  Tag:         0.8.0.2+  Tag:         0.8.1   Type:        darcs   Location:    http://code.haskell.org/synthesizer/core/ @@ -205,6 +206,8 @@     Synthesizer.Generic.Signal     Synthesizer.Generic.Wave     Synthesizer.PiecewiseConstant.Signal+    Synthesizer.PiecewiseConstant.Generic+    Synthesizer.PiecewiseConstant.Storable      -- that's only exposed for Haddock     Synthesizer.Plain.Tutorial@@ -219,6 +222,7 @@     Synthesizer.Basic.NumberTheory     Synthesizer.Generic.Permutation     Synthesizer.Generic.LengthSignal+    Synthesizer.PiecewiseConstant.Private   Test-Suite test@@ -252,6 +256,7 @@     Test.Sound.Synthesizer.Plain.Filter     Test.Sound.Synthesizer.Plain.Filter.Allpass     Test.Sound.Synthesizer.Plain.Filter.Hilbert+    Test.Sound.Synthesizer.Plain.Filter.FirstOrder     Test.Sound.Synthesizer.Plain.Interpolation     Test.Sound.Synthesizer.Plain.NonEmpty     Test.Sound.Synthesizer.Plain.Oscillator@@ -298,7 +303,7 @@     synthesizer-core,     numeric-prelude,     old-time >= 1.0 && < 1.2,-    directory >= 1.0 && < 1.3,+    directory >= 1.0 && < 1.4,     binary,     bytestring,     utility-ht,
test/Test/Main.hs view
@@ -3,6 +3,7 @@ import qualified Test.Sound.Synthesizer.Plain.Analysis       as Analysis import qualified Test.Sound.Synthesizer.Plain.Control        as Control import qualified Test.Sound.Synthesizer.Plain.Filter         as Filter+import qualified Test.Sound.Synthesizer.Plain.Filter.FirstOrder as Filt1 import qualified Test.Sound.Synthesizer.Plain.Interpolation  as Interpolation import qualified Test.Sound.Synthesizer.Plain.Oscillator     as Oscillator import qualified Test.Sound.Synthesizer.Plain.Wave           as Wave@@ -31,6 +32,7 @@    concat $       prefix "Plain.Analysis"       Analysis.tests :       prefix "Plain.Control"        Control.tests :+      prefix "Plain.Filter.FirstOrder" Filt1.tests :       prefix "Plain.Filter"         Filter.tests :       prefix "Plain.Interpolation"  Interpolation.tests :       prefix "Plain.Oscillator"     Oscillator.tests :
test/Test/Sound/Synthesizer/Basic/NumberTheory.hs view
@@ -46,7 +46,7 @@  instance Arbitrary Big where    arbitrary = do-      digits <- arbitrary+      digits <- QC.listOf arbitrary       -- negative digits yield numbers close to the maximum       let maxi = 10^50       return $ Big $@@ -152,6 +152,10 @@              (NT.ordersOfPrimitiveRootsOfUnityInteger !! (n-1)))          ==          NT.ordersOfRootsOfUnityInteger !! (n-1) !! (k-1)) :+   ("divideByMaximumPower",+      QC.quickCheck $+         QC.forAll (QC.choose (2,10::Integer)) $ \b (Positive n) ->+         NT.divideByMaximumPower b n == NT.divideByMaximumPowerRecursive b n) :    ("numbers3Smooth",       QC.quickCheckWith singleArgs $ equalList $ map (take 10000) $          [NT.numbers3SmoothCorec, NT.numbers3SmoothFoldr, NT.numbers3SmoothSet]) :
+ test/Test/Sound/Synthesizer/Plain/Filter/FirstOrder.hs view
@@ -0,0 +1,73 @@+module Test.Sound.Synthesizer.Plain.Filter.FirstOrder (tests) where++import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1+import qualified Synthesizer.Plain.Signal as Sig+import qualified Synthesizer.Causal.Process as Causal++import Test.QuickCheck (quickCheck, )++import qualified Number.GaloisField2p32m5 as GF++import Control.Applicative ((<$), )++import NumericPrelude.Numeric+import NumericPrelude.Base+import Prelude ()++++addLowHighpass :: Sig.T (Filt1.Parameter GF.T, GF.T) -> Bool+addLowHighpass pxs =+   let (ps, xs) = unzip pxs+   in  Filt1.lowpass ps xs + Filt1.highpass ps xs == xs++combineLowHighpass :: Sig.T (Filt1.Parameter GF.T) -> Sig.T GF.T -> Bool+combineLowHighpass ps xs =+   zipWith Filt1.Result (Filt1.highpass ps xs) (Filt1.lowpass ps xs)+   ==+   Causal.apply Filt1.causal (zip ps xs)+++lowpassId :: Sig.T GF.T -> Bool+lowpassId xs =+   Filt1.lowpass (repeat $ Filt1.Parameter (zero::GF.T)) xs == xs++lowpassZero :: Sig.T GF.T -> Bool+lowpassZero xs =+   Filt1.lowpass (repeat $ Filt1.Parameter (one::GF.T)) xs == (zero <$ xs)+--   isZero $ Filt1.lowpass (repeat $ Filt1.Parameter (one::GF.T)) xs++highpassId :: Sig.T GF.T -> Bool+highpassId xs =+   Filt1.highpass (repeat $ Filt1.Parameter (one::GF.T)) xs == xs++highpassZero :: Sig.T GF.T -> Bool+highpassZero xs =+   Filt1.highpass (repeat $ Filt1.Parameter (zero::GF.T)) xs == (zero <$ xs)+++lowpassConst :: Sig.T GF.T -> GF.T -> Bool+lowpassConst ks x =+   Filt1.lowpassInit x (map Filt1.Parameter ks) (repeat x) == (x <$ ks)++highpassConst :: Sig.T GF.T -> GF.T -> Bool+highpassConst ks x =+   Filt1.highpassInit x (map Filt1.Parameter ks) (repeat x) == (zero <$ ks)++highpassInitAlt :: GF.T -> Sig.T (Filt1.Parameter GF.T) -> Sig.T GF.T -> Bool+highpassInitAlt x0 ps xs =+   Filt1.highpassInit x0 ps xs == Filt1.highpassInitAlt x0 ps xs+++tests :: [(String, IO ())]+tests =+   ("addLowHighpass", quickCheck addLowHighpass) :+   ("combineLowHighpass", quickCheck combineLowHighpass) :+   ("lowpassId", quickCheck lowpassId) :+   ("lowpassZero", quickCheck lowpassZero) :+   ("highpassId", quickCheck highpassId) :+   ("highpassZero", quickCheck highpassZero) :+   ("lowpassConst", quickCheck lowpassConst) :+   ("highpassConst", quickCheck highpassConst) :+   ("highpassInitAlt", quickCheck highpassInitAlt) :+   []