synthesizer-llvm 0.8.1.2 → 0.8.2
raw patch · 37 files changed
+1274/−635 lines, 37 filesdep +semigroupsdep +shell-utilitydep ~containersdep ~llvm-extradep ~optparse-applicative
Dependencies added: semigroups, shell-utility
Dependency ranges changed: containers, llvm-extra, optparse-applicative, utility-ht
Files
- alsa/Synthesizer/LLVM/Server/Packed/Run.hs +12/−12
- example/Synthesizer/LLVM/Test.hs +20/−22
- render/Synthesizer/LLVM/Server/Render.hs +13/−18
- server/Synthesizer/LLVM/Server/CausalPacked/Arrange.hs +1/−1
- server/Synthesizer/LLVM/Server/OptionCommon.hs +2/−7
- src/Synthesizer/LLVM/Causal/Process.hs +7/−6
- src/Synthesizer/LLVM/Causal/ProcessPrivate.hs +13/−1
- src/Synthesizer/LLVM/Causal/ProcessValue.hs +10/−2
- src/Synthesizer/LLVM/CausalParameterized/Functional.hs +66/−1
- src/Synthesizer/LLVM/CausalParameterized/Helix.hs +20/−0
- src/Synthesizer/LLVM/CausalParameterized/Process.hs +30/−8
- src/Synthesizer/LLVM/ConstantPiece.hs +5/−9
- src/Synthesizer/LLVM/Filter/Allpass.hs +9/−6
- src/Synthesizer/LLVM/Filter/FirstOrder.hs +135/−28
- src/Synthesizer/LLVM/Filter/SecondOrder.hs +9/−9
- src/Synthesizer/LLVM/Filter/Universal.hs +2/−2
- src/Synthesizer/LLVM/ForeignPtr.hs +2/−2
- src/Synthesizer/LLVM/Frame/Stereo.hs +5/−0
- src/Synthesizer/LLVM/Parameter.hs +88/−2
- src/Synthesizer/LLVM/Parameterized/Signal.hs +7/−54
- src/Synthesizer/LLVM/Parameterized/SignalPrivate.hs +53/−7
- src/Synthesizer/LLVM/Server/CausalPacked/Instrument.hs +36/−44
- src/Synthesizer/LLVM/Server/Packed/Instrument.hs +93/−90
- src/Synthesizer/LLVM/Server/Parameter.hs +106/−0
- src/Synthesizer/LLVM/Simple/Signal.hs +55/−5
- src/Synthesizer/LLVM/Simple/SignalPrivate.hs +62/−2
- src/Synthesizer/LLVM/Storable/ChunkIterator.hs +1/−1
- src/Synthesizer/LLVM/Storable/Signal.hs +3/−3
- src/Synthesizer/LLVM/Storable/Vector.hs +1/−1
- src/Synthesizer/LLVM/Wave.hs +4/−4
- synthesizer-llvm.cabal +36/−24
- testsuite/Test/Synthesizer/LLVM/Filter.hs +92/−94
- testsuite/Test/Synthesizer/LLVM/Generator.hs +64/−0
- testsuite/Test/Synthesizer/LLVM/Helix.hs +27/−28
- testsuite/Test/Synthesizer/LLVM/Packed.hs +84/−80
- testsuite/Test/Synthesizer/LLVM/RingBufferForward.hs +62/−57
- testsuite/Test/Synthesizer/LLVM/Utility.hs +39/−5
alsa/Synthesizer/LLVM/Server/Packed/Run.hs view
@@ -44,7 +44,7 @@ import qualified System.Path.PartClass as PathClass import qualified System.Path as Path -import Control.Applicative.HT (liftA4, liftA5, liftA6, )+import qualified Control.Applicative.HT as App import Control.Arrow ((<<<), (^<<), arr, ) import Control.Applicative (pure, liftA2, liftA3, (<*>), ) import Control.Monad.Trans.State (evalState, )@@ -257,7 +257,7 @@ fmap (EventListMT.switchBodyL (error "empty controller stream") const) flt = evalState $- liftA6 (\rel -> flt0 (4*rel) rel)+ App.lift6 (\rel -> flt0 (4*rel) rel) (evHead $ PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) (PCS.controllerLinear controllerDetune (0,0.005) 0.001)@@ -273,7 +273,7 @@ (evHead $ PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) pngFM = evalState $- liftA6 (\rel det phs shp -> pngFM0 (4*rel) rel det shp 2 phs)+ App.lift6 (\rel det phs shp -> pngFM0 (4*rel) rel det shp 2 phs) (evHead $ PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) (PCS.controllerLinear controllerDetune (0,0.005) 0.001)@@ -283,7 +283,7 @@ (pure vcsize) (PCS.bendWheelPressure 2 0.04 0.03) sqr = evalState $- liftA6 (\rel -> sqr0 (4*rel) rel)+ App.lift6 (\rel -> sqr0 (4*rel) rel) (evHead $ PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) (PCS.controllerLinear controllerDetune (0,0.005) 0.001)@@ -298,7 +298,7 @@ (pure vcsize) (PCS.bendWheelPressure 2 0.04 0.03) tnc = evalState $- liftA6 (\rel -> tnc0 (4*rel) rel)+ App.lift6 (\rel -> tnc0 (4*rel) rel) (evHead $ PCS.controllerExponential controllerAttack (0.03,0.3) 0.1) (PCS.controllerLinear controllerDetune (0,0.005) 0.001)@@ -344,14 +344,14 @@ <*> (pure vcsize) <*> (PCS.bendWheelPressure 2 0.04 0.03) bel = evalState $- liftA4 (\rel -> bel0 (2*rel) rel)+ App.lift4 (\rel -> bel0 (2*rel) rel) (evHead $ PCS.controllerExponential controllerAttack (0.03,1.0) 0.3) (PCS.controllerLinear controllerDetune (0,0.005) 0.001) (pure vcsize) (PCS.bendWheelPressure 2 0.05 0.02) ben = evalState $- liftA5 (\rel -> ben0 (2*rel) rel)+ App.lift5 (\rel -> ben0 (2*rel) rel) (evHead $ PCS.controllerExponential controllerAttack (0.03,1.0) 0.3) (PCS.controllerLinear controllerTimbre0 (0,1) 0.3)@@ -365,14 +365,14 @@ (PCS.controllerLinear controllerDetune (0,0.01) 0.005) (PCS.bendWheelPressure 2 0.04 0.03) ssh = evalState $- liftA4 ssh0+ App.lift4 ssh0 (evHead $ PCS.controllerExponential controllerAttack (0.02,2) 0.5) (PCS.controllerLinear controllerDetune (0,0.01) 0.005) (PCS.controllerExponential controllerTimbre0 (1/pi,0.001) 0.05) (PCS.bendWheelPressure 2 0.04 0.03) makeArc gen = evalState $- liftA4 gen+ App.lift4 gen (evHead $ PCS.controllerExponential controllerAttack (0.02,2) 0.5) (PCS.controllerLinear controllerDetune (0,0.01) 0.005)@@ -384,7 +384,7 @@ asq = makeArc asq0 atr = makeArc atr0 fms = evalState $- liftA5 fms0+ App.lift5 fms0 (evHead $ PCS.controllerExponential controllerAttack (0.02,2) 0.5) (PCS.controllerLinear controllerDetune (0,0.01) 0.005)@@ -398,7 +398,7 @@ (PCS.controllerExponential controllerTimbre1 (1,1000) 100) (PCS.bendWheelPressure 12 0.8 0) wnp = evalState $- liftA5 wnp0+ App.lift5 wnp0 (evHead $ PCS.controllerExponential controllerAttack (0.02,2) 0.5) (PCS.controllerLinear controllerTimbre0 (0,1) 0.5)@@ -406,7 +406,7 @@ (PCS.controllerExponential controllerTimbre1 (1,1000) 100) (PCS.bendWheelPressure 12 0.8 0) brs = evalState $- liftA6+ App.lift6 (\rel det t0 peak -> brs0 (rel/2) 1.5 (rel/2) rel rel peak det t0) (evHead $ PCS.controllerExponential controllerAttack (0.01,0.1) 0.01)
example/Synthesizer/LLVM/Test.hs view
@@ -1045,13 +1045,12 @@ {-# NOINLINE makePing #-} makePing :: IO ((Float,Float) -> SVL.Vector Float) makePing =- let freq = snd- halfLife = fst- in fmap ($tonesChunkSize) $- SigP.runChunky- (SigP.envelope- (SigP.exponential2 halfLife 1)- (SigP.osciSaw 0.5 freq))+ fmap ($tonesChunkSize) $+ SigP.runChunky $+ Param.withTuple1 $ \(halfLife, freq) ->+ SigP.envelope+ (SigP.exponential2 halfLife 1)+ (SigP.osciSaw 0.5 freq) tonesDown :: IO () tonesDown = do@@ -1821,11 +1820,11 @@ helixSpeechStatic :: IO () helixSpeechStatic = do- let speed = fst- word = snd . snd- period = fst . snd smp <- loadTomato- stretched <- SigP.runChunky $ helixSpeechStaticSpeed speed word period+ stretched <-+ SigP.runChunky $+ Param.withTuple1 $ \(speed, (period, word)) ->+ helixSpeechStaticSpeed speed word period SVL.writeFile "speech-stretched.f32" $ asMono $ stretched SVL.defaultChunkSize (0.5, smp) @@ -1853,22 +1852,21 @@ helixSpeechDynamic :: IO () helixSpeechDynamic = do- let speed = fst- word = snd . snd- period = fst . snd smp <- loadTomato- stretched <- SigP.runChunky $ helixSpeechDynamicSpeed speed word period+ stretched <-+ SigP.runChunky $+ Param.withTuple1 $ \(speed, (period, word)) ->+ helixSpeechDynamicSpeed speed word period SVL.writeFile "speech-stretched.f32" $ asMono $ stretched SVL.defaultChunkSize (0.5, smp) helixSpeechCompare :: IO () helixSpeechCompare = do- let speed = fst- word = snd . snd- period = fst . snd smp <- loadTomato stretched <-- SigP.runChunky $ sequenceA $+ SigP.runChunky $+ Param.withTuple1 $ \(speed, (period, word)) ->+ sequenceA $ Stereo.cons (helixSpeechStaticSpeed speed word period) (helixSpeechDynamicSpeed speed word period)@@ -1877,11 +1875,11 @@ helixSpeechVariCompare :: IO () helixSpeechVariCompare = do- let word = snd- period = fst smp <- loadTomato stretched <-- SigP.runChunky $ sequenceA $+ SigP.runChunky $+ Param.withTuple1 $ \(period, word) ->+ sequenceA $ let speed = Func.fromSignal $ SigP.cycle $ SigP.fromStorableVector $ pure $
render/Synthesizer/LLVM/Server/Render.hs view
@@ -12,6 +12,8 @@ import qualified Synthesizer.CausalIO.Process as PIO import qualified Synthesizer.PiecewiseConstant.Signal as PC +import Shell.Utility.Exit (exitFailureMsg)+ import qualified Data.StorableVector.Lazy as SVL import qualified Data.EventList.Relative.TimeBody as EventList@@ -35,7 +37,6 @@ import qualified Numeric.NonNegative.Wrapper as NonNegW import qualified System.Exit as Exit-import qualified System.IO as IO import Prelude hiding (Real, id, ) @@ -94,28 +95,22 @@ soxResult <- sox case soxResult of Exit.ExitSuccess -> return ()- Exit.ExitFailure n -> do- IO.hPutStrLn IO.stderr $- "'sox' aborted with exit code " ++ show n- Exit.exitFailure+ Exit.ExitFailure n ->+ exitFailureMsg $ "'sox' aborted with exit code " ++ show n main :: IO () main = do (opt, midiPath, mWavePath) <- Option.get case Option.sampleRate opt of- SampleRate rate ->+ SampleRate rate -> do+ audio <- render opt <*> Load.fromFile midiPath case mWavePath of Nothing ->- handleSoxExit $- SoxPlay.simple SVL.hPut mempty rate =<<- (render opt <*> Load.fromFile midiPath)- -- Rendering to SoX ends with an error code 13, but why?- Just wavePath ->- handleSoxExit $- SoxWrite.simple SVL.hPut mempty wavePath rate =<<- (render opt <*> Load.fromFile midiPath)-{-+ handleSoxExit $ SoxPlay.simple SVL.hPut mempty rate audio Just wavePath ->- SVL.writeFile wavePath =<<- (render opt <*> Load.fromFile midiPath)--}+ if True+ then+ -- Rendering to SoX ends with an error code 13, but why?+ handleSoxExit $+ SoxWrite.simple SVL.hPut mempty wavePath rate audio+ else SVL.writeFile wavePath audio
server/Synthesizer/LLVM/Server/CausalPacked/Arrange.hs view
@@ -475,7 +475,7 @@ fmap (ListHT.unzipEithers . fmap (\ev ->- case Check.note chan ev of+ case Check.noteExplicitOff chan ev of Nothing -> Right ev Just (v,p,b) -> if p >= VoiceMsg.toPitch 36
server/Synthesizer/LLVM/Server/OptionCommon.hs view
@@ -17,6 +17,7 @@ import qualified System.Path.PartClass as PathClass import qualified System.Path as Path +import qualified Shell.Utility.ParseArgument as ParseArg import qualified Options.Applicative as OP import Control.Applicative ((<$>), (<*>), ) import Data.Monoid ((<>), )@@ -79,13 +80,7 @@ (Read a) => String -> (a -> Bool) -> String -> OP.ReadM a parseNumber name constraint constraintName =- OP.eitherReader $ \str ->- case reads str of- [(n, "")] ->- if constraint n- then return n- else Left $ name ++ " must be a " ++ constraintName ++ " number"- _ -> Left $ name ++ " must be a number, but is '" ++ str ++ "'"+ OP.eitherReader $ ParseArg.parseNumber name constraint constraintName sampleRate :: OP.Parser (Maybe (SampleRate Int)) sampleRate =
src/Synthesizer/LLVM/Causal/Process.hs view
@@ -37,6 +37,7 @@ mapProc, zipProcWith, mix,+ takeWhile, pipeline, stereoFromVector, vectorize,@@ -113,7 +114,7 @@ import Control.Exception (bracket, ) import qualified System.Unsafe as Unsafe -import Prelude hiding (and, map, zip, zipWith, init, )+import Prelude hiding (and, map, zip, zipWith, init, takeWhile, ) @@ -659,10 +660,10 @@ AllocUtil.with params $ \paramPtr -> fmap (fromIntegral :: Word32 -> Int) $ fill- (Memory.castStorablePtr paramPtr)+ (Memory.castTuplePtr paramPtr) (fromIntegral len)- (Memory.castStorablePtr aPtr)- (Memory.castStorablePtr bPtr)+ (Memory.castTuplePtr aPtr)+ (Memory.castTuplePtr bPtr) foreign import ccall safe "dynamic" derefStartPtr ::@@ -742,8 +743,8 @@ SVB.createAndTrim size $ fmap (fromIntegral :: Word32 -> Int) . fill paramPtr sptr (fromIntegral size)- (Memory.castStorablePtr aPtr) .- Memory.castStorablePtr+ (Memory.castTuplePtr aPtr) .+ Memory.castTuplePtr (if SV.length v > 0 then fmap (v:) else id) $
src/Synthesizer/LLVM/Causal/ProcessPrivate.hs view
@@ -14,7 +14,7 @@ import LLVM.Extra.Class (Undefined, MakeValueTuple, ValueTuple, ) import LLVM.Util.Loop (Phi, )-import LLVM.Core (CodeGenFunction, )+import LLVM.Core (CodeGenFunction, Value, ) import Foreign.Storable (Storable, ) @@ -193,6 +193,18 @@ process a c -> process a d zipProcWith f x y = zipWith f <<< x&&&y+++takeWhile ::+ (C process) =>+ (forall r. a -> CodeGenFunction r (Value Bool)) ->+ process a a+takeWhile p =+ simple+ (\a () -> do+ MaybeCont.guard =<< MaybeCont.lift (p a)+ return (a,()))+ (return ()) compose :: T a b -> T b c -> T a c
src/Synthesizer/LLVM/Causal/ProcessValue.hs view
@@ -6,17 +6,18 @@ instead of LLVM assembly functions. -} module Synthesizer.LLVM.Causal.ProcessValue (- map, zipWith, mapAccum,+ map, zipWith, mapAccum, takeWhile, ) where import qualified Synthesizer.LLVM.Causal.Process as Causal import qualified Synthesizer.LLVM.Simple.Value as Value import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Core as LLVM import Foreign.Storable.Tuple () -import Prelude ()+import Prelude (Bool) map ::@@ -42,3 +43,10 @@ Causal.mapAccum (Value.unlift2 next) (Value.unlift0 start)++takeWhile ::+ (Causal.C process) =>+ (Value.T a -> Value.T (LLVM.Value Bool)) ->+ process a a+takeWhile p =+ Causal.takeWhile (Value.unlift1 p)
src/Synthesizer/LLVM/CausalParameterized/Functional.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-} module Synthesizer.LLVM.CausalParameterized.Functional (@@ -11,11 +13,15 @@ withArgs, MakeArguments, Arguments, makeArgs, AnyArg(..), + Ground(Ground),+ withGroundArgs, MakeGroundArguments, GroundArguments,+ makeGroundArgs,+ Atom(..), atom, withGuidedArgs, MakeGuidedArguments, GuidedArguments, PatternArguments, makeGuidedArgs, - PrepareArguments, withPreparedArgs, withPreparedArgs2,+ PrepareArguments(PrepareArguments), withPreparedArgs, withPreparedArgs2, atomArg, stereoArgs, pairArgs, tripleArgs, ) where @@ -346,6 +352,65 @@ instance MakeArguments (AnyArg a) where makeArgs = fmap getAnyArg +++{- |+This is similar to 'withArgs'+but it requires to specify the decomposition depth+using constructors in the arguments.+-}+withGroundArgs ::+ (MakeGroundArguments (T p inp) args,+ GroundArguments args ~ inp) =>+ (args -> T p inp out) -> CausalP.T p inp out+withGroundArgs f = withId $ f . makeGroundArgs+++data Ground f a = Ground (f a)+++type family GroundArguments args++class (Functor f) => MakeGroundArguments f args where+ makeGroundArgs :: f (GroundArguments args) -> args+++type instance GroundArguments (Ground f a) = a+instance (Functor f, f ~ g) => MakeGroundArguments f (Ground g a) where+ makeGroundArgs = Ground++type instance GroundArguments (Stereo.T a) = Stereo.T (GroundArguments a)+instance MakeGroundArguments f a => MakeGroundArguments f (Stereo.T a) where+ makeGroundArgs f =+ Stereo.cons+ (makeGroundArgs $ fmap Stereo.left f)+ (makeGroundArgs $ fmap Stereo.right f)++type instance GroundArguments () = ()+instance (Functor f) => MakeGroundArguments f () where+ makeGroundArgs _ = ()+++type instance+ GroundArguments (a,b) =+ (GroundArguments a, GroundArguments b)+instance+ (MakeGroundArguments f a, MakeGroundArguments f b) =>+ MakeGroundArguments f (a,b) where+ makeGroundArgs f =+ (makeGroundArgs $ fmap fst f,+ makeGroundArgs $ fmap snd f)++type instance+ GroundArguments (a,b,c) =+ (GroundArguments a, GroundArguments b, GroundArguments c)+instance+ (MakeGroundArguments f a, MakeGroundArguments f b, MakeGroundArguments f c) =>+ MakeGroundArguments f (a,b,c) where+ makeGroundArgs f =+ (makeGroundArgs $ fmap fst3 f,+ makeGroundArgs $ fmap snd3 f,+ makeGroundArgs $ fmap thd3 f)
src/Synthesizer/LLVM/CausalParameterized/Helix.hs view
@@ -562,6 +562,19 @@ } +{- |+@zigZagLong loopStart loopLength@+creates a curve that starts at 0+and is linear until it reaches @loopStart+loopLength@.+Then it begins looping in a ping-pong manner+between @loopStart+loopLength@ and @loopStart@.+It is useful as @shape@ control for looping a sound.+Input of the causal process is the slope (or frequency) control.+Slope values must not be negative.++*Main> Sig.renderChunky SVL.defaultChunkSize (Causal.take 25 <<< Helix.zigZagLong 6 10 $* 2) () :: SVL.Vector Float+VectorLazy.fromChunks [Vector.pack [0.0,1.999999,3.9999995,6.0,8.0,10.0,12.0,14.0,15.999999,14.000001,12.0,10.0,7.999999,6.0,8.0,10.0,12.0,14.0,16.0,14.0,11.999999,9.999998,7.999998,6.0000024,8.000002]]+-} zigZagLong :: (Storable a, MakeValueTuple a, ValueTuple a ~ Value a, Memory.FirstClass a, Memory.Stored a ~ am, IsSized am,@@ -600,6 +613,13 @@ <<< id / constant loop +{- |+@zigZag start@ creates a zig-zag curve with values between 0 and 1, inclusively,+that is useful as @shape@ control for looping a sound.+Input of the causal process is the slope (or frequency) control.+Slope values must not be negative.+The start value must be at most 2 and may be negative.+-} zigZag :: (Storable a, MakeValueTuple a, ValueTuple a ~ Value a, Memory.FirstClass a, Memory.Stored a ~ am, IsSized am,
src/Synthesizer/LLVM/CausalParameterized/Process.hs view
@@ -24,6 +24,7 @@ feedbackControlled, Causal.feedbackControlledZero, Causal.fromModifier,+ fromInitializedModifier, stereoFromMono, stereoFromMonoControlled, stereoFromMonoParameterized,@@ -87,6 +88,7 @@ import qualified Synthesizer.LLVM.Parameterized.SignalPrivate as SigPPriv import qualified Synthesizer.LLVM.Parameterized.Signal as SigP import qualified Synthesizer.LLVM.Simple.SignalPrivate as SigPriv+import qualified Synthesizer.LLVM.Simple.Value as Value import qualified Synthesizer.LLVM.Interpolation as Interpolation import qualified Synthesizer.LLVM.Frame.Stereo as Stereo import qualified Synthesizer.LLVM.Frame as Frame@@ -96,6 +98,7 @@ import qualified Synthesizer.Causal.Class as CausalClass import qualified Synthesizer.Generic.Cut as Cut+import qualified Synthesizer.Plain.Modifier as Modifier import qualified Data.StorableVector.Lazy as SVL import qualified Data.StorableVector as SV@@ -119,6 +122,7 @@ import Type.Data.Num.Decimal (D1, ) import qualified Control.Category as Cat+import Control.Monad.Trans.State (runState, ) import Control.Arrow (arr, first, second, (<<<), (<<^), (>>>), (&&&), ) import Control.Monad (liftM, when, ) import Control.Applicative (liftA2, liftA3, pure, (<*>), )@@ -187,7 +191,25 @@ mapAccumSimple f s = mapAccum (\() -> f) (\() -> s) (return ()) (return ()) +fromInitializedModifier ::+ (Value.Flatten ah, Value.Registers ah ~ al,+ Value.Flatten bh, Value.Registers bh ~ bl,+ Value.Flatten ch, Value.Registers ch ~ cl,+ Value.Flatten sh, Value.Registers sh ~ sl, Memory.C sl,+ Value.Flatten ih, Value.Registers ih ~ il, Memory.C il,+ Storable i, MakeValueTuple i, ValueTuple i ~ il) =>+ Modifier.Initialized sh ih ch ah bh -> Param.T p i -> T p (cl,al) bl+fromInitializedModifier (Modifier.Initialized initF step) =+ mapAccum+ (\() (c,a) s ->+ Value.flatten $+ runState+ (step (Value.unfold c) (Value.unfold a))+ (Value.unfold s))+ (Value.flattenFunction initF)+ (return ()) + replicateParallel :: (Undefined b, Phi b) => Param.T p Int -> SigP.T p b -> T p (b,b) b -> T p a b -> T p a b@@ -762,10 +784,10 @@ SVB.createAndTrim len $ \ bPtr -> Alloc.with params $ \paramPtr -> fmap fromIntegral $- fill (Memory.castStorablePtr paramPtr)+ fill (Memory.castTuplePtr paramPtr) (fromIntegral len)- (Memory.castStorablePtr aPtr)- (Memory.castStorablePtr bPtr)+ (Memory.castTuplePtr aPtr)+ (Memory.castTuplePtr bPtr) applyStorable :: (Storable a, MakeValueTuple a, ValueTuple a ~ valueA, Memory.C valueA,@@ -958,8 +980,8 @@ fmap fromIntegral . fill sptr (fromIntegral size)- (Memory.castStorablePtr aPtr) .- Memory.castStorablePtr+ (Memory.castTuplePtr aPtr) .+ Memory.castTuplePtr touchForeignPtr ioContextPtr (if SV.length v > 0 then fmap (v:)@@ -1027,8 +1049,8 @@ AllocUtil.with paramOut $ \outptr -> fill paramPtr (fromIntegral maximumSize)- (Memory.castStorablePtr inptr)- (Memory.castStorablePtr outptr)+ (Memory.castTuplePtr inptr)+ (Memory.castTuplePtr outptr) deleteIn contextIn b <- deleteOut (fromIntegral actualSize) contextOut return (b, s))@@ -1040,7 +1062,7 @@ contextStatePtr <- AllocUtil.with param- (startFunc . Memory.castStorablePtr)+ (startFunc . Memory.castTuplePtr) return (ioContext, contextStatePtr)) (\(ioContext, contextStatePtr) -> do
src/Synthesizer/LLVM/ConstantPiece.hs view
@@ -49,15 +49,11 @@ addPhis bb (Cons lenA ya) (Cons lenB yb) = addPhis bb lenA lenB >> addPhis bb ya yb -instance (Undefined a) =>- Undefined (T a) where- undefTuple =- Cons Class.undefTuple Class.undefTuple+instance (Undefined a) => Undefined (T a) where+ undefTuple = Cons Class.undefTuple Class.undefTuple -instance (Class.Zero a) =>- Class.Zero (T a) where- zeroTuple =- Cons Class.zeroTuple Class.zeroTuple+instance (Class.Zero a) => Class.Zero (T a) where+ zeroTuple = Cons Class.zeroTuple Class.zeroTuple type Struct a = LLVM.Struct (Word32, (a, ())) @@ -84,7 +80,7 @@ flatten = Sig.alter (\(Sig.Core next start stop) -> Sig.Core (\context state0 -> do- (Cons length1 y1, s1) <-+ ~(Cons length1 y1, s1) <- Maybe.fromBool $ whileLoop (valueOf True, state0) (\(cont, (Cons len _y, _s)) ->
src/Synthesizer/LLVM/Filter/Allpass.hs view
@@ -113,6 +113,7 @@ (plainFromParamValue b) instance (MultiVector.C a) => MultiVector.C (Allpass.Parameter a) where+ cons = paramFromPlainVector . MultiVector.cons . fmap Allpass.getParameter undef = paramFromPlainVector MultiVector.undef zero = paramFromPlainVector MultiVector.zero @@ -125,10 +126,9 @@ (plainFromParamVector a) (plainFromParamVector b) - shuffleMatch is a =+ shuffle is a b = fmap paramFromPlainVector $- MultiVector.shuffleMatch is $- plainFromParamVector a+ MultiVector.shuffle is (plainFromParamVector a) (plainFromParamVector b) extract i v = fmap paramFromPlainValue $ MultiVector.extract i $@@ -241,6 +241,9 @@ (paramFromCascadeValue b) instance (MultiVector.C a) => MultiVector.C (CascadeParameter n a) where+ cons =+ cascadeFromParamVector . MultiVector.cons .+ fmap (\(CascadeParameter a) -> a) undef = cascadeFromParamVector MultiVector.undef zero = cascadeFromParamVector MultiVector.zero @@ -253,10 +256,10 @@ (paramFromCascadeVector a) (paramFromCascadeVector b) - shuffleMatch is a =+ shuffle is a b = fmap cascadeFromParamVector $- MultiVector.shuffleMatch is $- paramFromCascadeVector a+ MultiVector.shuffle is+ (paramFromCascadeVector a) (paramFromCascadeVector b) extract i v = fmap cascadeFromParamValue $ MultiVector.extract i $
src/Synthesizer/LLVM/Filter/FirstOrder.hs view
@@ -4,11 +4,15 @@ module Synthesizer.LLVM.Filter.FirstOrder ( Result(Result,lowpass_,highpass_), Parameter, parameter, causal, lowpassCausal, highpassCausal,+ causalInit, lowpassCausalInit, highpassCausalInit,+ causalInitPacked, lowpassCausalInitPacked, highpassCausalInitPacked, causalPacked, lowpassCausalPacked, highpassCausalPacked, causalRecursivePacked, -- for Allpass causalP, lowpassCausalP, highpassCausalP,+ causalInitP, lowpassCausalInitP, highpassCausalInitP, causalPackedP, lowpassCausalPackedP, highpassCausalPackedP,+ causalInitPackedP, lowpassCausalInitPackedP, highpassCausalInitPackedP, causalRecursivePackedP, -- for Allpass ) where @@ -21,6 +25,7 @@ import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP import qualified Synthesizer.LLVM.Causal.Process as Causal import qualified Synthesizer.LLVM.Frame.SerialVector as Serial+import qualified Synthesizer.LLVM.Parameter as Param import qualified Synthesizer.LLVM.Simple.Value as Value import qualified LLVM.Extra.Memory as Memory@@ -31,6 +36,8 @@ import qualified LLVM.Core as LLVM import LLVM.Util.Loop (Phi, phis, addPhis, ) +import Foreign.Storable (Storable, )+ import Control.Arrow (arr, (&&&), (<<<), ) import Control.Monad (liftM2, foldM, ) @@ -112,8 +119,46 @@ lowpassCausal = CausalP.fromModifier lowpassModifier highpassCausal = CausalP.fromModifier highpassModifier -lowpassCausalPacked, highpassCausalPacked, causalRecursivePacked ::++modifierInit ::+ (a ~ A.Scalar v, A.PseudoModule v, A.IntegerConstant a) =>+ Modifier.Initialized+ (Value.T v) (Value.T v)+ (Parameter (Value.T a))+ (Value.T v) (Result (Value.T v))+modifierInit = FirstOrder.modifierInit++lowpassModifierInit, highpassModifierInit ::+ (a ~ A.Scalar v, A.PseudoModule v, A.IntegerConstant a) =>+ Modifier.Initialized+ (Value.T v) (Value.T v)+ (Parameter (Value.T a))+ (Value.T v) (Value.T v)+lowpassModifierInit = FirstOrder.lowpassModifierInit+highpassModifierInit = FirstOrder.highpassModifierInit++causalInit :: (Causal.C process,+ A.IntegerConstant a, a ~ A.Scalar v, A.PseudoModule v, Memory.C v) =>+ v -> process (Parameter a, v) (Result v)+causalInit =+ Causal.fromModifier . Modifier.initialize modifierInit . Value.unfold++lowpassCausalInit, highpassCausalInit ::+ (Causal.C process,+ A.IntegerConstant a, a ~ A.Scalar v, A.PseudoModule v, Memory.C v) =>+ v -> process (Parameter a, v) v+lowpassCausalInit =+ CausalP.fromModifier .+ Modifier.initialize lowpassModifierInit . Value.unfold+highpassCausalInit =+ CausalP.fromModifier .+ Modifier.initialize highpassModifierInit . Value.unfold+++lowpassCausalPacked, highpassCausalPacked, causalRecursivePacked,+ preampPacked ::+ (Causal.C process, Serial.C v, Serial.Element v ~ a, Memory.C a, A.IntegerConstant a, A.PseudoRing v, A.PseudoRing a) =>@@ -121,12 +166,31 @@ highpassCausalPacked = Causal.zipWith A.sub <<< arr snd &&& lowpassCausalPacked lowpassCausalPacked =- causalRecursivePacked <<<- (arr fst &&&- Causal.map- (\(FirstOrder.Parameter k, x) ->- A.mul x =<< Serial.upsample =<< A.sub (A.fromInteger' 1) k))+ causalRecursivePacked <<< (arr fst &&& preampPacked) +causalRecursivePacked =+ causalRecursiveInitPacked A.zero++lowpassCausalInitPacked, highpassCausalInitPacked, causalRecursiveInitPacked ::+ (Causal.C process,+ A.PseudoRing v, Serial.C v, Serial.Element v ~ a,+ A.PseudoRing a, A.IntegerConstant a, Memory.C a) =>+ a -> process (Parameter a, v) v+causalRecursiveInitPacked a =+ Causal.mapAccum causalRecursivePackedStep (return a)++highpassCausalInitPacked a =+ Causal.zipWith A.sub <<< arr snd &&& lowpassCausalInitPacked a+lowpassCausalInitPacked a =+ causalRecursiveInitPacked a <<< (arr fst &&& preampPacked)++preampPacked =+ Causal.map+ (\(FirstOrder.Parameter k, x) ->+ A.mul x =<< Serial.upsample =<< A.sub (A.fromInteger' 1) k)+++ {- x = [x0, x1, x2, x3] @@ -141,9 +205,11 @@ f1x = f0x + k * f0x->1 f2x = f1x + k^2 * f1x->2 -}-causalRecursivePacked =- Causal.mapAccum- (\(FirstOrder.Parameter k, xk0) y1 -> do+causalRecursivePackedStep ::+ (A.PseudoRing v, Serial.C v, Serial.Element v ~ a, A.PseudoRing a) =>+ (Parameter a, v) -> a -> LLVM.CodeGenFunction r (v,a)+causalRecursivePackedStep =+ \(Parameter k, xk0) y1 -> do y1k <- A.mul k y1 xk1 <- Serial.modify A.zero (A.add y1k) xk0 let size = Serial.size xk0@@ -174,8 +240,7 @@ (takeWhile (< size) $ iterate (2*) 1) -} y0 <- Serial.extract (LLVM.valueOf $ fromIntegral $ size - 1) xk2- return (xk2, y0))- (return A.zero)+ return (xk2, y0) {- We can also optimize filtering with time-varying filter parameter.@@ -217,35 +282,43 @@ +addHighpass ::+ (Causal.C process, A.Additive v) =>+ process (param, v) v -> process (param, v) (Result v)+addHighpass lowpass =+{-+Before we added sharing to Simple.Value,+only this implementation allowed sharing+and using CausalP.fromModifier did not.+-}+ Causal.map (\(l,x) -> do+ h <- A.sub x l+ return (Result{FirstOrder.lowpass_ = l,+ FirstOrder.highpass_ = h}))+ <<< (lowpass &&& arr snd)+ causalPacked :: (Causal.C process, Serial.C v, Serial.Element v ~ a, Memory.C a, A.IntegerConstant a, A.PseudoRing v, A.PseudoRing a) => process (Parameter a, v) (Result v)-causalPacked =- Causal.map (\(l,x) -> do- h <- A.sub x l- return (Result{FirstOrder.lowpass_ = l,- FirstOrder.highpass_ = h}))- <<< (lowpassCausalPacked &&& arr snd)+causalPacked = addHighpass lowpassCausalPacked +causalInitPacked ::+ (Causal.C process,+ Serial.C v, Serial.Element v ~ a,+ Memory.C a, A.IntegerConstant a,+ A.PseudoRing v, A.PseudoRing a) =>+ a -> process (Parameter a, v) (Result v)+causalInitPacked a = addHighpass (lowpassCausalInitPacked a) + causalP :: (A.IntegerConstant a, a ~ A.Scalar v, A.PseudoModule v, Memory.C v) => CausalP.T p (Parameter a, v) (Result v)-{--Before we added sharing to Simple.Value,-only this implementation allowed sharing-and using CausalP.fromModifier did not.--}-causalP =- Causal.map (\(l,x) -> do- h <- A.sub x l- return (Result{FirstOrder.lowpass_ = l,- FirstOrder.highpass_ = h}))- <<< (lowpassCausalP &&& arr snd)+causalP = addHighpass lowpassCausalP lowpassCausalP, highpassCausalP :: (A.IntegerConstant a, a ~ A.Scalar v, A.PseudoModule v, Memory.C v) =>@@ -253,6 +326,19 @@ lowpassCausalP = lowpassCausal highpassCausalP = highpassCausal +causalInitP ::+ (A.IntegerConstant a, a ~ A.Scalar v, A.PseudoModule v, Memory.C v,+ Storable vh, Class.MakeValueTuple vh, Class.ValueTuple vh ~ v) =>+ Param.T p vh -> CausalP.T p (Parameter a, v) (Result v)+causalInitP = CausalP.fromInitializedModifier modifierInit++lowpassCausalInitP, highpassCausalInitP ::+ (A.IntegerConstant a, a ~ A.Scalar v, A.PseudoModule v, Memory.C v,+ Storable vh, Class.MakeValueTuple vh, Class.ValueTuple vh ~ v) =>+ Param.T p vh -> CausalP.T p (Parameter a, v) v+lowpassCausalInitP = CausalP.fromInitializedModifier lowpassModifierInit+highpassCausalInitP = CausalP.fromInitializedModifier highpassModifierInit+ lowpassCausalPackedP, highpassCausalPackedP, causalRecursivePackedP :: (Serial.C v, Serial.Element v ~ a, Memory.C a, A.IntegerConstant a,@@ -262,12 +348,33 @@ lowpassCausalPackedP = lowpassCausalPacked causalRecursivePackedP = causalRecursivePacked +lowpassCausalInitPackedP, highpassCausalInitPackedP,+ causalRecursiveInitPackedP ::+ (A.PseudoRing v, Serial.C v, Serial.Element v ~ a,+ A.PseudoRing a, A.IntegerConstant a, Memory.C a,+ Storable ah, Class.MakeValueTuple ah, Class.ValueTuple ah ~ a) =>+ Param.T p ah -> CausalP.T p (Parameter a, v) v+causalRecursiveInitPackedP a =+ CausalP.mapAccum (\() -> causalRecursivePackedStep) return (return ()) a++highpassCausalInitPackedP a =+ Causal.zipWith A.sub <<< arr snd &&& lowpassCausalInitPackedP a+lowpassCausalInitPackedP a =+ causalRecursiveInitPackedP a <<< (arr fst &&& preampPacked)+ causalPackedP :: (Serial.C v, Serial.Element v ~ a, Memory.C a, A.IntegerConstant a, A.PseudoRing v, A.PseudoRing a) => CausalP.T p (Parameter a, v) (Result v) causalPackedP = causalPacked++causalInitPackedP ::+ (A.PseudoRing v, Serial.C v, Serial.Element v ~ a,+ A.PseudoRing a, A.IntegerConstant a, Memory.C a,+ Storable ah, Class.MakeValueTuple ah, Class.ValueTuple ah ~ a) =>+ Param.T p ah -> CausalP.T p (Parameter a, v) (Result v)+causalInitPackedP a = addHighpass (lowpassCausalInitPackedP a) {-# DEPRECATED causalP "use 'causal' instead" #-}
src/Synthesizer/LLVM/Filter/SecondOrder.hs view
@@ -25,7 +25,6 @@ import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Class as Class import qualified LLVM.Extra.Arithmetic as A-import qualified LLVM.Extra.Monad as M import LLVM.Extra.Class (Undefined, undefTuple, ) import qualified LLVM.Core as LLVM@@ -35,10 +34,11 @@ import qualified Type.Data.Num.Decimal as TypeNum import Type.Data.Num.Decimal (d0, d1, d2, d3, d4, ) +import qualified Control.Monad.HT as M+import qualified Control.Applicative.HT as App import Control.Arrow (arr, (<<<), (&&&), ) import Control.Monad (liftM2, foldM, ) import Control.Applicative (pure, (<*>), )-import Control.Applicative.HT (liftA4, liftA5, ) import NumericPrelude.Numeric import NumericPrelude.Base@@ -70,7 +70,7 @@ (Memory.C a) => Memory.Record r (ParameterStruct (Memory.Struct a)) (Parameter a) parameterMemory =- liftA5 Parameter+ App.lift5 Parameter (Memory.element Filt2.c0 d0) (Memory.element Filt2.c1 d1) (Memory.element Filt2.c2 d2)@@ -129,7 +129,7 @@ (Memory.C a) => Memory.Record r (StateStruct (Memory.Struct a)) (Filt2.State a) stateMemory =- liftA4 Filt2.State+ App.lift4 Filt2.State (Memory.element Filt2.u1 d0) (Memory.element Filt2.u2 d1) (Memory.element Filt2.y1 d2)@@ -286,7 +286,7 @@ (\(y,(a,b)) d -> liftM2 (,) (A.add y =<<- M.liftR2 A.add+ M.liftJoin2 A.add {- Possibility for optimization: In the last step the second operand is a zero vector@@ -297,7 +297,7 @@ (Serial.shiftUpMultiZero d =<< A.mul y a) (Serial.shiftUpMultiZero (2*d) =<< A.mul y b)) $ liftM2 (,)- (M.liftR2 A.sub+ (M.liftJoin2 A.sub (A.mul a a) (A.mul b (A.fromInteger' 2))) (A.mul b b))@@ -316,7 +316,7 @@ Serial.modify (valueOf 0) (\u0 -> A.add u0 =<<- M.liftR2 A.add (A.mul (Filt2.d2 p) x2) (A.mul (Filt2.d1 p) x1)) =<<+ M.liftJoin2 A.add (A.mul (Filt2.d2 p) x2) (A.mul (Filt2.d1 p) x1)) =<< Serial.modify (valueOf 1) (\u1 -> A.add u1 =<< A.mul (Filt2.d2 p) x1) x0@@ -330,11 +330,11 @@ (\(y,(a,b)) d -> liftM2 (,) (A.add y =<<- M.liftR2 A.add+ M.liftJoin2 A.add (Serial.shiftUpMultiZero d =<< A.mul y a) (Serial.shiftUpMultiZero (2*d) =<< A.mul y b)) $ liftM2 (,)- (M.liftR2 A.sub+ (M.liftJoin2 A.sub (A.mul a a) (A.mul b (A.fromInteger' 2))) (A.mul b b))
src/Synthesizer/LLVM/Filter/Universal.hs view
@@ -29,7 +29,7 @@ import Type.Data.Num.Decimal (d0, d1, d2, d3, d4, d5, ) -import Control.Applicative.HT (liftA6, )+import qualified Control.Applicative.HT as App instance (Phi a) => Phi (Parameter a) where@@ -46,7 +46,7 @@ (Memory.C a) => Memory.Record r (ParameterStruct (Memory.Struct a)) (Parameter a) parameterMemory =- liftA6 Parameter+ App.lift6 Parameter (Memory.element Universal.k1 d0) (Memory.element Universal.k2 d1) (Memory.element Universal.ampIn d2)
src/Synthesizer/LLVM/ForeignPtr.hs view
@@ -46,7 +46,7 @@ (Ptr (Memory.Struct (ValueTuple b)) -> IO (Ptr a)) -> b -> IO (ForeignPtr a) newParam stop start b =- newInit stop (Marshal.with b (start . Memory.castStorablePtr))+ newInit stop (Marshal.with b (start . Memory.castTuplePtr)) new :: Storable a => IO () -> a -> IO (ForeignPtr a) new finalizer a = do@@ -59,4 +59,4 @@ (Storable a, MakeValueTuple a, Memory.C (ValueTuple a)) => ForeignPtr a -> (Ptr (Memory.Struct (ValueTuple a)) -> IO b) -> IO b with fp func =- withForeignPtr fp (func . Memory.castStorablePtr)+ withForeignPtr fp (func . Memory.castTuplePtr)
src/Synthesizer/LLVM/Frame/Stereo.hs view
@@ -127,3 +127,8 @@ add x y = Trav.sequence $ liftA2 A.add x y sub x y = Trav.sequence $ liftA2 A.sub x y neg x = Trav.sequence $ fmap A.neg x++type instance A.Scalar (Stereo.T a) = A.Scalar a++instance (A.PseudoModule a) => A.PseudoModule (Stereo.T a) where+ scale a = Trav.sequence . fmap (A.scale a)
src/Synthesizer/LLVM/Parameter.hs view
@@ -9,6 +9,11 @@ value, with, + Tuple(..),+ withTuple,+ withTuple1,+ withTuple2,+ -- * for implementation of new processes word32, ) where@@ -27,13 +32,14 @@ import qualified Control.Category as Cat import qualified Control.Arrow as Arr import qualified Control.Applicative as App-import Control.Applicative (pure, liftA2, )+import Control.Applicative (pure, liftA2, (<$>), ) +import qualified Data.Tuple.HT as TupleHT import Data.Tuple.HT (mapFst, ) import Data.Word (Word32, ) import NumericPrelude.Numeric-import Prelude (Functor, Monad, fmap, error, (.), const, id, )+import Prelude (Functor, Monad, fmap, error, (.), ($), const, id, ) import qualified Prelude as P @@ -231,3 +237,83 @@ instance P.Fractional a => P.Fractional (T p a) where (/) = liftA2 (P./) fromRational = pure . P.fromRational++instance P.Floating a => P.Floating (T p a) where+ pi = pure P.pi+ exp = fmap P.exp+ sqrt = fmap P.sqrt+ log = fmap P.log+ (**) = liftA2 (P.**)+ logBase = liftA2 P.logBase+ sin = fmap P.sin+ tan = fmap P.tan+ cos = fmap P.cos+ asin = fmap P.asin+ atan = fmap P.atan+ acos = fmap P.acos+ sinh = fmap P.sinh+ tanh = fmap P.tanh+ cosh = fmap P.cosh+ asinh = fmap P.asinh+ atanh = fmap P.atanh+ acosh = fmap P.acosh++++class Tuple tuple where+ type Composed tuple :: *+ type Source tuple :: *+ decompose :: T (Source tuple) (Composed tuple) -> tuple++instance Tuple (T p a) where+ type Composed (T p a) = a+ type Source (T p a) = p+ decompose = id++instance (Tuple a, Tuple b, Source a ~ Source b) => Tuple (a,b) where+ type Composed (a,b) = (Composed a, Composed b)+ type Source (a,b) = Source a+ decompose p = (decompose $ P.fst <$> p, decompose $ P.snd <$> p)++instance+ (Tuple a, Tuple b, Tuple c, Source a ~ Source b, Source b ~ Source c) =>+ Tuple (a,b,c) where+ type Composed (a,b,c) = (Composed a, Composed b, Composed c)+ type Source (a,b,c) = Source a+ decompose p =+ (decompose $ TupleHT.fst3 <$> p,+ decompose $ TupleHT.snd3 <$> p,+ decompose $ TupleHT.thd3 <$> p)++{- |+Provide all elements of a nested tuple as separate parameters.++If you do not use one of the tuple elements,+you will get a type error like+@Couldn't match type `Param.Composed t0' with `Int'@.+The problem is that the type checker cannot infer+that an element is a @Parameter.T@ if it remains unused.+-}+withTuple ::+ (Tuple tuple, Source tuple ~ p, Composed tuple ~ p) =>+ (tuple -> f p) -> f p+withTuple f = idFromFunctor $ f . decompose++idFromFunctor :: (T p p -> f p) -> f p+idFromFunctor f = f Cat.id++withTuple1 ::+ (Tuple tuple, Source tuple ~ p, Composed tuple ~ p) =>+ (tuple -> f p a) -> f p a+withTuple1 f = idFromFunctor1 $ f . decompose++idFromFunctor1 :: (T p p -> f p a) -> f p a+idFromFunctor1 f = f Cat.id++withTuple2 ::+ (Tuple tuple, Source tuple ~ p, Composed tuple ~ p) =>+ (tuple -> f p a b) -> f p a b+withTuple2 f = idFromFunctor2 $ f . decompose++idFromFunctor2 :: (T p p -> f p a b) -> f p a b+idFromFunctor2 f = f Cat.id
src/Synthesizer/LLVM/Parameterized/Signal.hs view
@@ -10,6 +10,7 @@ adjacentNodes13, amplify, amplifyStereo,+ Sig.empty, append, cycle, drop,@@ -24,6 +25,7 @@ mapSimple, mapAccum, Sig.mix,+ Sig.mixExt, noise, noiseCore, osci,@@ -97,7 +99,6 @@ import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.MaybeContinuation as MaybeCont-import qualified LLVM.Extra.Either as Either import qualified LLVM.Extra.Maybe as Maybe import qualified LLVM.Extra.Memory as Memory import LLVM.Extra.Class (MakeValueTuple, ValueTuple, Undefined, undefTuple, )@@ -115,7 +116,7 @@ import qualified Type.Data.Num.Decimal as TypeNum import Control.Monad.HT ((<=<), )-import Control.Monad (liftM2, when, )+import Control.Monad (when, ) import Control.Arrow ((^<<), ) import Control.Applicative (liftA2, liftA3, pure, (<$>), ) import Control.Functor.HT (void, )@@ -201,56 +202,7 @@ return (ioContext, (param, getN p))) deleteIOContext -{- |-Appending many signals is inefficient,-since in cascadingly appended signals the parts are counted in an unary way.-Concatenating infinitely many signals is impossible.-If you want to concatenate a lot of signals,-please render them to lazy storable vectors first.--}-{--We might save a little space by using a union-for the states of the first and the second signal generator.-If the concatenated generators allocate memory,-we could also save some memory by calling @startB@-only after the first generator finished.-However, for correct deallocation-we would need to track which of the @start@ blocks-have been executed so far.-This in turn might be difficult in connection with the garbage collector.--}-append ::- (Loop.Phi a, Undefined a) =>- T p a -> T p a -> T p a-append- (Cons nextA allocaA startA stopA createIOContextA deleteIOContextA)- (Cons nextB allocaB startB stopB createIOContextB deleteIOContextB) =- Cons- (\parameterB (localA, localB) ecs0 -> MaybeCont.fromMaybe $ do- ecs1 <-- Either.run ecs0- (\(ca, sa0) ->- MaybeCont.resolve- (nextA ca localA sa0)- (fmap Either.right $ startB parameterB)- (\(a1,sa1) -> return (Either.left (a1, (ca, sa1)))))- (return . Either.right) - Either.run ecs1- (\(a1,cs1) ->- return (Maybe.just (a1, Either.left cs1)))- (\(cb,sb0) ->- MaybeCont.toMaybe $- fmap (\(b,sb1) -> (b, Either.right (cb,sb1))) $- nextB cb localB sb0))- (liftM2 (,) allocaA allocaB)- (\(parameterA, parameterB) -> do- cs <- startA parameterA- return (parameterB, Either.left cs))- (\ _parameterB s -> Either.run s (uncurry stopA) (uncurry stopB))- (combineCreate createIOContextA createIOContextB)- (combineDelete deleteIOContextA deleteIOContextB)- cycle :: (Loop.Phi a, Undefined a) => T p a -> T p a@@ -344,6 +296,7 @@ (pure ()) yp0 + -- * signal generators @@ -733,8 +686,8 @@ SVB.createAndTrim len $ \ ptr -> Alloc.with params $ \paramPtr -> fmap fromIntegral $- fill (Memory.castStorablePtr paramPtr)- (fromIntegral len) (Memory.castStorablePtr ptr)+ fill (Memory.castTuplePtr paramPtr)+ (fromIntegral len) (Memory.castTuplePtr ptr) {- | This is not really a function, see 'renderChunky'.@@ -922,7 +875,7 @@ SVB.createAndTrim size $ fmap fromIntegral . fill sptr (fromIntegral size) .- Memory.castStorablePtr+ Memory.castTuplePtr touchForeignPtr ioContextPtr (if SV.length v > 0 then fmap (v:)
src/Synthesizer/LLVM/Parameterized/SignalPrivate.hs view
@@ -7,12 +7,14 @@ import qualified Synthesizer.LLVM.Simple.SignalPrivate as Sig import qualified Synthesizer.LLVM.Parameter as Param-import qualified LLVM.Extra.MaybeContinuation as Maybe+import qualified LLVM.Extra.MaybeContinuation as MaybeCont+import qualified LLVM.Extra.Either as Either+import qualified LLVM.Extra.Maybe as Maybe import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Core as LLVM-import LLVM.Extra.Class (MakeValueTuple, ValueTuple, )+import LLVM.Extra.Class (MakeValueTuple, ValueTuple, Undefined, ) import LLVM.Core (CodeGenFunction, ) import LLVM.Util.Loop (Phi, ) @@ -24,6 +26,9 @@ import Foreign.Storable (Storable, ) import Foreign.Ptr (Ptr, ) +import Data.Monoid (Monoid, mempty, mappend, )+import Data.Semigroup (Semigroup, (<>), )+ import qualified Number.Ratio as Ratio import qualified Algebra.Field as Field import qualified Algebra.Ring as Ring@@ -71,7 +76,7 @@ Cons (forall r c. (Phi c) =>- context -> local -> state -> Maybe.T r c (a, state))+ context -> local -> state -> MaybeCont.T r c (a, state)) -- compute next value (forall r. CodeGenFunction r local)@@ -173,7 +178,7 @@ Memory.C state) => (forall r c. (Phi c) =>- context -> state -> Maybe.T r c (al, state)) ->+ context -> state -> MaybeCont.T r c (al, state)) -> (forall r. ValueTuple parameters -> CodeGenFunction r (context, state)) ->@@ -228,10 +233,10 @@ Cons (\(parameterA, parameterB) (localA, localB) (sa0,sb0) -> do (a,sa1) <-- Maybe.onFail (stopB parameterB sb0) $+ MaybeCont.onFail (stopB parameterB sb0) $ nextA parameterA localA sa0 (b,sb1) <-- Maybe.onFail (stopA parameterA sa1) $+ MaybeCont.onFail (stopA parameterA sa1) $ nextB parameterB localB sb0 return ((a,b), (sa1,sb1))) (liftM2 (,) allocaA allocaB)@@ -299,6 +304,47 @@ (/) = zipWithSimple A.fdiv +{- |+For restrictions see 'Sig.append'.+-}+append :: (Phi a, Undefined a) => T p a -> T p a -> T p a+append+ (Cons nextA allocaA startA stopA createIOContextA deleteIOContextA)+ (Cons nextB allocaB startB stopB createIOContextB deleteIOContextB) =+ Cons+ (\parameterB (localA, localB) ecs0 -> MaybeCont.fromMaybe $ do+ ecs1 <-+ Either.run ecs0+ (\(ca, sa0) ->+ MaybeCont.resolve+ (nextA ca localA sa0)+ (fmap Either.right $ startB parameterB)+ (\(a1,sa1) -> return (Either.left (a1, (ca, sa1)))))+ (return . Either.right)++ Either.run ecs1+ (\(a1,cs1) ->+ return (Maybe.just (a1, Either.left cs1)))+ (\(cb,sb0) ->+ MaybeCont.toMaybe $+ fmap (\(b,sb1) -> (b, Either.right (cb,sb1))) $+ nextB cb localB sb0))+ (liftM2 (,) allocaA allocaB)+ (\(parameterA, parameterB) -> do+ cs <- startA parameterA+ return (parameterB, Either.left cs))+ (\ _parameterB s -> Either.run s (uncurry stopA) (uncurry stopB))+ (combineCreate createIOContextA createIOContextB)+ (combineDelete deleteIOContextA deleteIOContextB)++instance (Phi a, Undefined a) => Semigroup (T p a) where+ (<>) = append++instance (Phi a, Undefined a) => Monoid (T p a) where+ mempty = Sig.empty+ mappend = append++ iterate :: (Storable ph, MakeValueTuple ph, ValueTuple ph ~ pl, Memory.C pl, Storable a, MakeValueTuple a, ValueTuple a ~ al, Memory.C al) =>@@ -307,7 +353,7 @@ Param.T p a -> T p al iterate f param initial = simple (\pl al0 ->- Maybe.lift $ fmap (\al1 -> (al0,al1)) (f pl al0))+ MaybeCont.lift $ fmap (\al1 -> (al0,al1)) (f pl al0)) return (param &&& initial)
src/Synthesizer/LLVM/Server/CausalPacked/Instrument.hs view
@@ -32,9 +32,12 @@ frequencyControl, zipEnvelope, ) where +import qualified Synthesizer.LLVM.Server.Parameter as ParamS import Synthesizer.LLVM.Server.Packed.Instrument (stereoNoise, ) import Synthesizer.LLVM.Server.CommonPacked import Synthesizer.LLVM.Server.Common hiding (Instrument, )+import Synthesizer.LLVM.Server.Parameter+ (Number(Number), VectorTime(VectorTime), Signal(Signal)) import qualified Synthesizer.LLVM.Server.SampledSound as Sample import qualified Synthesizer.LLVM.Storable.Process as PSt@@ -76,19 +79,18 @@ import qualified Data.StorableVector.Lazy as SVL import qualified Data.StorableVector as SV -import qualified LLVM.Extra.Monad as LM- import qualified LLVM.Core as LLVM import qualified Type.Data.Num.Decimal as TypeNum -import qualified Data.Traversable as Trav+import qualified Control.Monad.HT as M import Control.Arrow (Arrow, arr, first, second, (&&&), (<<^), (^<<), ) import Control.Category (id, (.), ) import Control.Monad (liftM2, liftM3, liftM4, (<=<), ) import Control.Applicative (pure, liftA2, liftA3, )++import qualified Data.Traversable as Trav import Data.Monoid (mappend, )-import Data.Tuple.HT (fst3, snd3, thd3, ) import qualified Number.DimensionTerm as DN @@ -214,18 +216,14 @@ . Gate.allToChunkySize)) (CausalP.processIO $- let vel = number snd- decay = vectorTime fst- in CausalP.fromSignal $- SigPS.exponential2 decay- (fmap amplitudeFromVelocity vel))+ ParamS.withTuple2 $ \(VectorTime decay, Number vel) ->+ CausalP.fromSignal $+ SigPS.exponential2 decay (fmap amplitudeFromVelocity vel)) (CausalP.processIO $- let level = number snd- release = time fst- in CausalP.take (fmap round (vectorTime (const 1)))- .- CausalP.fromSignal- (SigPS.exponential2 release level))+ ParamS.withTuple2 $ \(ParamS.Time release, Number level) ->+ CausalP.take (fmap round (vectorTime (const 1)))+ .+ CausalP.fromSignal (SigPS.exponential2 release level)) pingRelease :: IO (Real -> Real -> Instrument Real Chunk) pingRelease =@@ -681,7 +679,7 @@ arcStringStereoFM wave = softStringShapeCore (\k p ->- LM.liftR2 Frame.amplifyMono+ M.liftJoin2 Frame.amplifyMono (WaveL.approxSine4 =<< WaveL.halfEnvelope p) (wave =<< WaveL.replicate k p)) @@ -902,11 +900,10 @@ IO ((SampleRate Real, ((Real, Real), SigSt.T Real)) -> PIO.T (Zip.T Chunk StereoChunk) StereoChunk) makeHelix =- CausalP.processIO- (let amp = number (fst.fst)- per = number (snd.fst)- smp = signal snd- in CausalPS.amplifyStereo amp+ CausalP.processIO $+ ParamS.withTuple2 $+ \((Number amp, Number per), Signal smp) ->+ CausalPS.amplifyStereo amp . CausalP.stereoFromMono (Helix.staticPacked@@ -917,36 +914,31 @@ . second (CausalPS.osciCore $< 0)) .- arr (\(shape, freq) -> fmap ((,) shape) freq))+ arr (\(shape, freq) -> fmap ((,) shape) freq) makeZigZag :: IO ((SampleRate Real, (Real, Real, Real)) -> PIO.T (Control Real) Chunk) makeZigZag =- CausalP.processIO- (let start = number fst3- loopStart = number snd3- loopLength = number thd3-- in CausalPS.raise start- .- -- CausalPS.pack (Helix.zigZagLong (loopStart-start) loopLength)- Helix.zigZagLongPacked (loopStart-start) loopLength- .- CausalP.mapSimple Serial.upsample)+ CausalP.processIO $+ ParamS.withTuple2 $+ \(Number start, Number loopStart, Number loopLength) ->+ CausalPS.raise start+ .+ -- CausalPS.pack (Helix.zigZagLong (loopStart-start) loopLength)+ Helix.zigZagLongPacked (loopStart-start) loopLength+ .+ CausalP.mapSimple Serial.upsample makeIntegrate :: IO ((SampleRate Real, (Real, Real)) -> PIO.T (Control Real) Chunk) makeIntegrate =- CausalP.processIO- (let start = number fst- stop = number snd-- in CausalPV.takeWhile- (\s v -> s %> Value.lift1 Serial.subsample v)- stop- .- CausalPS.integrate start- .- CausalP.mapSimple Serial.upsample)+ CausalP.processIO $+ ParamS.withTuple2 $+ \(Number start, Number stop) ->+ CausalPV.takeWhile (\s v -> s %> Value.lift1 Serial.subsample v) stop+ .+ CausalPS.integrate start+ .+ CausalP.mapSimple Serial.upsample
src/Synthesizer/LLVM/Server/Packed/Instrument.hs view
@@ -117,8 +117,11 @@ adsr, ) where +import qualified Synthesizer.LLVM.Server.Parameter as ParamS import Synthesizer.LLVM.Server.CommonPacked import Synthesizer.LLVM.Server.Common+import Synthesizer.LLVM.Server.Parameter+ (Number(Number), Signal(Signal), Control(Control)) import qualified Synthesizer.LLVM.Server.SampledSound as Sample import qualified Synthesizer.LLVM.MIDI.BendModulation as BM@@ -148,7 +151,6 @@ import Synthesizer.LLVM.CausalParameterized.Functional (($&), (&|&), ) import Synthesizer.LLVM.Parameter (($#), ) -import qualified LLVM.Extra.Monad as LM import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Core as LLVM import qualified Type.Data.Num.Decimal as TypeNum@@ -160,6 +162,7 @@ import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter +import qualified Control.Monad.HT as M import Control.Arrow ((<<<), (^<<), (<<^), (&&&), (***), arr, first, second, ) import Control.Category (id, ) import Control.Applicative (liftA2, liftA3, )@@ -191,6 +194,15 @@ arr (\(sr, p) -> (\(fm,freq) -> transposeModulation sr freq fm) $ param p) +newtype Modulation p = Modulation (Param p (PC.T (BM.T Real)))++instance ParamS.Tuple (Modulation p) where+ type Composed (Modulation p) = (PC.T (BM.T Real), Real)+ type Source (Modulation p) = p+ decompose sampleRate x =+ Modulation $+ liftA2 (\sr (fm,freq) -> transposeModulation sr freq fm) sampleRate x+ detuneModulation :: (p -> (PC.T Real, PC.T (BM.T Real), Real)) -> Param p (PC.T Real, PC.T (BM.T Real))@@ -199,7 +211,21 @@ case param p of (det,fm,freq) -> (det, transposeModulation sr freq fm) +newtype+ DetuneModulation p =+ DetuneModulation (Param p (PC.T Real, PC.T (BM.T Real))) +instance ParamS.Tuple (DetuneModulation p) where+ type Composed (DetuneModulation p) = (PC.T Real, PC.T (BM.T Real), Real)+ type Source (DetuneModulation p) = p+ decompose sampleRate x =+ DetuneModulation $+ liftA2+ (\sr (det,fm,freq) -> (det, transposeModulation sr freq fm))+ sampleRate x+++ frequencyFromBendModulation :: {- (Storable a,@@ -300,19 +326,18 @@ osc (sr, ((phase, phaseDecay), shape, (detune,fm,freq))) (env dec rel vcsize sr vel dur))- (CausalP.runStorableChunky- (let phase = number (fst.fst3) :: Param ((Real,a), b, c) Real- decay = time (snd.fst3) :: Param ((a,Real), b, c) Real- shape = control snd3 :: Param (a, PC.T Real, c) (PC.T Real)- fm = detuneModulation thd3 :: Param (a, b, (PC.T Real, PC.T (BM.T Real), Real)) (PC.T Real, PC.T (BM.T Real))- in CausalP.envelopeStereo $>+ (CausalP.runStorableChunky $+ ParamS.withTuple2 $+ \((Number phase, ParamS.Time decay),+ Control shape, DetuneModulation fm) ->+ CausalP.envelopeStereo $> ((CausalP.stereoFromMonoControlled (CausalPS.shapeModOsci WaveL.rationalApproxSine1) $< piecewiseConstantVector shape) <<^ Stereo.interleave $< (liftA2 Stereo.cons id (Additive.negate id) $* SigPS.exponential2 decay phase)- $* stereoFrequenciesFromDetuneBendModulation (frequencyConst 10) fm)))+ $* stereoFrequenciesFromDetuneBendModulation (frequencyConst 10) fm)) pingReleaseEnvelope {- |@@ -333,11 +358,9 @@ osc (sr, ((phase, shape), (detune,fm,freq))) (env dec rel vcsize sr vel dur))- (CausalP.runStorableChunky- (let phs = control (fst.fst)- shp = control (snd.fst)- fm = detuneModulation snd- chanOsci ::+ (CausalP.runStorableChunky $+ ParamS.withTuple2 $ \((Control phs, Control shp), DetuneModulation fm) ->+ (let chanOsci :: CausalP p ((VectorValue, VectorValue), VectorValue) VectorValue@@ -373,12 +396,10 @@ (env (dec/4) rel vcsize sr vel dur, env (dec/7) rel vcsize sr vel dur))) (env dec rel vcsize sr vel dur))- (CausalP.runStorableChunky- (let fm = detuneModulation fst3- vel = number snd3- env4 = signal (fst.thd3)- env7 = signal (snd.thd3)- osci ::+ (CausalP.runStorableChunky $+ ParamS.withTuple2 $+ \(DetuneModulation fm, Number vel, (Signal env4, Signal env7)) ->+ (let osci :: (Triple VectorValue -> VectorValue) -> Param.T p Real -> Param.T p Real ->@@ -428,15 +449,12 @@ env (dec/4) rel vcsize sr vel dur, env (dec/7) rel vcsize sr vel dur))) (env dec rel vcsize sr vel dur))- (CausalP.runStorableChunky- (let fm = modulation fst3- noiseAmp = control (fst.snd3)- noiseReson = control (snd.snd3)- vel = number (fst3.thd3)- env4 = signal (snd3.thd3)- env7 = signal (thd3.thd3)-- osci ::+ (CausalP.runStorableChunky $+ ParamS.withTuple2 $+ \(Modulation fm,+ (Control noiseAmp, Control noiseReson),+ (Number vel, Signal env4, Signal env7)) ->+ (let osci :: (Triple VectorValue -> VectorValue) -> Param.T p Real -> Param.T p Real ->@@ -454,14 +472,15 @@ CausalPS.amplify d)) noise ::+ (p ~+ ((PC.T (BM.T Real), Real),+ (PC.T Real, PC.T Real),+ (Real, SigSt.T Vector, SigSt.T Vector))) => (Triple VectorValue -> VectorValue) ->- Param (a, (PC.T Real, PC.T Real), c) Real ->- CausalP (a, (PC.T Real, PC.T Real), c)- (Triple VectorValue, VectorValue)- VectorValue+ Param p Real ->+ CausalP p (Triple VectorValue, VectorValue) VectorValue noise sel d =- (CausalP.envelope $<- piecewiseConstantVector noiseAmp)+ (CausalP.envelope $< piecewiseConstantVector noiseAmp) <<< CausalP.envelope <<<@@ -527,7 +546,8 @@ (2*freq))))) pingReleaseEnvelope -tineStereo :: IO (Real -> Real -> SigSt.ChunkSize -> Instrument Real (Stereo.T Vector))+tineStereo ::+ IO (Real -> Real -> SigSt.ChunkSize -> Instrument Real (Stereo.T Vector)) tineStereo = liftA2 (\osc env dec rel vcsize sr vel freq dur ->@@ -586,8 +606,7 @@ (\osc env sr vel freq dur -> osc (sr, freq) (env 1 sr vel dur)) (let freq = frequency id- osci d =- SigPS.osciSimple WaveL.saw zero (d * freq)+ osci d = SigPS.osciSimple WaveL.saw zero (d * freq) in CausalP.runStorableChunky $ (CausalP.envelopeStereo $> (liftA2 Stereo.cons@@ -596,9 +615,7 @@ softStringReleaseEnvelope -softStringFM ::- IO (PC.T (BM.T Real) ->- Instrument Real (Stereo.T Vector))+softStringFM :: IO (PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector)) softStringFM = liftA2 (\osc env fm sr vel freq dur ->@@ -705,14 +722,12 @@ osc (sr, ((index, depth), vel, (detune,fm,freq))) (env dec rel vcsize sr 0 dur))- (CausalP.runStorableChunky- (let index = control (fst.fst3)- depth = control (snd.fst3)- vel = number snd3- fm = detuneModulation thd3- in CausalP.envelopeStereo $>- (tineControlledFnProc index depth vel $*- stereoFrequenciesFromDetuneBendModulation (frequencyConst 5) fm)))+ (CausalP.runStorableChunky $+ ParamS.withTuple2 $+ \((Control index, Control depth), Number vel, DetuneModulation fm) ->+ CausalP.envelopeStereo $>+ (tineControlledFnProc index depth vel $*+ stereoFrequenciesFromDetuneBendModulation (frequencyConst 5) fm)) pingReleaseEnvelope @@ -786,15 +801,13 @@ osc (sr, (((index, depth), fade), vel, (detune,fm,freq))) (env dec rel vcsize sr 0 dur))- (CausalP.runStorableChunky- (let index = control (fst.fst.fst3)- depth = control (snd.fst.fst3)- fade = control (snd.fst3)- vel = number snd3- fm = detuneModulation thd3- in CausalP.envelopeStereo $>- (fenderProc fade index depth vel $*- stereoFrequenciesFromDetuneBendModulation (frequencyConst 5) fm)))+ (CausalP.runStorableChunky $+ ParamS.withTuple2 $+ \(((Control index, Control depth), Control fade),+ Number vel, DetuneModulation fm) ->+ CausalP.envelopeStereo $>+ (fenderProc fade index depth vel $*+ stereoFrequenciesFromDetuneBendModulation (frequencyConst 5) fm)) pingReleaseEnvelope @@ -830,16 +843,13 @@ depth1 depth2 depth3 depth4 vcsize fm sr vel freq dur -> osc- (sr, ((depth1,(depth2,(depth3,(depth4,())))), vel, (detune,fm,freq)))+ (sr, ((depth1,(depth2,(depth3,(depth4)))), vel, (detune,fm,freq))) (env dec rel vcsize sr 0 dur))- (CausalP.runStorableChunky- (let depth1 = control (fst.fst3)- depth2 = control (fst.snd.fst3)- depth3 = control (fst.snd.snd.fst3)- depth4 = control (fst.snd.snd.snd.fst3)- vel = number snd3- fm = detuneModulation thd3- in CausalP.envelopeStereo $>+ (CausalP.runStorableChunky $+ ParamS.withTuple2 $+ \((Control depth1, (Control depth2, (Control depth3, Control depth4))),+ Number vel, DetuneModulation fm) ->+ (CausalP.envelopeStereo $> (CausalP.stereoFromMono (CausalPS.osciSimple WaveL.approxSine2) <<<@@ -872,22 +882,17 @@ vcsize fm sr vel freq dur -> osc (sr,- ((depth1,(depth2,(depth3,(depth4,())))),- (partial1,(partial2,(partial3,(partial4,())))),+ ((depth1,(depth2,(depth3,(depth4)))),+ (partial1,(partial2,(partial3,(partial4)))), (vel, (detune,fm,freq)))) (env dec rel vcsize sr 0 dur))- (CausalP.runStorableChunky- (let depth1 = control (fst.fst3)- depth2 = control (fst.snd.fst3)- depth3 = control (fst.snd.snd.fst3)- depth4 = control (fst.snd.snd.snd.fst3)- partial1 = control (fst.snd3)- partial2 = control (fst.snd.snd3)- partial3 = control (fst.snd.snd.snd3)- partial4 = control (fst.snd.snd.snd.snd3)- vel = number (fst.thd3)- fm = detuneModulation (snd.thd3)- partial ::+ (CausalP.runStorableChunky $+ ParamS.withTuple2 $+ \((Control depth1, (Control depth2, (Control depth3, Control depth4))),+ (Control partial1,(Control partial2, (Control partial3, Control partial4))),+ (Number vel, DetuneModulation fm)) ->++ (let partial :: VectorValue -> Int -> VectorValue -> LLVM.CodeGenFunction r VectorValue partial amp n t =@@ -979,15 +984,13 @@ osc (sr, ((reson, index, depth), vel, (detune,fm,freq))) (env dec rel vcsize sr 0 dur))- (CausalP.runStorableChunky- (let reson = control (fst3.fst3)- index = control (snd3.fst3)- depth = control (thd3.fst3)- vel = number snd3- fm = detuneModulation thd3- in CausalP.envelopeStereo $>- (resonantFMSynthProc reson index depth vel $*- stereoFrequenciesFromDetuneBendModulation (frequencyConst 5) fm)))+ (CausalP.runStorableChunky $+ ParamS.withTuple2 $+ \((Control reson, Control index, Control depth),+ Number vel, DetuneModulation fm) ->+ CausalP.envelopeStereo $>+ (resonantFMSynthProc reson index depth vel $*+ stereoFrequenciesFromDetuneBendModulation (frequencyConst 5) fm)) pingReleaseEnvelope @@ -1067,7 +1070,7 @@ arcStringStereoFM wave = softStringShapeCore (\k p ->- LM.liftR2 Frame.amplifyMono+ M.liftJoin2 Frame.amplifyMono (WaveL.approxSine4 =<< WaveL.halfEnvelope p) (wave =<< WaveL.replicate k p))
+ src/Synthesizer/LLVM/Server/Parameter.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE TypeFamilies #-}+module Synthesizer.LLVM.Server.Parameter (+ Tuple(..),+ Frequency(..), Time(..), VectorTime(..), Number(..), Control(..), Signal(..),+ withTuple2,+ ) where++import Synthesizer.LLVM.Server.CommonPacked (vectorSize)+import Synthesizer.LLVM.Server.Common (Param, Real, SampleRate(SampleRate))++import qualified Synthesizer.PiecewiseConstant.Signal as PC+import qualified Synthesizer.LLVM.Parameter as Param++import qualified Synthesizer.Storable.Signal as SigSt++import qualified Control.Category as Cat+import Control.Applicative ((<$>), )++import qualified Data.Tuple.HT as TupleHT++import Prelude hiding (Real, )+++class Tuple tuple where+ type Composed tuple :: *+ type Source tuple :: *+ decompose ::+ Param (Source tuple) (SampleRate Real) ->+ Param (Source tuple) (Composed tuple) -> tuple+++newtype Number p = Number (Param p Real)++instance Tuple (Number p) where+ type Composed (Number p) = Real+ type Source (Number p) = p+ decompose _sr t = Number t+++deconsSampleRate :: Param p (SampleRate a) -> Param p a+deconsSampleRate = fmap (\(SampleRate sr) -> sr)++newtype Time p = Time (Param p Real)++instance Tuple (Time p) where+ type Composed (Time p) = Real+ type Source (Time p) = p+ decompose sr t = Time (t * deconsSampleRate sr)++newtype VectorTime p = VectorTime (Param p Real)++instance Tuple (VectorTime p) where+ type Composed (VectorTime p) = Real+ type Source (VectorTime p) = p+ decompose sr t =+ VectorTime (t * deconsSampleRate sr / fromIntegral vectorSize)++newtype Frequency p = Frequency (Param p Real)++instance Tuple (Frequency p) where+ type Composed (Frequency p) = Real+ type Source (Frequency p) = p+ decompose sr freq = Frequency (freq / deconsSampleRate sr)+++newtype Control p = Control (Param p (PC.T Real))++instance Tuple (Control p) where+ type Composed (Control p) = PC.T Real+ type Source (Control p) = p+ decompose _sr x = Control x+++newtype Signal p a = Signal (Param p (SigSt.T a))++instance Tuple (Signal p a) where+ type Composed (Signal p a) = SigSt.T a+ type Source (Signal p a) = p+ decompose _sr x = Signal x+++instance (Tuple a, Tuple b, Source a ~ Source b) => Tuple (a,b) where+ type Composed (a,b) = (Composed a, Composed b)+ type Source (a,b) = Source a+ decompose sr p = (decompose sr $ fst <$> p, decompose sr $ snd <$> p)++instance+ (Tuple a, Tuple b, Tuple c, Source a ~ Source b, Source b ~ Source c) =>+ Tuple (a,b,c) where+ type Composed (a,b,c) = (Composed a, Composed b, Composed c)+ type Source (a,b,c) = Source a+ decompose sr p =+ (decompose sr $ TupleHT.fst3 <$> p,+ decompose sr $ TupleHT.snd3 <$> p,+ decompose sr $ TupleHT.thd3 <$> p)+++withTuple2 ::+ (Tuple tuple, Source tuple ~ p, Composed tuple ~ p) =>+ (tuple -> f (SampleRate Real, p) a b) -> f (SampleRate Real, p) a b+withTuple2 f =+ idFromFunctor2 $ \param -> f $ decompose (fst<$>param) (snd<$>param)++-- cf. Param.idFromFunctor2+idFromFunctor2 :: (Param.T p p -> f p a b) -> f p a b+idFromFunctor2 f = f Cat.id
src/Synthesizer/LLVM/Simple/Signal.hs view
@@ -17,6 +17,10 @@ map, mapAccum, mix,+ mixExt,+ takeWhile,+ empty,+ append, osci, osciPlain, osciSaw,@@ -51,7 +55,7 @@ import qualified LLVM.Extra.Maybe as Maybe import qualified LLVM.Extra.Arithmetic as A import LLVM.Extra.Arithmetic (advanceArrayElementPtr, )-import LLVM.Extra.Class (MakeValueTuple, ValueTuple, valueTupleOf, )+import LLVM.Extra.Class (Undefined, MakeValueTuple, ValueTuple, valueTupleOf, ) import qualified LLVM.Core as LLVM import LLVM.Util.Loop (Phi, )@@ -60,8 +64,10 @@ IsSized, IsConst, IsArithmetic) import Control.Monad (liftM2, )-import Control.Applicative (pure, liftA3, (<$>), )+import Control.Applicative (pure, liftA2, liftA3, (<$>), ) +import Data.Monoid (Monoid, mappend, )+ import qualified Algebra.Transcendental as Trans import qualified System.Unsafe as Unsafe@@ -73,7 +79,7 @@ import Control.Exception (bracket, ) import NumericPrelude.Numeric-import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, )+import NumericPrelude.Base hiding (and, iterate, map, zip, zipWith, takeWhile, ) constant :: (C signal, IsConst a) => a -> signal (Value a)@@ -95,12 +101,56 @@ (stop . fst)) +{- |+Warning:+This shortens the result to the shorter input signal.+This is consistent with @Causal.mix@ but it may not be what you expect.+Consider using 'mixExt' instead.+-} mix :: (C signal, A.Additive a) => signal a -> signal a -> signal a mix = zipWith Frame.mix +{- |+The result of mixing is as long as the longer of the two input signals.+-}+mixExt ::+ (C signal, Monoid (signal (Value Bool, a)),+ A.Additive a, Phi a, Undefined a) =>+ signal a -> signal a -> signal a+mixExt xs ys =+ let ext zs =+ mappend+ ((,) (valueOf True) <$> zs)+ (pure (valueOf False, A.zero))+ in fmap snd $ takeWhile (return . fst) $+ zipWith+ (\(cx,x) (cy,y) -> liftA2 (,) (A.or cx cy) (A.add x y))+ (ext xs) (ext ys) ++{-+You can apply Causal.takeWhile instead,+but this requires a pretty complex type signature+including a 'process' variable that is not of interest for the user.+-}+takeWhile ::+ (C signal) =>+ (forall r. a -> CodeGenFunction r (Value Bool)) ->+ signal a -> signal a+takeWhile p =+ alter+ (\(Core next start stop) ->+ Core+ (\context sa0 -> do+ (a,sa1) <- next context sa0+ MaybeCont.guard =<< MaybeCont.lift (p a)+ return (a,sa1))+ start+ stop)++ envelope :: (C signal, A.PseudoRing a) => signal a -> signal a -> signal a@@ -260,7 +310,7 @@ compile (next $ valueTupleOf params) alloca (start $ valueTupleOf params) fmap (fromIntegral :: Word32 -> Int) $- fill (fromIntegral len) (Memory.castStorablePtr ptr)+ fill (fromIntegral len) (Memory.castTuplePtr ptr) foreign import ccall safe "dynamic" derefStartPtr ::@@ -336,7 +386,7 @@ SVB.createAndTrim size $ fmap (fromIntegral :: Word32 -> Int) . fill sptr (fromIntegral size) .- Memory.castStorablePtr+ Memory.castTuplePtr touchForeignPtr ioContextPtr (if SV.length v > 0 then fmap (v:)
src/Synthesizer/LLVM/Simple/SignalPrivate.hs view
@@ -3,16 +3,17 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-}-{-# LANGUAGE ForeignFunctionInterface #-} module Synthesizer.LLVM.Simple.SignalPrivate where import qualified Synthesizer.LLVM.Storable.ChunkIterator as ChunkIt import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.MaybeContinuation as MaybeCont+import qualified LLVM.Extra.Either as Either+import qualified LLVM.Extra.Maybe as Maybe import qualified LLVM.Extra.Arithmetic as A import LLVM.Extra.Control (ifThen, )-import LLVM.Extra.Class (MakeValueTuple, ValueTuple, )+import LLVM.Extra.Class (MakeValueTuple, ValueTuple, Undefined, ) import qualified LLVM.Core as LLVM import LLVM.Util.Loop (Phi, )@@ -26,6 +27,8 @@ import Foreign.StablePtr (StablePtr, ) import Foreign.Ptr (Ptr, nullPtr, ) +import Data.Monoid (Monoid, mempty, mappend, )+import Data.Semigroup (Semigroup, (<>), ) import Data.Word (Word32, ) import qualified Number.Ratio as Ratio@@ -236,6 +239,63 @@ instance (A.Field a, A.Real a, A.RationalConstant a) => P.Fractional (T a) where fromRational x = pure (A.fromRational' x) (/) = zipWith A.fdiv++++empty :: (C signal) => signal a+empty = simple (const $ MaybeCont.nothing) (return ())++{- |+Appending many signals is inefficient,+since in cascadingly appended signals the parts are counted in an unary way.+Concatenating infinitely many signals is impossible.+If you want to concatenate a lot of signals,+please render them to lazy storable vectors first.+-}+{-+We might save a little space by using a union+for the states of the first and the second signal generator.+If the concatenated generators allocate memory,+we could also save some memory by calling @startB@+only after the first generator finished.+However, for correct deallocation+we would need to track which of the @start@ blocks+have been executed so far.+This in turn might be difficult in connection with the garbage collector.+-}+append :: (Phi a, Undefined a) => T a -> T a -> T a+append+ (Cons nextA allocaA startA createIOContextA deleteIOContextA)+ (Cons nextB allocaB startB createIOContextB deleteIOContextB) =+ Cons+ (\(parameterA, parameterB) (localA, localB) es0 ->+ MaybeCont.fromMaybe $ do+ es1 <-+ Either.run es0+ (\sa0 ->+ MaybeCont.resolve+ (nextA parameterA localA sa0)+ (fmap Either.right $ startB parameterB)+ (\(a1,sa1) -> return (Either.left (a1, sa1))))+ (return . Either.right)++ Either.run es1+ (\(a1,s1) -> return (Maybe.just (a1, Either.left s1)))+ (\sb0 ->+ MaybeCont.toMaybe $+ fmap (\(b,sb1) -> (b, Either.right sb1)) $+ nextB parameterB localB sb0))+ (liftM2 (,) allocaA allocaB)+ (\(parameterA, _parameterB) -> Either.left <$> startA parameterA)+ (combineCreate createIOContextA createIOContextB)+ (combineDelete deleteIOContextA deleteIOContextB)++instance (Phi a, Undefined a) => Semigroup (T a) where+ (<>) = append++instance (Phi a, Undefined a) => Monoid (T a) where+ mempty = empty+ mappend = append
src/Synthesizer/LLVM/Storable/ChunkIterator.hs view
@@ -74,4 +74,4 @@ SVB.withStartPtr x (\p l -> poke lenPtr (fromIntegral l) >>- return (Memory.castStorablePtr p))+ return (Memory.castTuplePtr p))
src/Synthesizer/LLVM/Storable/Signal.hs view
@@ -148,7 +148,7 @@ -- IO (Word32 -> Ptr struct -> Ptr struct -> IO ()) makeReverser rev = fmap (\f len srcPtr dstPtr ->- f len (Memory.castStorablePtr srcPtr) (Memory.castStorablePtr dstPtr)) $+ f len (Memory.castTuplePtr srcPtr) (Memory.castTuplePtr dstPtr)) $ Exec.compileModule $ Exec.createFunction derefMixPtr "reverse" $ \ size ptrA ptrB -> do ptrAEnd <- getElementPtr ptrA (size, ())@@ -276,7 +276,7 @@ (MakeValueTuple a, ValueTuple a ~ value, Memory.C value) => value -> IO (Word32 -> Ptr a -> IO ()) fillBuffer x =- fmap (\f len ptr -> f len (Memory.castStorablePtr ptr)) $+ fmap (\f len ptr -> f len (Memory.castTuplePtr ptr)) $ Exec.compileModule $ Exec.createFunction derefFillPtr "constantfill" $ \ size ptr -> do arrayLoop size ptr () $ \ ptri () -> do@@ -294,7 +294,7 @@ IO (Word32 -> Ptr a -> Ptr a -> IO ()) makeMixer add = fmap (\f len srcPtr dstPtr ->- f len (Memory.castStorablePtr srcPtr) (Memory.castStorablePtr dstPtr)) $+ f len (Memory.castTuplePtr srcPtr) (Memory.castTuplePtr dstPtr)) $ Exec.compileModule $ Exec.createFunction derefMixPtr "mix" $ \ size srcPtr dstPtr -> do _ <- arrayLoop size srcPtr dstPtr $ \ srcPtri dstPtri -> do
src/Synthesizer/LLVM/Storable/Vector.hs view
@@ -21,5 +21,5 @@ unsafeToPointers v = let (fp,s,l) = SVB.toForeignPtr v in (fp,- Memory.castStorablePtr $ Unsafe.foreignPtrToPtr fp `advancePtr` s,+ Memory.castTuplePtr $ Unsafe.foreignPtrToPtr fp `advancePtr` s, l)
src/Synthesizer/LLVM/Wave.hs view
@@ -5,10 +5,10 @@ import qualified Synthesizer.LLVM.Simple.Value as Value import qualified LLVM.Extra.Arithmetic as A-import qualified LLVM.Extra.Monad as M import LLVM.Core (CodeGenFunction, ) +import qualified Control.Monad.HT as M import Control.Monad.HT ((<=<), ) import NumericPrelude.Numeric@@ -120,7 +120,7 @@ A.square =<< A.mul t =<< A.sub (A.fromInteger' 1) t- M.liftR2 A.fdiv+ M.liftJoin2 A.fdiv (A.sub num2 den2) (A.add num2 den2) @@ -132,9 +132,9 @@ den <- A.mul t =<< A.sub (A.fromInteger' 1) t- M.liftR2 A.fdiv+ M.liftJoin2 A.fdiv (A.mul (A.fromInteger' (-2)) =<< A.mul num den)- (M.liftR2 A.add (A.square num) (A.square den))+ (M.liftJoin2 A.add (A.square num) (A.square den)) trapezoidSkew ::
synthesizer-llvm.cabal view
@@ -1,5 +1,5 @@ Name: synthesizer-llvm-Version: 0.8.1.2+Version: 0.8.2 License: GPL License-File: LICENSE Author: Henning Thielemann <haskell@henning-thielemann.de>@@ -39,7 +39,7 @@ should be especially useful for an introduction. Stability: Experimental Tested-With: GHC==7.4.2, GHC==7.6.3, GHC==7.8.4, GHC==7.10.1-Cabal-Version: >=1.14+Cabal-Version: 1.14 Build-Type: Simple Extra-Source-Files: Changes.md@@ -57,7 +57,7 @@ default: False Source-Repository this- Tag: 0.8.1.2+ Tag: 0.8.2 Type: darcs Location: http://code.haskell.org/synthesizer/llvm/ @@ -68,9 +68,7 @@ Library Build-Depends:- llvm-extra >=0.7 && <0.8,- -- llvm must be imported with restrictive version bounds,- -- because we import implicitly and unqualified+ llvm-extra >=0.8 && <0.9, llvm-tf >=3.1 && <3.2, tfp >=1.0 && <1.1, vault >=0.3 && <0.4,@@ -88,9 +86,10 @@ event-list >=0.1 && <0.2, pathtype >=0.8 && <0.9, random >=1.0 && <1.2,- containers >=0.1 && <0.6,+ containers >=0.1 && <0.7, transformers >=0.2 && <0.6,- utility-ht >=0.0.12 && <0.1+ semigroups >=0.1 && <1.0,+ utility-ht >=0.0.14 && <0.1 Build-Depends: -- base-4 needed for Control.Category@@ -166,6 +165,7 @@ Synthesizer.LLVM.Server.SampledSound Synthesizer.LLVM.Server.Common Synthesizer.LLVM.Server.CommonPacked+ Synthesizer.LLVM.Server.Parameter Other-Modules: Synthesizer.LLVM.ConstantPiece@@ -210,7 +210,7 @@ non-negative >=0.1 && <0.2, event-list >=0.1 && <0.2, random,- containers >=0.1 && <0.6,+ containers >=0.1 && <0.7, transformers, non-empty, utility-ht,@@ -220,7 +220,8 @@ Buildable: False Default-Language: Haskell98 GHC-Options: -Wall- GHC-Prof-Options: -auto-all+ GHC-Options: -pgmlg+++ GHC-Prof-Options: -fprof-auto-exported If impl(ghc>=7.0) GHC-Options: -fwarn-unused-do-bind CPP-Options: -DNoImplicitPrelude=RebindableSyntax@@ -254,7 +255,7 @@ non-negative >=0.1 && <0.2, event-list >=0.1 && <0.2, random,- containers >=0.1 && <0.6,+ containers >=0.1 && <0.7, transformers, non-empty, utility-ht,@@ -267,7 +268,8 @@ Buildable: False Default-Language: Haskell98 GHC-Options: -Wall- GHC-Prof-Options: -auto-all+ GHC-Options: -pgmlg+++ GHC-Prof-Options: -fprof-auto-exported If impl(ghc>=7.0) GHC-Options: -fwarn-unused-do-bind CPP-Options: -DNoImplicitPrelude=RebindableSyntax@@ -298,9 +300,10 @@ numeric-prelude >=0.3 && <0.5, non-negative >=0.1 && <0.2, event-list >=0.1 && <0.2,+ shell-utility >=0.0 && <0.1, pathtype >=0.8 && <0.9,- optparse-applicative >=0.11 && <0.13,- containers >=0.1 && <0.6,+ optparse-applicative >=0.11 && <0.15,+ containers >=0.1 && <0.7, transformers, utility-ht, @@ -314,8 +317,9 @@ Default-Language: Haskell98 -- -threaded -debug GHC-Options: -Wall+ GHC-Options: -pgmlg++ GHC-Options: -rtsopts- GHC-Prof-Options: -auto-all+ GHC-Prof-Options: -fprof-auto-exported If impl(ghc>=7.0) GHC-Options: -fwarn-unused-do-bind CPP-Options: -DNoImplicitPrelude=RebindableSyntax@@ -360,9 +364,10 @@ random, explicit-exception >=0.1.7 && <0.2, event-list >=0.1 && <0.2,+ shell-utility >=0.0 && <0.1, pathtype >=0.8 && <0.9,- optparse-applicative >=0.11 && <0.13,- containers >=0.1 && <0.6,+ optparse-applicative >=0.11 && <0.15,+ containers >=0.1 && <0.7, transformers, utility-ht, @@ -373,8 +378,9 @@ Default-Language: Haskell98 -- -threaded -debug GHC-Options: -Wall+ GHC-Options: -pgmlg++ GHC-Options: -rtsopts- GHC-Prof-Options: -auto-all+ GHC-Prof-Options: -fprof-auto-exported If impl(ghc>=7.0) GHC-Options: -fwarn-unused-do-bind CPP-Options: -DNoImplicitPrelude=RebindableSyntax@@ -406,9 +412,10 @@ non-negative >=0.1 && <0.2, explicit-exception >=0.1.7 && <0.2, event-list >=0.1 && <0.2,+ shell-utility >=0.0 && <0.1, pathtype >=0.8 && <0.9,- optparse-applicative >=0.11 && <0.13,- containers >=0.1 && <0.6,+ optparse-applicative >=0.11 && <0.15,+ containers >=0.1 && <0.7, transformers, utility-ht, @@ -419,8 +426,9 @@ Default-Language: Haskell98 -- -threaded -debug GHC-Options: -Wall+ GHC-Options: -pgmlg++ GHC-Options: -rtsopts- GHC-Prof-Options: -auto-all+ GHC-Prof-Options: -fprof-auto-exported If impl(ghc>=7.0) GHC-Options: -fwarn-unused-do-bind CPP-Options: -DNoImplicitPrelude=RebindableSyntax@@ -448,7 +456,8 @@ Else Buildable: False Default-Language: Haskell98- GHC-Options: -Wall+ GHC-Options: -Wall+ GHC-Options: -pgmlg++ If impl(ghc>=7.0) GHC-Options: -fwarn-unused-do-bind CPP-Options: -DNoImplicitPrelude=RebindableSyntax@@ -475,7 +484,8 @@ Else Buildable: False Default-Language: Haskell98- GHC-Options: -Wall+ GHC-Options: -Wall+ GHC-Options: -pgmlg++ If impl(ghc>=7.0) GHC-Options: -fwarn-unused-do-bind CPP-Options: -DNoImplicitPrelude=RebindableSyntax@@ -503,7 +513,8 @@ QuickCheck >=1 && <3, base >=4 && <5 Default-Language: Haskell98- GHC-Options: -Wall+ GHC-Options: -Wall+ GHC-Options: -pgmlg++ If impl(ghc>=7.0) GHC-Options: -fwarn-unused-do-bind CPP-Options: -DNoImplicitPrelude=RebindableSyntax@@ -520,3 +531,4 @@ Test.Synthesizer.LLVM.Filter Test.Synthesizer.LLVM.Packed Test.Synthesizer.LLVM.Utility+ Test.Synthesizer.LLVM.Generator
testsuite/Test/Synthesizer/LLVM/Filter.hs view
@@ -43,16 +43,19 @@ import qualified Synthesizer.Basic.Phase as Phase import qualified Data.StorableVector.Lazy as SVL-import qualified Data.StorableVector as SV-import Data.StorableVector.Lazy (ChunkSize, ) +import qualified Test.Synthesizer.LLVM.Generator as Gen+import Test.Synthesizer.LLVM.Generator+ (checkWithParam, arg, pair, withGenArgs, ) import Test.Synthesizer.LLVM.Utility- (checkSimilarity, checkSimilarityState, rangeFromInt,- CheckSimilarity, CheckSimilarityState, )+ (checkSimilarity, checkSimilarityState,+ CheckSimilarity, CheckSimilarityState,+ randomStorableVector, checkSimilarityPacked, ) import qualified Control.Category as Cat import Control.Category ((<<<), )-import Control.Arrow (arr, (&&&), (***), (^<<), (<<^), )+import Control.Arrow ((&&&), (^<<), (<<^), )+import Control.Applicative (liftA2, (<$>), ) import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Memory as Memory@@ -70,7 +73,7 @@ import qualified System.Random as Rnd import Data.Word (Word32, ) -import Test.QuickCheck (quickCheck, )+import qualified Test.QuickCheck as QC import NumericPrelude.Numeric import NumericPrelude.Base@@ -128,12 +131,26 @@ $< allpassControl order reduct $* xs) -allpassPipeline :: IO (ChunkSize -> ((Int,Int), Int) -> SimFloat)++genOsci :: Gen.T (Param.T p) (Float, Float) (Param.T p Float, Param.T p Float)+genOsci = pair (Gen.choose (0.001, 0.01)) (Gen.choose (0, 0.99))++genOsciReduct ::+ Gen.T+ (Param.T p) ((Float, Float), Float)+ ((Param.T p Float, Param.T p Float), Param.T p Float)+genOsciReduct = pair genOsci (Gen.choose (10, 100))++genOsciReductPacked ::+ Gen.T+ (Param.T p) ((Float, Float), Float)+ ((Param.T p Float, Param.T p Float), Param.T p Float)+genOsciReductPacked = pair genOsci (arg $ (4*) <$> QC.choose (1, 25))++allpassPipeline :: Gen.Test ((Float,Float), Float) SimFloat allpassPipeline =- let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst- phase = rangeFromInt (0, 0.99 :: Float) <<^ snd . fst- reduct = rangeFromInt (10, 100) <<^ snd- tone = SigP.osciSimple Wave.triangle phase freq+ withGenArgs genOsciReduct $ \((freq,phase), reduct) ->+ let tone = SigP.osciSimple Wave.triangle phase freq in checkSimilarity 1e-2 limitFloat (allpassPhaserCausal reduct tone) (allpassPhaserPipeline reduct tone)@@ -165,16 +182,14 @@ applyPacked Allpass.phaserPacked (allpassControl TypeNum.d16 reduct) -allpassPacked :: IO (ChunkSize -> ((Int,Int), Int) -> SimFloat)+allpassPacked :: Gen.Test ((Float,Float), Float) SimFloat allpassPacked =- let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst- phase = rangeFromInt (0, 0.99) <<^ snd . fst- reduct = (4*) ^<< rangeFromInt (1, 25) <<^ snd- tone = SigP.osciSimple Wave.triangle phase freq+ withGenArgs genOsciReductPacked $ \((freq,phase), reduct) ->+ let tone = SigP.osciSimple Wave.triangle phase freq toneP = SigPS.osciSimple Wave.triangle phase freq- in checkSimilarity 1e-2 limitFloat+ in checkSimilarityPacked 1e-2 limitFloat (allpassPhaserCausal reduct tone)- (SigPS.unpack $ allpassPhaserPacked reduct toneP)+ (allpassPhaserPacked reduct toneP) interpolateConstant :: Float -> SigS.T a -> SigS.T a@@ -209,12 +224,10 @@ &&& Cat.id) -allpassCore :: IO (ChunkSize -> ((Int,Int), Int) -> SimStateFloat)+allpassCore :: Gen.Test ((Float,Float), Float) SimStateFloat allpassCore =- let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst- phase = rangeFromInt (0, 0.99) <<^ snd . fst- reduct = rangeFromInt (10, 100) <<^ snd- tone = SigP.osciSimple Wave.triangle phase freq+ withGenArgs genOsciReduct $ \((freq,phase), reduct) ->+ let tone = SigP.osciSimple Wave.triangle phase freq toneS p = OsciS.static WaveCore.triangle (Phase.fromRepresentative (Param.get phase p)) (Param.get freq p)@@ -238,10 +251,10 @@ $< SigP.constant (FirstOrderCore.parameter ^<< cutOff) $* xs -firstOrderExponential :: IO (ChunkSize -> (Int,Int) -> SimFloat)+firstOrderExponential :: Gen.Test Float SimFloat firstOrderExponential =- let cutOff = rangeFromInt (0.001, 0.01) <<^ fst- gain = exp(-2*pi*cutOff)+ withGenArgs (Gen.choose (0.001, 0.01)) $ \cutOff ->+ let gain = exp(-2*pi*cutOff) in checkSimilarity 1e-2 limitFloat (SigP.amplify (recip (1 - gain)) $ firstOrderConstant cutOff diracImpulse)@@ -266,12 +279,10 @@ CausalS.applyFst FirstOrderCore.lowpassCausal $ lfoSineCore FirstOrderCore.parameter reduct -firstOrder :: IO (ChunkSize -> ((Int,Int), Int) -> SimStateFloat)+firstOrder :: Gen.Test ((Float,Float), Float) SimStateFloat firstOrder =- let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst- phase = rangeFromInt (0, 0.99) <<^ snd . fst- reduct = rangeFromInt (10, 100) <<^ snd- tone = SigP.osciSimple Wave.triangle phase freq+ withGenArgs genOsciReduct $ \((freq,phase), reduct) ->+ let tone = SigP.osciSimple Wave.triangle phase freq toneS p = OsciS.static WaveCore.triangle (Phase.fromRepresentative (Param.get phase p)) (Param.get freq p)@@ -288,16 +299,14 @@ FirstOrder.lowpassCausalPacked (lfoSine FirstOrder.parameter reduct) -firstOrderPacked :: IO (ChunkSize -> ((Int,Int), Int) -> SimFloat)+firstOrderPacked :: Gen.Test ((Float,Float), Float) SimFloat firstOrderPacked =- let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst- phase = rangeFromInt (0, 0.99) <<^ snd . fst- reduct = (4*) ^<< rangeFromInt (1, 25) <<^ snd- tone = SigP.osciSimple Wave.triangle phase freq+ withGenArgs genOsciReductPacked $ \((freq,phase), reduct) ->+ let tone = SigP.osciSimple Wave.triangle phase freq toneP = SigPS.osciSimple Wave.triangle phase freq- in checkSimilarity 1e-2 limitFloat+ in checkSimilarityPacked 1e-2 limitFloat (firstOrderCausal reduct tone)- (SigPS.unpack $ firstOrderCausalPacked reduct toneP)+ (firstOrderCausalPacked reduct toneP) secondOrderCausal ::@@ -317,16 +326,14 @@ applyPacked SecondOrder.causalPacked (lfoSine (SecondOrder.bandpassParameter (LLVM.valueOf (10::Float))) reduct) -secondOrderPacked :: IO (ChunkSize -> ((Int,Int), Int) -> SimFloat)+secondOrderPacked :: Gen.Test ((Float,Float), Float) SimFloat secondOrderPacked =- let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst- phase = rangeFromInt (0, 0.99) <<^ snd . fst- reduct = (4*) ^<< rangeFromInt (1, 25) <<^ snd- tone = SigP.osciSimple Wave.triangle phase freq+ withGenArgs genOsciReductPacked $ \((freq,phase), reduct) ->+ let tone = SigP.osciSimple Wave.triangle phase freq toneP = SigPS.osciSimple Wave.triangle phase freq- in checkSimilarity 1e-2 limitFloat+ in checkSimilarityPacked 1e-2 limitFloat (secondOrderCausal reduct tone)- (SigPS.unpack $ secondOrderCausalPacked reduct toneP)+ (secondOrderCausalPacked reduct toneP) secondOrderCausalPacked2 :: Param.T p Float ->@@ -337,12 +344,10 @@ $< lfoSine (SecondOrderP.bandpassParameter (LLVM.valueOf (10::Float))) reduct $* xs -secondOrderPacked2 :: IO (ChunkSize -> ((Int,Int), Int) -> SimFloat)+secondOrderPacked2 :: Gen.Test ((Float,Float), Float) SimFloat secondOrderPacked2 =- let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst- phase = rangeFromInt (0, 0.99 :: Float) <<^ snd . fst- reduct = rangeFromInt (10, 100) <<^ snd- tone = SigP.osciSimple Wave.triangle phase freq+ withGenArgs genOsciReduct $ \((freq,phase), reduct) ->+ let tone = SigP.osciSimple Wave.triangle phase freq in checkSimilarity 1e-2 limitFloat (secondOrderCausal reduct tone) (secondOrderCausalPacked2 reduct tone)@@ -374,12 +379,10 @@ CausalS.applyFst UniFilterCore.causal $ lfoSineCore (UniFilterCore.parameter . Pole 10) reduct -universal :: IO (ChunkSize -> ((Int,Int), Int) -> SimStateFloat)+universal :: Gen.Test ((Float,Float), Float) SimStateFloat universal =- let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst- phase = rangeFromInt (0, 0.99) <<^ snd . fst- reduct = rangeFromInt (10, 100) <<^ snd- tone = SigP.osciSimple Wave.triangle phase freq+ withGenArgs genOsciReduct $ \((freq,phase), reduct) ->+ let tone = SigP.osciSimple Wave.triangle phase freq toneS p = OsciS.static WaveCore.triangle (Phase.fromRepresentative (Param.get phase p)) (Param.get freq p)@@ -418,12 +421,10 @@ CausalS.applyFst (MoogCore.lowpassCausal order) $ lfoSineCore (MoogCore.parameter order . Pole 10) reduct -moog :: IO (ChunkSize -> ((Int,Int), Int) -> SimStateFloat)+moog :: Gen.Test ((Float,Float), Float) SimStateFloat moog =- let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst- phase = rangeFromInt (0, 0.99) <<^ snd . fst- reduct = rangeFromInt (10, 100) <<^ snd- order = TypeNum.d6+ withGenArgs genOsciReduct $ \((freq,phase), reduct) ->+ let order = TypeNum.d6 tone = SigP.osciSimple Wave.triangle phase freq toneS p = OsciS.static WaveCore.triangle@@ -453,12 +454,10 @@ $< lfoSine (ComplexFilterP.parameter (LLVM.valueOf (10::Float))) reduct) <<^ (\x -> Stereo.cons x A.zero) -complexPacked :: IO (ChunkSize -> ((Int,Int), Int) -> SimFloat)+complexPacked :: Gen.Test ((Float,Float), Float) SimFloat complexPacked =- let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst- phase = rangeFromInt (0, 0.99 :: Float) <<^ snd . fst- reduct = rangeFromInt (10, 100) <<^ snd- tone = SigP.osciSimple Wave.triangle phase freq+ withGenArgs genOsciReduct $ \((freq,phase), reduct) ->+ let tone = SigP.osciSimple Wave.triangle phase freq in checkSimilarity 1e-2 limitFloat (fmap Stereo.left $ complexCausal reduct tone)@@ -476,12 +475,10 @@ CausalS.applyFst ComplexFilterCore.causal (lfoSineCore (ComplexFilterCore.parameter . Pole 10) reduct) -complex :: IO (ChunkSize -> ((Int,Int), Int) -> SimStateFloat)+complex :: Gen.Test ((Float,Float), Float) SimStateFloat complex =- let freq = rangeFromInt (0.001, 0.01) <<^ fst . fst- phase = rangeFromInt (0, 0.99) <<^ snd . fst- reduct = rangeFromInt (10, 100) <<^ snd- tone = SigP.osciSimple Wave.triangle phase freq+ withGenArgs genOsciReduct $ \((freq,phase), reduct) ->+ let tone = SigP.osciSimple Wave.triangle phase freq toneS p = OsciS.static WaveCore.triangle (Phase.fromRepresentative (Param.get phase p)) (Param.get freq p)@@ -498,34 +495,35 @@ -} -convolvePacked :: IO (ChunkSize -> ((Int,Int), Word32) -> SimFloat)+convolvePacked :: Gen.Test ((Int,Rnd.StdGen), Word32) SimFloat convolvePacked =- let mask =- (\(len, seed) ->- fst $ SV.packN len $ Rnd.randomRs (-1,1::Float) seed)- ^<< rangeFromInt (1,20) *** arr Rnd.mkStdGen <<^ fst- noise = SigP.noise (arr snd) 1- noiseP = SigPS.noise (arr snd) 1- unpack :: SigP.T p VectorValue -> SigP.T p (Value Float)- unpack = SigPS.unpack- in checkSimilarity 1e-3 limitFloat+ withGenArgs+ (pair+ (arg $ liftA2 (,) (QC.choose (1,20)) (Rnd.mkStdGen <$> QC.arbitrary))+ Gen.arbitrary)+ $+ \(rnd, seed) ->+ let mask = randomStorableVector (-1,1::Float) <$> rnd+ noise = SigP.noise seed 1+ noiseP = SigPS.noise seed 1+ in checkSimilarityPacked 1e-3 limitFloat (FiltNR.convolve mask $* noise)- (unpack $ (FiltNR.convolvePacked mask $* noiseP))+ (FiltNR.convolvePacked mask $* noiseP) tests :: [(String, IO ())] tests =- ("secondOrderPacked", quickCheck =<< secondOrderPacked) :- ("secondOrderPacked2", quickCheck =<< secondOrderPacked2) :- ("firstOrderExponential", quickCheck =<< firstOrderExponential) :- ("firstOrder", quickCheck =<< firstOrder) :- ("firstOrderPacked", quickCheck =<< firstOrderPacked) :- ("universal", quickCheck =<< universal) :- ("allpassPacked", quickCheck =<< allpassPacked) :- ("allpassPipeline", quickCheck =<< allpassPipeline) :- ("allpassCore", quickCheck =<< allpassCore) :- ("moog", quickCheck =<< moog) :- ("complexPacked", quickCheck =<< complexPacked) :- ("complex", quickCheck =<< complex) :- ("convolvePacked", quickCheck =<< convolvePacked) :+ ("secondOrderPacked", checkWithParam secondOrderPacked) :+ ("secondOrderPacked2", checkWithParam secondOrderPacked2) :+ ("firstOrderExponential", checkWithParam firstOrderExponential) :+ ("firstOrder", checkWithParam firstOrder) :+ ("firstOrderPacked", checkWithParam firstOrderPacked) :+ ("universal", checkWithParam universal) :+ ("allpassPacked", checkWithParam allpassPacked) :+ ("allpassPipeline", checkWithParam allpassPipeline) :+ ("allpassCore", checkWithParam allpassCore) :+ ("moog", checkWithParam moog) :+ ("complexPacked", checkWithParam complexPacked) :+ ("complex", checkWithParam complex) :+ ("convolvePacked", checkWithParam convolvePacked) : []
+ testsuite/Test/Synthesizer/LLVM/Generator.hs view
@@ -0,0 +1,64 @@+module Test.Synthesizer.LLVM.Generator where++import qualified Synthesizer.LLVM.Parameter as Param+import qualified Synthesizer.LLVM.CausalParameterized.Functional as F++import Data.StorableVector.Lazy (ChunkSize, )++import System.Random (Random, )++import Control.Category (id, )+import Control.Applicative (liftA2, liftA3, )++import qualified Test.QuickCheck as QC++import Prelude hiding (id, )+++data T f p a = Cons (QC.Gen p) (F.PrepareArguments f p a)++arg :: QC.Gen a -> T f a (f a)+arg gen = Cons gen F.atomArg++arbitrary :: (QC.Arbitrary a) => T f a (f a)+arbitrary = arg QC.arbitrary++choose :: (Random a) => (a,a) -> T f a (f a)+choose rng = arg $ QC.choose rng+++pair ::+ (Functor f) =>+ T f a0 b0 ->+ T f a1 b1 ->+ T f (a0,a1) (b0,b1)+pair (Cons g0 p0) (Cons g1 p1) =+ Cons (liftA2 (,) g0 g1) (F.pairArgs p0 p1)++triple ::+ (Functor f) =>+ T f a0 b0 ->+ T f a1 b1 ->+ T f a2 b2 ->+ T f (a0,a1,a2) (b0,b1,b2)+triple (Cons g0 p0) (Cons g1 p1) (Cons g2 p2) =+ Cons (liftA3 (,,) g0 g1 g2) (F.tripleArgs p0 p1 p2)++withGenArgs ::+ T (Param.T p) p a ->+ (a -> IO (ChunkSize -> p -> test)) -> Test p test+withGenArgs (Cons gen prepArgs) f =+ (gen, withPreparedArgs prepArgs f)+++withPreparedArgs ::+ F.PrepareArguments (Param.T p) p a -> (a -> test) -> test+withPreparedArgs (F.PrepareArguments prepare) f = f $ prepare id+++type Test p test = (QC.Gen p, IO (ChunkSize -> p -> test))++checkWithParam :: (Show p, QC.Testable test) => Test p test -> IO ()+checkWithParam (gen, test) = do+ f <- test+ QC.quickCheck (QC.forAll gen $ flip f)
testsuite/Test/Synthesizer/LLVM/Helix.hs view
@@ -18,12 +18,13 @@ import qualified Data.StorableVector as SV import Data.StorableVector.Lazy (ChunkSize, ) +import Test.Synthesizer.LLVM.Generator (withPreparedArgs, checkWithParam, ) import Test.Synthesizer.LLVM.Utility- (CheckSimilarity, checkSimilarity, rangeFromInt, )+ (CheckSimilarity, checkSimilarity,+ genRandomVectorParam, randomSignal, ) -import Control.Category ((<<<), )-import Control.Arrow (arr, (***), (^<<), (<<^), )-import Control.Applicative (pure, )+import Control.Arrow (arr, )+import Control.Applicative (pure, liftA2, ) import LLVM.Core (Value, ) @@ -33,7 +34,7 @@ import Data.Word (Word32, ) -- import qualified Graphics.Gnuplot.Simple as Gnuplot-import Test.QuickCheck (quickCheck, )+import qualified Test.QuickCheck as QC import NumericPrelude.Numeric import NumericPrelude.Base@@ -49,32 +50,29 @@ limitFloat = SVL.take signalLength -randomSpeed :: Param.T p (Int, Int) -> SigP.T p (Value Float)-randomSpeed p =- SigP.fromStorableVectorLazy- ((\(len, seed) ->- SVL.cycle $- SVL.fromChunks- [fst $ SV.packN len $ Rnd.randomRs (0,10::Float) seed])- ^<< rangeFromInt (1,100) *** arr Rnd.mkStdGen <<< p)+randomSpeed :: Param.T p (Int, Rnd.StdGen) -> SigP.T p (Value Float)+randomSpeed = randomSignal (0,10::Float) -randomPhase :: Param.T p (Int, Int) -> SigP.T p (Value Float)-randomPhase p =- SigP.fromStorableVectorLazy- ((\(len, seed) ->- SVL.cycle $- SVL.fromChunks- [fst $ SV.packN len $ Rnd.randomRs (0,1::Float) seed])- ^<< rangeFromInt (1,100) *** arr Rnd.mkStdGen <<< p)+randomPhase :: Param.T p (Int, Rnd.StdGen) -> SigP.T p (Value Float)+randomPhase = randomSignal (0,1::Float) +genStaticDynamic ::+ QC.Gen (((Int, Rnd.StdGen), (Int, Rnd.StdGen)), (Float, Word32))+genStaticDynamic =+ liftA2 (,)+ (liftA2 (,) genRandomVectorParam genRandomVectorParam)+ (liftA2 (,) (QC.choose (1,32)) QC.arbitrary)+ staticDynamic ::- IO (ChunkSize -> (((Int, Int), (Int, Int)), (Int, Word32)) -> SimFloat)+ IO (ChunkSize ->+ (((Int, Rnd.StdGen), (Int, Rnd.StdGen)), (Float, Word32)) -> SimFloat) staticDynamic =+ withPreparedArgs+ (Func.pairArgs+ (Func.pairArgs Func.atomArg Func.atomArg)+ (Func.pairArgs Func.atomArg Func.atomArg)) $+ \((speedParam, phaseParam), (period, noiseParam)) -> let len = 1000- speedParam = arr $ fst.fst- phaseParam = arr $ snd.fst- noiseParam = arr $ snd.snd- period = rangeFromInt (1,32::Float) <<^ fst.snd noise :: Param.T p Word32 -> SigP.T p (Value Float) noise seed = CausalP.take (pure len) $* SigP.noise seed 1 @@ -104,7 +102,8 @@ plot :: IO () plot = do render <- staticDynamic- case render (SVL.chunkSize 1) (((111,0),(0,23)),(107,11)) of+ case render (SVL.chunkSize 1)+ (((76, Rnd.mkStdGen 0),(84, Rnd.mkStdGen 23)),(8.901705,11)) of CheckSimilarity _tol xs ys -> Gnuplot.plotLists [] [SVL.unpack xs, SVL.unpack ys] >>@@ -114,5 +113,5 @@ tests :: [(String, IO ())] tests =- ("staticDynamic", quickCheck =<< staticDynamic) :+ ("staticDynamic", checkWithParam (genStaticDynamic, staticDynamic)) : []
testsuite/Test/Synthesizer/LLVM/Packed.hs view
@@ -1,9 +1,12 @@ {-# LANGUAGE NoImplicitPrelude #-} module Test.Synthesizer.LLVM.Packed (tests) where +import qualified Test.Synthesizer.LLVM.Generator as Gen+import Test.Synthesizer.LLVM.Generator+ (Test, checkWithParam, arg, pair, withGenArgs, ) import Test.Synthesizer.LLVM.Utility- (checkSimilarity, checkEquality, rangeFromInt,- CheckSimilarity, CheckEquality, )+ (checkSimilarity, checkEquality,+ CheckSimilarity, CheckEquality, checkSimilarityPacked, ) import qualified Synthesizer.LLVM.Wave as Wave import qualified Synthesizer.LLVM.Parameter as Param@@ -22,10 +25,12 @@ import qualified Data.StorableVector.Lazy as SVL import Data.StorableVector.Lazy (ChunkSize, ) -import Control.Arrow (arr, (^<<), (<<^), (<<<), )+import Control.Arrow (arr, (<<<), )+import Control.Applicative ((<$>), ) import Data.Word (Word32, ) +import qualified Test.QuickCheck as QC import Test.QuickCheck (quickCheck, ) import NumericPrelude.Numeric@@ -43,9 +48,11 @@ limitFloat = SVL.take signalLength -durFromInt :: Param.T Int Float-durFromInt =- fromIntegral ^<< rangeFromInt (signalLength,2*signalLength)+withDur ::+ (Param.T Float Float -> IO (ChunkSize -> Float -> test)) ->+ Test Float test+withDur =+ withGenArgs (arg (fromIntegral <$> QC.choose (signalLength, 2*signalLength))) {- limitPackedFloat ::@@ -53,109 +60,106 @@ limitPackedFloat = SVL.take (div signalLength 4) -} -constant :: IO (ChunkSize -> Int -> SimFloat)+constant :: Test Float SimFloat constant =- let y = rangeFromInt (-1, 1)- in checkSimilarity 1e-3 limitFloat- (SigP.constant y)- (SigPS.unpack (SigPS.constant y :: SigP.T Int VectorValue))+ withGenArgs (Gen.choose (-1, 1)) $ \y ->+ checkSimilarityPacked 1e-3 limitFloat+ (SigP.constant y) (SigPS.constant y) -ramp :: IO (ChunkSize -> Int -> SimFloat)+ramp :: Test Float SimFloat ramp =- let dur = durFromInt- in checkSimilarity 1e-3 limitFloat- (SigP.rampInf dur)- (SigPS.unpack (SigPS.rampInf dur :: SigP.T Int VectorValue))+ withDur $ \dur ->+ checkSimilarityPacked 1e-3 limitFloat+ (SigP.rampInf dur) (SigPS.rampInf dur) -parabolaFadeIn :: IO (ChunkSize -> Int -> SimFloat)+parabolaFadeIn :: Test Float SimFloat parabolaFadeIn =- let dur = durFromInt- in checkSimilarity 1e-3 limitFloat- (SigP.parabolaFadeInInf dur)- (SigPS.unpack (SigPS.parabolaFadeInInf dur ::- SigP.T Int VectorValue))+ withDur $ \dur ->+ checkSimilarityPacked 1e-3 limitFloat+ (SigP.parabolaFadeInInf dur)+ (SigPS.parabolaFadeInInf dur) -parabolaFadeOut :: IO (ChunkSize -> Int -> SimFloat)+parabolaFadeOut :: Test Float SimFloat parabolaFadeOut =- let dur = durFromInt- in checkSimilarity 1e-3 limitFloat- (SigP.parabolaFadeOutInf dur)- (SigPS.unpack (SigPS.parabolaFadeOutInf dur ::- SigP.T Int VectorValue))+ withDur $ \dur ->+ checkSimilarityPacked 1e-3 limitFloat+ (SigP.parabolaFadeOutInf dur)+ (SigPS.parabolaFadeOutInf dur) -parabolaFadeInMap :: IO (ChunkSize -> Int -> SimFloat)+parabolaFadeInMap :: Test Float SimFloat parabolaFadeInMap =- let dur = durFromInt- in checkSimilarity 1e-3 limitFloat+ withDur $ \dur ->+ checkSimilarity 1e-3 limitFloat (SigP.parabolaFadeIn dur) (SigP.parabolaFadeInMap dur) -parabolaFadeOutMap :: IO (ChunkSize -> Int -> SimFloat)+parabolaFadeOutMap :: Test Float SimFloat parabolaFadeOutMap =- let dur = durFromInt- in checkSimilarity 1e-3 limitFloat+ withDur $ \dur ->+ checkSimilarity 1e-3 limitFloat (SigP.parabolaFadeOut dur) (SigP.parabolaFadeOutMap dur) -exponential2 :: IO (ChunkSize -> (Int,Int) -> SimFloat)++genExp :: Gen.T (Param.T p) (Float, Float) (Param.T p Float, Param.T p Float)+genExp = pair (Gen.choose (1000,10000)) (Gen.choose (-1,1))++exponential2 :: Test (Float,Float) SimFloat exponential2 =- let halfLife = rangeFromInt (1000,10000) <<^ fst- start = rangeFromInt ( -1, 1) <<^ snd- in checkSimilarity 1e-3 limitFloat- (SigP.exponential2 halfLife start)- (SigPS.unpack (SigPS.exponential2 halfLife start ::- SigP.T (Int,Int) VectorValue))+ withGenArgs genExp $ \(halfLife,start) ->+ checkSimilarityPacked 1e-3 limitFloat+ (SigP.exponential2 halfLife start)+ (SigPS.exponential2 halfLife start) -exponential2Static :: IO (ChunkSize -> (Int,Int) -> SimFloat)+exponential2Static :: Test (Float,Float) SimFloat exponential2Static =- let halfLife = rangeFromInt (1000,10000) <<^ fst- start = rangeFromInt ( -1, 1) <<^ snd- in checkSimilarity 1e-3 limitFloat+ withGenArgs genExp $ \(halfLife,start) ->+ checkSimilarity 1e-3 limitFloat (SigP.exponential2 halfLife start) (Exp.causalP start <<< CausalP.mapSimple Exp.parameter $* SigP.constant halfLife) -exponential2PackedStatic :: IO (ChunkSize -> (Int,Int) -> SimFloat)+exponential2PackedStatic :: Test (Float,Float) SimFloat exponential2PackedStatic =- let halfLife = rangeFromInt (1000,10000) <<^ fst- start = rangeFromInt ( -1, 1) <<^ snd- in checkSimilarity 1e-3 (limitFloat . SigStL.unpack)+ withGenArgs genExp $ \(halfLife,start) ->+ checkSimilarity 1e-3 (limitFloat . SigStL.unpack) (SigPS.exponential2 halfLife start ::- SigP.T (Int,Int) VectorValue)+ SigP.T (Float,Float) VectorValue) (Exp.causalPackedP start <<< CausalP.mapSimple Exp.parameterPacked $* SigP.constant halfLife) -exponential2Controlled :: IO (ChunkSize -> ((Int,Int), (Int,Int)) -> SimFloat)+exponential2Controlled :: Test ((Float,Float), (Float,Float)) SimFloat exponential2Controlled =- let halfLife = rangeFromInt (1000,10000) <<^ (fst.fst)- start = rangeFromInt ( -1, 1) <<^ (snd.fst)- -- this is the LFO frequency measured at vector-rate- freq = rangeFromInt (0.0001, 0.001) <<^ (fst.snd)- phase = rangeFromInt (0, 0.99 :: Float) <<^ (snd.snd)- lfo =+ withGenArgs+ (pair genExp+ (pair (Gen.choose (0.0001, 0.001)) (Gen.choose (0, 0.99 :: Float)))) $++ -- 'freq' is the LFO frequency measured at vector-rate+ \((halfLife,start), (freq,phase)) ->+ let lfo = CausalP.mapExponential 2 halfLife $* SigP.osciSimple Wave.approxSine2 phase freq- in checkSimilarity 1e-3 limitFloat+ in checkSimilarityPacked 1e-3 limitFloat (Exp.causalP start <<< CausalP.mapSimple Exp.parameter $* SigP.interpolateConstant (TypeNum.integralFromProxy TypeNum.d4 :: Param.T p Float) lfo)- (SigPS.unpack- (Exp.causalPackedP start <<<- CausalP.mapSimple Exp.parameterPacked $*- lfo :: SigP.T ((Int,Int),(Int,Int)) VectorValue))+ (Exp.causalPackedP start <<<+ CausalP.mapSimple Exp.parameterPacked $* lfo) -osci :: IO (ChunkSize -> (Int,Int) -> SimFloat)+osci :: Test (Float,Float) SimFloat osci =- let freq = rangeFromInt (0.001, 0.01) <<^ fst- phase = rangeFromInt (0, 0.99) <<^ snd- in checkSimilarity 1e-2 limitFloat- (SigP.osciSimple Wave.approxSine2 phase freq)- (SigPS.unpack (SigPS.osciSimple Wave.approxSine2 phase freq ::- SigP.T (Int,Int) VectorValue))+ withGenArgs+ (pair+ (Gen.choose (0.001, 0.01))+ (Gen.choose (0, 0.99))) $+ \(freq,phase) ->+ checkSimilarityPacked 1e-2 limitFloat+ (SigP.osciSimple Wave.approxSine2 phase freq)+ (SigPS.osciSimple Wave.approxSine2 phase freq) @@ -188,17 +192,17 @@ tests :: [(String, IO ())] tests =- ("constant", quickCheck =<< constant) :- ("ramp", quickCheck =<< ramp) :- ("parabolaFadeIn", quickCheck =<< parabolaFadeIn) :- ("parabolaFadeOut", quickCheck =<< parabolaFadeOut) :- ("parabolaFadeInMap", quickCheck =<< parabolaFadeInMap) :- ("parabolaFadeOutMap", quickCheck =<< parabolaFadeOutMap) :- ("exponential2", quickCheck =<< exponential2) :- ("exponential2Static", quickCheck =<< exponential2Static) :- ("exponential2PackedStatic", quickCheck =<< exponential2PackedStatic) :- ("exponential2Controlled", quickCheck =<< exponential2Controlled) :- ("osci", quickCheck =<< osci) :+ ("constant", checkWithParam constant) :+ ("ramp", checkWithParam ramp) :+ ("parabolaFadeIn", checkWithParam parabolaFadeIn) :+ ("parabolaFadeOut", checkWithParam parabolaFadeOut) :+ ("parabolaFadeInMap", checkWithParam parabolaFadeInMap) :+ ("parabolaFadeOutMap", checkWithParam parabolaFadeOutMap) :+ ("exponential2", checkWithParam exponential2) :+ ("exponential2Static", checkWithParam exponential2Static) :+ ("exponential2PackedStatic", checkWithParam exponential2PackedStatic) :+ ("exponential2Controlled", checkWithParam exponential2Controlled) :+ ("osci", checkWithParam osci) : ("noise", quickCheck =<< noise) : ("noiseVector", quickCheck =<< noiseVector) : ("noiseScalarVector", quickCheck =<< noiseScalarVector) :
testsuite/Test/Synthesizer/LLVM/RingBufferForward.hs view
@@ -9,16 +9,14 @@ import Synthesizer.LLVM.CausalParameterized.Process (($*), ) import qualified Data.StorableVector.Lazy as SVL-import qualified Data.StorableVector as SV-import Data.StorableVector.Lazy (ChunkSize, ) +import qualified Test.Synthesizer.LLVM.Generator as Gen+import Test.Synthesizer.LLVM.Generator+ (Test, checkWithParam, arg, pair, triple, withGenArgs, ) import Test.Synthesizer.LLVM.Utility- (CheckEquality, checkEquality, rangeFromInt, )+ (CheckEquality, checkEquality, genRandomVectorParam, randomSignal, ) -import Control.Category ((<<<), )-import Control.Arrow (arr, (***), (^<<), (<<^), ) import Control.Applicative (pure, )-import Data.Tuple.HT (fst3, snd3, thd3, ) import qualified LLVM.Extra.Arithmetic as A @@ -30,8 +28,6 @@ import qualified System.Random as Rnd import Data.Word (Word32, ) -import Test.QuickCheck (quickCheck, )- import NumericPrelude.Numeric import NumericPrelude.Base @@ -46,76 +42,85 @@ limitFloat = SVL.take signalLength -trackId :: IO (ChunkSize -> (Int, Word32) -> EquFloat)+trackId :: Test (Int, Word32) EquFloat trackId =- let bufferSize = rangeFromInt (1,1000) <<^ fst- noise = SigP.noise (arr snd) 1- in checkEquality limitFloat+ withGenArgs (pair (Gen.choose (1,1000)) Gen.arbitrary) $+ \(bufferSize, seed) ->+ let noise = SigP.noise seed 1+ in checkEquality limitFloat noise (CausalP.mapSimple (RingBuffer.index A.zero) $* RingBuffer.track bufferSize noise) -trackTail :: IO (ChunkSize -> (Int, Word32) -> EquFloat)+trackTail :: Test (Int, Word32) EquFloat trackTail =- let bufferSize = rangeFromInt (2,1000) <<^ fst- noise = SigP.noise (arr snd) 1- in checkEquality limitFloat+ withGenArgs (pair (Gen.choose (2,1000)) Gen.arbitrary) $+ \(bufferSize, seed) ->+ let noise = SigP.noise seed 1+ in checkEquality limitFloat (SigP.tail noise) (CausalP.mapSimple (RingBuffer.index A.one) $* RingBuffer.track bufferSize noise) -trackDrop :: IO (ChunkSize -> (Int, Word32) -> EquFloat)+trackDrop :: Test (Int, Word32) EquFloat trackDrop =- let n = rangeFromInt (0,1000) <<^ fst- noise = SigP.noise (arr snd) 1- in checkEquality limitFloat+ withGenArgs (pair (Gen.choose (0,1000)) Gen.arbitrary) $+ \(n, seed) ->+ let noise = SigP.noise seed 1+ in checkEquality limitFloat (SigP.drop n noise) (CausalP.map RingBuffer.index (fmap (fromIntegral :: Int -> Word32) n) $* RingBuffer.track (fmap succ n) noise) -randomSkips :: Param.T p (Int, Int) -> SigP.T p (Value Word32)-randomSkips p =- SigP.fromStorableVectorLazy- ((\(len, seed) ->- SVL.cycle $- SVL.fromChunks- [fst $ SV.packN len $ Rnd.randomRs (0,10::Word32) seed])- ^<< rangeFromInt (1,100) *** arr Rnd.mkStdGen <<< p)+randomSkips :: Param.T p (Int, Rnd.StdGen) -> SigP.T p (Value Word32)+randomSkips = randomSignal (0,10::Word32) -trackSkip :: IO (ChunkSize -> ((Int,Int), Word32) -> EquFloat)+trackSkip :: Test ((Int, Rnd.StdGen), Word32) EquFloat trackSkip =- let skips = randomSkips (arr fst)- noise = SigP.noise (arr snd) 1+ withGenArgs (pair (arg genRandomVectorParam) Gen.arbitrary) $+ \(sk, seed) ->+ let skips = randomSkips sk+ noise = SigP.noise seed 1 in checkEquality limitFloat (CausalP.skip noise $* skips) (CausalP.mapSimple (RingBuffer.index A.one) $* (RingBuffer.trackSkip 1 noise $* skips)) -trackSkip1 :: IO (ChunkSize -> (Int, Word32) -> EquFloat)+trackSkip1 :: Test (Word32, Word32) EquFloat trackSkip1 =- let bufferSize = 1000- k = rangeFromInt (0, fromIntegral bufferSize-1 :: Word32) <<^ fst- noise = SigP.noise (arr snd) 1- in checkEquality limitFloat- (CausalP.map RingBuffer.index k $*- (RingBuffer.track (pure bufferSize) noise))- (CausalP.map RingBuffer.index k $*- (RingBuffer.trackSkip (pure bufferSize) noise $* 1))+ let bufferSize :: Int+ bufferSize = 1000+ in withGenArgs+ (pair+ (Gen.choose (0, fromIntegral bufferSize - 1))+ Gen.arbitrary) $+ \(k, seed) ->+ let noise = SigP.noise seed 1+ in checkEquality limitFloat+ (CausalP.map RingBuffer.index k $*+ (RingBuffer.track (pure bufferSize) noise))+ (CausalP.map RingBuffer.index k $*+ (RingBuffer.trackSkip (pure bufferSize) noise $* 1)) trackSkipHold ::- IO (ChunkSize -> ((Int,Int), Int, Word32) -> CheckEquality (Bool, Float))+ Test ((Int, Rnd.StdGen), Word32, Word32) (CheckEquality (Bool, Float)) trackSkipHold = let bufferSize = 1000- skips = randomSkips (arr fst3)- k = rangeFromInt (0, fromIntegral bufferSize-1 :: Word32) <<^ snd3- noise = SigP.noise (arr thd3) 1- in checkEquality limitFloat- (fmap ((,) (LLVM.valueOf True)) $- (CausalP.map RingBuffer.index k $*- (RingBuffer.trackSkip (pure bufferSize) noise $* skips)))- (CausalP.map- (\ki ((b,_s),buf) -> fmap ((,) b) $ RingBuffer.index ki buf) k $*- (RingBuffer.trackSkipHold (pure bufferSize) noise $* skips))+ in withGenArgs+ (triple+ (arg genRandomVectorParam)+ (Gen.choose (0, fromIntegral bufferSize - 1))+ Gen.arbitrary) $+ \(sk, k, seed) ->+ let skips = randomSkips sk+ noise = SigP.noise seed 1+ in checkEquality limitFloat+ (fmap ((,) (LLVM.valueOf True)) $+ (CausalP.map RingBuffer.index k $*+ (RingBuffer.trackSkip (pure bufferSize) noise $* skips)))+ (CausalP.map+ (\ki ((b,_s),buf) -> fmap ((,) b) $ RingBuffer.index ki buf) k $*+ (RingBuffer.trackSkipHold (pure bufferSize) noise $* skips)) {- To do:@@ -126,10 +131,10 @@ tests :: [(String, IO ())] tests =- ("trackId", quickCheck =<< trackId) :- ("trackTail", quickCheck =<< trackTail) :- ("trackDrop", quickCheck =<< trackDrop) :- ("trackSkip", quickCheck =<< trackSkip) :- ("trackSkip1", quickCheck =<< trackSkip1) :- ("trackSkipHold", quickCheck =<< trackSkipHold) :+ ("trackId", checkWithParam trackId) :+ ("trackTail", checkWithParam trackTail) :+ ("trackDrop", checkWithParam trackDrop) :+ ("trackSkip", checkWithParam trackSkip) :+ ("trackSkip1", checkWithParam trackSkip1) :+ ("trackSkipHold", checkWithParam trackSkipHold) : []
testsuite/Test/Synthesizer/LLVM/Utility.hs view
@@ -2,23 +2,29 @@ {-# LANGUAGE TypeFamilies #-} module Test.Synthesizer.LLVM.Utility where +import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS import qualified Synthesizer.LLVM.Parameterized.Signal as SigP import qualified Synthesizer.LLVM.Parameter as Param+import qualified Synthesizer.LLVM.Frame.SerialVector as Serial import qualified Synthesizer.State.Signal as SigS -import Control.Arrow (arr, ) import Control.Monad (liftM, liftM2, )+import Control.Applicative ((<$>), ) import qualified Data.StorableVector.Lazy as SVL+import qualified Data.StorableVector as SV import Data.StorableVector.Lazy (ChunkSize, ) import Foreign.Storable (Storable, ) import qualified LLVM.Extra.Memory as Memory import qualified LLVM.Extra.Class as Class+import qualified LLVM.Core as LLVM -import System.Random (Random, randomR, mkStdGen, )+import qualified Type.Data.Num.Decimal as TypeNum +import System.Random (Random, randomRs, StdGen, mkStdGen, )+ import qualified Test.QuickCheck as QC import qualified Algebra.RealRing as RealRing@@ -28,11 +34,30 @@ import NumericPrelude.Base -rangeFromInt :: Random a => (a,a) -> Param.T Int a-rangeFromInt rng =- arr $ fst . randomR rng . mkStdGen+genRandomVectorParam :: QC.Gen (Int, StdGen)+genRandomVectorParam =+ liftM2 (,) (QC.choose (1,100)) (mkStdGen <$> QC.arbitrary) +randomStorableVector ::+ (Storable a, Random a) =>+ (a, a) -> (Int, StdGen) -> SV.Vector a+randomStorableVector range (len, seed) =+ fst $ SV.packN len $ randomRs range seed +randomStorableVectorLoop ::+ (Storable a, Random a) =>+ (a, a) -> (Int, StdGen) -> SVL.Vector a+randomStorableVectorLoop range param =+ SVL.cycle $ SVL.fromChunks [randomStorableVector range param]++randomSignal ::+ (Class.MakeValueTuple a, Class.ValueTuple a ~ tuple, Memory.C tuple,+ Storable a, Random a) =>+ (a, a) -> Param.T p (Int, StdGen) -> SigP.T p (Class.ValueTuple a)+randomSignal range p =+ SigP.fromStorableVectorLazy (randomStorableVectorLoop range <$> p)++ render :: (Storable a, Class.MakeValueTuple a, Class.ValueTuple a ~ al, Memory.C al) => (SVL.Vector a -> sig) ->@@ -100,6 +125,15 @@ CheckSimilarity tol (sig0 chunkSize p) (sig1 chunkSize p)) (render limit gen0) (render limit gen1)++checkSimilarityPacked ::+ Float ->+ (SVL.Vector Float -> SVL.Vector Float) ->+ SigP.T p (LLVM.Value Float) ->+ SigP.T p (Serial.Value TypeNum.D4 Float) ->+ IO (ChunkSize -> p -> CheckSimilarity Float)+checkSimilarityPacked tol limit scalar vector =+ checkSimilarity tol limit scalar (SigPS.unpack vector) {- |