diff --git a/private/Synthesizer/Basic/NumberTheory.hs b/private/Synthesizer/Basic/NumberTheory.hs --- a/private/Synthesizer/Basic/NumberTheory.hs +++ b/private/Synthesizer/Basic/NumberTheory.hs @@ -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 ( Integer -ceiling5Smooth n = +ceiling5SmoothScan :: Integer -> Integer +ceiling5SmoothScan n = head $ dropWhile ( 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 {- | diff --git a/src/Synthesizer/Causal/Analysis.hs b/src/Synthesizer/Causal/Analysis.hs --- a/src/Synthesizer/Causal/Analysis.hs +++ b/src/Synthesizer/Causal/Analysis.hs @@ -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) diff --git a/src/Synthesizer/Causal/Class.hs b/src/Synthesizer/Causal/Class.hs --- a/src/Synthesizer/Causal/Class.hs +++ b/src/Synthesizer/Causal/Class.hs @@ -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) diff --git a/src/Synthesizer/Causal/Process.hs b/src/Synthesizer/Causal/Process.hs --- a/src/Synthesizer/Causal/Process.hs +++ b/src/Synthesizer/Causal/Process.hs @@ -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)) diff --git a/src/Synthesizer/Causal/Utility.hs b/src/Synthesizer/Causal/Utility.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Causal/Utility.hs @@ -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) diff --git a/src/Synthesizer/CausalIO/Process.hs b/src/Synthesizer/CausalIO/Process.hs --- a/src/Synthesizer/CausalIO/Process.hs +++ b/src/Synthesizer/CausalIO/Process.hs @@ -14,7 +14,7 @@ T(Cons), fromCausal, mapAccum, - traverse, + Synthesizer.CausalIO.Process.traverse, runCont, runStorableChunkyCont, zip, diff --git a/src/Synthesizer/Generic/Filter/Recursive/Comb.hs b/src/Synthesizer/Generic/Filter/Recursive/Comb.hs --- a/src/Synthesizer/Generic/Filter/Recursive/Comb.hs +++ b/src/Synthesizer/Generic/Filter/Recursive/Comb.hs @@ -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 diff --git a/src/Synthesizer/Generic/Signal.hs b/src/Synthesizer/Generic/Signal.hs --- a/src/Synthesizer/Generic/Signal.hs +++ b/src/Synthesizer/Generic/Signal.hs @@ -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 diff --git a/src/Synthesizer/Plain/Effect/Fly.hs b/src/Synthesizer/Plain/Effect/Fly.hs --- a/src/Synthesizer/Plain/Effect/Fly.hs +++ b/src/Synthesizer/Plain/Effect/Fly.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleContexts #-} module Synthesizer.Plain.Effect.Fly where import qualified Synthesizer.Causal.Spatial as Spatial diff --git a/src/Synthesizer/Plain/Filter/Recursive/FirstOrder.hs b/src/Synthesizer/Plain/Filter/Recursive/FirstOrder.hs --- a/src/Synthesizer/Plain/Filter/Recursive/FirstOrder.hs +++ b/src/Synthesizer/Plain/Filter/Recursive/FirstOrder.hs @@ -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 diff --git a/synthesizer-core.cabal b/synthesizer-core.cabal --- a/synthesizer-core.cabal +++ b/synthesizer-core.cabal @@ -1,5 +1,5 @@ Name: synthesizer-core -Version: 0.7.0.2 +Version: 0.7.1 License: GPL License-File: LICENSE Author: Henning Thielemann @@ -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, diff --git a/test/Test/Sound/Synthesizer/Basic/NumberTheory.hs b/test/Test/Sound/Synthesizer/Basic/NumberTheory.hs --- a/test/Test/Sound/Synthesizer/Basic/NumberTheory.hs +++ b/test/Test/Sound/Synthesizer/Basic/NumberTheory.hs @@ -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) : [] diff --git a/test/Test/Sound/Synthesizer/Causal/Analysis.hs b/test/Test/Sound/Synthesizer/Causal/Analysis.hs --- a/test/Test/Sound/Synthesizer/Causal/Analysis.hs +++ b/test/Test/Sound/Synthesizer/Causal/Analysis.hs @@ -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])) : []