{-# LANGUAGE Rank2Types #-} module Synthesizer.LLVM.Server.Packed.Instrument where import Synthesizer.LLVM.Server.Common import qualified Synthesizer.EventList.ALSA.MIDI as Ev import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC import qualified Synthesizer.LLVM.Frame.Stereo as Stereo import qualified Sound.Sox.Read as SoxRead import qualified Sound.Sox.Option.Format as SoxOption import Synthesizer.Storable.ALSA.MIDI (Instrument, chunkSizesFromLazyTime, ) 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.ALSA.MIDI as MIDIL import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS import qualified Synthesizer.LLVM.CausalParameterized.ControlledPacked as CtrlPS import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP import qualified Synthesizer.LLVM.Parameterized.Signal as SigP import qualified Synthesizer.LLVM.Storable.Signal as SigStL import qualified Synthesizer.LLVM.Sample as Sample import qualified Synthesizer.LLVM.Wave as WaveL import qualified Synthesizer.LLVM.Parameter as Param import Synthesizer.LLVM.CausalParameterized.Process (($<), ($>), ($*), ) import Synthesizer.LLVM.Parameterized.Signal (($#), ) import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.Monad as LM import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Core as LLVM import qualified Data.TypeLevel.Num as TypeNum import Control.Arrow.Monad ((=<<<), listen, ) import qualified Data.HList as HL 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 Control.Arrow ((<<<), (^<<), (<<^), (&&&), (***), arr, first, second, ) import Control.Applicative (liftA2, liftA3, ) import Data.Tuple.HT (mapPair, fst3, snd3, thd3, ) import Data.Int (Int32, ) {- import qualified Numeric.NonNegative.Class as NonNeg import qualified Numeric.NonNegative.Wrapper as NonNegW -} import qualified Numeric.NonNegative.Chunky as NonNegChunky import qualified Algebra.RealRing as RealRing import qualified Algebra.Additive as Additive import NumericPrelude.Numeric (zero, round, (^?), ) import Prelude hiding (Real, round, break, ) type Vector = LLVM.Vector VectorSize Real type VectorSize = TypeNum.D4 vectorSize :: Int vectorSize = TypeNum.toInt (undefined :: VectorSize) vectorChunkSize :: SVL.ChunkSize vectorChunkSize = let (SVL.ChunkSize size) = chunkSize in SVL.ChunkSize (div size vectorSize) vectorRate :: Fractional a => a vectorRate = sampleRate / fromIntegral vectorSize frequencyFromBendModulation :: {- (Storable a, LLVM.MakeValueTuple a (Value a)) => -} Param.T p Real -> Param.T p (PC.T (PC.BendModulation Real), Real) -> SigP.T p (LLVM.Value Vector) frequencyFromBendModulation speed fmFreq = MIDIL.frequencyFromBendModulationPacked (speed/sampleRate) $* piecewiseConstant (fmap (\(fm,freq) -> transposeModulation freq fm) fmFreq) stereoFrequenciesFromDetuneBendModulation :: Param.T p Real -> Param.T p (PC.T Real, PC.T (PC.BendModulation Real), Real) -> SigP.T p (Stereo.T (LLVM.Value Vector)) stereoFrequenciesFromDetuneBendModulation speed detFmFreq = (CausalP.envelopeStereo $< frequencyFromBendModulation speed (fmap (\(_det,fm,freq) -> (fm,freq)) detFmFreq)) <<< CausalP.zipWithSimple Sample.zipStereo <<< CausalPS.raise 1 &&& (CausalPS.raise 1 <<< CausalP.mapSimple LLVM.neg) $* piecewiseConstantVector (fmap (\(det,_fm,_freq) -> det) detFmFreq) pingReleaseEnvelope :: IO (Real -> Real -> Real -> Ev.LazyTime -> SigSt.T Vector) pingReleaseEnvelope = liftA2 (\pressed release decay rel vel dur -> SigStL.continuePacked (pressed (chunkSizesFromLazyTime dur) (decay,vel)) (\x -> release vectorChunkSize (rel,x))) (SigP.runChunkyPattern $ let decay = arr fst velocity = arr snd in SigPS.exponential2 (decay*sampleRate) (amplitudeFromVelocity ^<< velocity)) (SigP.runChunky $ let release = arr fst amplitude = arr snd in (CausalP.take (round ^<< (release*5*vectorRate)) $* SigPS.exponential2 (release*sampleRate) amplitude)) pingRelease :: IO (Real -> Real -> Instrument Real Vector) pingRelease = liftA2 (\osc env dec rel vel freq dur -> osc freq (env dec rel vel dur)) (CausalP.runStorableChunky (let freq = arr id in CausalP.envelope $> SigPS.osciSimple WaveL.saw zero (freq/sampleRate))) pingReleaseEnvelope pingStereoRelease :: IO (Real -> Real -> Instrument Real (Stereo.T Vector)) pingStereoRelease = liftA2 (\osc env dec rel vel freq dur -> osc freq (env dec rel vel dur)) (CausalP.runStorableChunky (let freq = arr id in CausalP.envelopeStereo $> SigP.zipWithSimple Sample.zipStereo (SigPS.osciSimple WaveL.saw zero (0.999*freq/sampleRate)) (SigPS.osciSimple WaveL.saw zero (1.001*freq/sampleRate)))) pingReleaseEnvelope pingStereoReleaseFM :: IO (Real -> Real -> PC.T Real -> PC.T Real -> Real -> Real -> PC.T (PC.BendModulation Real) -> Instrument Real (Stereo.T Vector)) pingStereoReleaseFM = liftA2 (\osc env dec rel detune shape phase phaseDecay fm vel freq dur -> osc ((phase, phaseDecay), shape, (detune,fm,freq)) (env dec rel vel dur)) (CausalP.runStorableChunky (let phs = arr (fst.fst3) dec = arr (snd.fst3) shp = arr snd3 fm = arr thd3 in CausalP.envelopeStereo $> ((CausalP.stereoFromMonoControlled (CausalPS.shapeModOsci WaveL.rationalApproxSine1) $< piecewiseConstantVector shp) <<^ Stereo.interleave $< (CausalP.zipWithSimple Sample.zipStereo <<< arr id &&& CausalP.mapSimple LLVM.neg $* SigPS.exponential2 (dec*sampleRate) phs) $* stereoFrequenciesFromDetuneBendModulation 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 -> PC.T (PC.BendModulation Real) -> Instrument Real (Stereo.T Vector)) squareStereoReleaseFM = liftA2 (\osc env dec rel detune shape phase fm vel freq dur -> osc ((phase, shape), (detune,fm,freq)) (env dec rel vel dur)) (CausalP.runStorableChunky (let phs = arr (fst.fst) shp = arr (snd.fst) fm = arr snd chanOsci = CausalP.mix <<< (CausalPS.shapeModOsci WaveL.rationalApproxSine1 <<< second (first (CausalP.mapSimple LLVM.neg))) &&& (CausalP.mapSimple LLVM.neg <<< CausalPS.shapeModOsci WaveL.rationalApproxSine1) <<^ (\((p,s),f) -> (s,(p,f))) in CausalP.envelopeStereo $> ((CausalP.stereoFromMonoControlled chanOsci $< SigP.zip (piecewiseConstantVector phs) (piecewiseConstantVector shp)) $* stereoFrequenciesFromDetuneBendModulation 10 fm))) pingReleaseEnvelope bellStereoFM :: IO (Real -> Real -> PC.T Real -> PC.T (PC.BendModulation Real) -> Instrument Real (Stereo.T Vector)) bellStereoFM = liftA2 (\osc env dec rel detune fm vel freq dur -> osc ((detune, fm, freq), vel, (env (dec/4) rel vel dur, env (dec/7) rel vel dur)) (env dec rel vel dur)) (CausalP.runStorableChunky (let fm = arr fst3 vel = arr snd3 env4 = arr (fst.thd3) env7 = arr (snd.thd3) mix x y = CausalP.mixStereo <<< x&&&y osci sel v d = CausalP.envelopeStereo <<< (arr sel *** (CausalPS.amplifyStereo v <<< CausalP.stereoFromMono (CausalPS.osciSimple WaveL.approxSine4 $< SigPS.constant zero) <<< CausalPS.amplifyStereo d)) in (osci fst3 0.6 1 `mix` osci snd3 (0.02 * 50^?vel) 4 `mix` osci thd3 (0.02 * 100^?vel) 7) <<< CausalP.feedSnd (stereoFrequenciesFromDetuneBendModulation 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 -> PC.T (PC.BendModulation Real) -> Instrument Real (Stereo.T Vector)) bellNoiseStereoFM = liftA2 (\osc env dec rel noiseAmp noiseReson fm vel freq dur -> osc ((fm, freq), (noiseAmp,noiseReson), (vel, env (dec/4) rel vel dur, env (dec/7) rel vel dur)) (env dec rel vel dur)) (CausalP.runStorableChunky (let fm = arr fst3 noiseAmp = arr (fst.snd3) noiseReson = arr (snd.snd3) vel = arr (fst3.thd3) env4 = arr (snd3.thd3) env7 = arr (thd3.thd3) mix x y = CausalP.mix <<< x&&&y osci sel v d = CausalP.envelope <<< (arr sel *** (CausalPS.amplify v <<< (CausalPS.osciSimple WaveL.approxSine4 $< SigPS.constant zero) <<< CausalPS.amplify d)) noise sel d = (CausalP.envelope $< piecewiseConstantVector noiseAmp) <<< CausalP.envelope <<< (arr sel *** ({- UniFilter.lowpass ^<< -} (CtrlPS.process $> SigPS.noise 12 (sampleRate/20000)) <<< -- CausalP.zipWithSimple UniFilterL.parameter CausalP.zipWithSimple (MoogL.parameter TypeNum.d8) {- FIXME: This leads to a run-time crash even without LLVM optimizations. However, I cannot reproduce this in the Test module. (CausalP.quantizeLift $# (1 :: Real)) (arr id) (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 Sample.subsampleVector <<< CausalPS.amplify d)) in CausalP.zipWithSimple Sample.zipStereo <<< (osci fst3 0.6 (1*0.999) `mix` osci snd3 (0.02 * 50^?vel) (4*0.999) `mix` osci thd3 (0.02 * 100^?vel) (7*0.999) `mix` noise fst3 0.999) &&& (osci fst3 0.6 (1*1.001) `mix` osci snd3 (0.02 * 50^?vel) (4*1.001) `mix` osci thd3 (0.02 * 100^?vel) (7*1.001) `mix` noise fst3 1.001) <<< CausalP.feedSnd (frequencyFromBendModulation 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 -> Instrument Real Vector) tine = liftA2 (\osc env dec rel vel freq dur -> osc (vel,freq) (env dec rel 0 dur)) (CausalP.runStorableChunky (let freq = arr snd vel = arr fst in CausalP.envelope $> (CausalPS.osciSimple WaveL.approxSine2 $> (SigPS.constant (freq/sampleRate)) $* (CausalP.envelope $< SigPS.exponential2 (1*sampleRate) (vel+1) $* SigPS.osciSimple WaveL.approxSine2 zero (2*freq/sampleRate))))) pingReleaseEnvelope tineStereo :: IO (Real -> Real -> Instrument Real (Stereo.T Vector)) tineStereo = liftA2 (\osc env dec rel vel freq dur -> osc (vel,freq) (env dec rel 0 dur)) (CausalP.runStorableChunky (let freq = arr snd vel = arr fst chanOsci d = CausalPS.osciSimple WaveL.approxSine2 $> SigPS.constant (freq*d/sampleRate) in CausalP.envelopeStereo $> ((CausalP.zipWithSimple Sample.zipStereo <<< (chanOsci 0.995 &&& chanOsci 1.005)) $* SigP.envelope (SigPS.exponential2 (1*sampleRate) (vel+1)) (SigPS.osciSimple WaveL.approxSine2 zero (2*freq/sampleRate))))) pingReleaseEnvelope softStringReleaseEnvelope :: IO (Real -> Real -> Ev.LazyTime -> SigSt.T Vector) softStringReleaseEnvelope = liftA2 (\rev env attackTime vel dur -> let attackTimeVector = div (round (attackTime*sampleRate)) vectorSize amp = amplitudeFromVelocity vel {- 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) (amp, attackTimeVector) release = rev attack in attack `SigSt.append` sustain `SigSt.append` release) SigStL.makeReversePacked (let amp = arr fst attackTimeVector = arr snd in SigP.runChunkyPattern $ flip SigP.append (SigPS.constant amp) $ (CausalPS.amplify amp <<< CausalP.take attackTimeVector $* SigPS.parabolaFadeInInf (fmap fromIntegral attackTimeVector * fromIntegral vectorSize))) softString :: IO (Instrument Real (Stereo.T Vector)) softString = liftA2 (\osc env vel freq dur -> osc freq (env 1 vel dur)) (let freq = arr id osci d = SigPS.osciSimple WaveL.saw zero (d * freq / sampleRate) in CausalP.runStorableChunky $ (CausalP.envelopeStereo $> (SigP.zipWithSimple Sample.zipStereo (SigP.mix (osci 1.005) (osci 0.998)) (SigP.mix (osci 1.002) (osci 0.995))))) softStringReleaseEnvelope softStringFM :: IO (PC.T (PC.BendModulation Real) -> Instrument Real (Stereo.T Vector)) softStringFM = liftA2 (\osc env fm vel freq dur -> osc (fm,freq) (env 1 vel dur)) (let fm = arr id osci :: Param.T fm Real -> CausalP.T fm (LLVM.Value Vector) (LLVM.Value Vector) osci d = (CausalPS.osciSimple WaveL.saw $< (SigPS.constant $# (zero::Real))) <<< CausalPS.amplify d in CausalP.runStorableChunky $ (CausalP.envelopeStereo $> (CausalP.zipWithSimple Sample.zipStereo <<< (CausalP.mix <<< osci 1.005 &&& osci 0.998) &&& (CausalP.mix <<< osci 1.002 &&& osci 0.995) $* frequencyFromBendModulation 5 fm))) softStringReleaseEnvelope tineStereoFM :: IO (Real -> Real -> PC.T (PC.BendModulation Real) -> Instrument Real (Stereo.T Vector)) tineStereoFM = liftA2 (\osc env dec rel fm vel freq dur -> osc (vel,(fm,freq)) (env dec rel 0 dur)) (CausalP.runStorableChunky (let vel = arr fst fm = arr snd chanOsci d = CausalPS.osciSimple WaveL.approxSine2 <<< second (CausalPS.amplify d) in CausalP.envelopeStereo $> ((CausalP.zipWithSimple Sample.zipStereo <<< chanOsci 0.995 &&& chanOsci 1.005) <<< (((CausalP.envelope $< SigPS.exponential2 (1*sampleRate) (vel+1)) <<< (CausalPS.osciSimple WaveL.approxSine2 $< (SigPS.constant $# (zero::Real))) <<< CausalPS.amplify 2) &&& arr id) $* frequencyFromBendModulation 5 fm))) pingReleaseEnvelope tineControlledProc, tineControlledFnProc :: Param.T p (PC.T Real) -> Param.T p (PC.T Real) -> Param.T p Real -> CausalP.T p (Stereo.T (LLVM.Value Vector)) (Stereo.T (LLVM.Value Vector)) tineControlledProc index depth vel = CausalP.stereoFromMono (CausalPS.osciSimple WaveL.approxSine2) <<< Stereo.interleave ^<< ((CausalP.envelopeStereo $< SigP.envelope (piecewiseConstantVector depth) (SigPS.exponential2 (1*sampleRate) (vel+1))) <<< CausalP.stereoFromMono (CausalPS.osciSimple WaveL.approxSine2 $< (SigPS.constant $# (zero::Real))) <<< (CausalP.envelopeStereo $< piecewiseConstantVector index)) &&& arr id tineControlledFnProc index depth vel = ((\freq -> CausalP.stereoFromMono (CausalPS.osciSimple WaveL.approxSine2) <<< Stereo.interleave ^<< ((CausalP.envelopeStereo $< SigP.envelope (piecewiseConstantVector depth) (SigPS.exponential2 (1*sampleRate) (vel+1))) <<< CausalP.stereoFromMono (CausalPS.osciSimple WaveL.approxSine2 $< (SigPS.constant $# (zero::Real))) <<< (CausalP.envelopeStereo $< piecewiseConstantVector index) <<< listen freq) &&& listen freq) -- =<<< listen HL.hNil =<<< arr HL.hHead) <<< arr (\freq -> HL.hCons freq HL.hNil) tineControlledFM :: IO (Real -> Real -> PC.T Real -> PC.T Real -> PC.T Real -> PC.T (PC.BendModulation Real) -> Instrument Real (Stereo.T Vector)) tineControlledFM = liftA2 (\osc env dec rel detune index depth fm vel freq dur -> osc ((index, depth), vel, (detune,fm,freq)) (env dec rel 0 dur)) (CausalP.runStorableChunky (let index = arr (fst.fst3) depth = arr (snd.fst3) vel = arr snd3 fm = arr thd3 in CausalP.envelopeStereo $> (tineControlledFnProc index depth vel $* stereoFrequenciesFromDetuneBendModulation 5 fm))) pingReleaseEnvelope fenderProc :: Param.T p (PC.T Real) -> Param.T p (PC.T Real) -> Param.T p (PC.T Real) -> Param.T p Real -> CausalP.T p (Stereo.T (LLVM.Value Vector)) (Stereo.T (LLVM.Value Vector)) fenderProc fade index depth vel = ((\stereoFreq -> let channel_n_1 freq = CausalPS.osciSimple WaveL.approxSine2 <<< ((CausalP.envelope $< SigP.envelope (piecewiseConstantVector depth) (SigPS.exponential2 (1*sampleRate) (vel+1))) <<< (CausalPS.osciSimple WaveL.approxSine2 $< (SigPS.constant $# (zero::Real))) <<< (CausalP.envelope $< piecewiseConstantVector index) <<< freq) &&& freq channel_1_2 freq = CausalPS.osciSimple WaveL.approxSine2 <<< ((CausalP.envelope $< SigP.envelope (piecewiseConstantVector depth) (SigPS.exponential2 (1*sampleRate) (vel+1))) <<< (CausalPS.osciSimple WaveL.approxSine2 $< (SigPS.constant $# (zero::Real))) <<< freq) &&& (CausalPS.amplify 2 <<< freq) in (CausalP.stereoFromMonoControlled (fadeProcess (channel_n_1 (arr id)) (channel_1_2 (arr id))) $< piecewiseConstantVector fade) <<< listen stereoFreq) =<<< arr HL.hHead) <<< arr (\freq -> HL.hCons freq HL.hNil) fenderFM :: IO (Real -> Real -> PC.T Real -> PC.T Real -> PC.T Real -> PC.T Real -> PC.T (PC.BendModulation Real) -> Instrument Real (Stereo.T Vector)) fenderFM = liftA2 (\osc env dec rel detune index depth fade fm vel freq dur -> osc (((index, depth), fade), vel, (detune,fm,freq)) (env dec rel 0 dur)) (CausalP.runStorableChunky (let index = arr (fst.fst.fst3) depth = arr (snd.fst.fst3) fade = arr (snd.fst3) vel = arr snd3 fm = arr thd3 in CausalP.envelopeStereo $> (fenderProc fade index depth vel $* stereoFrequenciesFromDetuneBendModulation 5 fm))) pingReleaseEnvelope tineModulatorBankFM :: IO (Real -> Real -> PC.T Real -> PC.T Real -> PC.T Real -> PC.T Real -> PC.T Real -> PC.T (PC.BendModulation Real) -> Instrument Real (Stereo.T Vector)) tineModulatorBankFM = liftA2 (\osc env dec rel detune depth1 depth2 depth3 depth4 fm vel freq dur -> osc ((depth1,(depth2,(depth3,(depth4,())))), vel, (detune,fm,freq)) (env dec rel 0 dur)) (CausalP.runStorableChunky (let depth1 = arr (fst.fst3) depth2 = arr (fst.snd.fst3) depth3 = arr (fst.snd.snd.fst3) depth4 = arr (fst.snd.snd.snd.fst3) vel = arr snd3 fm = arr thd3 mix x y = CausalP.mixStereo <<< x&&&y modulator n depth = (CausalP.envelopeStereo $< SigP.envelope (piecewiseConstantVector depth) (SigPS.exponential2 (1*sampleRate) (vel+1))) <<< CausalP.stereoFromMono (CausalPS.osciSimple WaveL.approxSine2 $< (SigPS.constant $# (zero::Real))) <<< CausalP.amplifyStereo n in CausalP.envelopeStereo $> (CausalP.stereoFromMono (CausalPS.osciSimple WaveL.approxSine2) <<< Stereo.interleave ^<< (modulator 1 depth1 `mix` modulator 2 depth2 `mix` modulator 3 depth3 `mix` modulator 4 depth4) &&& arr id $* stereoFrequenciesFromDetuneBendModulation 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 -> PC.T (PC.BendModulation Real) -> Instrument Real (Stereo.T Vector)) tineBankFM = liftA2 (\osc env dec rel detune depth1 depth2 depth3 depth4 partial1 partial2 partial3 partial4 fm vel freq dur -> osc ((depth1,(depth2,(depth3,(depth4,())))), (partial1,(partial2,(partial3,(partial4,())))), (vel, (detune,fm,freq))) (env dec rel 0 dur)) (CausalP.runStorableChunky (let depth1 = arr (fst.fst3) depth2 = arr (fst.snd.fst3) depth3 = arr (fst.snd.snd.fst3) depth4 = arr (fst.snd.snd.snd.fst3) partial1 = arr (fst.snd3) partial2 = arr (fst.snd.snd3) partial3 = arr (fst.snd.snd.snd3) partial4 = arr (fst.snd.snd.snd.snd3) vel = arr (fst.thd3) fm = arr (snd.thd3) mixStereo x y = CausalP.mixStereo <<< x&&&y modulator n depth = (CausalP.envelopeStereo $< SigP.envelope (piecewiseConstantVector depth) (SigPS.exponential2 (1*sampleRate) (vel+1))) <<< CausalP.stereoFromMono (CausalPS.osciSimple WaveL.approxSine2 $< (SigPS.constant $# (zero::Real))) <<< CausalP.amplifyStereo n partial :: LLVM.Value Vector -> Int32 -> LLVM.Value Vector -> LLVM.CodeGenFunction r (LLVM.Value Vector) partial amp n t = A.mul amp =<< WaveL.partial WaveL.approxSine2 (LLVM.valueOf 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 ^<< (modulator 1 depth1 `mixStereo` modulator 2 depth2 `mixStereo` modulator 3 depth3 `mixStereo` modulator 4 depth4) &&& arr id $* stereoFrequenciesFromDetuneBendModulation 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.T p (PC.T Real) -> Param.T p (PC.T Real) -> Param.T p (PC.T Real) -> Param.T p Real -> CausalP.T p (Stereo.T (LLVM.Value Vector)) (Stereo.T (LLVM.Value Vector)) resonantFMSynthProc reson index depth vel = ((\stereoFreq -> let chan freq = CausalPS.osciSimple WaveL.approxSine2 <<< ((CausalP.envelope $< SigP.envelope (piecewiseConstantVector depth) (SigPS.exponential2 (1*sampleRate) (vel+1))) <<< UniFilter.lowpass ^<< CtrlPS.process <<< (CausalP.zipWithSimple UniFilterL.parameter <<< CausalP.feedFst (piecewiseConstant reson) <<< (CausalP.envelope $< piecewiseConstant index) <<< CausalP.mapSimple Sample.subsampleVector <<< freq) &&& ((CausalPS.osciSimple WaveL.saw $< (SigPS.constant $# (zero::Real))) <<< freq)) &&& freq in CausalP.stereoFromMono (chan (arr id)) <<< listen stereoFreq) =<<< arr HL.hHead) <<< arr (\freq -> HL.hCons freq HL.hNil) resonantFMSynth :: IO (Real -> Real -> PC.T Real -> PC.T Real -> PC.T Real -> PC.T Real -> PC.T (PC.BendModulation Real) -> Instrument Real (Stereo.T Vector)) resonantFMSynth = liftA2 (\osc env dec rel detune reson index depth fm vel freq dur -> osc ((reson, index, depth), vel, (detune,fm,freq)) (env dec rel 0 dur)) (CausalP.runStorableChunky (let reson = arr (fst3.fst3) index = arr (snd3.fst3) depth = arr (thd3.fst3) vel = arr snd3 fm = arr thd3 in CausalP.envelopeStereo $> (resonantFMSynthProc reson index depth vel $* stereoFrequenciesFromDetuneBendModulation 5 fm))) pingReleaseEnvelope piecewiseConstantVector :: Param.T p (PC.T Real) -> SigP.T p (LLVM.Value Vector) {- (Storable a, LLVM.MakeValueTuple a al, Rep.Memory al am, LLVM.IsSized am as) => Param.T p (PC.T a) -> SigP.T p (LLVM.Vector n al) -} piecewiseConstantVector pc = SigP.mapSimple SoV.replicate $ piecewiseConstant pc softStringDetuneFM :: IO (Real -> PC.T Real -> PC.T (PC.BendModulation Real) -> Instrument Real (Stereo.T Vector)) softStringDetuneFM = liftA2 (\osc env att det fm vel freq dur -> osc (det, (fm,freq)) (env att vel dur)) (let det = arr fst fm = arr snd mix x y = CausalP.mix <<< x&&&y osci :: Param.T (det,fm) Real -> CausalP.T (det,fm) (LLVM.Value Vector, LLVM.Value Vector) (LLVM.Value Vector) osci d = (CausalPS.osciSimple WaveL.saw $< (SigPS.constant $# (zero::Real))) <<< CausalP.envelope <<< first (CausalPS.raise 1 <<< CausalPS.amplify d) in CausalP.runStorableChunky $ (CausalP.envelopeStereo $> (CausalPS.amplifyStereo 0.25 <<< CausalP.zipWithSimple Sample.zipStereo <<< ((osci 1.0 `mix` osci (-0.4)) `mix` (osci 0.5 `mix` osci (-0.7))) &&& ((osci 0.4 `mix` osci (-1.0)) `mix` (osci 0.7 `mix` osci (-0.5))) <<< CausalP.feedFst (piecewiseConstantVector det) $* frequencyFromBendModulation 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 (PC.BendModulation 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. LLVM.Value Vector -> LLVM.CodeGenFunction r (LLVM.Value Vector)) -> IO (Real -> PC.T Real -> PC.T Real -> PC.T (PC.BendModulation Real) -> Instrument Real (Stereo.T Vector)) arcStringStereoFM wave = softStringShapeCore (\k p -> LM.liftR2 Sample.amplifyMono (WaveL.approxSine4 =<< WaveL.halfEnvelope p) (wave =<< WaveL.replicate k p)) softStringShapeCore :: (forall r. LLVM.Value Vector -> LLVM.Value Vector -> LLVM.CodeGenFunction r (LLVM.Value Vector)) -> IO (Real -> PC.T Real -> PC.T Real -> PC.T (PC.BendModulation Real) -> Instrument Real (Stereo.T Vector)) softStringShapeCore wave = liftA2 (\osc env att det dist fm vel freq dur -> osc ((det, dist), (fm,freq)) (env att vel dur)) (let det = arr (fst.fst) dist = arr (snd.fst) fm = arr snd mix x y = CausalP.mix <<< x&&&y osci :: Param.T (mod,fm) Real -> CausalP.T (mod,fm) (LLVM.Value Vector, {- wave shape parameter -} (LLVM.Value Vector, LLVM.Value Vector) {- detune, frequency modulation -}) (LLVM.Value Vector) osci d = CausalPS.shapeModOsci wave <<< second (CausalP.feedFst (SigPS.constant $# (zero::Real)) <<< CausalP.envelope <<< first (CausalPS.raise 1 <<< CausalPS.amplify d)) in CausalP.runStorableChunky $ (CausalP.envelopeStereo $> (CausalPS.amplifyStereo 0.25 <<< CausalP.zipWithSimple Sample.zipStereo <<< ((osci 1.0 `mix` osci (-0.4)) `mix` (osci 0.5 `mix` osci (-0.7))) &&& ((osci 0.4 `mix` osci (-1.0)) `mix` (osci 0.7 `mix` osci (-0.5))) $< piecewiseConstantVector dist $< piecewiseConstantVector det $* frequencyFromBendModulation 5 fm))) softStringReleaseEnvelope fmStringStereoFM :: IO (Real -> PC.T Real -> PC.T Real -> PC.T Real -> PC.T (PC.BendModulation Real) -> Instrument Real (Stereo.T Vector)) fmStringStereoFM = liftA2 (\osc env att det depth dist fm vel freq dur -> osc ((det, depth, dist), (fm, freq)) (env att vel dur)) (let det = arr (fst3.fst) depth = arr (snd3.fst) dist = arr (thd3.fst) fm = arr snd mix x y = CausalP.mix <<< x&&&y osci :: Param.T (mod,fm) Real -> CausalP.T (mod,fm) ((LLVM.Value Vector, LLVM.Value Vector) {- phase modulation depth, modulator distortion -}, (LLVM.Value Vector, LLVM.Value Vector) {- detune, frequency modulation -}) (LLVM.Value Vector) osci d = CausalPS.osciSimple WaveL.approxSine2 <<< (CausalP.envelope <<< second (CausalPS.shapeModOsci WaveL.rationalApproxSine1 <<< second (CausalP.feedFst (SigPS.constant 0))) <<^ (\((dp, ds), f) -> (dp, (ds, f)))) &&& arr snd <<< second (CausalP.envelope <<< first (CausalPS.raise 1 <<< CausalPS.amplify d)) in CausalP.runStorableChunky (CausalP.envelopeStereo <<< (arr id &&& (CausalPS.amplifyStereo 0.25 <<< CausalP.zipWithSimple Sample.zipStereo <<< ((osci 1.0 `mix` osci (-0.4)) `mix` (osci 0.5 `mix` osci (-0.7))) &&& ((osci 0.4 `mix` osci (-1.0)) `mix` (osci 0.7 `mix` osci (-0.5))) <<< CausalP.feedSnd (SigP.zip (piecewiseConstantVector det) (frequencyFromBendModulation 5 fm)) <<< CausalP.feedSnd (piecewiseConstantVector dist) <<< (CausalP.envelope $< piecewiseConstantVector depth))))) softStringReleaseEnvelope wind :: IO (Real -> PC.T Real -> PC.T (PC.BendModulation Real) -> Instrument Real (Stereo.T Vector)) wind = liftA2 (\osc env att reson fm vel freq dur -> osc (reson, (fm,freq)) (env att vel dur)) (let reson = arr fst fm = arr snd in CausalP.runStorableChunky $ (CausalP.envelopeStereo $> (CausalP.stereoFromMonoControlled CtrlPS.process $< SigP.zipWithSimple (MoogL.parameter TypeNum.d8) (piecewiseConstant reson) (SigP.mapSimple Sample.subsampleVector (frequencyFromBendModulation 0.2 fm)) $* SigP.zipWithSimple Sample.zipStereo (SigPS.noise 13 (sampleRate/20000)) (SigPS.noise 14 (sampleRate/20000) :: SigP.T p (LLVM.Value Vector))))) softStringReleaseEnvelope fadeProcess :: (Num b, LLVM.IsConst b, LLVM.IsArithmetic v, SoV.Replicate b v) => CausalP.T p a (LLVM.Value v) -> CausalP.T p a (LLVM.Value v) -> CausalP.T p (LLVM.Value v, a) (LLVM.Value v) fadeProcess proc0 proc1 = CausalP.mapSimple (\(k,(a0,a1)) -> do b0 <- A.mul a0 =<< A.sub (SoV.replicateOf 1) k b1 <- A.mul a1 k A.add b0 b1) <<< second (proc0 &&& proc1) windPhaser :: IO (Real -> PC.T Real -> PC.T Real -> PC.T Real -> PC.T (PC.BendModulation Real) -> Instrument Real (Stereo.T Vector)) windPhaser = liftA2 (\osc env att phaserMix phaserFreq reson fm vel freq dur -> osc ((phaserMix,phaserFreq), reson, (fm,freq)) (env att vel dur)) (let phaserMix = arr (fst.fst3) phaserFreq = arr (snd.fst3) reson = arr snd3 fm = arr thd3 in CausalP.runStorableChunky $ (CausalP.envelopeStereo $> ((CausalP.stereoFromMonoControlled (fadeProcess (arr snd) CtrlPS.process <<< first (CausalP.mapSimple SoV.replicate) <<^ (\((k,p),x) -> (k,(p,x)))) $< SigP.zip (piecewiseConstant phaserMix) (piecewiseConstant (fmap (Allpass.flangerParameterPlain TypeNum.d8 . (/sampleRate)) ^<< phaserFreq))) <<< CausalP.stereoFromMonoControlled CtrlPS.process $< SigP.zipWithSimple (MoogL.parameter TypeNum.d8) (piecewiseConstant reson) (SigP.mapSimple Sample.subsampleVector (frequencyFromBendModulation 0.2 fm)) $* SigP.zipWithSimple Sample.zipStereo (SigPS.noise 13 (sampleRate/20000)) (SigPS.noise 14 (sampleRate/20000) :: SigP.T p (LLVM.Value Vector))))) softStringReleaseEnvelope filterSawStereoFM :: IO (Real -> Real -> PC.T Real -> Real -> Real -> PC.T (PC.BendModulation Real) -> Instrument Real (Stereo.T Vector)) filterSawStereoFM = liftA2 (\osc env dec rel detune bright brightDecay fm vel freq dur -> osc ((bright, brightDecay), (detune,fm,freq)) (env dec rel vel dur)) (CausalP.runStorableChunky (let bright = arr (fst.fst) brightDec = arr (snd.fst) fm = arr snd in CausalP.envelopeStereo $> (CausalP.stereoFromMono (UniFilter.lowpass ^<< (CtrlPS.processCtrlRate $# (100::Real)) (\k -> SigP.mapSimple (UniFilterL.parameter (LLVM.valueOf 10)) {- bound control in order to avoid too low resonant frequency, which makes the filter instable -} (SigP.exponentialBounded2 (100/sampleRate) (brightDec*sampleRate/k) (bright/sampleRate))) <<< CausalPS.osciSimple WaveL.saw $< SigPS.constant zero) $* stereoFrequenciesFromDetuneBendModulation 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 -> Real -> Ev.LazyTime -> SigSt.T Vector) adsr = liftA3 (\attack decay release attackTime attackPeak attackHalfLife decayHalfLife releaseHalfLife vel dur -> let amp = amplitudeFromVelocity vel (attackDur, decayDur) = CutG.splitAt (round (attackTime*vectorRate)) dur in SigStL.continuePacked (attack (chunkSizesFromLazyTime attackDur) (attackHalfLife, attackPeak * amp / (1 - 2^?(-attackTime/attackHalfLife))) `SigSt.append` decay (chunkSizesFromLazyTime decayDur) (decayHalfLife, ((attackPeak-1)*amp, amp))) (\x -> release vectorChunkSize (releaseHalfLife,x))) (SigP.runChunkyPattern $ let halfLife = arr fst amplitude = arr snd in SigP.zipWithSimple A.sub (SigPS.constant amplitude) (SigPS.exponential2 (halfLife*sampleRate) amplitude)) (SigP.runChunkyPattern $ let halfLife = arr fst amplitude = arr (fst.snd) saturation = arr (snd.snd) in SigP.mix (SigPS.constant saturation) $ SigPS.exponential2 (halfLife*sampleRate) amplitude) (SigP.runChunky $ let release = arr fst amplitude = arr snd in (CausalP.take (round ^<< (release*5*vectorRate)) $* SigPS.exponential2 (release*sampleRate) amplitude)) brass :: IO (Real -> Real -> Real -> Real -> Real -> Real -> PC.T Real -> PC.T Real -> PC.T (PC.BendModulation Real) -> Instrument Real (Stereo.T Vector)) brass = liftA2 (\osc env attTime attPeak attHL dec rel emph det dist fm vel freq dur -> osc ((det, dist), (fm,freq), env attTime emph attHL dec rel vel dur) (env attTime attPeak attHL dec rel vel dur)) (let det = arr (fst.fst3) dist = arr (snd.fst3) fm = arr snd3 emph = arr thd3 mix x y = CausalP.mix <<< x&&&y osci :: Param.T p Real -> CausalP.T p (LLVM.Value Vector, {- wave shrink/replication factor -} (LLVM.Value Vector, LLVM.Value Vector) {- detune, frequency modulation -}) (LLVM.Value Vector) osci d = CausalPS.shapeModOsci WaveL.rationalApproxSine1 <<< second (CausalP.feedFst (SigPS.constant $# (zero::Real)) <<< CausalP.envelope <<< first (CausalPS.raise 1 <<< CausalPS.amplify d)) in CausalP.runStorableChunky $ (CausalP.envelopeStereo $> (CausalPS.amplifyStereo 0.25 <<< CausalP.zipWithSimple Sample.zipStereo <<< ((osci 1.0 `mix` osci (-0.4)) `mix` (osci 0.5 `mix` osci (-0.7))) &&& ((osci 0.4 `mix` osci (-1.0)) `mix` (osci 0.7 `mix` osci (-0.5))) <<< CausalP.feedFst (piecewiseConstantVector dist) <<< CausalP.feedSnd (frequencyFromBendModulation 5 fm) <<< (CausalP.envelope $< piecewiseConstantVector det) $* SigP.fromStorableVectorLazy emph))) adsr data SamplePositions = SamplePositions { sampleStart, sampleLength, sampleLoopStart, sampleLoopLength :: Int } data SampledSound = SampledSound { sampleData :: SigSt.T Real, samplePositions :: SamplePositions, samplePeriod :: Real } sampledSound :: IO (SampledSound -> PC.T (PC.BendModulation Real) -> Instrument Real (Stereo.T Vector)) sampledSound = liftA2 (\osc freqMod smp fm 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)) (fm, freq*samplePeriod smp) :: SigSt.T Vector pos = samplePositions smp amp = 2 * amplitudeFromVelocity vel (attack,sustain) = mapPair (SigSt.drop (sampleStart pos), SigSt.take (sampleLoopLength pos)) $ SigSt.splitAt (sampleLoopStart pos) $ sampleData smp release = SigSt.drop (sampleLoopStart pos + sampleLoopLength pos) $ SigSt.take (sampleStart pos + sampleLength pos) $ sampleData smp in (\cont -> osc cont (amp, attack `SigSt.append` SVL.cycle (SigSt.take (sampleLoopLength pos) sustain), chunkSizesFromLazyTime dur) fmSig) (osc (const SigSt.empty) (amp, release, NonNegChunky.fromChunks (repeat 1000)))) (CausalP.runStorableChunkyCont (let amp = arr fst3 smp = arr snd3 dur = arr thd3 in CausalPS.amplifyStereo amp <<< CausalP.stereoFromMono (CausalPS.pack (CausalP.frequencyModulationLinear (SigP.fromStorableVectorLazy smp))) <<< CausalP.zipWithSimple Sample.zipStereo <<< CausalPS.amplify 0.999 &&& CausalPS.amplify 1.001 <<< arr fst <<< CausalP.feedSnd (SigP.lazySize dur))) (SigP.runChunkyPattern (frequencyFromBendModulation 3 (arr id))) sampledSoundLeaky :: IO (SampledSound -> PC.T (PC.BendModulation Real) -> Instrument Real (Stereo.T Vector)) sampledSoundLeaky = liftA2 (\osc freqMod smp fm 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)) (fm, freq*samplePeriod smp) :: SigSt.T Vector) pos = samplePositions smp amp = 2 * amplitudeFromVelocity vel (attack,sustain) = mapPair (SigSt.drop (sampleStart pos), SigSt.take (sampleLoopLength pos)) $ SigSt.splitAt (sampleLoopStart pos) $ sampleData smp release = SigSt.drop (sampleLoopStart pos + sampleLoopLength pos) $ SigSt.take (sampleStart pos + sampleLength pos) $ sampleData smp in osc (amp, attack `SigSt.append` SVL.cycle (SigSt.take (sampleLoopLength pos) sustain)) sustainFM `SigSt.append` osc (amp,release) releaseFM) (CausalP.runStorableChunky (let smp = arr snd amp = arr fst in CausalPS.amplifyStereo amp <<< CausalP.stereoFromMono (CausalPS.pack (CausalP.frequencyModulationLinear (SigP.fromStorableVectorLazy smp))) <<< CausalP.zipWithSimple Sample.zipStereo <<< CausalPS.amplify 0.999 &&& CausalPS.amplify 1.001)) (SigP.runChunkyPattern (frequencyFromBendModulation 3 (arr id))) type SampleInfo = (FilePath, [SamplePositions], Real) makeSampledSounds :: SampleInfo -> IO [-- PC.T Real -> PC.T (PC.BendModulation Real) -> Instrument Real (Stereo.T Vector)] makeSampledSounds (path, positions, period) = do {- sound <- (SoxRead.withHandle1 (SVL.hGetContentsSync chunkSize) =<< SoxRead.open SoxOption.none "speech/tomatensalat2.wav") play (44100::Real) (sound::SVL.Vector Real) -} liftA2 (\makeSmp smp -> map (\pos -> makeSmp (SampledSound smp pos period)) positions) sampledSound (SoxRead.withHandle1 (SVL.hGetContentsSync chunkSize) =<< SoxRead.open SoxOption.none path) tomatensalatPositions :: [SamplePositions] tomatensalatPositions = SamplePositions 0 29499 12501 15073 : SamplePositions 29499 31672 38163 17312 : SamplePositions 67379 28610 81811 10667 : SamplePositions 95989 31253 106058 16111 : SamplePositions 127242 38596 136689 11514 : [] tomatensalat :: SampleInfo tomatensalat = ("speech/tomatensalat2.wav", tomatensalatPositions, 324.5) halPositions :: [SamplePositions] halPositions = -- SamplePositions 2371 25957 7362 6321 : SamplePositions 2371 25957 (2371+25957) 1 : SamplePositions 40546 34460 63540 9546 : SamplePositions 79128 32348 94367 14016 : SamplePositions 112027 21227 125880 5500 : SamplePositions 146057 23235 168941 352 : [] hal :: SampleInfo hal = ("speech/haskell-in-leipzig2.wav", halPositions, 316) graphentheoriePositions :: [SamplePositions] graphentheoriePositions = SamplePositions 0 29524 13267 14768 : SamplePositions 29524 35333 47624 9968 : SamplePositions 64857 31189 73818 16408 : SamplePositions 96046 31312 106206 18504 : SamplePositions 127358 32127 132469 16530 : [] graphentheorie :: SampleInfo graphentheorie = ("speech/graphentheorie0.wav", graphentheoriePositions, 301.15)