{- ToDo: organization: compile instrument when switching a MIDI program However caching and sharing might be a good idea like for quickly changing between tomatensalat syllabels. Ideally we just need to run instrument generation using unsafeInterleaveIO. This however will trigger instrument compilation when the sound is played the first time. This may cause buffer underruns. On the other hand, forcing instrument compilation on program changes might still cause buffer underruns. instruments: use a greymap picture as source of waveforms mix of detuned noisy-waverforms, try different and uniform waveforms mix of sawtooth, where every sawtooth is modulated with red noise mix of sine with harmonics where every harmonic is modulated differently Flute: sine + filtered noise Drum with various parameters derive percussive instruments from fmString and arcString (for bass synths) an FM sound with a slowly changing timbre by using a very slightly detuned frequency for the modulator making a tone out of noise using time stretch with helix algorithm a chorus effect could be applied by two successive helix stretches or by mixture of two stretches signals additionally a resonant filter could be applied a kind of Karplus-Strong algorithm with a non-linear function of past values e.g. y(t) = f(y(t-d), y(t-2*d)) where d is the tone period and f is non-linear, maybe chaotic function. In order to limit the appearance of chaotic waveforms, we could combine this with a lowpass filter. let attack and release depend on On and Off velocity tineStereoFM: continuous control of the modulation index by linear interpolation of waves between modulations with integral indices. E.g. modulation index 2.3 means 0.7*modulation with index 2 and 0.3*modulation with index 3. effects: reverb and controllable delay phaser or Chebyshev filter continuous sounds: fly water/bubbles when I accidentally did not scale filter frequency with sample rate, the filter sound much like water bubbles. I think a control curve consisting of some ramps will do the same. hail, Geiger counter, pitch applied by comb filter at a very high impulse rate the impulses itself can generate an almost periodic signal Speech sounds improvements (tomatensalat) use PSOLA for transposition To this end divide signal into tonal part and residue (noise) by a comb filter. Maybe a non-linear comb filter may help, that selects the center value from the filter window, if the side values are similar and returns zero, if the the side values differ too much. Process the tonal part by PSOLA and simply mix it with the non-tonal part on replay. Harmonizer-like: We like to input an audio signal of speech and a set of keys, and the speech is extended to chords according to the pressed keys. The lowest key is interpreted as base frequency of the input audio speech. A PSOLA method transposes the audio input. Resonant filter controlled by keys applied to an audio input signal or an ordinary audio signal generated by other keys. The splitting of keys however could be performed by a MIDI event stream editor. -} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Rank2Types #-} module Synthesizer.LLVM.Server.Packed.Instrument ( pingRelease, pingStereoRelease, pingStereoReleaseFM, squareStereoReleaseFM, bellStereoFM, bellNoiseStereoFM, tine, tineStereo, softString, softStringFM, tineStereoFM, tineControlledFM, fenderFM, tineModulatorBankFM, tineBankFM, resonantFMSynth, softStringDetuneFM, softStringShapeFM, cosineStringStereoFM, arcSineStringStereoFM, arcTriangleStringStereoFM, arcSquareStringStereoFM, arcSawStringStereoFM, fmStringStereoFM, wind, windPhaser, filterSawStereoFM, brass, sampledSound, -- * helper functions stereoNoise, frequencyFromBendModulation, modulation, piecewiseConstantVector, -- * for testing pingReleaseEnvelope, 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 import qualified Synthesizer.MIDI.PiecewiseConstant as PC import qualified Synthesizer.MIDI.EventList as Ev import Synthesizer.MIDI.Storable (chunkSizesFromLazyTime) import qualified Synthesizer.LLVM.Frame.Stereo as Stereo import qualified Synthesizer.LLVM.Filter.Universal as UniFilterL import qualified Synthesizer.LLVM.Filter.Allpass as Allpass import qualified Synthesizer.LLVM.Filter.Moog as MoogL import qualified Synthesizer.LLVM.MIDI as MIDIL import qualified Synthesizer.LLVM.CausalParameterized.ControlledPacked as CtrlPS import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP import qualified Synthesizer.LLVM.CausalParameterized.Functional as F import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS import qualified Synthesizer.LLVM.Parameterized.Signal as SigP import qualified Synthesizer.LLVM.Simple.Signal as Sig import qualified Synthesizer.LLVM.Storable.Signal as SigStL import qualified Synthesizer.LLVM.Frame as Frame import qualified Synthesizer.LLVM.Frame.SerialVector as Serial import qualified Synthesizer.LLVM.Wave as WaveL import Synthesizer.LLVM.CausalParameterized.Process (($<), ($>), ($*)) import Synthesizer.LLVM.CausalParameterized.Functional (($&), (&|&)) import qualified LLVM.DSL.Parameter as Param import LLVM.DSL.Parameter (($#)) import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Core as LLVM import qualified Type.Data.Num.Decimal as TypeNum import qualified Synthesizer.Generic.Cut as CutG import qualified Synthesizer.Storable.Signal as SigSt import qualified Data.StorableVector.Lazy.Pattern as SVP import qualified Data.StorableVector.Lazy as SVL 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) import Data.Traversable (traverse) import qualified Data.Traversable as Trav import Data.Tuple.HT (fst3, snd3, thd3) import qualified Numeric.NonNegative.Chunky as NonNegChunky import qualified Algebra.Additive as Additive import NumericPrelude.Numeric (zero, one, round, (^?), (+), (-), (*)) import Prelude hiding (Real, round, break, id, (+), (-), (*)) frequencyControl :: (p -> PC.T Real) -> Param p (PC.T Real) frequencyControl param = arr (\(SampleRate sampleRate, p) -> fmap (/sampleRate) $ param p) modulation :: (p -> (PC.T (BM.T Real), Real)) -> Param p (PC.T (BM.T Real)) modulation param = 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)) detuneModulation param = arr $ \(sr, p) -> 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, Tuple.Value a, ValueTuple a ~ (Value a)) => -} Param p Real -> Param p (PC.T (BM.T Real)) -> SigP p VectorValue frequencyFromBendModulation speed fmFreq = MIDIL.frequencyFromBendModulationPacked speed $* piecewiseConstant fmFreq stereoFrequenciesFromDetuneBendModulation :: Param p Real -> Param p (PC.T Real, PC.T (BM.T Real)) -> SigP p (Stereo.T VectorValue) stereoFrequenciesFromDetuneBendModulation speed detFmFreq = (CausalP.envelopeStereo $< frequencyFromBendModulation speed (fmap (\(_det,fm) -> (fm)) detFmFreq)) <<< liftA2 Stereo.cons (one + id) (one - id) $* piecewiseConstantVector (fmap (\(det,_fm) -> det) detFmFreq) piecewiseConstantVector :: Param.T p (PC.T Real) -> SigP.T p VectorValue {- (Storable a, Tuple.Value a, Tuple.ValueOf a ~ al, Memory.C al am, LLVM.IsSized am as) => Param.T p (PC.T a) -> SigP.T p (Serial.Value n al) -} piecewiseConstantVector = piecewiseConstant . fmap (fmap (Serial.replicate)) pingReleaseEnvelope :: IO (Real -> Real -> SigSt.ChunkSize -> SampleRate Real -> Real -> Ev.LazyTime -> SigSt.T Vector) pingReleaseEnvelope = liftA2 (\pressed release decay rel vcsize sr vel dur -> SigStL.continuePacked (pressed (chunkSizesFromLazyTime dur) (sr, (decay,vel))) (\x -> release vcsize (sr, (rel,x)))) (SigP.runChunkyPattern $ let decay = time fst velocity = number snd in SigPS.exponential2 decay (amplitudeFromVelocity ^<< velocity)) (SigP.runChunky $ let releaseTime = vectorTime fst * 5 releaseHL = time fst amplitude = number snd in CausalP.take (round ^<< releaseTime) $* SigPS.exponential2 releaseHL amplitude) pingRelease :: IO (Real -> Real -> SigSt.ChunkSize -> Instrument Real Vector) pingRelease = liftA2 (\osc env dec rel vcsize sr vel freq dur -> osc (sr,freq) (env dec rel vcsize sr vel dur)) (CausalP.runStorableChunky (let freq = frequency id in CausalP.envelope $> SigPS.osciSimple WaveL.saw zero freq)) pingReleaseEnvelope pingStereoRelease :: IO (Real -> Real -> SigSt.ChunkSize -> Instrument Real (Stereo.T Vector)) pingStereoRelease = liftA2 (\osc env dec rel vcsize sr vel freq dur -> osc (sr,freq) (env dec rel vcsize sr vel dur)) (CausalP.runStorableChunky (let freq = frequency id in CausalP.envelopeStereo $> liftA2 Stereo.cons (SigPS.osciSimple WaveL.saw zero (0.999*freq)) (SigPS.osciSimple WaveL.saw zero (1.001*freq)))) pingReleaseEnvelope pingStereoReleaseFM :: IO (Real -> Real -> PC.T Real -> PC.T Real -> Real -> Real -> SigSt.ChunkSize -> PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector)) pingStereoReleaseFM = liftA2 (\osc env dec rel detune shape phase phaseDecay vcsize fm sr vel freq dur -> osc (sr, ((phase, phaseDecay), shape, (detune,fm,freq))) (env dec rel vcsize sr vel dur)) (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)) pingReleaseEnvelope {- | Square like wave constructed as difference of two phase shifted sawtooth like oscillations. -} squareStereoReleaseFM :: IO (Real -> Real -> PC.T Real -> PC.T Real -> PC.T Real -> SigSt.ChunkSize -> PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector)) squareStereoReleaseFM = liftA2 (\osc env dec rel detune shape phase vcsize fm sr vel freq dur -> osc (sr, ((phase, shape), (detune,fm,freq))) (env dec rel vcsize sr vel dur)) (CausalP.runStorableChunky $ ParamS.withTuple2 $ \((Control phs, Control shp), DetuneModulation fm) -> (let chanOsci :: CausalP p ((VectorValue, VectorValue), VectorValue) VectorValue chanOsci = ((CausalPS.shapeModOsci WaveL.rationalApproxSine1 <<< second (first (Additive.negate id))) - CausalPS.shapeModOsci WaveL.rationalApproxSine1) <<^ (\((p,s),f) -> (s,(p,f))) in CausalP.envelopeStereo $> ((CausalP.stereoFromMonoControlled chanOsci $< SigP.zip (piecewiseConstantVector phs) (piecewiseConstantVector shp)) $* stereoFrequenciesFromDetuneBendModulation (frequencyConst 10) fm))) pingReleaseEnvelope type Triple a = (a, a, a) bellStereoFM :: IO (Real -> Real -> PC.T Real -> SigSt.ChunkSize -> PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector)) bellStereoFM = liftA2 (\osc env dec rel detune vcsize fm sr vel freq dur -> osc (sr, ((detune, fm, freq), vel, (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 $ ParamS.withTuple2 $ \(DetuneModulation fm, Number vel, (Signal env4, Signal env7)) -> (let osci :: (Triple VectorValue -> VectorValue) -> Param.T p Real -> Param.T p Real -> CausalP.T p (Triple VectorValue, Stereo.T VectorValue) (Stereo.T VectorValue) osci sel v d = CausalP.envelopeStereo <<< (arr sel *** (CausalPS.amplifyStereo v <<< CausalP.stereoFromMono (CausalPS.osciSimple WaveL.approxSine4 $< zero) <<< CausalPS.amplifyStereo d)) in sumNested [osci fst3 0.6 1, osci snd3 (0.02 * 50^?vel) 4, osci thd3 (0.02 * 100^?vel) 7] <<< CausalP.feedSnd (stereoFrequenciesFromDetuneBendModulation (frequencyConst 5) fm) <<< arr (\(e1,(e4,e7)) -> (e1,e4,e7)) $> {- Be careful, those storable vectors shorten the whole sound if they have shorter release than the main envelope. -} SigP.zip (SigP.fromStorableVectorLazy env4) (SigP.fromStorableVectorLazy env7))) pingReleaseEnvelope bellNoiseStereoFM :: IO (Real -> Real -> PC.T Real -> PC.T Real -> SigSt.ChunkSize -> PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector)) bellNoiseStereoFM = liftA2 (\osc env dec rel noiseAmp noiseReson vcsize fm sr vel freq dur -> osc (sr, ((fm, freq), (noiseAmp,noiseReson), (vel, 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 $ 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 -> CausalP.T p (Triple VectorValue, VectorValue) VectorValue osci sel v d = CausalP.envelope <<< (arr sel *** (CausalPS.amplify v <<< (CausalPS.osciSimple WaveL.approxSine4 $< zero) <<< 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 p Real -> CausalP p (Triple VectorValue, VectorValue) VectorValue noise sel d = (CausalP.envelope $< piecewiseConstantVector noiseAmp) <<< CausalP.envelope <<< (arr sel *** ({- UniFilter.lowpass ^<< -} (CtrlPS.process $> SigPS.noise 12 (noiseReference 20000)) <<< {- (CausalP.quantizeLift $# (128 / fromIntegral vectorSize :: Real)) (CausalP.zipWithSimple UniFilterL.parameter) -} (CausalP.quantizeLift $# (128 / fromIntegral vectorSize :: Real)) (CausalP.zipWithSimple (MoogL.parameter TypeNum.d8)) <<< CausalP.feedFst (piecewiseConstant noiseReson) <<< CausalP.mapSimple Serial.subsample <<< CausalPS.amplify d)) in liftA2 Stereo.cons (sumNested [osci fst3 0.6 (1*0.999), osci snd3 (0.02 * 50^?vel) (4*0.999), osci thd3 (0.02 * 100^?vel) (7*0.999), noise fst3 0.999]) (sumNested [osci fst3 0.6 (1*1.001), osci snd3 (0.02 * 50^?vel) (4*1.001), osci thd3 (0.02 * 100^?vel) (7*1.001), noise fst3 1.001]) <<< CausalP.feedSnd (frequencyFromBendModulation (frequencyConst 5) fm) <<< arr (\(e1,(e4,e7)) -> (e1,e4,e7)) $> {- Be careful, those storable vectors shorten the whole sound if they have shorter release than the main envelope. -} SigP.zip (SigP.fromStorableVectorLazy env4) (SigP.fromStorableVectorLazy env7))) pingReleaseEnvelope tine :: IO (Real -> Real -> SigSt.ChunkSize -> Instrument Real Vector) tine = liftA2 (\osc env dec rel vcsize sr vel freq dur -> osc (sr, (vel,freq)) (env dec rel vcsize sr 0 dur)) (CausalP.runStorableChunky (let freq = frequency snd vel = number fst in CausalP.envelope $> (CausalPS.osciSimple WaveL.approxSine2 $> SigPS.constant freq $* (CausalP.envelope $< SigPS.exponential2 (timeConst 1) (vel+1) $* SigPS.osciSimple WaveL.approxSine2 zero (2*freq))))) pingReleaseEnvelope tineStereo :: IO (Real -> Real -> SigSt.ChunkSize -> Instrument Real (Stereo.T Vector)) tineStereo = liftA2 (\osc env dec rel vcsize sr vel freq dur -> osc (sr, (vel,freq)) (env dec rel vcsize sr 0 dur)) (CausalP.runStorableChunky (let freq = frequency snd vel = number fst chanOsci d = CausalPS.osciSimple WaveL.approxSine2 $> SigPS.constant (freq*d) in CausalP.envelopeStereo $> (liftA2 Stereo.cons (chanOsci 0.995) (chanOsci 1.005) $* SigP.envelope (SigPS.exponential2 (timeConst 1) (vel+1)) (SigPS.osciSimple WaveL.approxSine2 zero (2*freq))))) pingReleaseEnvelope softStringReleaseEnvelope :: IO (Real -> SampleRate Real -> Real -> Ev.LazyTime -> SigSt.T Vector) softStringReleaseEnvelope = liftA2 (\rev env attackTime sr vel dur -> let attackTimeVector = round (attackTime * vectorRate sr) {- release <- take attackTime beginning would yield a space leak, thus we first split 'beginning' and then concatenate it again -} {- We can not easily generate attack and sustain separately, because we want to use the chunk structure implied by 'dur'. -} (attack, sustain) = SigSt.splitAt attackTimeVector $ env (chunkSizesFromLazyTime dur) (sr, (amplitudeFromVelocity vel, attackTimeVector)) release = rev attack in attack `SigSt.append` sustain `SigSt.append` release) SigStL.makeReversePacked (let amp = number fst attackTimeVector = parameter snd in SigP.runChunkyPattern $ flip SigP.append (SigPS.constant amp) $ (CausalPS.amplify amp <<< CausalP.take attackTimeVector $* SigPS.parabolaFadeInInf (fmap (fromIntegral . (vectorSize*)) attackTimeVector))) softString :: IO (Instrument Real (Stereo.T Vector)) softString = liftA2 (\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) in CausalP.runStorableChunky $ (CausalP.envelopeStereo $> (liftA2 Stereo.cons (osci 1.005 + osci 0.998) (osci 1.002 + osci 0.995)))) softStringReleaseEnvelope softStringFM :: IO (PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector)) softStringFM = liftA2 (\osc env fm sr vel freq dur -> osc (sr, (fm,freq)) (env 1 sr vel dur)) (let fm = modulation id osci :: Param.T fm Real -> CausalP.T fm VectorValue VectorValue osci d = (CausalPS.osciSimple WaveL.saw $< zero) <<< CausalPS.amplify d in CausalP.runStorableChunky $ (CausalP.envelopeStereo $> (liftA2 Stereo.cons (osci 1.005 + osci 0.998) (osci 1.002 + osci 0.995) $* frequencyFromBendModulation (frequencyConst 5) fm))) softStringReleaseEnvelope tineStereoFM :: IO (Real -> Real -> SigSt.ChunkSize -> PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector)) tineStereoFM = liftA2 (\osc env dec rel vcsize fm sr vel freq dur -> osc (sr, (vel,(fm,freq))) (env dec rel vcsize sr 0 dur)) (CausalP.runStorableChunky (let vel = number fst fm = modulation snd chanOsci d = CausalPS.osciSimple WaveL.approxSine2 <<< second (CausalPS.amplify d) in CausalP.envelopeStereo $> (liftA2 Stereo.cons (chanOsci 0.995) (chanOsci 1.005) <<< (((CausalP.envelope $< SigPS.exponential2 (timeConst 1) (vel+1)) <<< (CausalPS.osciSimple WaveL.approxSine2 $< zero) <<< CausalPS.amplify 2) &&& id) $* frequencyFromBendModulation (frequencyConst 5) fm))) pingReleaseEnvelope _tineControlledProc, tineControlledFnProc :: Param p (PC.T Real) -> Param p (PC.T Real) -> Param p Real -> CausalP p (Stereo.T VectorValue) (Stereo.T VectorValue) _tineControlledProc index depth vel = CausalP.stereoFromMono (CausalPS.osciSimple WaveL.approxSine2) <<< Stereo.interleave ^<< ((CausalP.envelopeStereo $< SigP.envelope (piecewiseConstantVector depth) (SigPS.exponential2 (timeConst 1) (vel+1))) <<< CausalP.stereoFromMono (CausalPS.osciSimple WaveL.approxSine2 $< zero) <<< (CausalP.envelopeStereo $< piecewiseConstantVector index)) &&& id tineControlledFnProc index depth vel = F.withGuidedArgs F.atom $ \freq -> CausalP.stereoFromMono (CausalPS.osciSimple WaveL.approxSine2) $& liftA2 (liftA2 (,)) ((CausalP.envelopeStereo $< SigP.envelope (piecewiseConstantVector depth) (SigPS.exponential2 (timeConst 1) (vel+1))) <<< CausalP.stereoFromMono (CausalPS.osciSimple WaveL.approxSine2 $< zero) <<< (CausalP.envelopeStereo $< piecewiseConstantVector index) $& freq) freq tineControlledFM :: IO (Real -> Real -> PC.T Real -> PC.T Real -> PC.T Real -> SigSt.ChunkSize -> PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector)) tineControlledFM = liftA2 (\osc env dec rel detune index depth vcsize fm sr vel freq dur -> osc (sr, ((index, depth), vel, (detune,fm,freq))) (env dec rel vcsize sr 0 dur)) (CausalP.runStorableChunky $ ParamS.withTuple2 $ \((Control index, Control depth), Number vel, DetuneModulation fm) -> CausalP.envelopeStereo $> (tineControlledFnProc index depth vel $* stereoFrequenciesFromDetuneBendModulation (frequencyConst 5) fm)) pingReleaseEnvelope fenderProc :: Param p (PC.T Real) -> Param p (PC.T Real) -> Param p (PC.T Real) -> Param p Real -> CausalP p (Stereo.T VectorValue) (Stereo.T VectorValue) fenderProc fade index depth vel = F.withGuidedArgs F.atom $ \stereoFreq -> let {- channel_n_1 :: FuncP p VectorValue VectorValue -> FuncP p VectorValue VectorValue -} channel_n_1 freq = CausalPS.osciSimple WaveL.approxSine2 $& ((CausalP.envelope $< SigP.envelope (piecewiseConstantVector depth) (SigPS.exponential2 (timeConst 1) (vel+1))) <<< (CausalPS.osciSimple WaveL.approxSine2 $< zero) <<< (CausalP.envelope $< piecewiseConstantVector index) $& freq) &|& freq {- channel_1_2 :: FuncP p VectorValue VectorValue -> FuncP p VectorValue VectorValue -} channel_1_2 freq = CausalPS.osciSimple WaveL.approxSine2 $& ((CausalP.envelope $< SigP.envelope (piecewiseConstantVector depth) (SigPS.exponential2 (timeConst 1) (vel+1))) <<< (CausalPS.osciSimple WaveL.approxSine2 $< zero) $& freq) &|& (CausalPS.amplify 2 $& freq) in (CausalP.stereoFromMonoControlled (fadeProcess (F.compile $ channel_n_1 $ F.lift id) (F.compile $ channel_1_2 $ F.lift id)) $< piecewiseConstantVector fade) $& stereoFreq fenderFM :: IO (Real -> Real -> PC.T Real -> PC.T Real -> PC.T Real -> PC.T Real -> SigSt.ChunkSize -> PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector)) fenderFM = liftA2 (\osc env dec rel detune index depth fade vcsize fm sr vel freq dur -> osc (sr, (((index, depth), fade), vel, (detune,fm,freq))) (env dec rel vcsize sr 0 dur)) (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 fmModulator :: Param p Real -> Param p Real -> Param p (PC.T Real) -> CausalP p (Stereo.T VectorValue) (Stereo.T VectorValue) fmModulator vel n depth = (CausalP.envelopeStereo $< SigP.envelope (piecewiseConstantVector depth) (SigPS.exponential2 (timeConst 1) (vel+1))) <<< CausalP.stereoFromMono (CausalPS.osciSimple WaveL.approxSine2 $< zero) <<< CausalPS.amplifyStereo n tineModulatorBankFM :: IO (Real -> Real -> PC.T Real -> PC.T Real -> PC.T Real -> PC.T Real -> PC.T Real -> SigSt.ChunkSize -> PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector)) tineModulatorBankFM = liftA2 (\osc env dec rel detune depth1 depth2 depth3 depth4 vcsize fm sr vel freq dur -> osc (sr, ((depth1,(depth2,(depth3,(depth4)))), vel, (detune,fm,freq))) (env dec rel vcsize sr 0 dur)) (CausalP.runStorableChunky $ ParamS.withTuple2 $ \((Control depth1, (Control depth2, (Control depth3, Control depth4))), Number vel, DetuneModulation fm) -> (CausalP.envelopeStereo $> (CausalP.stereoFromMono (CausalPS.osciSimple WaveL.approxSine2) <<< Stereo.interleave ^<< sumNested [fmModulator vel 1 depth1, fmModulator vel 2 depth2, fmModulator vel 3 depth3, fmModulator vel 4 depth4] &&& id $* stereoFrequenciesFromDetuneBendModulation (frequencyConst 5) fm))) pingReleaseEnvelope tineBankFM :: IO (Real -> Real -> PC.T Real -> PC.T Real -> PC.T Real -> PC.T Real -> PC.T Real -> PC.T Real -> PC.T Real -> PC.T Real -> PC.T Real -> SigSt.ChunkSize -> PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector)) tineBankFM = liftA2 (\osc env dec rel detune depth1 depth2 depth3 depth4 partial1 partial2 partial3 partial4 vcsize fm sr vel freq dur -> osc (sr, ((depth1,(depth2,(depth3,(depth4)))), (partial1,(partial2,(partial3,(partial4)))), (vel, (detune,fm,freq)))) (env dec rel vcsize sr 0 dur)) (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 = A.mul amp =<< WaveL.partial WaveL.approxSine2 n t in CausalP.envelopeStereo $> (CausalP.stereoFromMono (CausalPS.shapeModOsci (\(p1,(p2,(p3,p4))) t -> do y1 <- A.mul p1 =<< WaveL.approxSine2 t y2 <- partial p2 2 t y3 <- partial p3 3 t y4 <- partial p4 4 t A.add y1 =<< A.add y2 =<< A.add y3 y4) $< (SigP.zip (piecewiseConstantVector partial1) $ SigP.zip (piecewiseConstantVector partial2) $ SigP.zip (piecewiseConstantVector partial3) (piecewiseConstantVector partial4))) <<< Stereo.interleave ^<< sumNested [fmModulator vel 1 depth1, fmModulator vel 2 depth2, fmModulator vel 3 depth3, fmModulator vel 4 depth4] &&& id $* stereoFrequenciesFromDetuneBendModulation (frequencyConst 5) fm))) pingReleaseEnvelope {- | FM synthesis where the modulator is a resonantly filtered sawtooth. This way we get a sinus-like modulator where the sine frequency (that is, something like the modulation index) can be controlled continously. -} resonantFMSynthProc :: Param p (PC.T Real) -> Param p (PC.T Real) -> Param p (PC.T Real) -> Param p Real -> CausalP p (Stereo.T VectorValue) (Stereo.T VectorValue) resonantFMSynthProc reson index depth vel = F.withGuidedArgs (Stereo.cons F.atom F.atom) $ \stereoFreq -> let -- chan :: FuncP p inp VectorValue -> FuncP p inp VectorValue chan freq = CausalPS.osciSimple WaveL.approxSine2 $& ((CausalP.envelope $< SigP.envelope (piecewiseConstantVector depth) (SigPS.exponential2 (timeConst 1) (vel+1))) <<< UniFilter.lowpass ^<< CtrlPS.process $& (CausalP.zipWithSimple UniFilterL.parameter <<< CausalP.feedFst (piecewiseConstant reson) <<< (CausalP.envelope $< piecewiseConstant index) <<< CausalP.mapSimple Serial.subsample $& freq) &|& ((CausalPS.osciSimple WaveL.saw $< zero) $& freq)) &|& freq in Trav.traverse chan stereoFreq resonantFMSynth :: IO (Real -> Real -> PC.T Real -> PC.T Real -> PC.T Real -> PC.T Real -> SigSt.ChunkSize -> PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector)) resonantFMSynth = liftA2 (\osc env dec rel detune reson index depth vcsize fm sr vel freq dur -> osc (sr, ((reson, index, depth), vel, (detune,fm,freq))) (env dec rel vcsize sr 0 dur)) (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 phaserOsci :: (Param.T p Real -> CausalP.T p a VectorValue) -> CausalP.T p a (Stereo.T VectorValue) phaserOsci osci = CausalPS.amplifyStereo 0.25 <<< liftA2 Stereo.cons (sumNested $ map osci [1.0, -0.4, 0.5, -0.7]) (sumNested $ map osci [0.4, -1.0, 0.7, -0.5]) softStringDetuneFM :: IO (Real -> PC.T Real -> PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector)) softStringDetuneFM = liftA2 (\osc env att det fm sr vel freq dur -> osc (sr, (det, (fm,freq))) (env att sr vel dur)) (let det = control fst fm = modulation snd osci :: Param.T (det,fm) Real -> CausalP.T (det,fm) (VectorValue, VectorValue) VectorValue osci d = (CausalPS.osciSimple WaveL.saw $< zero) <<< CausalP.envelope <<< first (one + CausalPS.amplify d) in CausalP.runStorableChunky $ (CausalP.envelopeStereo $> (phaserOsci osci <<< CausalP.feedFst (piecewiseConstantVector det) $* frequencyFromBendModulation (frequencyConst 5) fm))) softStringReleaseEnvelope {- We might decouple the frequency of the enveloped tone from the frequency of the envelope, in order to get something like formants. -} softStringShapeFM, cosineStringStereoFM, arcSineStringStereoFM, arcTriangleStringStereoFM, arcSquareStringStereoFM, arcSawStringStereoFM :: IO (Real -> PC.T Real -> PC.T Real -> PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector)) softStringShapeFM = softStringShapeCore WaveL.rationalApproxSine1 cosineStringStereoFM = softStringShapeCore (\k p -> WaveL.approxSine2 =<< WaveL.replicate k p) arcSawStringStereoFM = arcStringStereoFM WaveL.saw arcSineStringStereoFM = arcStringStereoFM WaveL.approxSine2 arcSquareStringStereoFM = arcStringStereoFM WaveL.square arcTriangleStringStereoFM = arcStringStereoFM WaveL.triangle arcStringStereoFM :: (forall r. VectorValue -> LLVM.CodeGenFunction r VectorValue) -> IO (Real -> PC.T Real -> PC.T Real -> PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector)) arcStringStereoFM wave = softStringShapeCore (\k p -> M.liftJoin2 Frame.amplifyMono (WaveL.approxSine4 =<< WaveL.halfEnvelope p) (wave =<< WaveL.replicate k p)) softStringShapeCore :: (forall r. VectorValue -> VectorValue -> LLVM.CodeGenFunction r VectorValue) -> IO (Real -> PC.T Real -> PC.T Real -> PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector)) softStringShapeCore wave = liftA2 (\osc env att det dist fm sr vel freq dur -> osc (sr, ((det, dist), (fm,freq))) (env att sr vel dur)) (let det = control (fst.fst) dist = control (snd.fst) fm = modulation snd osci :: Param.T (mod,fm) Real -> CausalP.T (mod,fm) (VectorValue, {- wave shape parameter -} (VectorValue, VectorValue) {- detune, frequency modulation -}) VectorValue osci d = CausalPS.shapeModOsci wave <<< second (CausalP.feedFst zero <<< CausalP.envelope <<< first (one + CausalPS.amplify d)) in CausalP.runStorableChunky $ (CausalP.envelopeStereo $> (phaserOsci osci $< piecewiseConstantVector dist $< piecewiseConstantVector det $* frequencyFromBendModulation (frequencyConst 5) fm))) softStringReleaseEnvelope fmStringStereoFM :: IO (Real -> PC.T Real -> PC.T Real -> PC.T Real -> PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector)) fmStringStereoFM = liftA2 (\osc env att det depth dist fm sr vel freq dur -> osc (sr, ((det, depth, dist), (fm, freq))) (env att sr vel dur)) (let det = control (fst3.fst) depth = control (snd3.fst) dist = control (thd3.fst) fm = modulation snd osci :: Param.T (mod,fm) Real -> CausalP.T (mod,fm) ((VectorValue, VectorValue) {- phase modulation depth, modulator distortion -}, (VectorValue, VectorValue) {- detune, frequency modulation -}) VectorValue osci d = CausalPS.osciSimple WaveL.approxSine2 <<< (CausalP.envelope <<< second (CausalPS.shapeModOsci WaveL.rationalApproxSine1 <<< second (CausalP.feedFst zero)) <<^ (\((dp, ds), f) -> (dp, (ds, f)))) &&& arr snd <<< second (CausalP.envelope <<< first (one + CausalPS.amplify d)) in CausalP.runStorableChunky (CausalP.envelopeStereo <<< (id &&& (phaserOsci osci <<< CausalP.feedSnd (SigP.zip (piecewiseConstantVector det) (frequencyFromBendModulation (frequencyConst 5) fm)) <<< CausalP.feedSnd (piecewiseConstantVector dist) <<< (CausalP.envelope $< piecewiseConstantVector depth))))) softStringReleaseEnvelope stereoNoise :: SigP p (Stereo.T VectorValue) stereoNoise = traverse (\uid -> SigPS.noise uid (noiseReference 20000)) (Stereo.cons 13 14) windCore :: Param p (PC.T Real) -> Param p (PC.T (BM.T Real)) -> SigP p (Stereo.T VectorValue) windCore reson fm = CausalP.stereoFromMonoControlled CtrlPS.process $< Sig.zipWith (MoogL.parameter TypeNum.d8) (piecewiseConstant reson) (Sig.map Serial.subsample (frequencyFromBendModulation (frequencyConst 0.2) fm)) $* stereoNoise wind :: IO (Real -> PC.T Real -> PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector)) wind = liftA2 (\osc env att reson fm sr vel freq dur -> osc (sr, (reson, (fm,freq))) (env att sr vel dur)) (let reson = control fst fm = modulation snd in CausalP.runStorableChunky $ (CausalP.envelopeStereo $> windCore reson fm)) softStringReleaseEnvelope fadeProcess :: (A.PseudoRing v, A.IntegerConstant v) => CausalP.T p a v -> CausalP.T p a v -> CausalP.T p (v, a) v fadeProcess proc0 proc1 = let k = arr fst a0 = proc0 <<^ snd a1 = proc1 <<^ snd in (one-k)*a0 + k*a1 windPhaser :: IO (Real -> PC.T Real -> PC.T Real -> PC.T Real -> PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector)) windPhaser = liftA2 (\osc env att phaserMix phaserFreq reson fm sr vel freq dur -> osc (sr, ((phaserMix,phaserFreq), reson, (fm,freq))) (env att sr vel dur)) (let phaserMix = control (fst.fst3) phaserFreq = frequencyControl (snd.fst3) reson = control snd3 fm = modulation thd3 in CausalP.runStorableChunky $ (CausalP.envelopeStereo $> ((CausalP.stereoFromMonoControlled (fadeProcess (arr snd) CtrlPS.process <<< first (CausalP.mapSimple Serial.upsample) <<^ (\((k,p),x) -> (k,(p,x)))) $< SigP.zip (piecewiseConstant phaserMix) (piecewiseConstant (fmap (Allpass.flangerParameterPlain TypeNum.d8) ^<< phaserFreq))) $* windCore reson fm))) softStringReleaseEnvelope filterSawStereoFM :: IO (Real -> Real -> PC.T Real -> Real -> Real -> SigSt.ChunkSize -> PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector)) filterSawStereoFM = liftA2 (\osc env dec rel detune bright brightDecay vcsize fm sr vel freq dur -> osc (sr, ((bright, brightDecay), (detune,fm,freq))) (env dec rel vcsize sr vel dur)) (CausalP.runStorableChunky (let bright = frequency (fst.fst) brightDec = time (snd.fst) fm = detuneModulation snd in CausalP.envelopeStereo $> (CausalP.stereoFromMono (UniFilter.lowpass ^<< (CtrlPS.processCtrlRate $# (100::Real)) (\k -> Sig.map (UniFilterL.parameter (LLVM.valueOf 10)) {- bound control in order to avoid too low resonant frequency, which makes the filter instable -} (SigP.exponentialBounded2 (frequencyConst 100) (brightDec/k) (bright))) <<< CausalPS.osciSimple WaveL.saw $< zero) $* stereoFrequenciesFromDetuneBendModulation (frequencyConst 10) fm))) pingReleaseEnvelope {- | The ADSR curve is composed from three parts: Attack, Decay(+Sustain), Release. Attack starts when the key is pressed and lasts attackTime seconds where it reaches height attackPeak*amplitudeOfVelocity. It should be attackPeak>1 because in the following phase we want to approach 1 from above. Say the curve would approach the limit value L if it would continue after the end of the attack phase, the slope is determined by the halfLife with respect to this upper bound. That is, attackHalfLife is the time in seconds where the attack curve reaches or would reach L/2. After Attack the Decay part starts at the same level and decays to amplitudeOfVelocity. The slope is again a halfLife, that is, decayHalfLife is the time where the curve drops from attackPeak*amplitudeOfVelocity to (attackPeak+1)/2*amplitudeOfVelocity. This phase lasts as long as the key is pressed. If the key is released the curve decays with half life releaseHalfLife. -} {- 1 - 2^(-attackTime/attackHalfLife) = peak -} adsr :: IO (Real -> Real -> Real -> Real -> Real -> SigSt.ChunkSize -> SampleRate Real -> Real -> Ev.LazyTime -> SigSt.T Vector) adsr = liftA3 (\attack decay release attackTime attackPeak attackHalfLife decayHalfLife releaseHalfLife vcsize sr vel dur -> let amp = amplitudeFromVelocity vel (attackDur, decayDur) = CutG.splitAt (round (attackTime * vectorRate sr)) dur in SigStL.continuePacked (attack (chunkSizesFromLazyTime attackDur) (sr, (attackHalfLife, attackPeak * amp / (1 - 2^?(-attackTime/attackHalfLife)))) `SigSt.append` decay (chunkSizesFromLazyTime decayDur) (sr, (decayHalfLife, ((attackPeak-1)*amp, amp)))) (\x -> release vcsize (sr,(releaseHalfLife,x)))) (SigP.runChunkyPattern $ let halfLife = time fst amplitude = number snd in SigPS.constant amplitude - SigPS.exponential2 halfLife amplitude) (SigP.runChunkyPattern $ let halfLife = time fst amplitude = number (fst.snd) saturation = number (snd.snd) in SigPS.constant saturation + SigPS.exponential2 halfLife amplitude) (SigP.runChunky $ let releaseTime = vectorTime fst * 5 releaseHL = time fst amplitude = number snd in CausalP.take (round ^<< releaseTime) $* SigPS.exponential2 releaseHL amplitude) brass :: IO (Real -> Real -> Real -> Real -> Real -> Real -> PC.T Real -> PC.T Real -> SigSt.ChunkSize -> PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector)) brass = liftA2 (\osc env attTime attPeak attHL dec rel emph det dist vcsize fm sr vel freq dur -> osc (sr, ((det, dist), (fm,freq), env attTime emph attHL dec rel vcsize sr vel dur)) (env attTime attPeak attHL dec rel vcsize sr vel dur)) (let det = control (fst.fst3) dist = control (snd.fst3) fm = modulation snd3 emph = signal thd3 osci :: Param.T p Real -> CausalP.T p (VectorValue, {- wave shrink/replication factor -} (VectorValue, VectorValue) {- detune, frequency modulation -}) VectorValue osci d = CausalPS.shapeModOsci WaveL.rationalApproxSine1 <<< second (CausalP.feedFst zero <<< CausalP.envelope <<< first (one + CausalPS.amplify d)) in CausalP.runStorableChunky $ (CausalP.envelopeStereo $> (phaserOsci osci <<< CausalP.feedFst (piecewiseConstantVector dist) <<< CausalP.feedSnd (frequencyFromBendModulation (frequencyConst 5) fm) <<< (CausalP.envelope $< piecewiseConstantVector det) $* SigP.fromStorableVectorLazy emph))) adsr sampledSound :: IO (Sample.T -> PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector)) sampledSound = liftA2 (\osc freqMod smp fm sr vel freq dur -> {- We split the frequency modulation signal in order to get a smooth frequency modulation curve. Without (periodic) frequency modulation we could just split the piecewise constant control curve @fm@. -} let fmSig = freqMod (chunkSizesFromLazyTime (PC.duration fm)) (sr, (fm, freq * Sample.period pos)) :: SigSt.T Vector pos = Sample.positions smp amp = 2 * amplitudeFromVelocity vel (attack, sustain, release) = Sample.parts smp in (\cont -> osc cont (sr, (amp, attack `SigSt.append` SVL.cycle (SigSt.take (Sample.loopLength pos) sustain), chunkSizesFromLazyTime dur)) fmSig) (osc (const SigSt.empty) (sr, (amp, release, NonNegChunky.fromChunks (repeat 1000))))) (CausalP.runStorableChunkyCont (let amp = number fst3 smp = signal snd3 dur = parameter thd3 in CausalPS.amplifyStereo amp <<< CausalP.stereoFromMono (CausalPS.pack (CausalP.frequencyModulationLinear (SigP.fromStorableVectorLazy smp))) <<< liftA2 Stereo.cons (CausalPS.amplify 0.999) (CausalPS.amplify 1.001) <<< arr fst <<< CausalP.feedSnd (SigP.lazySize dur))) (SigP.runChunkyPattern (frequencyFromBendModulation (frequencyConst 3) (modulation id))) _sampledSoundLeaky :: IO (Sample.T -> PC.T (BM.T Real) -> Instrument Real (Stereo.T Vector)) _sampledSoundLeaky = liftA2 (\osc freqMod smp fm sr vel freq dur -> {- We split the frequency modulation signal in order to get a smooth frequency modulation curve. Without (periodic) frequency modulation we could just split the piecewise constant control curve @fm@. -} let (sustainFM, releaseFM) = SVP.splitAt (chunkSizesFromLazyTime dur) $ (freqMod (chunkSizesFromLazyTime (PC.duration fm)) (sr, (fm, freq * Sample.period pos)) :: SigSt.T Vector) pos = Sample.positions smp amp = 2 * amplitudeFromVelocity vel (attack, sustain, release) = Sample.parts smp in osc (sr, (amp, attack `SigSt.append` SVL.cycle (SigSt.take (Sample.loopLength pos) sustain))) sustainFM `SigSt.append` osc (sr, (amp,release)) releaseFM) (CausalP.runStorableChunky (let smp = signal snd amp = number fst in CausalPS.amplifyStereo amp <<< CausalP.stereoFromMono (CausalPS.pack (CausalP.frequencyModulationLinear (SigP.fromStorableVectorLazy smp))) <<< liftA2 Stereo.cons (CausalPS.amplify 0.999) (CausalPS.amplify 1.001))) (SigP.runChunkyPattern (frequencyFromBendModulation (frequencyConst 3) (modulation id)))