packages feed

synthesizer-core 0.6 → 0.7

raw patch · 30 files changed

+481/−251 lines, 30 filesdep +non-emptydep ~arraydep ~basedep ~directory

Dependencies added: non-empty

Dependency ranges changed: array, base, directory, process, sample-frame-np

Files

Makefile view
@@ -6,6 +6,9 @@ ghci: 	ghci -Wall -odirdist/build -hidirdist/build $(HIDE_SYNTH) -i:$(MODULE_PATH) +ghci7:+	ghci -Wall -odirdist/build -hidirdist/build $(HIDE_SYNTH) -i:$(MODULE_PATH) -XCPP -DNoImplicitPrelude=RebindableSyntax+ tutorial: 	ghci -Wall -fobject-code -fexcess-precision -O2 -fvia-C -optc-O2 -odirdist/build -hidirdist/build $(HIDE_SYNTH) -i:$(MODULE_PATH) src/Synthesizer/Generic/Tutorial.hs
src/Synthesizer/Basic/Phase.hs view
@@ -207,7 +207,7 @@  FIXME: The increment and decrement routines are a bit dangerous,-because they fail if the increment value is large than maxBound::Int.+because they fail if the increment value is larger than maxBound::Int. However, we will always use increments with absolute value below one. -} {-# RULES
+ src/Synthesizer/Causal/Class.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE TypeFamilies #-}+module Synthesizer.Causal.Class where++import qualified Control.Category as Cat+import Control.Arrow (Arrow, arr, (<<<), (>>>), (&&&), )++import Data.Function.HT (nest, )+++class (Arrow process, ProcessOf (SignalOf process) ~ process) => C process where+   type SignalOf process :: * -> *+   type ProcessOf (signal :: * -> *) :: * -> * -> *+   toSignal :: process () a -> SignalOf process a+   fromSignal :: SignalOf process b -> process a b+++infixl 0 $<, $>, $*+-- infixr 0 $:*   -- can be used together with $++apply ::+   (C process) => process a b -> SignalOf process a -> SignalOf process b+apply proc sig =+   toSignal (proc <<< fromSignal sig)++applyFst, ($<) ::+   (C process) => process (a,b) c -> SignalOf process a -> process b c+applyFst proc sig =+   proc <<< feedFst sig++applySnd, ($>) ::+   (C process) => process (a,b) c -> SignalOf process b -> process a c+applySnd proc sig =+   proc <<< feedSnd sig++feedFst :: (C process) => SignalOf process a -> process b (a,b)+feedFst sig =+   fromSignal sig &&& Cat.id++feedSnd :: (C process) => SignalOf process a -> process b (b,a)+feedSnd sig =+   Cat.id &&& fromSignal sig++{-+These infix operators may become methods of a type class+that can also have synthesizer-core:Causal.Process as instance.+-}+($*) ::+   (C process) =>+   process a b -> SignalOf process a -> SignalOf process b+($*) = apply+($<) = applyFst+($>) = applySnd++++{-# INLINE chainControlled #-}+chainControlled ::+   (Arrow arrow) =>+   [arrow (c,x) x] -> arrow (c,x) x+chainControlled =+   foldr+      (\p rest -> arr fst &&& p  >>>  rest)+      (arr snd)++{-# INLINE replicateControlled #-}+replicateControlled ::+   (Arrow arrow) =>+   Int -> arrow (c,x) x -> arrow (c,x) x+replicateControlled n p =+   nest n+      (arr fst &&& p  >>> )+      (arr snd)
src/Synthesizer/Causal/Filter/NonRecursive.hs view
@@ -7,10 +7,12 @@ 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.Control as CtrlS import qualified Synthesizer.State.Signal as SigS+import Synthesizer.Utility (affineComb, )  import qualified Algebra.Module         as Module--- import qualified Algebra.Field          as Field+import qualified Algebra.Field          as Field import qualified Algebra.Ring           as Ring import qualified Algebra.Additive       as Additive @@ -37,6 +39,16 @@ envelopeVector :: (Module.C a v) =>    Causal.T (a,v) v envelopeVector = Causal.map (uncurry (*>))+++{-# INLINE crossfade #-}+crossfade :: (Field.C a, Module.C a a) => Int -> Causal.T (a,a) a+crossfade len =+   let affineCombMono :: (Module.C a a) => a -> (a,a) -> a+       affineCombMono = affineComb+   in  Causal.applyFst+          (Causal.map (uncurry affineCombMono))+          (CtrlS.line len (0, 1))   {-# INLINE accumulatePosModulatedFromPyramid #-}
src/Synthesizer/Causal/Process.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ExistentialQuantification #-} {- |@@ -71,6 +72,7 @@  import qualified Synthesizer.State.Signal as Sig import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.Causal.Class as Class  import qualified Synthesizer.Plain.Modifier as Modifier @@ -89,7 +91,6 @@ import Control.Monad (liftM, )  import Data.Tuple.HT (mapSnd, )-import Data.Function.HT (nest, ) import Prelude hiding (id, map, zipWith, )  @@ -158,6 +159,13 @@    loop = liftKleisli loop  +instance Class.C T where+   type SignalOf T = Sig.T+   type ProcessOf Sig.T = T+   toSignal = flip applyConst ()+   fromSignal sig = const () ^>> feed sig++ {-# INLINE extendStateFstT #-} extendStateFstT :: Monad m => StateT s m a -> StateT (t,s) m a extendStateFstT st =@@ -398,10 +406,7 @@  {-# INLINE chainControlled #-} chainControlled :: [T (c,x) x] -> T (c,x) x-chainControlled =-   foldr-      (\p rest -> map fst &&& p  >>>  rest)-      (map snd)+chainControlled = Class.chainControlled  {- | If @T@ would be the function type @->@@@ -410,10 +415,7 @@ -} {-# INLINE replicateControlled #-} replicateControlled :: Int -> T (c,x) x -> T (c,x) x-replicateControlled n p =-   nest n-      (map fst &&& p  >>> )-      (map snd)+replicateControlled = Class.replicateControlled   {-# INLINE feedback #-}
src/Synthesizer/Causal/ToneModulation.hs view
@@ -68,11 +68,6 @@     ((t, Phase.T t), sig y) ->     ((t,t), ToneModS.Cell sig y) seekCell periodInt period =-    {--    n will be zero within the data body.-    It's only needed for extrapolation at the end.-    Is it really needed?-    -}     (\(sp,ptr) ->        let (k,q) = ToneMod.flattenShapePhase periodInt period sp        in  (q, ToneModS.makeCell periodInt $@@ -137,8 +132,7 @@    Int -> Int -> sig y -> ((Bool, Int), sig y) dropMargin margin n xs =    mapFst ((,) (SigG.lengthAtMost (margin+n) xs)) $-   SigG.dropMarginRem margin-      (ToneModS.checkNonNeg n) xs+   SigG.dropMarginRem margin (ToneModS.checkNonNeg n) xs  regroup :: (Int,t) -> Phase.T t -> ToneMod.Skip t regroup (d,s) p = (d, (s,p))@@ -228,7 +222,7 @@          then (x0, Causal.id)          else (xMin,                Causal.crochetL-                  (\x lim ->+                  (\x lim -> Just $                      let d = x-lim-                     in  Just $ if d>=zero+                     in  if d>=zero                            then (d,zero) else (zero, negate d)) x1)
src/Synthesizer/Frame/Stereo.hs view
@@ -1,6 +1,11 @@-module Synthesizer.Frame.Stereo-   (T, left, right, cons, map,-    arrowFromMono, arrowFromMonoControlled, arrowFromChannels, ) where+module Synthesizer.Frame.Stereo (+   T, left, right, cons, map,+   arrowFromMono, arrowFromMonoControlled, arrowFromChannels,+   Stereo.Channel(Left, Right), Stereo.select,+   Stereo.interleave,+   Stereo.sequence,+   Stereo.liftApplicative,+   ) where  import Sound.Frame.NumericPrelude.Stereo as Stereo import Control.Arrow (Arrow, (^<<), (<<^), (&&&), )
src/Synthesizer/Generic/Filter/NonRecursive.hs view
@@ -55,6 +55,13 @@    a -> sig v -> sig v amplifyVector v = SigG.map (v*>) +{-# INLINE normalize #-}+normalize ::+   (Field.C a, SigG.Transform sig a) =>+   (sig a -> a) -> sig a -> sig a+normalize volume xs =+   amplify (recip $ volume xs) xs+ {-# INLINE envelope #-} envelope ::    (Ring.C a, SigG.Transform sig a) =>
src/Synthesizer/Generic/Signal.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} {- | Type classes that give a uniform interface to@@ -83,28 +84,28 @@   -class Storage signal y where+class Storage signal where -   data Constraints signal y :: *+   data Constraints signal :: * -   constraints :: signal y -> Constraints signal y+   constraints :: signal -> Constraints signal   class Read0 sig where-   toList :: Storage sig y => sig y -> [y]-   toState :: Storage sig y => sig y -> SigS.T y---   toState :: Storage sig y => StateT (sig y) Maybe y-   foldL :: Storage sig y => (s -> y -> s) -> s -> sig y -> s-   foldR :: Storage sig y => (y -> s -> s) -> s -> sig y -> s-   index :: Storage sig y => sig y -> Int -> y+   toList :: Storage (sig y) => sig y -> [y]+   toState :: Storage (sig y) => sig y -> SigS.T y+--   toState :: Storage (sig y) => StateT (sig y) Maybe y+   foldL :: Storage (sig y) => (s -> y -> s) -> s -> sig y -> s+   foldR :: Storage (sig y) => (y -> s -> s) -> s -> sig y -> s+   index :: Storage (sig y) => sig y -> Int -> y -class (Cut.Read (sig y), Read0 sig, Storage sig y) => Read sig y where+class (Cut.Read (sig y), Read0 sig, Storage (sig y)) => Read sig y where  class (Read0 sig) => Transform0 sig where-   cons :: Storage sig y => y -> sig y -> sig y-   takeWhile :: Storage sig y => (y -> Bool) -> sig y -> sig y-   dropWhile :: Storage sig y => (y -> Bool) -> sig y -> sig y-   span :: Storage sig y => (y -> Bool) -> sig y -> (sig y, sig y)+   cons :: Storage (sig y) => y -> sig y -> sig y+   takeWhile :: Storage (sig y) => (y -> Bool) -> sig y -> sig y+   dropWhile :: Storage (sig y) => (y -> Bool) -> sig y -> sig y+   span :: Storage (sig y) => (y -> Bool) -> sig y -> (sig y, sig y)     {- |    When using 'viewL' for traversing a signal,@@ -112,20 +113,20 @@    since this might involve optimized traversing    like in case of Storable signals.    -}-   viewL :: Storage sig y => sig y -> Maybe (y, sig y)-   viewR :: Storage sig y => sig y -> Maybe (sig y, y)+   viewL :: Storage (sig y) => sig y -> Maybe (y, sig y)+   viewR :: Storage (sig y) => sig y -> Maybe (sig y, y) -   zipWithAppend :: Storage sig y => (y -> y -> y) -> sig y -> sig y -> sig y+   zipWithAppend :: Storage (sig y) => (y -> y -> y) -> sig y -> sig y -> sig y     -- functions from Transform2 that are oftenly used with only one type variable    map ::-      (Storage sig y0, Storage sig y1) =>+      (Storage (sig y0), Storage (sig y1)) =>       (y0 -> y1) -> (sig y0 -> sig y1)    scanL ::-      (Storage sig y0, Storage sig y1) =>+      (Storage (sig y0), Storage (sig y1)) =>       (y1 -> y0 -> y1) -> y1 -> sig y0 -> sig y1    crochetL ::-      (Storage sig y0, Storage sig y1) =>+      (Storage (sig y0), Storage (sig y1)) =>       (y0 -> s -> Maybe (y1, s)) -> s -> sig y0 -> sig y1  class (Cut.Transform (sig y), Transform0 sig, Read sig y) => Transform sig y where@@ -205,31 +206,31 @@ for multiple signal processors. -} class Transform0 sig => Write0 sig where-   fromList :: Storage sig y => LazySize -> [y] -> sig y---   fromState :: Storage sig y => LazySize -> SigS.T y -> sig y---   fromState :: Storage sig y => LazySize -> StateT s Maybe y -> s -> sig y-   repeat :: Storage sig y => LazySize -> y -> sig y-   replicate :: Storage sig y => LazySize -> Int -> y -> sig y-   iterate :: Storage sig y => LazySize -> (y -> y) -> y -> sig y-   iterateAssociative :: Storage sig y => LazySize -> (y -> y -> y) -> y -> sig y-   unfoldR :: Storage sig y => LazySize -> (s -> Maybe (y,s)) -> s -> sig y+   fromList :: Storage (sig y) => LazySize -> [y] -> sig y+--   fromState :: Storage (sig y) => LazySize -> SigS.T y -> sig y+--   fromState :: Storage (sig y) => LazySize -> StateT s Maybe y -> s -> sig y+   repeat :: Storage (sig y) => LazySize -> y -> sig y+   replicate :: Storage (sig y) => LazySize -> Int -> y -> sig y+   iterate :: Storage (sig y) => LazySize -> (y -> y) -> y -> sig y+   iterateAssociative :: Storage (sig y) => LazySize -> (y -> y -> y) -> y -> sig y+   unfoldR :: Storage (sig y) => LazySize -> (s -> Maybe (y,s)) -> s -> sig y  class (Write0 sig, Transform sig y) => Write sig y where  -instance (Storable y) => Storage SVL.Vector y where-   data Constraints SVL.Vector y = Storable y => StorableLazyConstraints+instance (Storable y) => Storage (SVL.Vector y) where+   data Constraints (SVL.Vector y) = Storable y => StorableLazyConstraints    constraints _ = StorableLazyConstraints   readSVL ::    (Storable a => SVL.Vector a -> b) ->-   (Storage SVL.Vector a => SVL.Vector a -> b)+   (Storage (SVL.Vector a) => SVL.Vector a -> b) readSVL f x = case constraints x of StorableLazyConstraints -> f x  writeSVL ::    (Storable a => SVL.Vector a) ->-   (Storage SVL.Vector a => SVL.Vector a)+   (Storage (SVL.Vector a) => SVL.Vector a) writeSVL x =    let z = case constraints z of StorableLazyConstraints -> x    in  z@@ -309,18 +310,18 @@   -instance (Storable y) => Storage SV.Vector y where-   data Constraints SV.Vector y = Storable y => StorableConstraints+instance (Storable y) => Storage (SV.Vector y) where+   data Constraints (SV.Vector y) = Storable y => StorableConstraints    constraints _ = StorableConstraints  readSV ::    (Storable a => SV.Vector a -> b) ->-   (Storage SV.Vector a => SV.Vector a -> b)+   (Storage (SV.Vector a) => SV.Vector a -> b) readSV f x = case constraints x of StorableConstraints -> f x  writeSV ::    (Storable a => SV.Vector a) ->-   (Storage SV.Vector a => SV.Vector a)+   (Storage (SV.Vector a) => SV.Vector a) writeSV x =    let z = case constraints z of StorableConstraints -> x    in  z@@ -375,8 +376,8 @@   -instance Storage [] y where-   data Constraints [] y = ListConstraints+instance Storage [y] where+   data Constraints [y] = ListConstraints    constraints _ = ListConstraints  instance Read [] y where@@ -439,8 +440,8 @@   -instance Storage SigS.T y where-   data Constraints SigS.T y = StateConstraints+instance Storage (SigS.T y) where+   data Constraints (SigS.T y) = StateConstraints    constraints _ = StateConstraints  instance Read SigS.T y@@ -508,8 +509,8 @@    iterateAssociative _ = SigS.iterateAssociative  -instance Storage (EventList.T time) y where-   data Constraints (EventList.T time) y = EventListConstraints+instance Storage (EventList.T time y) where+   data Constraints (EventList.T time y) = EventListConstraints    constraints _ = EventListConstraints  instance (NonNeg98.C time, P.Integral time) =>@@ -667,8 +668,8 @@    sig y ->    (forall s. (s -> Maybe (y, s)) -> s -> x) ->    x-runViewL =-   SigS.runViewL . toState+runViewL xs =+   SigS.runViewL (toState xs)  {-# INLINE runSwitchL #-} runSwitchL ::@@ -676,8 +677,8 @@    sig y ->    (forall s. (forall z. z -> (y -> s -> z) -> s -> z) -> s -> x) ->    x-runSwitchL =-   SigS.runSwitchL . toState+runSwitchL xs =+   SigS.runSwitchL (toState xs)   {-# INLINE singleton #-}
src/Synthesizer/Generic/Wave.hs view
@@ -44,6 +44,8 @@ --   uncurry (ToneMod.interpolateCell ipStep ipLeap . swap) $    uncurry (ToneMod.interpolateCell ipLeap ipStep) $    ToneMod.sampledToneCell-      (ToneMod.makePrototype (Interpolation.margin ipLeap) (Interpolation.margin ipStep) period tone)+      (ToneMod.makePrototype+          (Interpolation.margin ipLeap) (Interpolation.margin ipStep)+          period tone)       shape phase
+ src/Synthesizer/Interpolation/Core.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+Plain interpolation functions.+-}+module Synthesizer.Interpolation.Core (+   linear,+   cubic,+   cubicAlt,+   ) where++import qualified Algebra.Module    as Module+import qualified Algebra.Field     as Field++import Synthesizer.Utility (affineComb, )++import NumericPrelude.Base+import NumericPrelude.Numeric++++{-# INLINE linear #-}+linear ::+   (Module.C a v) =>+   v -> v -> a -> v+linear x0 x1 phase = affineComb phase (x0,x1)++{-# INLINE cubic #-}+cubic ::+   (Module.C a v, Field.C a) =>+   v -> v -> v -> v -> a -> v+cubic xm1 x0 x1 x2 t =+   let lipm12 = affineComb t (xm1,x2)+       lip01  = affineComb t (x0, x1)+       three  = 3 `asTypeOf` t+   in  lip01 + (t*(t-1)/2) *>+                  (lipm12 + (x0+x1) - three *> lip01)++{- |+The interpolators for module operations+do not simply compute a straight linear combination of some vectors.+Instead they add then scale, then add again, and so on.+This is efficient whenever scaling and addition is cheap.+In this case they might save multiplications.+I can't say much about numeric cancellations, however.+-}+{-# INLINE cubicAlt #-}+cubicAlt ::+   (Module.C a v, Field.C a) =>+   v -> v -> v -> v -> a -> v+cubicAlt xm1 x0 x1 x2 t =+   let half = 1/2 `asTypeOf` t+   in  cubicHalf    t  x0 (half *> (x1-xm1)) ++       cubicHalf (1-t) x1 (half *> (x0-x2))++{- |+@\t -> cubicHalf t x x'@ has a double zero at 1 and+at 0 it has value x and slope x'.+-}+{-# INLINE cubicHalf #-}+cubicHalf :: (Module.C t y) => t -> y -> y -> y+cubicHalf t x x' =+   (t-1)^2 *> ((1+2*t)*>x + t*>x')
src/Synthesizer/Interpolation/Module.hs view
@@ -18,6 +18,8 @@ import qualified Synthesizer.State.Signal  as Sig import qualified Synthesizer.Plain.Control as Ctrl +import qualified Synthesizer.Interpolation.Core as Core+ import Synthesizer.Interpolation (    T, cons, getNode, fromPrefixReader,    constant,@@ -28,7 +30,6 @@  import Control.Applicative (liftA2, ) import Synthesizer.ApplicativeUtility (liftA4, )-import Synthesizer.Utility (affineComb, )  import NumericPrelude.Base import NumericPrelude.Numeric@@ -39,9 +40,7 @@ linear :: (Module.C t y) => T t y linear =    fromPrefixReader "linear" 0-      (liftA2-          (\x0 x1 phase -> affineComb phase (x0,x1))-          getNode getNode)+      (liftA2 Core.linear getNode getNode)  {- | Consider the signal to be piecewise cubic,@@ -57,43 +56,13 @@ cubic :: (Field.C t, Module.C t y) => T t y cubic =    fromPrefixReader "cubic" 1-      (liftA4-         (\xm1 x0 x1 x2 t ->-            let lipm12 = affineComb t (xm1,x2)-                lip01  = affineComb t (x0, x1)-                three  = 3 `asTypeOf` t-            in  lip01 + (t*(t-1)/2) *>-                           (lipm12 + (x0+x1) - three *> lip01))-         getNode getNode getNode getNode)+      (liftA4 Core.cubic getNode getNode getNode getNode) -{- |-The interpolators for module operations-do not simply compute a straight linear combination of some vectors.-Instead they add then scale, then add again, and so on.-This is efficient whenever scaling and addition is cheap.-In this case they might save multiplications.-I can't say much about numeric cancellations, however.--} {-# INLINE cubicAlt #-} cubicAlt :: (Field.C t, Module.C t y) => T t y cubicAlt =    fromPrefixReader "cubicAlt" 1-      (liftA4-         (\xm1 x0 x1 x2 t ->-          let half = 1/2 `asTypeOf` t-          in  cubicHalf    t  x0 (half *> (x1-xm1)) +-              cubicHalf (1-t) x1 (half *> (x0-x2)))-         getNode getNode getNode getNode)---{- |-@\t -> cubicHalf t x x'@ has a double zero at 1 and-at 0 it has value x and slope x'.--}-{-# INLINE cubicHalf #-}-cubicHalf :: (Module.C t y) => t -> y -> y -> y-cubicHalf t x x' =-   (t-1)^2 *> ((1+2*t)*>x + t*>x')+      (liftA4 Core.cubicAlt getNode getNode getNode getNode)
src/Synthesizer/PiecewiseConstant/Signal.hs view
@@ -8,6 +8,7 @@    subdivideLazyToShort,    subdivideLongStrict,    chopLongTime,+   longFromShortTime,    zipWith,    ) where @@ -80,6 +81,13 @@    in  map (NonNegW.fromNumberMsg "chopLongTime" . fromInteger) $        List.genericReplicate q d ++        if not $ isZero r then [r] else []++{-# INLINE longFromShortTime #-}+longFromShortTime :: ShortStrictTime -> StrictTime+longFromShortTime =+   NonNegW.fromNumberMsg "longFromShortTime" .+   fromIntegral .+   NonNegW.toNumber   {-# INLINE subdivideLongStrict #-}
src/Synthesizer/Plain/Analysis.hs view
@@ -21,6 +21,7 @@ import qualified Algebra.NormedSpace.Euclidean as NormedEuc import qualified Algebra.NormedSpace.Sum       as NormedSum +import qualified Data.NonEmpty as NonEmpty import qualified Data.Array as Array  import qualified Data.IntMap as IntMap@@ -94,9 +95,8 @@ Compute minimum and maximum value of the stream the efficient way. Input list must be non-empty and finite. -}-bounds :: Ord y => Sig.T y -> (y,y)-bounds [] = error "Analysis.bounds: List must contain at least one element."-bounds (x:xs) =+bounds :: Ord y => NonEmpty.T Sig.T y -> (y,y)+bounds (NonEmpty.Cons x xs) =    foldl' (\(minX,maxX) y -> (min y minX, max y maxX)) (x,x) xs  @@ -136,13 +136,11 @@ Input list must be finite. List is scanned twice, but counting may be faster. -}-histogramDiscreteArray :: Sig.T Int -> (Int, Sig.T Int)-histogramDiscreteArray [] =-   (error "histogramDiscreteArray: no bounds found", [])+histogramDiscreteArray :: NonEmpty.T Sig.T Int -> (Int, Sig.T Int) histogramDiscreteArray x =    let hist =           accumArray (+) zero-             (bounds x) (attachOne x)+             (bounds x) (attachOne $ NonEmpty.flatten x)    in  (fst (Array.bounds hist), Array.elems hist)  @@ -152,10 +150,8 @@ List is scanned twice, but counting may be faster. The sum of all histogram values is one less than the length of the signal. -}-histogramLinearArray :: RealField.C y => Sig.T y -> (Int, Sig.T y)-histogramLinearArray [] =-   (error "histogramLinearArray: no bounds found", [])-histogramLinearArray [x] = (floor x, [])+histogramLinearArray :: RealField.C y => NonEmpty.T Sig.T y -> (Int, Sig.T y)+histogramLinearArray (NonEmpty.Cons x []) = (floor x, []) histogramLinearArray x =    let (xMin,xMax) = bounds x        hist =@@ -170,11 +166,9 @@ If the input signal is empty, the offset is @undefined@. List is scanned once, counting may be slower. -}-histogramDiscreteIntMap :: Sig.T Int -> (Int, Sig.T Int)-histogramDiscreteIntMap [] =-   (error "histogramDiscreteIntMap: no bounds found", [])+histogramDiscreteIntMap :: NonEmpty.T Sig.T Int -> (Int, Sig.T Int) histogramDiscreteIntMap x =-   let hist = IntMap.fromListWith (+) (attachOne x)+   let hist = IntMap.fromListWith (+) (attachOne $ NonEmpty.flatten x)    in  case IntMap.toAscList hist of           [] -> error "histogramDiscreteIntMap: the list was non-empty before processing ..."           fAll@((fIndex,fHead):fs) -> (fIndex, fHead :@@ -182,10 +176,8 @@                  (\(i0,_) (i1,f1) -> replicate (i1-i0-1) zero ++ [f1])                  fAll fs)) -histogramLinearIntMap :: RealField.C y => Sig.T y -> (Int, Sig.T y)-histogramLinearIntMap [] =-   (error "histogramLinearIntMap: no bounds found", [])-histogramLinearIntMap [x] = (floor x, [])+histogramLinearIntMap :: RealField.C y => NonEmpty.T Sig.T y -> (Int, Sig.T y)+histogramLinearIntMap (NonEmpty.Cons x []) = (floor x, []) histogramLinearIntMap x =    let hist = IntMap.fromListWith (+) (meanValues x)    -- we can rely on the fact that the keys are contiguous@@ -207,18 +199,18 @@ The bug has gone in IntMap as shipped with GHC-6.6. -} -histogramIntMap :: (RealField.C y) => y -> Sig.T y -> (Int, Sig.T Int)+histogramIntMap :: (RealField.C y) => y -> NonEmpty.T Sig.T y -> (Int, Sig.T Int) histogramIntMap binsPerUnit =    histogramDiscreteIntMap . quantize binsPerUnit -quantize :: (RealField.C y) => y -> Sig.T y -> Sig.T Int-quantize binsPerUnit = map (floor . (binsPerUnit*))+quantize :: (Functor f, RealField.C y) => y -> f y -> f Int+quantize binsPerUnit = fmap (floor . (binsPerUnit*))  attachOne :: Sig.T i -> Sig.T (i,Int) attachOne = map (\i -> (i,one)) -meanValues :: RealField.C y => Sig.T y -> [(Int,y)]-meanValues x = concatMap spread (zip x (tail x))+meanValues :: RealField.C y => NonEmpty.T Sig.T y -> [(Int,y)]+meanValues = concatMap spread . NonEmpty.mapAdjacent (,)  spread :: RealField.C y => (y,y) -> [(Int,y)] spread (l0,r0) =
src/Synthesizer/Plain/Effect.hs view
@@ -16,8 +16,8 @@  import qualified Synthesizer.Plain.File as File import qualified Control.Monad.Exception.Synchronous as Exc-import System.Exit(ExitCode)-import System.Cmd(rawSystem)+import System.Process (rawSystem, )+import System.Exit (ExitCode, )  main :: IO ExitCode main =
src/Synthesizer/Plain/File.hs view
@@ -37,7 +37,7 @@  import qualified Control.Monad.Exception.Synchronous as Exc import Control.Monad.Trans.Class (lift, )-import System.Cmd (rawSystem, )+import System.Process (rawSystem, ) import System.Exit (ExitCode, ) import Control.Monad (liftM2, ) import Data.Monoid (mconcat, )
src/Synthesizer/Plain/Filter/Delay.hs view
@@ -5,7 +5,7 @@ import qualified Synthesizer.Plain.Displacement as Syn import qualified Synthesizer.Plain.Control as Ctrl import qualified Synthesizer.Plain.Noise   as Noise-import System.Random (Random, randomRs, mkStdGen, )+import System.Random (randomRs, mkStdGen, )  import qualified Algebra.Module    as Module import qualified Algebra.RealField as RealField
src/Synthesizer/Plain/Filter/Recursive/Butterworth.hs view
@@ -60,11 +60,11 @@   -partialParameterInstable, partialParameter :: (Trans.C a) =>+partialLowpassParameterInstable, partialLowpassParameter :: (Trans.C a) =>    a -> a -> a -> Filt2.Parameter a  {- must handle infinite values when 'freq' approaches 0.5 -}-partialParameterInstable ratio freq sinw =+partialLowpassParameterInstable ratio freq sinw =    let wc    = ratio * tan (pi*freq)        sinw2 = 2 * wc * sinw        wc2   = wc * wc@@ -74,7 +74,7 @@           (2*(1-wc2)/denom) ((-wc2+sinw2-1)/denom)  -- using ratio disallows simplification by trigonometric Pythagoras' theorem-partialParameter ratio freq =+partialLowpassParameter ratio freq =    let phi      = pi*freq        rsin2phi = ratio * sin (2*phi)        cosphi2  = cos phi ^ 2@@ -104,11 +104,19 @@    let sinesVec = SV.pack (makeSines order)    in  \ (Pole ratio freq) ->            Cascade.Parameter $-           SV.map (\sinw ->-              Filt2.adjustPassband kind-                 (flip (partialParameter (partialRatio order ratio)) sinw) freq) $+           SV.map+              (\sinw ->+                 partialParameter kind (partialRatio order ratio) sinw freq) $            sinesVec +partialParameter ::+   Trans.C a =>+   Passband -> a -> a -> a -> Filt2.Parameter a+partialParameter kind partRatio sinw freq =+   Filt2.adjustPassband kind+      (flip (partialLowpassParameter partRatio) sinw)+      freq+ {-# INLINE modifier #-} modifier ::    (Ring.C a, Module.C a v, Storable a, Storable v) =>@@ -155,15 +163,17 @@  It uses the frequency and ratio information directly and thus cannot benefit from efficient parameter interpolation-(asynchronous run of a ControlledProcess.+(asynchronous run of a ControlledProcess). -} runPole :: (Trans.C a, Module.C a v) =>    Passband -> Int -> Sig.T a -> Sig.T a -> Sig.T v -> Sig.T v runPole kind order ratios freqs =    let makePartialFilter s =-          Filt2.run (zipWith (\ratio ->-             Filt2.adjustPassband kind $ \freq ->-                partialParameter (partialRatio order ratio) freq s) ratios freqs)+          Filt2.run $+          zipWith+             (\ratio freq ->+                partialParameter kind (partialRatio order ratio) s freq)+             ratios freqs    in  foldl (.) id (map makePartialFilter (makeSines order))  causalPole :: (Trans.C a, Module.C a v) =>@@ -171,9 +181,10 @@ causalPole kind order =    let {-# INLINE makePartialFilter #-}        makePartialFilter s =-          Causal.first (Causal.map (\(Pole ratio freq) ->-             Filt2.adjustPassband kind-                (flip (partialParameter (partialRatio order ratio)) s) freq)) >>>+          Causal.first+             (Causal.map (\(Pole ratio freq) ->+                partialParameter kind (partialRatio order ratio) s freq))+          >>>           Filt2.causal    in  Causal.chainControlled $ map makePartialFilter $ makeSines order
src/Synthesizer/Plain/Filter/Recursive/Chebyshev.hs view
@@ -24,6 +24,7 @@  import qualified Algebra.Module                as Module import qualified Algebra.Transcendental        as Trans+import qualified Algebra.Field                 as Field import qualified Algebra.Ring                  as Ring  import Number.Complex (real, imag, cis, )@@ -61,10 +62,10 @@ for the Butterworth filter the quadratic factors of the polynomial can be determined more efficiently than the zeros. -}-partialParameterA, partialParameterB :: (Trans.C a) =>+partialLowpassParameterA, partialLowpassParameterB :: (Trans.C a) =>    Int -> a -> a -> Complex.T a -> Filt2.Parameter a {--partialParameterA order ratio freq =+partialLowpassParameterA order ratio freq =    let {- if ratio == (sqrt 2) then the product of the normalization factors is           2^(1-2*order) -} --       bn = asinh (ratio/sqrt(1-ratio^2)) / fromIntegral (2*order)@@ -91,7 +92,7 @@                  (-2*(cpims*cmims - resin2)/denom) ((cpims^2 + resin2)/denom) -} -partialParameterA order ratio freq =+partialLowpassParameterA order ratio freq =    let {- if ratio == (sqrt 2) then the product of the normalization factors is           2^(1-2*order) -} --       bn = asinh (ratio/sqrt(1-ratio^2)) / fromIntegral (2*order)@@ -125,7 +126,7 @@                  (-2*(cpims*cmims - resin2)/denom) ((cpims^2 + resin2)/denom)  {--partialParameterA order ratio freq =+partialLowpassParameterA order ratio freq =    let {- if ratio == (sqrt 2) then the product of the normalization factors is           2^(1-2*order) -}        bn = asinh (ratio/sqrt(1-ratio^2)) / fromIntegral (2*order)@@ -155,7 +156,7 @@ -}  {--partialParameterA order ratio freq =+partialLowpassParameterA order ratio freq =    let {- if ratio == (sqrt 2) then the product of the normalization factors is           2^(1-2*order) -}        bn = asinh (ratio/sqrt(1-ratio^2)) / fromIntegral (2*order)@@ -185,7 +186,7 @@ -}  {--partialParameterB order ratio freq =+partialLowpassParameterB order ratio freq =    let -- bn = asinh (sqrt(1-ratio^2)/ratio) / fromIntegral (2*order)        bn = (log(1+sqrt(1-ratio^2)) - log ratio) / fromIntegral (2*order)        coshbn  = cosh bn@@ -213,7 +214,7 @@                  (-2*(spimc*smimc - recos2)/denom) (-(spimc^2 + recos2)/denom) -} -partialParameterB order ratio freq =+partialLowpassParameterB order ratio freq =    let -- bn = asinh (sqrt(1-ratio^2)/ratio) / fromIntegral (2*order)        bn = (log(1+sqrt(1-ratio^2)) - log ratio) / fromIntegral (2*order)        coshbn  = cosh bn@@ -244,6 +245,26 @@  -- * use second order filter parameters for control +{-# INLINE partialParameter #-}+partialParameter ::+   (Field.C a) =>+   (a -> a -> Complex.T a -> Filt2.Parameter a) ->+   Passband -> a -> Complex.T a -> a -> Filt2.Parameter a+partialParameter lowpassParameter kind ratio c freq =+   Filt2.adjustPassband kind+      (flip (lowpassParameter ratio) c)+      freq++{-# INLINE partialParameterA #-}+{-# INLINE partialParameterB #-}+partialParameterA, partialParameterB ::+   (Trans.C a) =>+   Passband -> Int -> a -> Complex.T a -> a -> Filt2.Parameter a+partialParameterA kind order =+   partialParameter (partialLowpassParameterA order) kind+partialParameterB kind order =+   partialParameter (partialLowpassParameterB order) kind+ {- We could prevent definition of an extra parameter type by applying application to one of the filters using Filt2.amplify.@@ -260,9 +281,7 @@    in  \ (Pole ratio freq) ->           (ratio,            Cascade.Parameter $-           SV.map (\c ->-              Filt2.adjustPassband kind-                 (flip (partialParameterA order ratio) c) freq) $+           SV.map (\c -> partialParameterA kind order ratio c freq) $            circleVec)  {-# INLINE canonicalizeParameterA #-}@@ -285,9 +304,7 @@    let circleVec = SV.pack (makeCirclePoints order)    in  \ (Pole ratio freq) ->            Cascade.Parameter $-           SV.map (\c ->-              Filt2.adjustPassband kind-                 (flip (partialParameterB order ratio) c) freq) $+           SV.map (\c -> partialParameterB kind order ratio c freq) $            circleVec  {-@@ -326,8 +343,7 @@    let makePartialFilter c =           Filt2.run              (zipWith-                 (\ratio -> Filt2.adjustPassband kind $-                  \freq -> partialParameterA order ratio freq c)+                 (\ratio freq -> partialParameterA kind order ratio c freq)                  ratios freqs)    in  foldl (.) (zipWith (*>) ratios)           (map makePartialFilter (makeCirclePoints order))@@ -336,8 +352,7 @@    let makePartialFilter c =           Filt2.run              (zipWith-                 (\ratio -> Filt2.adjustPassband kind $-                  \freq -> partialParameterB order ratio freq c)+                 (\ratio freq -> partialParameterB kind order ratio c freq)                  ratios freqs)    in  foldl (.) id (map makePartialFilter (makeCirclePoints order)) @@ -348,8 +363,7 @@    let {-# INLINE makePartialFilter #-}        makePartialFilter c =           Causal.first (Causal.map (\(Pole ratio freq) ->-             Filt2.adjustPassband kind-             (flip (partialParameterA order ratio) c) freq)) >>>+             partialParameterA kind order ratio c freq)) >>>           Filt2.causal    in  (\(p, y) -> (p, poleResonance p *> y)) ^>>        (Causal.chainControlled $@@ -360,8 +374,7 @@    let {-# INLINE makePartialFilter #-}        makePartialFilter c =           Causal.first (Causal.map (\(Pole ratio freq) ->-             Filt2.adjustPassband kind-             (flip (partialParameterB order ratio) c) freq)) >>>+             partialParameterB kind order ratio c freq)) >>>           Filt2.causal    in  Causal.chainControlled $        map makePartialFilter $
src/Synthesizer/Plain/Filter/Recursive/FirstOrderComplex.hs view
@@ -11,6 +11,7 @@  First order lowpass and highpass with complex valued feedback. The complex feedback allows resonance.+It is often called complex resonator. -} module Synthesizer.Plain.Filter.Recursive.FirstOrderComplex (    Parameter,
src/Synthesizer/Plain/Filter/Recursive/Universal.hs view
@@ -190,22 +190,57 @@   by factor one and cancels the resonance frequency. -} {-# INLINE parameter #-}-parameter :: Trans.C a => Pole a -> Parameter a+parameter, parameterAlt, parameterOld :: Trans.C a => Pole a -> Parameter a parameter (Pole resonance frequency) =-    let zr     = cos (2*pi*frequency)-        zr1    = zr-1-        q2     = resonance^2-        sqrtQZ = sqrt (zr1*(-8*q2+zr1-4*q2*zr1))-        pk1    = (-zr1+sqrtQZ) / (2*q2-zr1+sqrtQZ)-        q21zr  = 4*q2*zr-        a      = 2 * (zr1*zr1-q21zr*zr) / (zr1+q21zr+(1+2*zr1)*sqrtQZ)-        pk2    = a+2-pk1-        volHP  = (4-2*pk1-pk2) / 4-        volLP  = pk2-        volBP  = sqrt (volHP*volLP)-    in  Parameter-           (pk1*volHP/volBP)  (pk2*volHP/volLP)-           volHP  (volBP/volHP)  (volLP/volBP)  (recip resonance)+   let w      = sin (pi*frequency)+       w2     = w^2+       q2     = resonance^2+       q21w2  = 4*q2*(1-w2)+       sqrtQZ = w * sqrt (q21w2 + w2)+       pk1    = (w2+sqrtQZ) / (q2+w2+sqrtQZ)+       d      = (q21w2*w2 + w2^2 - q2)+                  / (q21w2 - 2*q2 - w2 + (1-4*w2)*sqrtQZ)+       volHP  = (2-pk1)/4 - d+       volRel = sqrt ((2-pk1 + 4 * d) / volHP)+   in  Parameter+          (pk1/volRel)  volHP+          volHP  volRel  volRel  (recip resonance)++parameterAlt (Pole resonance frequency) =+   let w      = sin (pi*frequency)+       w2     = w^2+       q2     = resonance^2+       sqrtQZ = w * sqrt (4*q2 + w2 - 4*q2*w2)+       pk1    = (w2+sqrtQZ) / (q2+w2+sqrtQZ)+       zr     = 1 - 2 * w2+       pk2    = 2-pk1 ++                   4 * (w2^2-q2*zr^2) / (2*q2*zr-w2+(1-4*w2)*sqrtQZ)+       volHP  = (4-2*pk1-pk2) / 4+       volLP  = pk2+       volBP  = sqrt (volHP*volLP)+   in  Parameter+          (pk1*volHP/volBP)  (pk2*volHP/volLP)+          volHP  (volBP/volHP)  (volLP/volBP)  (recip resonance)++{-+This computation is more affected by cancelations+for small frequencies, i.e. zr1 = cos eps - 1.+-}+parameterOld (Pole resonance frequency) =+   let zr     = cos (2*pi*frequency)+       zr1    = zr-1+       q2     = resonance^2+       sqrtQZ = sqrt (zr1*(-8*q2+zr1-4*q2*zr1))+       pk1    = (-zr1+sqrtQZ) / (2*q2-zr1+sqrtQZ)+       q21zr  = 4*q2*zr+       a      = 2 * (zr1*zr1-q21zr*zr) / (zr1+q21zr+(1+2*zr1)*sqrtQZ)+       pk2    = a+2-pk1+       volHP  = (4-2*pk1-pk2) / 4+       volLP  = pk2+       volBP  = sqrt (volHP*volLP)+   in  Parameter+          (pk1*volHP/volBP)  (pk2*volHP/volLP)+          volHP  (volBP/volHP)  (volLP/volBP)  (recip resonance)   {-
src/Synthesizer/Plain/IO.hs view
@@ -18,7 +18,7 @@ import Control.Exception (bracket, ) import Control.Monad (liftM, ) -import Data.Monoid (Monoid, mconcat, )+import Data.Monoid (mconcat, )  import qualified Data.ByteString.Lazy as B import qualified Data.Binary.Builder as Builder
src/Synthesizer/Plain/Signal.hs view
@@ -19,7 +19,7 @@ import Data.Tuple.HT (forcePair, mapFst, mapSnd, )  -type T a = [a]+type T = []   {- * Generic routines that are useful for filters -}
src/Synthesizer/Plain/ToneModulation.hs view
@@ -120,10 +120,7 @@        limits =           if lower > upper             then error "min>max"-            else-              (fromIntegral lower, fromIntegral upper)--       arr = listArray (0, pred len) tone+            else (fromIntegral lower, fromIntegral upper)     in  Prototype {           protoMarginLeap  = marginLeap,@@ -132,7 +129,7 @@           protoPeriod      = period,           protoPeriodInt   = periodInt,           protoShapeLimits = limits,-          protoArray       = arr+          protoArray       = listArray (0, pred len) tone        }  sampledToneCell :: (RealField.C t) =>
src/Synthesizer/State/Signal.hs view
@@ -35,6 +35,7 @@  import qualified Control.Applicative as App +import Data.Foldable (Foldable, foldr, ) import Data.Monoid (Monoid, mappend, mempty, )  import qualified Synthesizer.Storable.Signal as SigSt@@ -83,6 +84,9 @@  instance Functor T where    fmap g (Cons f s) = Cons (fmap g f) s++instance Foldable T where+   foldr = foldR  instance App.Applicative T where    pure = singleton
src/Synthesizer/State/ToneModulation.hs view
@@ -29,7 +29,10 @@  type Cell sig y = SigS.T (sig y) --- cells are organised in a transposed style, when compared with Plain.ToneModulation+{- |+cells are organised in a transposed style,+when compared with Plain.ToneModulation+-} {-# INLINE interpolateCell #-} interpolateCell ::    (SigG.Read sig y) =>@@ -70,8 +73,7 @@        limits =           if lower > upper             then error "min>max"-            else-              (fromIntegral lower, fromIntegral upper)+            else (fromIntegral lower, fromIntegral upper)     in  Prototype {           protoMarginLeap  = marginLeap,
src/Synthesizer/Utility.hs view
@@ -2,6 +2,7 @@  import qualified Algebra.Module    as Module import qualified Algebra.RealField as RealField+import qualified Algebra.Ring      as Ring import qualified Algebra.Field     as Field  import System.Random (Random, RandomGen, randomRs, )@@ -43,9 +44,17 @@ --   y /= 0 ==>    fmod x y == fmodAlt x y +{- |+This one should be more precise than 'affineCombAlt' in floating computations+whenever @x1@ is small and @x0@ is big.+-} {-# INLINE affineComb #-} affineComb :: (Module.C t y) => t -> (y,y) -> y-affineComb phase (x0,x1) = x0 + phase *> (x1-x0)+affineComb phase (x0,x1) = (Ring.one-phase) *> x0 + phase *> x1++affineCombAlt :: (Module.C t y) => t -> (y,y) -> y+affineCombAlt phase (x0,x1) = x0 + phase *> (x1-x0)+  {-# INLINE balanceLevel #-} balanceLevel :: (Field.C y) =>
src/Synthesizer/Zip.hs view
@@ -5,7 +5,7 @@ import Data.Monoid (Monoid, mempty, mappend, )  import qualified Control.Arrow as Arrow-import Control.Arrow (Arrow, (^<<), (<<^), )+import Control.Arrow (Arrow, (<<<), (^<<), (<<^), )   {- |@@ -93,6 +93,20 @@    arrow a c -> arrow b d -> arrow (T a b) (T c d) arrowSplit x y =    uncurry Cons  Arrow.^<<  x Arrow.*** y  Arrow.<<^  (\(Cons a b) -> (a,b))+++arrowFanoutShorten ::+   (Arrow arrow, CutG.Transform a, CutG.Transform b, CutG.Transform c) =>+   arrow a b -> arrow a c -> arrow a (T b c)+arrowFanoutShorten a b =+   arrowSplitShorten a b <<^ (\x -> Cons x x)++arrowSplitShorten ::+   (Arrow arrow,+    CutG.Transform a, CutG.Transform b, CutG.Transform c, CutG.Transform d) =>+   arrow a c -> arrow b d -> arrow (T a b) (T c d)+arrowSplitShorten a b =+   arrowFirstShorten a <<< arrowSecondShorten b   instance (Monoid a, Monoid b) => Monoid (T a b) where
src/Test/Sound/Synthesizer/Plain/Analysis.hs view
@@ -13,16 +13,12 @@  import qualified MathObj.LaurentPolynomial as LPoly --- import Algebra.Module((*>))-+import qualified Data.NonEmpty as NonEmpty import Data.List (genericLength)  import Test.QuickCheck (quickCheck, Property, (==>)) import Test.Utility (approxEqual) --- import qualified Algebra.Ring                  as Ring--- import qualified Algebra.Additive              as Additive- import NumericPrelude.Numeric import NumericPrelude.Base import Prelude ()@@ -32,27 +28,32 @@ volumeVectorMaximum xs =    Analysis.volumeVectorMaximum xs == Analysis.volumeMaximum xs -volumeVectorEuclidean :: (NormedEuc.C y y, Algebraic.C y, Eq y) => y -> [y] -> Bool-volumeVectorEuclidean x xs =-   let ys = x:xs+volumeVectorEuclidean ::+   (NormedEuc.C y y, Algebraic.C y, Eq y) =>+   NonEmpty.T [] y -> Bool+volumeVectorEuclidean xs =+   let ys = NonEmpty.flatten xs    in  Analysis.volumeVectorEuclidean ys == Analysis.volumeEuclidean ys -volumeVectorEuclideanSqr :: (NormedEuc.Sqr y y, Field.C y, Eq y) => y -> [y] -> Bool-volumeVectorEuclideanSqr x xs =-   let ys = x:xs+volumeVectorEuclideanSqr ::+   (NormedEuc.Sqr y y, Field.C y, Eq y) =>+   NonEmpty.T [] y -> Bool+volumeVectorEuclideanSqr xs =+   let ys = NonEmpty.flatten xs    in  Analysis.volumeVectorEuclideanSqr ys == Analysis.volumeEuclideanSqr ys -volumeVectorSum :: (NormedSum.C y y, RealField.C y) => y -> [y] -> Bool-volumeVectorSum x xs =-   let ys = x:xs+volumeVectorSum ::+   (NormedSum.C y y, RealField.C y) =>+   NonEmpty.T [] y -> Bool+volumeVectorSum xs =+   let ys = NonEmpty.flatten xs    in  Analysis.volumeVectorSum ys == Analysis.volumeSum ys   -bounds :: Ord a => a -> [a] -> Bool-bounds x xs =-   let ys = x:xs-   in  Analysis.bounds ys  ==  (minimum ys, maximum ys)+bounds :: Ord a => NonEmpty.T [] a -> Bool+bounds xs =+   Analysis.bounds xs  ==  (NonEmpty.minimum xs, NonEmpty.maximum xs)   spread :: RealField.C a => (a,a) -> Bool@@ -60,45 +61,52 @@    sum (map snd (Analysis.spread b)) == one  -histogramDiscrete :: Int -> [Int] -> Bool-histogramDiscrete x xs =-   let ys = x:xs-   in  Analysis.histogramDiscreteArray ys ==-       Analysis.histogramDiscreteIntMap ys+histogramDiscrete :: NonEmpty.T [] Int -> Bool+histogramDiscrete xs =+   Analysis.histogramDiscreteArray xs ==+   Analysis.histogramDiscreteIntMap xs +withEmptyHistogram ::+   (NonEmpty.T [] y -> (Int, [y])) ->+   [y] -> (Int, [y])+withEmptyHistogram f =+   maybe (error "no bounds", []) f . NonEmpty.fetch+ histogramDiscreteLength :: [Int] -> Bool histogramDiscreteLength xs =-   sum (snd (Analysis.histogramDiscreteIntMap xs)) == length xs+   sum (snd (withEmptyHistogram Analysis.histogramDiscreteIntMap xs))+   ==+   length xs  histogramDiscreteConcat :: [Int] -> [Int] -> Bool histogramDiscreteConcat xs ys =-   let xHist = Analysis.histogramDiscreteIntMap xs-       yHist = Analysis.histogramDiscreteIntMap ys+   let xHist = withEmptyHistogram Analysis.histogramDiscreteIntMap xs+       yHist = withEmptyHistogram Analysis.histogramDiscreteIntMap ys        xyHist0 =           LPoly.add              (uncurry LPoly.Cons xHist)              (uncurry LPoly.Cons yHist)        xyHist1 =           uncurry LPoly.Cons-             (Analysis.histogramDiscreteIntMap (xs++ys))+             (withEmptyHistogram Analysis.histogramDiscreteIntMap (xs++ys))    in  if null (LPoly.coeffs xyHist0)          then LPoly.coeffs xyHist0 == LPoly.coeffs xyHist1          else xyHist0 == xyHist1  -histogramLinear :: Int -> [Int] -> Bool-histogramLinear x xs =-   let ys = map fromIntegral (x:xs) :: [Double]+histogramLinear :: NonEmpty.T [] Int -> Bool+histogramLinear xs =+   let ys = fmap fromIntegral xs :: NonEmpty.T [] Double    in  Analysis.histogramLinearArray ys ==        Analysis.histogramLinearIntMap ys  -histogramLinearLength :: Int -> [Int] -> Bool-histogramLinearLength x xs =-   let ys = map fromIntegral (x:xs) :: [Double]+histogramLinearLength :: NonEmpty.T [] Int -> Bool+histogramLinearLength xs =+   let ys = fmap fromIntegral xs :: NonEmpty.T [] Double    in  approxEqual 1e-10-          (genericLength ys)-          (sum (snd (Analysis.histogramLinearIntMap ys)) + 1)+          (genericLength $ NonEmpty.tail ys)+          (sum (snd (Analysis.histogramLinearIntMap ys))) {- With eps = 1e-15 @@ -119,30 +127,34 @@       Analysis.centroid xs == Analysis.centroidAlt xs -- Test.QuickCheck.quickCheck (\xs -> sum xs /= 0 Test.QuickCheck.==> propCentroid (xs::[Rational])) -histogramDCOffset :: Int -> Int -> [Int] -> Property-histogramDCOffset x0 x1 xs =-   let x = x0:x1:xs-       (offset, hist) = Analysis.histogramDiscreteArray x+histogramDCOffset :: NonEmpty.T (NonEmpty.T []) Int -> Property+histogramDCOffset xs =+   let x1 = NonEmpty.flatten xs+       x  = NonEmpty.flatten x1+       (offset, hist) = Analysis.histogramDiscreteArray x1    in  sum x /= 0 ==>           fromIntegral offset + Analysis.centroid (map fromIntegral hist) ==           (Analysis.directCurrentOffset (map fromIntegral x) :: Rational)  +small :: (Functor f) => f Int -> f Int+small = fmap (flip mod 1000) + tests :: [(String, IO ())] tests =    ("volumeVectorMaximum", quickCheck (volumeVectorMaximum :: [Rational] -> Bool)) :    -- quickCheck may fail due to rounding errors, but so far the computation is exactly the same-   ("volumeVectorEuclidean", quickCheck (volumeVectorEuclidean :: Double -> [Double] -> Bool)) :-   ("volumeVectorEuclideanSqr", quickCheck (volumeVectorEuclideanSqr :: Rational -> [Rational] -> Bool)) :-   ("volumeVectorSum", quickCheck (volumeVectorSum :: Rational -> [Rational] -> Bool)) :-   ("bounds", quickCheck (bounds :: Rational -> [Rational] -> Bool)) :+   ("volumeVectorEuclidean", quickCheck (volumeVectorEuclidean :: NonEmpty.T [] Double -> Bool)) :+   ("volumeVectorEuclideanSqr", quickCheck (volumeVectorEuclideanSqr :: NonEmpty.T [] Rational -> Bool)) :+   ("volumeVectorSum", quickCheck (volumeVectorSum :: NonEmpty.T [] Rational -> Bool)) :+   ("bounds", quickCheck (bounds :: NonEmpty.T [] Rational -> Bool)) :    ("spread", quickCheck (spread :: (Rational,Rational) -> Bool)) :-   ("histogramDiscrete", quickCheck (histogramDiscrete :: Int -> [Int] -> Bool)) :-   ("histogramDiscreteLength", quickCheck (histogramDiscreteLength :: [Int] -> Bool)) :-   ("histogramDiscreteConcat", quickCheck (histogramDiscreteConcat :: [Int] -> [Int] -> Bool)) :-   ("histogramLinear", quickCheck (histogramLinear :: Int -> [Int] -> Bool)) :-   ("histogramLinearLength", quickCheck (histogramLinearLength :: Int -> [Int] -> Bool)) :+   ("histogramDiscrete", quickCheck (histogramDiscrete . small)) :+   ("histogramDiscreteLength", quickCheck (histogramDiscreteLength . small)) :+   ("histogramDiscreteConcat", quickCheck (\x y -> histogramDiscreteConcat (small x) (small y))) :+   ("histogramLinear", quickCheck (histogramLinear . small)) :+   ("histogramLinearLength", quickCheck (histogramLinearLength . small)) :    ("centroid", quickCheck (centroid :: [Rational] -> Property)) :-   ("histogramDCOffset", quickCheck (histogramDCOffset :: Int -> Int -> [Int] -> Property)) :+   ("histogramDCOffset", quickCheck (histogramDCOffset . small)) :    []
synthesizer-core.cabal view
@@ -1,5 +1,5 @@ Name:           synthesizer-core-Version:        0.6+Version:        0.7 License:        GPL License-File:   LICENSE Author:         Henning Thielemann <haskell@henning-thielemann.de>@@ -48,7 +48,7 @@   Source-Repository this-  Tag:         0.6+  Tag:         0.7   Type:        darcs   Location:    http://code.haskell.org/synthesizer/core/ @@ -58,9 +58,10 @@  Library   Build-Depends:-    sample-frame-np >=0.0.2 && <0.1,+    sample-frame-np >=0.0.4 && <0.1,     sox >=0.1 && <0.3,     transformers >=0.2 && <0.4,+    non-empty >=0.2 && <0.3,     event-list >=0.1 && <0.2,     non-negative >=0.1 && <0.2,     explicit-exception >=0.1.6 && <0.2,@@ -76,11 +77,11 @@     storable-record >=0.0.1 && <0.1,     storable-tuple >=0.0.1 && <0.1,     QuickCheck >=1 && <3,-    array >=0.1 && <0.5,+    array >=0.1 && <0.6,     containers >=0.1 && <0.6,     random >=1.0 && <2.0,-    process >=1.0 && <1.2,-    base >= 4 && <6+    process >=1.0 && <1.3,+    base >= 4 && <5    If impl(ghc>=7.0) -- also warns about NumericPrelude import:  -fwarn-missing-import-lists@@ -106,6 +107,7 @@     Synthesizer.Basic.Wave     Synthesizer.Basic.WaveSmoothed     Synthesizer.Interpolation+    Synthesizer.Interpolation.Core     Synthesizer.Interpolation.Class     Synthesizer.Interpolation.Module     Synthesizer.Interpolation.Custom@@ -178,6 +180,7 @@     Synthesizer.State.Signal     Synthesizer.State.ToneModulation     Synthesizer.Causal.Process+    Synthesizer.Causal.Class     Synthesizer.Causal.Arrow     Synthesizer.Causal.Analysis     Synthesizer.Causal.Cut@@ -315,7 +318,7 @@   If flag(splitBase)     Build-Depends:       old-time >= 1.0 && < 1.2,-      directory >= 1.0 && < 1.2+      directory >= 1.0 && < 1.3  Executable speedtest-simple   If !flag(buildProfilers)