packages feed

synthesizer-core 0.7.0.2 → 0.7.1

raw patch · 13 files changed

+443/−73 lines, 13 filesdep ~deepseqdep ~filepathdep ~non-empty

Dependency ranges changed: deepseq, filepath, non-empty, transformers

Files

private/Synthesizer/Basic/NumberTheory.hs view
@@ -133,17 +133,33 @@   +multiplicativeGenerator :: Integer -> Integer+multiplicativeGenerator = multiplicativeGeneratorDivisors+ {- | Argument must be a prime. Usage of Set for efficient filtering of candidates seems to be overkill, since the multiplicative generator seems to be small in most cases, i.e. 2 or 3.++Smallest multiplicative generators for primes:+http://oeis.org/A001918++Especially large generators:+$ filter ((>31) . snd) $ map (\n -> (n, multiplicativeGenerator n)) $ tail NumberTheory.primes+[(36721,37),(48889,34),(51361,37),(55441,38),(63361,37),(64609,35),(71761,44),(88321,34),(92401,34),(93481,35),(95471,43),(97441,37),(104711,43),(110881,69)++$ filter ((>63) . snd) $ map (\n -> (n, multiplicativeGenerator n)) $ tail NumberTheory.primes+[(110881,69),(760321,73)++A solution with medium complexity+could at least observe the least 64 numbers using a Word64. -}-multiplicativeGenerator :: Integer -> Integer-multiplicativeGenerator p =+multiplicativeGeneratorSet :: Integer -> Integer+multiplicativeGeneratorSet p =    let search candidates =           case Set.minView candidates of-             Nothing -> error $ show p ++ " is not an odd prime"+             Nothing -> error $ show p ++ " is not a prime"              Just (x,rest) ->                 case orbitSet $ orbit p x of                    new ->@@ -151,9 +167,13 @@                       if new == Set.fromList [1..p-1]                         then x                         else search (Set.difference rest new)-   in  search (Set.fromList [2..p-1])+   in  search $ Set.fromList [1..p-1] +multiplicativeGeneratorDivisors :: Integer -> Integer+multiplicativeGeneratorDivisors p =+   head $ primitiveRootsOfUnity p (Order $ p-1) + newtype Order = Order {getOrder :: Integer}    deriving (Show, Eq, Ord) @@ -205,6 +225,15 @@    primitiveRootsOfUnityPower  {-+First check, that element x is a root of unity.+If x is not primitive,+this means there is a non-maximal exponent y with x^y=1.+This y must be a divisor of order.+Thus it is enough to check all possibilities of order/q as exponents,+where q is a prime divisor of order.+Computing a single power is much faster+than computing all powers up to the maximum power.+ Verifying that a ring has no primitive root of the wanted order takes a long time if we do it by exhaustive search. In the case of a=Integer we could first check,@@ -502,7 +531,8 @@  The list is not exhaustive but computes suggestions quickly.-The first found modulus seems to be smallest one that exist.+The first found modulus is often the smallest one that exist,+but not always (smallest counter-example: Order 80). However, the first modulus is not the smallest one among the ones that only have the wanted primitive root, but where 'order' is not necessarily a unit.@@ -590,33 +620,57 @@ OEIS:A003586 -} numbers3Smooth :: [Integer]-numbers3Smooth =+numbers3Smooth = numbers3SmoothCorec++numbers3SmoothCorec :: [Integer]+numbers3SmoothCorec = mergePowers 3 $ iterate (2*) 1++mergePowers :: (Ord a, Ring.C a) => a -> [a] -> [a]+mergePowers _ [] = []+mergePowers p (x:xs) =+   let ys = x : ListHT.mergeBy (<=) xs (map (p*) ys)+   in  ys++numbers3SmoothFoldr :: [Integer]+numbers3SmoothFoldr =    foldr       (\(x0:x1:xs) ys -> x0 : x1 : ListHT.mergeBy (<=) xs ys)-      (error "numbers3Smooth: infinite list should not have an end") $+      (error "numbers3SmoothFoldr: infinite list should not have an end") $    iterate (map (3*)) $    iterate (2*) 1 -numbers3SmoothAlt :: [Integer]-numbers3SmoothAlt =+numbers3SmoothSet :: [Integer]+numbers3SmoothSet =    unfoldr       (fmap (\(m,rest) -> (m, Set.union rest $ Set.fromAscList [2*m,3*m])) .        Set.minView) $    Set.singleton 1 + {-+Hamming sequence OEIS:A051037 -} numbers5Smooth :: [Integer]-numbers5Smooth =+numbers5Smooth = numbers5SmoothCorec++numbers5SmoothCorec :: [Integer]+numbers5SmoothCorec =+   if False+     then -- causes permanent storage of numbers3SmoothCorec+          mergePowers 5 $ numbers3SmoothCorec+     else mergePowers 5 $ mergePowers 3 $ iterate (2*) 1++numbers5SmoothFoldr :: [Integer]+numbers5SmoothFoldr =    foldr       (\(x0:x1:x2:xs) ys -> x0 : x1 : x2 : ListHT.mergeBy (<=) xs ys)-      (error "numbers5Smooth: infinite list should not have an end") $+      (error "numbers5SmoothFoldr: infinite list should not have an end") $    iterate (map (5*)) $-   numbers3Smooth+   numbers3SmoothFoldr -numbers5SmoothAlt :: [Integer]-numbers5SmoothAlt =+numbers5SmoothSet :: [Integer]+numbers5SmoothSet =    unfoldr       (fmap (\(m,rest) -> (m, Set.union rest $ Set.fromAscList [2*m,3*m,5*m])) .        Set.minView) $@@ -631,6 +685,16 @@    scanl (\m d -> shiftR m d .|. m) (n-1) $    iterate (2*) 1 +{- |+It's not awfully efficient, but ok for our uses.+-}+ceilingPower :: (Integral.C a, Ord a) => a -> a -> a+ceilingPower base n = base ^ fromIntegral (ceilingLog base n)++ceilingLog :: (Integral.C a, Ord a) => a -> a -> Int+ceilingLog base =+   length . takeWhile (>0) . iterate (flip div base) . subtract 1+ divideByMaximumPower ::    (Integral.C a, ZeroTestable.C a) => a -> a -> a divideByMaximumPower b n =@@ -671,6 +735,13 @@    divideByMaximumPower 3 .    divideByMaximumPower 2 ++ceiling3Smooth :: Integer -> Integer+ceiling3Smooth = ceiling3SmoothTrace++ceiling5Smooth :: Integer -> Integer+ceiling5Smooth = ceiling5SmoothTrace+ {- | Compute the smallest composite of 2 and 3 that is as least as large as the input. This can be interpreted as solving an integer linear programming problem with@@ -678,31 +749,85 @@ over the domain {(a,b) : a>=0, b>=0, a * log 2 + b * log 3 >= log n} -} {--Problem: We cannot just start with the ceilingPowerOfTwo-and then multiply with 3/4 until we fall below n,-since the 3/4 decreases too fast.-27/32 is closer to one,-and higher powers of 3 and 2 in the ratio make the ratio even closer to one.+This implementation looks stupid,+but it is drastically faster for large numbers than ceiling3SmoothNaive.+The reason is that the smooth numbers are logarithmically equally distributed.+That is, from @n@ to the next smooth number+it may be only 1% deviation from @n@,+but for huge @n@ the absolute difference @0.01*n@ is still huge.++@ceiling3Smooth (10^400+1)@ can be computed in about 0.1 seconds.+(Surprisingly, @ceiling3Smooth (10^500+1)@ needs almost 30 seconds.) -}-ceiling3Smooth :: Integer -> Integer-ceiling3Smooth n =+ceiling3SmoothScan :: Integer -> Integer+ceiling3SmoothScan n =    head $ dropWhile (<n) numbers3Smooth -ceiling5Smooth :: Integer -> Integer-ceiling5Smooth n =+ceiling5SmoothScan :: Integer -> Integer+ceiling5SmoothScan n =    head $ dropWhile (<n) numbers5Smooth  ceiling3SmoothNaive :: Integer -> Integer ceiling3SmoothNaive =-   head .-   dropWhile (not . is3Smooth) .-   iterate (1+)+   head . dropWhile (not . is3Smooth) . iterate (1+)  ceiling5SmoothNaive :: Integer -> Integer ceiling5SmoothNaive =-   head .-   dropWhile (not . is5Smooth) .-   iterate (1+)+   head . dropWhile (not . is5Smooth) . iterate (1+)+++{-+Problem: We cannot just start with the ceilingPowerOfTwo+and then multiply with 3/4 until we fall below n,+since the 3/4 decreases too fast.+27/32 is closer to one,+and higher powers of 3 and 2 in the ratio make the ratio even closer to one.++This implementation is different:+It always moves and tests above @n@.+For every power of 3 it computes the least power of 2,+such that their product is above @n@.+-}+ceiling3SmoothTrace :: Integer -> Integer+ceiling3SmoothTrace n =+   minimum $ ceilingSmoothsTrace 2 3 n $ ceilingPowerOfTwo n++{-+We must be careful not to skip combinations that are optimal.++E.g.:+> ceiling5SmoothTraceWrong (10^70+1)+10002658207445093206727527411583349735126415100956607165326185795158016+> ceiling5Smooth (10^70+1)+10001329015408448808646079907338649600000000000000000000000000000000000+-}+ceiling5SmoothTraceWrong :: Integer -> Integer+ceiling5SmoothTraceWrong n =+   minimum $ map (minimum . ceilingSmoothsTrace 3 5 n) $+   ceilingSmoothsTrace 2 3 n $ ceilingPowerOfTwo n++{-+For every reasonable pair of powers of 3 and 5+it computes the least power of 2,+such that their product is above @n@.+-}+ceiling5SmoothTrace :: Integer -> Integer+ceiling5SmoothTrace n =+   minimum $ map (minimum . ceilingSmoothsTrace 2 5 n) $+   ceilingSmoothsTrace 2 3 n $ ceilingPowerOfTwo n++{- |+@ceilingSmoothsTrace a b n m@+replaces successively @a@ factors in @m@ by @b@ factors+while keeping the product above @n@.+-}+ceilingSmoothsTrace :: Integer -> Integer -> Integer -> Integer -> [Integer]+ceilingSmoothsTrace a b n =+   let divMany k =+          case divMod k a of+             (q,r) -> if r==0 && q>=n then divMany q else k+       go m  =  m : if mod m a == 0 then go $ divMany $ m*b else []+   in  go   {- |
src/Synthesizer/Causal/Analysis.hs view
@@ -10,6 +10,8 @@  import Control.Arrow (second, (^<<), (<<^), ) +import qualified Data.Map as Map+ -- import qualified Prelude as P import NumericPrelude.Base import NumericPrelude.Numeric@@ -32,3 +34,19 @@        second Integration.run <<^        (\((threshold,xi),cum) -> (threshold,xi-cum)))       (Causal.consInit zero)+++{-+Abuse (Map a ()) as (Set a),+because in GHC-7.4.2 there is no Set.elemAt function.+-}+movingMedian :: (Ord a) => Int -> Causal.T a a+movingMedian n =+   Causal.mapAccumL+      (\new (k,queue,oldSet) ->+         let set =+               Map.insert (new,k) () $+               maybe id (\old -> Map.delete (old,k)) (Map.lookup k queue) oldSet+         in  (fst $ fst $ Map.elemAt (div (Map.size set) 2) set,+              (mod (k+1) n, Map.insert k new queue, set)))+      (0, Map.empty, Map.empty)
src/Synthesizer/Causal/Class.hs view
@@ -1,10 +1,14 @@ {-# LANGUAGE TypeFamilies #-}-module Synthesizer.Causal.Class where+module Synthesizer.Causal.Class (+   module Synthesizer.Causal.Class,+   Util.chainControlled,+   Util.replicateControlled,+   ) where -import qualified Control.Category as Cat-import Control.Arrow (Arrow, arr, (<<<), (>>>), (&&&), )+import qualified Synthesizer.Causal.Utility as Util -import Data.Function.HT (nest, )+import qualified Control.Category as Cat+import Control.Arrow (Arrow, arr, (<<<), (&&&), )   class (Arrow process, ProcessOf (SignalOf process) ~ process) => C process where@@ -32,6 +36,22 @@ applySnd proc sig =    proc <<< feedSnd sig +applyConst ::+   (C process) => process a b -> a -> SignalOf process b+applyConst proc a =+   toSignal (proc <<< arr (\() -> a))++applyConstFst ::+   (Arrow process) => process (a,b) c -> a -> process b c+applyConstFst proc a =+   proc <<< feedConstFst a++applyConstSnd ::+   (Arrow process) => process (a,b) c -> b -> process a c+applyConstSnd proc a =+   proc <<< feedConstSnd a++ feedFst :: (C process) => SignalOf process a -> process b (a,b) feedFst sig =    fromSignal sig &&& Cat.id@@ -40,33 +60,18 @@ 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.--}+{-# INLINE feedConstFst #-}+feedConstFst :: (Arrow process) => a -> process b (a,b)+feedConstFst a = arr (\b -> (a,b))++{-# INLINE feedConstSnd #-}+feedConstSnd :: (Arrow process) => a -> process b (b,a)+feedConstSnd a = arr (\b -> (b,a))++ ($*) ::    (C process) =>    process a b -> SignalOf process a -> SignalOf process b ($*) = apply ($<) = applyFst ($>) = applySnd----{-# 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/Process.hs view
@@ -20,6 +20,7 @@    fromStateMaybe,    fromState,    fromSimpleModifier,+   fromInitializedModifier,     id,    map,@@ -56,6 +57,7 @@    feedConstSnd,     crochetL,+   mapAccumL,    scanL,    scanL1,    zipWith,@@ -73,6 +75,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.Causal.Utility as ArrowUtil  import qualified Synthesizer.Plain.Modifier as Modifier @@ -86,11 +89,18 @@           (Arrow(..), returnA, (<<<), (>>>), (^>>), ArrowLoop(..),            Kleisli(Kleisli), runKleisli, ) import Control.Monad.Trans.State-          (State, state, runState,+          (State, runState,            StateT(StateT), runStateT, ) import Control.Monad (liftM, )+import Control.Applicative (Applicative, liftA2, pure, (<*>), )  import Data.Tuple.HT (mapSnd, )++import qualified Algebra.Field as Field+import qualified Algebra.Ring as Ring+import qualified Algebra.Additive as Additive++import qualified Prelude as P import Prelude hiding (id, map, zipWith, )  @@ -118,7 +128,13 @@ fromSimpleModifier (Modifier.Simple s f) =    fromState (uncurry f) s +{-# INLINE fromInitializedModifier #-}+fromInitializedModifier ::+   Modifier.Initialized s init ctrl a b -> init -> T (ctrl,a) b+fromInitializedModifier (Modifier.Initialized initF f) initS =+   fromState (uncurry f) (initF initS) + {- It's almost a Kleisli Arrow, but the hidden type of the state disturbs.@@ -166,6 +182,47 @@    fromSignal sig = const () ^>> feed sig  +instance Functor (T a) where+   fmap = ArrowUtil.map++instance Applicative (T a) where+   pure = ArrowUtil.pure+   (<*>) = ArrowUtil.apply+++instance (Additive.C b) => Additive.C (T a b) where+   zero = pure Additive.zero+   negate = fmap Additive.negate+   (+) = liftA2 (Additive.+)+   (-) = liftA2 (Additive.-)++instance (Ring.C b) => Ring.C (T a b) where+   one = pure Ring.one+   (*) = liftA2 (Ring.*)+   x^n = fmap (Ring.^ n) x+   fromInteger = pure . Ring.fromInteger++instance (Field.C b) => Field.C (T a b) where+   (/) = liftA2 (Field./)+   recip = fmap Field.recip+   fromRational' = pure . Field.fromRational'+++instance (P.Num b) => P.Num (T a b) where+   (+) = liftA2 (P.+)+   (-) = liftA2 (P.-)+   (*) = liftA2 (P.*)+   negate = fmap P.negate+   abs = fmap P.abs+   signum = fmap P.signum+   fromInteger = pure . P.fromInteger++instance (P.Fractional b) => P.Fractional (T a b) where+   (/) = liftA2 (P./)+   fromRational = pure . P.fromRational+++ {-# INLINE extendStateFstT #-} extendStateFstT :: Monad m => StateT s m a -> StateT (t,s) m a extendStateFstT st =@@ -377,15 +434,18 @@ crochetL :: (x -> acc -> Maybe (y, acc)) -> acc -> T x y crochetL f s = fromStateMaybe (StateT . f) s +{-# INLINE mapAccumL #-}+mapAccumL :: (x -> acc -> (y, acc)) -> acc -> T x y+mapAccumL next = crochetL (\a s -> Just $ next a s)+ {-# INLINE scanL #-} scanL :: (acc -> x -> acc) -> acc -> T x acc-scanL f start =-   fromState (\x -> state $ \acc -> (acc, f acc x)) start+scanL f = mapAccumL (\x acc -> (acc, f acc x))  {-# INLINE scanL1 #-} scanL1 :: (x -> x -> x) -> T x x scanL1 f =-   crochetL (\x acc -> Just (x, Just $ maybe x (flip f x) acc)) Nothing+   mapAccumL (\x acc -> (x, Just $ maybe x (flip f x) acc)) Nothing  {-# INLINE zipWith #-} zipWith :: (SigG.Read sig a) =>@@ -399,8 +459,7 @@ -} {-# INLINE consInit #-} consInit :: x -> T x x-consInit =-   crochetL (\x acc -> Just (acc, x))+consInit = mapAccumL (\x acc -> (acc, x))
+ src/Synthesizer/Causal/Utility.hs view
@@ -0,0 +1,37 @@+{- |+Utility functions based only on 'Arrow' class.+-}+module Synthesizer.Causal.Utility where++import Control.Arrow (Arrow, arr, (>>>), (&&&), (^<<), )++import Data.Function.HT (nest, )+++map :: (Arrow arrow) => (b -> c) -> arrow a b -> arrow a c+map = (^<<)++pure :: (Arrow arrow) => b -> arrow a b+pure x = arr (const x)++apply :: (Arrow arrow) => arrow a (b -> c) -> arrow a b -> arrow a c+apply f x = uncurry ($) ^<< f&&&x+++{-# INLINE chainControlled #-}+chainControlled ::+   (Arrow arrow) =>+   [arrow (c,x) x] -> arrow (c,x) x+chainControlled =+   foldr+      (\p rest -> arr fst &&& p  >>>  rest)+      (arr snd)++{-# INLINE replicateControlled #-}+replicateControlled ::+   (Arrow arrow) =>+   Int -> arrow (c,x) x -> arrow (c,x) x+replicateControlled n p =+   nest n+      (arr fst &&& p  >>> )+      (arr snd)
src/Synthesizer/CausalIO/Process.hs view
@@ -14,7 +14,7 @@    T(Cons),    fromCausal,    mapAccum,-   traverse,+   Synthesizer.CausalIO.Process.traverse,    runCont,    runStorableChunkyCont,    zip,
src/Synthesizer/Generic/Filter/Recursive/Comb.hs view
@@ -11,12 +11,18 @@ Comb filters, useful for emphasis of tones with harmonics and for repeated echos. -}-module Synthesizer.Generic.Filter.Recursive.Comb where+module Synthesizer.Generic.Filter.Recursive.Comb (+   karplusStrong,+   run,+   runMulti,+   runProc,+   ) where  import qualified Synthesizer.Generic.Filter.NonRecursive as Filt import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1  import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.Generic.Cut as CutG  import qualified Algebra.Module                as Module import qualified Algebra.Ring                  as Ring@@ -57,7 +63,7 @@ Chunk size must be smaller than all of the delay times. -} {-# INLINE runMulti #-}-runMulti :: (Ring.C t, Module.C t y, SigG.Write sig y) =>+runMulti :: (Module.C t y, SigG.Write sig y) =>    [Int] -> t -> sig y -> sig y runMulti times gain x =     let y = foldl@@ -71,3 +77,23 @@ runProc :: (Additive.C y, SigG.Write sig y) =>    Int -> (sig y -> sig y) -> sig y -> sig y runProc = SigG.delayLoopOverlap+++{- |+Alternative to 'run' that uses 'CutG.splitAt' at the beginning+instead of adding a zero signal.+-}+_run :: (Module.C t y, SigG.Transform sig y) => t -> Int -> sig y -> sig y+_run gain delay xs =+   let (xs0,xs1) = CutG.splitAt delay $ Filt.amplifyVector (1-gain) xs+       ys = CutG.append xs0 $ SigG.zipWith (+) xs1 $ Filt.amplifyVector gain ys+   in  ys++_runInf :: (Module.C t y, SigG.Write sig y) => t -> Int -> sig y -> sig y+_runInf gain delay xs =+   let (xs0,xs1) =+          CutG.splitAt delay $+          Filt.amplifyVector (1-gain) xs `CutG.append`+             SigG.repeat (SigG.LazySize delay) zero+       ys = CutG.append xs0 $ SigG.zipWith (+) xs1 $ Filt.amplifyVector gain ys+   in  ys
src/Synthesizer/Generic/Signal.hs view
@@ -873,6 +873,9 @@       (append xt . repeat size . snd)       (viewR xt) +snoc :: (Transform sig y) => sig y -> y -> sig y+snoc xs x = append xs $ singleton x+  -- comonadic 'bind' -- only non-empty suffixes are processed
src/Synthesizer/Plain/Effect/Fly.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE FlexibleContexts #-} module Synthesizer.Plain.Effect.Fly where  import qualified Synthesizer.Causal.Spatial as Spatial
src/Synthesizer/Plain/Filter/Recursive/FirstOrder.hs view
@@ -230,3 +230,10 @@    Causal.T (Parameter a, v) (Result v) causal =    Causal.fromSimpleModifier modifier++{-# INLINE causalInit #-}+causalInit ::+   (Module.C a v) =>+   v -> Causal.T (Parameter a, v) (Result v)+causalInit =+   Causal.fromInitializedModifier modifierInit
synthesizer-core.cabal view
@@ -1,5 +1,5 @@ Name:           synthesizer-core-Version:        0.7.0.2+Version:        0.7.1 License:        GPL License-File:   LICENSE Author:         Henning Thielemann <haskell@henning-thielemann.de>@@ -37,7 +37,7 @@   Source-Repository this-  Tag:         0.7.0.2+  Tag:         0.7.1   Type:        darcs   Location:    http://code.haskell.org/synthesizer/core/ @@ -49,7 +49,7 @@   Build-Depends:     sample-frame-np >=0.0.4 && <0.1,     sox >=0.1 && <0.3,-    transformers >=0.2 && <0.4,+    transformers >=0.2 && <0.5,     non-empty >=0.2 && <0.3,     event-list >=0.1 && <0.2,     non-negative >=0.1 && <0.2,@@ -57,11 +57,11 @@     numeric-prelude >=0.4 && <0.5,     numeric-quest >=0.1 && <0.3,     utility-ht >=0.0.5 && <0.1,-    filepath >=1.1 && <1.4,+    filepath >=1.1 && <1.5,     stream-fusion >=0.1.2 && <0.2,     bytestring >=0.9 && <0.11,     binary >=0.1 && <1,-    deepseq >=1.1 && <1.4,+    deepseq >=1.1 && <1.5,     storablevector >=0.2.5 && <0.3,     storable-record >=0.0.1 && <0.1,     storable-tuple >=0.0.1 && <0.1,@@ -172,6 +172,7 @@     Synthesizer.Causal.Process     Synthesizer.Causal.Class     Synthesizer.Causal.Arrow+    Synthesizer.Causal.Utility     Synthesizer.Causal.Analysis     Synthesizer.Causal.Cut     Synthesizer.Causal.Displacement@@ -226,7 +227,7 @@     storablevector,     storable-tuple,     event-list,-    non-empty,+    non-empty >=0.2.1 && <0.3,     non-negative,     utility-ht,     numeric-prelude,
test/Test/Sound/Synthesizer/Basic/NumberTheory.hs view
@@ -4,8 +4,11 @@ import Synthesizer.Basic.NumberTheory (Order(Order), ) import qualified Synthesizer.Basic.NumberTheory as NT import qualified Data.Set as Set+import qualified Data.Bits as Bit +import qualified Test.QuickCheck as QC import Test.QuickCheck (Testable, Arbitrary, arbitrary, quickCheck, )+import Test.Utility (equalList, )  import qualified Algebra.Absolute              as Absolute @@ -28,13 +31,44 @@    arbitrary = fmap (Positive . (1+) . abs) arbitrary  +newtype Prime = Prime Integer+   deriving (Show)++instance Arbitrary Prime where+   arbitrary = do+      n <- fmap ((2+) . flip mod 10000) arbitrary+      if NT.isPrime n+        then return $ Prime n+        else arbitrary+++newtype Big = Big Integer+   deriving (Show)++instance Arbitrary Big where+   arbitrary = do+      digits <- arbitrary+      -- negative digits yield numbers close to the maximum+      let maxi = 10^50+      return $ Big $+         foldl (\acc d -> mod (Bit.shiftL acc 16 + d) maxi) 0 digits++ simple ::    (Testable t, Arbitrary (wrapper Integer), Show (wrapper Integer)) =>    (wrapper Integer -> t) -> IO () simple = quickCheck +singleArgs :: QC.Args+singleArgs = QC.stdArgs {QC.maxSuccess = 1}+ tests :: [(String, IO ())] tests =+   ("multiplicativeGenerator set vs. divisor",+      quickCheck $ \(Prime n) ->+         NT.multiplicativeGeneratorSet n+         ==+         NT.multiplicativeGeneratorDivisors n) :    ("primitiveRootsOfUnity naive vs. power",       simple $ \(Cardinal m) order ->          NT.primitiveRootsOfUnityNaive m order@@ -64,8 +98,12 @@          in  g (Order $ lcm a b) == lcm (g ao) (g bo)) :    ("ringsWithPrimitiveRootsOfUnityAndUnits: minimal modulus",       quickCheck $ \order@(Order expo) ->+         {-+         Often equality holds, but not always.+         Smallest counter-example: expo=80.+         -}          (head $ NT.ringsWithPrimitiveRootOfUnityAndUnit order)-         ==+         >=          (head $ NT.ringsWithPrimitiveRootsOfUnityAndUnitsNaive             [order] [expo])) :    ("combine two rings with primitive roots of certain orders",@@ -116,4 +154,38 @@              (NT.ordersOfPrimitiveRootsOfUnityInteger !! (n-1)))          ==          NT.ordersOfRootsOfUnityInteger !! (n-1) !! (k-1)) :+   ("numbers3Smooth",+      QC.quickCheckWith singleArgs $ equalList $ map (take 10000) $+         [NT.numbers3SmoothCorec, NT.numbers3SmoothFoldr, NT.numbers3SmoothSet]) :+   ("numbers5Smooth",+      QC.quickCheckWith singleArgs $ equalList $ map (take 10000) $+         [NT.numbers5SmoothCorec, NT.numbers5SmoothFoldr, NT.numbers5SmoothSet]) :+   ("ceiling3Smooth vs. is3Smooth",+      quickCheck $ \(Positive n) -> NT.is3Smooth $ NT.ceiling3Smooth n) :+   ("ceiling5Smooth vs. is5Smooth",+      quickCheck $ \(Positive n) -> NT.is5Smooth $ NT.ceiling5Smooth n) :+   ("ceiling3Smooth vs. numbers3Smooth",+      simple $ \(Positive k) ->+         let (n0:n1:_) = drop (fromInteger $ mod k 500) NT.numbers3Smooth+         in  NT.ceiling3Smooth n0 == n0+             &&+             NT.ceiling3Smooth (n0+1) == n1) :+   ("ceiling5Smooth vs. numbers5Smooth",+      simple $ \(Positive k) ->+         let (n0:n1:_) = drop (fromInteger $ mod k 500) NT.numbers5Smooth+         in  NT.ceiling5Smooth n0 == n0+             &&+             NT.ceiling5Smooth (n0+1) == n1) :+   ("ceiling3Smooth naive vs. trace",+      quickCheck $ \(Positive n) ->+         NT.ceiling3SmoothNaive n == NT.ceiling3SmoothTrace n) :+   ("ceiling5Smooth naive vs. trace",+      quickCheck $ \(Positive n) ->+         NT.ceiling5SmoothNaive n == NT.ceiling5SmoothTrace n) :+   ("ceiling3Smooth scan vs. trace",+      quickCheck $ \(Big n) ->+         NT.ceiling3SmoothScan n == NT.ceiling3SmoothTrace n) :+   ("ceiling5Smooth scan vs. trace",+      quickCheck $ \(Big n) ->+         NT.ceiling5SmoothScan n == NT.ceiling5SmoothTrace n) :    []
test/Test/Sound/Synthesizer/Causal/Analysis.hs view
@@ -6,7 +6,10 @@  import Control.Arrow ((<<<), ) +import qualified Data.NonEmpty.Class as NonEmptyC+import qualified Data.NonEmpty as NonEmpty import qualified Data.List.Match as Match+import qualified Data.List as List  import Test.QuickCheck (quickCheck, ) @@ -15,6 +18,13 @@ import Prelude ()  +movingMedian :: (Ord a) => Int -> [a] -> [a]+movingMedian n =+   map (\xs -> List.sort xs !! div (length xs) 2) . NonEmpty.tail .+   NonEmptyC.zipWith (drop . max 0) (NonEmptyC.iterate succ (negate n)) .+   NonEmpty.inits++ tests :: [(String, IO ())] tests =    ("deltaSigmaModulation",@@ -29,4 +39,10 @@          Causal.apply             (AnaC.deltaSigmaModulationPositive <<<              Causal.feedConstFst threshold) (xs::[Rational])) :+   ("movingMedian",+      quickCheck $ \n0 xs ->+         let n = mod n0 20 + 1+         in  movingMedian n xs+             ==+             Causal.apply (AnaC.movingMedian n) (xs::[Char])) :    []