diff --git a/alsa/Synthesizer/LLVM/Server/Packed/Run.hs b/alsa/Synthesizer/LLVM/Server/Packed/Run.hs --- a/alsa/Synthesizer/LLVM/Server/Packed/Run.hs +++ b/alsa/Synthesizer/LLVM/Server/Packed/Run.hs @@ -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) diff --git a/example/Synthesizer/LLVM/Test.hs b/example/Synthesizer/LLVM/Test.hs --- a/example/Synthesizer/LLVM/Test.hs +++ b/example/Synthesizer/LLVM/Test.hs @@ -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 $ diff --git a/render/Synthesizer/LLVM/Server/Render.hs b/render/Synthesizer/LLVM/Server/Render.hs --- a/render/Synthesizer/LLVM/Server/Render.hs +++ b/render/Synthesizer/LLVM/Server/Render.hs @@ -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 diff --git a/server/Synthesizer/LLVM/Server/CausalPacked/Arrange.hs b/server/Synthesizer/LLVM/Server/CausalPacked/Arrange.hs --- a/server/Synthesizer/LLVM/Server/CausalPacked/Arrange.hs +++ b/server/Synthesizer/LLVM/Server/CausalPacked/Arrange.hs @@ -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 diff --git a/server/Synthesizer/LLVM/Server/OptionCommon.hs b/server/Synthesizer/LLVM/Server/OptionCommon.hs --- a/server/Synthesizer/LLVM/Server/OptionCommon.hs +++ b/server/Synthesizer/LLVM/Server/OptionCommon.hs @@ -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 = diff --git a/src/Synthesizer/LLVM/Causal/Process.hs b/src/Synthesizer/LLVM/Causal/Process.hs --- a/src/Synthesizer/LLVM/Causal/Process.hs +++ b/src/Synthesizer/LLVM/Causal/Process.hs @@ -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) $ diff --git a/src/Synthesizer/LLVM/Causal/ProcessPrivate.hs b/src/Synthesizer/LLVM/Causal/ProcessPrivate.hs --- a/src/Synthesizer/LLVM/Causal/ProcessPrivate.hs +++ b/src/Synthesizer/LLVM/Causal/ProcessPrivate.hs @@ -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 diff --git a/src/Synthesizer/LLVM/Causal/ProcessValue.hs b/src/Synthesizer/LLVM/Causal/ProcessValue.hs --- a/src/Synthesizer/LLVM/Causal/ProcessValue.hs +++ b/src/Synthesizer/LLVM/Causal/ProcessValue.hs @@ -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) diff --git a/src/Synthesizer/LLVM/CausalParameterized/Functional.hs b/src/Synthesizer/LLVM/CausalParameterized/Functional.hs --- a/src/Synthesizer/LLVM/CausalParameterized/Functional.hs +++ b/src/Synthesizer/LLVM/CausalParameterized/Functional.hs @@ -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) diff --git a/src/Synthesizer/LLVM/CausalParameterized/Helix.hs b/src/Synthesizer/LLVM/CausalParameterized/Helix.hs --- a/src/Synthesizer/LLVM/CausalParameterized/Helix.hs +++ b/src/Synthesizer/LLVM/CausalParameterized/Helix.hs @@ -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, diff --git a/src/Synthesizer/LLVM/CausalParameterized/Process.hs b/src/Synthesizer/LLVM/CausalParameterized/Process.hs --- a/src/Synthesizer/LLVM/CausalParameterized/Process.hs +++ b/src/Synthesizer/LLVM/CausalParameterized/Process.hs @@ -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 diff --git a/src/Synthesizer/LLVM/ConstantPiece.hs b/src/Synthesizer/LLVM/ConstantPiece.hs --- a/src/Synthesizer/LLVM/ConstantPiece.hs +++ b/src/Synthesizer/LLVM/ConstantPiece.hs @@ -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)) -> diff --git a/src/Synthesizer/LLVM/Filter/Allpass.hs b/src/Synthesizer/LLVM/Filter/Allpass.hs --- a/src/Synthesizer/LLVM/Filter/Allpass.hs +++ b/src/Synthesizer/LLVM/Filter/Allpass.hs @@ -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 $ diff --git a/src/Synthesizer/LLVM/Filter/FirstOrder.hs b/src/Synthesizer/LLVM/Filter/FirstOrder.hs --- a/src/Synthesizer/LLVM/Filter/FirstOrder.hs +++ b/src/Synthesizer/LLVM/Filter/FirstOrder.hs @@ -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" #-} diff --git a/src/Synthesizer/LLVM/Filter/SecondOrder.hs b/src/Synthesizer/LLVM/Filter/SecondOrder.hs --- a/src/Synthesizer/LLVM/Filter/SecondOrder.hs +++ b/src/Synthesizer/LLVM/Filter/SecondOrder.hs @@ -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)) diff --git a/src/Synthesizer/LLVM/Filter/Universal.hs b/src/Synthesizer/LLVM/Filter/Universal.hs --- a/src/Synthesizer/LLVM/Filter/Universal.hs +++ b/src/Synthesizer/LLVM/Filter/Universal.hs @@ -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) diff --git a/src/Synthesizer/LLVM/ForeignPtr.hs b/src/Synthesizer/LLVM/ForeignPtr.hs --- a/src/Synthesizer/LLVM/ForeignPtr.hs +++ b/src/Synthesizer/LLVM/ForeignPtr.hs @@ -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) diff --git a/src/Synthesizer/LLVM/Frame/Stereo.hs b/src/Synthesizer/LLVM/Frame/Stereo.hs --- a/src/Synthesizer/LLVM/Frame/Stereo.hs +++ b/src/Synthesizer/LLVM/Frame/Stereo.hs @@ -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) diff --git a/src/Synthesizer/LLVM/Parameter.hs b/src/Synthesizer/LLVM/Parameter.hs --- a/src/Synthesizer/LLVM/Parameter.hs +++ b/src/Synthesizer/LLVM/Parameter.hs @@ -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 diff --git a/src/Synthesizer/LLVM/Parameterized/Signal.hs b/src/Synthesizer/LLVM/Parameterized/Signal.hs --- a/src/Synthesizer/LLVM/Parameterized/Signal.hs +++ b/src/Synthesizer/LLVM/Parameterized/Signal.hs @@ -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:) diff --git a/src/Synthesizer/LLVM/Parameterized/SignalPrivate.hs b/src/Synthesizer/LLVM/Parameterized/SignalPrivate.hs --- a/src/Synthesizer/LLVM/Parameterized/SignalPrivate.hs +++ b/src/Synthesizer/LLVM/Parameterized/SignalPrivate.hs @@ -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) diff --git a/src/Synthesizer/LLVM/Server/CausalPacked/Instrument.hs b/src/Synthesizer/LLVM/Server/CausalPacked/Instrument.hs --- a/src/Synthesizer/LLVM/Server/CausalPacked/Instrument.hs +++ b/src/Synthesizer/LLVM/Server/CausalPacked/Instrument.hs @@ -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 diff --git a/src/Synthesizer/LLVM/Server/Packed/Instrument.hs b/src/Synthesizer/LLVM/Server/Packed/Instrument.hs --- a/src/Synthesizer/LLVM/Server/Packed/Instrument.hs +++ b/src/Synthesizer/LLVM/Server/Packed/Instrument.hs @@ -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)) diff --git a/src/Synthesizer/LLVM/Server/Parameter.hs b/src/Synthesizer/LLVM/Server/Parameter.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/LLVM/Server/Parameter.hs @@ -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 diff --git a/src/Synthesizer/LLVM/Simple/Signal.hs b/src/Synthesizer/LLVM/Simple/Signal.hs --- a/src/Synthesizer/LLVM/Simple/Signal.hs +++ b/src/Synthesizer/LLVM/Simple/Signal.hs @@ -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:) diff --git a/src/Synthesizer/LLVM/Simple/SignalPrivate.hs b/src/Synthesizer/LLVM/Simple/SignalPrivate.hs --- a/src/Synthesizer/LLVM/Simple/SignalPrivate.hs +++ b/src/Synthesizer/LLVM/Simple/SignalPrivate.hs @@ -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 diff --git a/src/Synthesizer/LLVM/Storable/ChunkIterator.hs b/src/Synthesizer/LLVM/Storable/ChunkIterator.hs --- a/src/Synthesizer/LLVM/Storable/ChunkIterator.hs +++ b/src/Synthesizer/LLVM/Storable/ChunkIterator.hs @@ -74,4 +74,4 @@ SVB.withStartPtr x (\p l -> poke lenPtr (fromIntegral l) >> - return (Memory.castStorablePtr p)) + return (Memory.castTuplePtr p)) diff --git a/src/Synthesizer/LLVM/Storable/Signal.hs b/src/Synthesizer/LLVM/Storable/Signal.hs --- a/src/Synthesizer/LLVM/Storable/Signal.hs +++ b/src/Synthesizer/LLVM/Storable/Signal.hs @@ -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 diff --git a/src/Synthesizer/LLVM/Storable/Vector.hs b/src/Synthesizer/LLVM/Storable/Vector.hs --- a/src/Synthesizer/LLVM/Storable/Vector.hs +++ b/src/Synthesizer/LLVM/Storable/Vector.hs @@ -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) diff --git a/src/Synthesizer/LLVM/Wave.hs b/src/Synthesizer/LLVM/Wave.hs --- a/src/Synthesizer/LLVM/Wave.hs +++ b/src/Synthesizer/LLVM/Wave.hs @@ -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 :: diff --git a/synthesizer-llvm.cabal b/synthesizer-llvm.cabal --- a/synthesizer-llvm.cabal +++ b/synthesizer-llvm.cabal @@ -1,5 +1,5 @@ Name: synthesizer-llvm -Version: 0.8.1.2 +Version: 0.8.2 License: GPL License-File: LICENSE Author: Henning Thielemann @@ -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 diff --git a/testsuite/Test/Synthesizer/LLVM/Filter.hs b/testsuite/Test/Synthesizer/LLVM/Filter.hs --- a/testsuite/Test/Synthesizer/LLVM/Filter.hs +++ b/testsuite/Test/Synthesizer/LLVM/Filter.hs @@ -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) : [] diff --git a/testsuite/Test/Synthesizer/LLVM/Generator.hs b/testsuite/Test/Synthesizer/LLVM/Generator.hs new file mode 100644 --- /dev/null +++ b/testsuite/Test/Synthesizer/LLVM/Generator.hs @@ -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) diff --git a/testsuite/Test/Synthesizer/LLVM/Helix.hs b/testsuite/Test/Synthesizer/LLVM/Helix.hs --- a/testsuite/Test/Synthesizer/LLVM/Helix.hs +++ b/testsuite/Test/Synthesizer/LLVM/Helix.hs @@ -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)) : [] diff --git a/testsuite/Test/Synthesizer/LLVM/Packed.hs b/testsuite/Test/Synthesizer/LLVM/Packed.hs --- a/testsuite/Test/Synthesizer/LLVM/Packed.hs +++ b/testsuite/Test/Synthesizer/LLVM/Packed.hs @@ -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) : diff --git a/testsuite/Test/Synthesizer/LLVM/RingBufferForward.hs b/testsuite/Test/Synthesizer/LLVM/RingBufferForward.hs --- a/testsuite/Test/Synthesizer/LLVM/RingBufferForward.hs +++ b/testsuite/Test/Synthesizer/LLVM/RingBufferForward.hs @@ -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) : [] diff --git a/testsuite/Test/Synthesizer/LLVM/Utility.hs b/testsuite/Test/Synthesizer/LLVM/Utility.hs --- a/testsuite/Test/Synthesizer/LLVM/Utility.hs +++ b/testsuite/Test/Synthesizer/LLVM/Utility.hs @@ -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) {- |