{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE Rank2Types #-} module Synthesizer.LLVM.Server.CausalPacked.Instrument where import Synthesizer.LLVM.Server.Packed.Instrument (Vector, vectorTime, vectorSize, SampleInfo, SampledSound(..), loadSound, sampleStart, sampleLength, sampleLoopStart, sampleLoopLength, stereoNoise, noiseReference, sumNested, ) import Synthesizer.LLVM.Server.Common hiding (Instrument, ) import qualified Synthesizer.LLVM.Storable.Process as PSt import qualified Synthesizer.CausalIO.ALSA.Process as PAlsa import qualified Synthesizer.CausalIO.Gate as Gate import qualified Synthesizer.CausalIO.Process as PIO import Synthesizer.LLVM.CausalParameterized.Functional (($&), (&|&), ) import qualified Synthesizer.LLVM.Filter.Universal as UniFilter import qualified Synthesizer.LLVM.Filter.Allpass as Allpass import qualified Synthesizer.LLVM.Filter.Moog as Moog import qualified Synthesizer.LLVM.Generator.Exponential2 as Exp import qualified Synthesizer.LLVM.Frame.Stereo as Stereo import qualified Synthesizer.LLVM.Frame as Frame import qualified Synthesizer.LLVM.CausalParameterized.Functional as F 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.Parameterized.SignalPacked as SigPS import qualified Synthesizer.LLVM.Parameterized.Signal as SigP import qualified Synthesizer.LLVM.Parameter as Param import qualified Synthesizer.LLVM.Wave as WaveL import qualified Synthesizer.LLVM.ALSA.BendModulation as BM import qualified Synthesizer.LLVM.ALSA.MIDI as MIDIL import qualified Synthesizer.PiecewiseConstant.Signal as PC import qualified Synthesizer.Generic.Cut as CutG import qualified Synthesizer.Zip as Zip import qualified Data.EventList.Relative.BodyTime as EventListBT import qualified Synthesizer.Storable.Signal as SigSt import qualified Data.StorableVector.Lazy as SVL import qualified Data.StorableVector as SV import System.FilePath ((), ) import qualified LLVM.Extra.ScalarOrVector as SoV import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Monad as LM import qualified LLVM.Core as LLVM import qualified Data.TypeLevel.Num as TypeNum import qualified Data.Traversable as Trav import Control.Arrow (Arrow, arr, first, second, (&&&), (***), (<<^), (^<<), ) import Control.Category (id, (.), ) import Control.Monad (liftM2, liftM3, (<=<), ) import Control.Applicative (Applicative, pure, liftA2, liftA3, ) import Data.Monoid (mappend, ) import Data.Tuple.HT (swap, mapPair, ) import qualified Number.DimensionTerm as DN {- import qualified Numeric.NonNegative.Class as NonNeg import qualified Numeric.NonNegative.Wrapper as NonNegW import qualified Numeric.NonNegative.Chunky as NonNegChunky -} import qualified Algebra.Additive as Additive import NumericPrelude.Numeric import NumericPrelude.Base hiding (id, (.), ) type Param p = Param.T (SampleRate Real, p) type CausalP p = CausalP.T (SampleRate Real, p) type Instrument a sig = SampleRate a -> PAlsa.Instrument a sig type Control = EventListBT.T PC.ShortStrictTime type Time = DN.Time Real type Frequency = DN.Frequency Real stereoFrequenciesFromDetuneBendModulation :: Param p Real -> CausalP p (LLVM.Value Real, BM.T (LLVM.Value Real)) (Stereo.T (LLVM.Value Vector)) stereoFrequenciesFromDetuneBendModulation speed = CausalP.envelopeStereo . (MIDIL.frequencyFromBendModulationPacked speed *** CausalP.mapSimple (Trav.mapM SoV.replicate) . liftA2 Stereo.cons (one + id) (one - id)) . arr swap frequencyFromSampleRate :: SampleRate a -> DN.Frequency a frequencyFromSampleRate (SampleRate sr) = DN.frequency sr halfLifeControl :: (Functor f) => SampleRate Real -> f Time -> f (Exp.ParameterPacked Vector) halfLifeControl sr = fmap (Exp.parameterPackedPlain . flip DN.mulToScalar (frequencyFromSampleRate sr)) frequencyControl :: (Functor f) => SampleRate Real -> f Frequency -> f Real frequencyControl sr = fmap (flip DN.divToScalar $ frequencyFromSampleRate sr) takeThreshold :: Param.T p Real -> CausalP.T p (LLVM.Value Vector) (LLVM.Value Vector) takeThreshold = CausalP.takeWhile (\threshold y -> A.cmp LLVM.CmpLE threshold =<< Frame.subsampleVector y) liftStereo :: (Applicative f) => (f a -> f b) -> f (Stereo.T a) -> f (Stereo.T b) liftStereo proc freqs = liftA2 Stereo.cons (proc $ fmap Stereo.left freqs) (proc $ fmap Stereo.right freqs) fanoutShorten :: (CutG.Transform a, CutG.Transform b, CutG.Transform c) => PIO.T a b -> PIO.T a c -> PIO.T a (Zip.T b c) fanoutShorten a b = Zip.arrowFirstShorten a . Zip.arrowSecondShorten b . arr (\x -> Zip.Cons x x) reorderEnvelopeControl :: (Arrow arrow, CutG.Read remainder) => arrow (Zip.T PAlsa.GateChunk (Zip.T (Zip.T (Control Time) (Control Time)) remainder)) (Zip.T (Zip.T PAlsa.GateChunk (Zip.T (Control Time) (Control Time))) remainder) reorderEnvelopeControl = arr $ \(Zip.Cons gate (Zip.Cons times ctrl)) -> Zip.consChecked "ping gate ctrl" (Zip.consChecked "ping gate times" gate times) ctrl ping :: IO (Instrument Real (SV.Vector Vector)) ping = fmap (\proc sampleRate vel freq -> proc (sampleRate, (vel,freq)) . Gate.toStorableVector) $ CausalP.processIO $ let vel = number fst freq = frequency snd in CausalP.fromSignal $ SigP.envelope (SigPS.exponential2 (timeConst 0.2) (fmap amplitudeFromVelocity vel)) $ SigPS.osciSimple WaveL.saw zero freq pingReleaseEnvelope :: IO (Real -> Real -> SampleRate Real -> Real -> PIO.T PAlsa.GateChunk (SV.Vector Vector)) pingReleaseEnvelope = liftM2 (\sustain release dec rel sr vel -> PSt.continuePacked (sustain (sr,(dec,vel)) . Gate.toChunkySize) (\y -> release (sr,(rel,y)) . Gate.allToChunkySize)) (CausalP.processIO $ let vel = number snd decay = vectorTime fst in 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)) pingRelease :: IO (Real -> Real -> Instrument Real (SV.Vector Vector)) pingRelease = liftM2 (\osci envelope dec rel sr vel freq -> osci (sr, freq) . envelope dec rel sr vel) (CausalP.processIO $ let freq = frequency id in CausalP.envelope . CausalP.feedFst (SigPS.osciSimple WaveL.saw zero freq)) pingReleaseEnvelope pingControlledEnvelope :: Maybe Real -> IO (SampleRate Real -> Real -> PIO.T (Zip.T PAlsa.GateChunk (Zip.T (Control Time) (Control Time))) (SV.Vector Vector)) pingControlledEnvelope threshold = liftM2 (\sustain release sr vel -> PSt.continuePacked (sustain (sr,vel) . Gate.shorten . Zip.arrowSecond (arr (halfLifeControl sr . Zip.first))) (\y -> release (sr,y) <<^ halfLifeControl sr . Zip.second . Zip.second)) (CausalP.processIO $ let vel = number id in Exp.causalPackedP (fmap amplitudeFromVelocity vel)) (CausalP.processIO $ let level = number id expo = Exp.causalPackedP level in case threshold of Just y -> takeThreshold (pure y) . expo Nothing -> expo) pingStereoReleaseFM :: IO (SampleRate Real -> Real -> Real -> PIO.T (Zip.T PAlsa.GateChunk (Zip.T (Zip.T (Control Time) (Control Time)) (Zip.T (Zip.T (Control Real) (Control Time)) (Zip.T (Zip.T (Control Real) (Control Time)) (Zip.T (Control Real) (Control (BM.T Real))))))) (SV.Vector (Stereo.T Vector))) pingStereoReleaseFM = liftA2 (\osc env sr vel freq -> osc (sr, ()) . (Zip.arrowSecond $ Zip.arrowSecond $ Zip.arrowSecond $ Zip.arrowSecond $ arr $ transposeModulation sr freq) . (Zip.arrowSecond $ Zip.arrowSecond $ Zip.arrowFirst $ Zip.arrowSecond $ arr $ halfLifeControl sr) . (Zip.arrowSecond $ Zip.arrowFirst $ Zip.arrowSecond $ arr $ halfLifeControl sr) . Zip.arrowFirstShorten (env sr vel) . reorderEnvelopeControl) (CausalP.processIO (CausalP.envelopeStereo . second (let fm = F.lift (arr (snd.snd)) shape = F.lift (CausalP.mapSimple SoV.replicate . arr (fst.fst)) shapeDecay = F.lift (arr (snd.fst)) shapeCtrl = 1/3.14 + (shape-1/3.14) * (Exp.causalPackedP (1::Param.T p Real) $& shapeDecay) freqs = stereoFrequenciesFromDetuneBendModulation (frequencyConst 10) $& fm phase = F.lift (arr (fst.fst.snd)) phaseDecay = F.lift (arr (snd.fst.snd)) expo = (CausalP.mapSimple SoV.replicate $& phase) * (Exp.causalPackedP (1::Param.T p Real) $& phaseDecay) osci = CausalPS.shapeModOsci WaveL.rationalApproxSine1 in F.compile $ liftA2 Stereo.cons (osci $& shapeCtrl &|& (expo &|& fmap Stereo.left freqs)) (osci $& shapeCtrl &|& (Additive.negate expo &|& fmap Stereo.right freqs))))) (pingControlledEnvelope (Just 0.01)) filterSawStereoFM :: IO (SampleRate Real -> Real -> Real -> PIO.T (Zip.T PAlsa.GateChunk (Zip.T (Zip.T (Control Time) (Control Time)) (Zip.T (Zip.T (Control Frequency) (Control Time)) (Zip.T (Control Real) (Control (BM.T Real)))))) (SV.Vector (Stereo.T Vector))) filterSawStereoFM = liftA2 (\osc env sr vel freq -> osc (sr, ()) . (Zip.arrowSecond $ Zip.arrowSecond $ Zip.arrowSecond $ arr $ transposeModulation sr freq) . (Zip.arrowSecond $ Zip.arrowFirst $ Zip.arrowSecond $ arr $ halfLifeControl sr) . (Zip.arrowSecond $ Zip.arrowFirst $ Zip.arrowFirst $ arr $ frequencyControl sr) . Zip.arrowFirstShorten (env sr vel) . reorderEnvelopeControl) (CausalP.processIO (CausalP.envelopeStereo . second (let fm = F.lift (arr snd) cutoff = F.lift (CausalP.mapSimple SoV.replicate . arr (fst.fst)) cutoffDecay = F.lift (arr (snd.fst)) freqs = stereoFrequenciesFromDetuneBendModulation (frequencyConst 10) $& fm {- bound control in order to avoid too low resonant frequency, which makes the filter instable -} expo = takeThreshold (frequencyConst 100) $& (CausalP.mapSimple SoV.replicate $& cutoff) * (Exp.causalPackedP (1::Param.T p Real) $& cutoffDecay) in F.compile $ CausalP.stereoFromMonoControlled (UniFilter.lowpass ^<< CtrlPS.process) $& (CausalP.quantizeLift (100 / fromIntegral vectorSize :: Param.T p Real) (CausalP.mapSimple (UniFilter.parameter (LLVM.valueOf 10) <=< Frame.subsampleVector)) $& expo) &|& (CausalP.stereoFromMono (CausalPS.osciSimple WaveL.saw . CausalP.feedFst zero) $& freqs)))) (pingControlledEnvelope (Just 0.01)) tineStereoFM :: IO (SampleRate Real -> Real -> Real -> PIO.T (Zip.T PAlsa.GateChunk (Zip.T (Zip.T (Control Time) (Control Time)) (Zip.T (Zip.T (Control Real) (Control Real)) (Zip.T (Control Real) (Control (BM.T Real)))))) (SV.Vector (Stereo.T Vector))) tineStereoFM = liftA2 (\osc env sr vel freq -> osc (sr, vel) . (Zip.arrowSecond $ Zip.arrowSecond $ Zip.arrowSecond $ arr $ transposeModulation sr freq) . Zip.arrowFirstShorten (env sr vel) . reorderEnvelopeControl) (CausalP.processIO (CausalP.envelopeStereo . second (let vel = number id fm = F.lift (arr snd) freqs = stereoFrequenciesFromDetuneBendModulation (frequencyConst 5) $& fm index = F.lift (CausalP.mapSimple SoV.replicate . arr (fst.fst)) depth = F.lift (CausalP.mapSimple SoV.replicate . arr (snd.fst)) expo = F.lift $ CausalP.fromSignal $ SigPS.exponential2 (timeConst 1) (1 + vel) osci freq = CausalPS.osciSimple WaveL.approxSine2 $& expo * depth * (CausalPS.osciSimple WaveL.approxSine2 $& zero &|& index*freq) &|& freq in F.compile $ liftStereo osci freqs))) (pingControlledEnvelope (Just 0.01)) bellNoiseStereoFM :: IO (SampleRate Real -> Real -> Real -> PIO.T (Zip.T PAlsa.GateChunk (Zip.T (Zip.T (Control Time) (Control Time)) (Zip.T (Zip.T (Control Real) (Control Real)) (Zip.T (Control Real) (Control (BM.T Real)))))) (SV.Vector (Stereo.T Vector))) bellNoiseStereoFM = liftA3 (\osc env envInf sr vel freq -> osc (sr, ()) . (Zip.arrowSecond $ Zip.arrowSecond $ Zip.arrowSecond $ arr $ transposeModulation sr freq) . Zip.arrowFirstShorten (fanoutShorten (env sr (vel*0.5)) (let shortenTimes :: Real -> PIO.T (Zip.T (Control Time) (Control Time)) (Zip.T (Control Time) (Control Time)) shortenTimes n = let rn = recip n in (Zip.arrowFirst $ arr $ fmap $ DN.scale rn) . (Zip.arrowSecond $ arr $ fmap $ DN.scale rn) in PIO.zip (envInf sr (vel*2) . Zip.arrowSecond (shortenTimes 4)) (envInf sr (vel*4) . Zip.arrowSecond (shortenTimes 7)))) . reorderEnvelopeControl) (CausalP.processIO (let env1 = F.lift (arr (fst.fst)) env4 = F.lift (arr (fst.snd.fst)) env7 = F.lift (arr (snd.snd.fst)) fm = F.lift (arr (snd.snd)) noiseAmp = F.lift (CausalP.mapSimple SoV.replicate . arr (fst.fst.snd)) noiseReson = F.lift (arr (snd.fst.snd)) noiseParam = CausalP.quantizeLift (100 / fromIntegral vectorSize :: Param.T p Real) (CausalP.zipWithSimple (Moog.parameter TypeNum.d8)) noise = F.lift (CausalP.fromSignal (SigPS.noise 12 (noiseReference 20000))) freqs = stereoFrequenciesFromDetuneBendModulation (frequencyConst 5) $& fm osci amp env n = CausalPS.amplifyStereo amp $& CausalP.envelopeStereo $& env &|& (CausalP.stereoFromMono (CausalPS.osciSimple WaveL.approxSine4 . CausalP.feedFst zero) $& CausalPS.amplifyStereo n $& freqs) in F.compile $ (CausalP.envelopeStereo $& (noiseAmp * env1) &|& liftStereo (\freq -> CtrlPS.process $& (noiseParam $& noiseReson &|& (CausalP.mapSimple Frame.subsampleVector $& freq)) &|& noise) freqs) + osci 1.00 env1 1 + osci 0.10 env4 4 + osci 0.01 env7 7)) (pingControlledEnvelope (Just 0.01)) (pingControlledEnvelope Nothing) stringControlledEnvelope :: IO (SampleRate Real -> Real -> PIO.T (Zip.T PAlsa.GateChunk (Zip.T (Control Time) (Control Time))) (SV.Vector Vector)) stringControlledEnvelope = liftM3 (\attack sustain release sr vel -> let amp = amplitudeFromVelocity vel in PSt.continuePacked (mappend (attack (sr,amp)) {- we could also feed the sustain process with a signal with sample type () -} (sustain (sr,amp)) . Gate.shorten . Zip.arrowSecond (arr (halfLifeControl sr . Zip.first))) (\y -> release (sr,y) <<^ halfLifeControl sr . Zip.second . Zip.second)) (CausalP.processIO $ let amp = number id in CausalP.fromSignal (SigPS.constant amp) - takeThreshold (1e-4 :: Param.T p Real) . Exp.causalPackedP amp) (CausalP.processIO $ let amp = number id in CausalP.fromSignal (SigPS.constant amp)) (CausalP.processIO $ let level = number id in takeThreshold (0.01 :: Param.T p Real) . Exp.causalPackedP level) windCore :: F.T (SampleRate Real, p) a (LLVM.Value Real) -> F.T (SampleRate Real, p) a (BM.T (LLVM.Value Real)) -> F.T (SampleRate Real, p) a (Stereo.T (LLVM.Value Vector)) windCore reson fm = let modu = CausalP.mapSimple Frame.subsampleVector $& (fmap (`asTypeOf` (undefined :: LLVM.Value Vector)) $ (MIDIL.frequencyFromBendModulationPacked (frequencyConst 0.2) $& fm)) in CausalP.stereoFromMonoControlled CtrlPS.process $& (CausalP.zipWithSimple (Moog.parameter TypeNum.d8) $& reson &|& modu) &|& F.lift (CausalP.fromSignal stereoNoise) wind :: IO (SampleRate Real -> Real -> Real -> PIO.T (Zip.T PAlsa.GateChunk (Zip.T (Zip.T (Control Time) (Control Time)) (Zip.T (Control Real) (Control (BM.T Real))))) (SV.Vector (Stereo.T Vector))) wind = liftA2 (\osc env sr vel freq -> osc (sr, ()) . (Zip.arrowSecond $ Zip.arrowSecond $ arr $ transposeModulation sr freq) . Zip.arrowFirstShorten (env sr vel) . reorderEnvelopeControl) (CausalP.processIO (let env = F.lift (arr fst) reson = F.lift (arr (fst.snd)) fm = F.lift (arr (snd.snd)) in F.compile $ CausalP.envelopeStereo $& env &|& windCore reson fm)) stringControlledEnvelope windPhaser :: IO (SampleRate Real -> Real -> Real -> PIO.T (Zip.T PAlsa.GateChunk (Zip.T (Zip.T (Control Time) (Control Time)) (Zip.T (Control Real) (Zip.T (Control Frequency) (Zip.T (Control Real) (Control (BM.T Real))))))) (SV.Vector (Stereo.T Vector))) windPhaser = liftA2 (\osc env sr vel freq -> osc (sr, ()) . (Zip.arrowSecond $ Zip.arrowSecond $ Zip.arrowSecond $ Zip.arrowSecond $ arr $ transposeModulation sr freq) . (Zip.arrowSecond $ Zip.arrowSecond $ Zip.arrowFirst $ arr $ fmap (Allpass.flangerParameterPlain TypeNum.d8) . frequencyControl sr) . Zip.arrowFirstShorten (env sr vel) . reorderEnvelopeControl) (CausalP.processIO (let env = F.lift (arr fst) phaserMix = F.lift (CausalP.mapSimple SoV.replicate . arr (fst.snd)) phaserFreq = F.lift (arr (fst.snd.snd)) reson = F.lift (arr (fst.snd.snd.snd)) fm = F.lift (arr (snd.snd.snd.snd)) noise = windCore reson fm in F.compile $ CausalP.envelopeStereo $& env &|& ((CausalP.envelopeStereo $& (1 - phaserMix) &|& noise) + (CausalP.envelopeStereo $& phaserMix &|& (Stereo.arrowFromMonoControlled CtrlPS.process $& phaserFreq &|& noise))))) stringControlledEnvelope phaserOsci :: (Param.T p Real -> Param.T p Real -> CausalP.T p a (LLVM.Value Vector)) -> CausalP.T p a (Stereo.T (LLVM.Value Vector)) phaserOsci osci = CausalPS.amplifyStereo 0.25 . Trav.traverse sumNested (Stereo.cons (zipWith osci [0.1, 0.7, 0.2, 0.3] [1.0, -0.4, 0.5, -0.7]) (zipWith osci [0.4, 0.9, 0.6, 0.5] [0.4, -1.0, 0.7, -0.5])) type StringInstrument = SampleRate Real -> Real -> Real -> PIO.T (Zip.T PAlsa.GateChunk (Zip.T (Zip.T (Control Time) (Control Time)) (Zip.T (Control Real) (Zip.T (Control Real) (Control (BM.T Real)))))) (SV.Vector (Stereo.T Vector)) softStringShapeCore :: (forall r. LLVM.Value Vector -> LLVM.Value Vector -> LLVM.CodeGenFunction r (LLVM.Value Vector)) -> IO StringInstrument softStringShapeCore wave = liftA2 (\osc env sr vel freq -> osc (sr, ()) . (Zip.arrowSecond $ Zip.arrowSecond $ Zip.arrowSecond $ arr $ transposeModulation sr freq) . Zip.arrowFirstShorten (env sr vel) . reorderEnvelopeControl) (CausalP.processIO (CausalP.envelopeStereo . second (let fm = F.lift (arr (snd.snd)) det = F.lift (CausalP.mapSimple SoV.replicate . arr (fst.snd)) shape = F.lift (CausalP.mapSimple SoV.replicate . arr fst) modu = MIDIL.frequencyFromBendModulationPacked (frequencyConst 5) $& fm osci :: Param.T (mod,fm) Real -> 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 p d = CausalPS.shapeModOsci wave . second (CausalP.feedFst (SigPS.constant p) . CausalP.envelope . first (one + CausalPS.amplify d)) in F.compile $ phaserOsci osci $& shape &|& det &|& modu))) stringControlledEnvelope arcStringStereoFM :: (forall r. LLVM.Value Vector -> LLVM.CodeGenFunction r (LLVM.Value Vector)) -> IO StringInstrument arcStringStereoFM wave = softStringShapeCore (\k p -> LM.liftR2 Frame.amplifyMono (WaveL.approxSine4 =<< WaveL.halfEnvelope p) (wave =<< WaveL.replicate k p)) softStringShapeFM, cosineStringStereoFM, arcSawStringStereoFM, arcSineStringStereoFM, arcSquareStringStereoFM, arcTriangleStringStereoFM :: IO StringInstrument 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 fmStringStereoFM :: IO (SampleRate Real -> Real -> Real -> PIO.T (Zip.T PAlsa.GateChunk (Zip.T (Zip.T (Control Time) (Control Time)) (Zip.T (Zip.T (Control Real) (Control Real)) (Zip.T (Control Real) (Control (BM.T Real)))))) (SV.Vector (Stereo.T Vector))) fmStringStereoFM = liftA2 (\osc env sr vel freq -> osc (sr, ()) . (Zip.arrowSecond $ Zip.arrowSecond $ Zip.arrowSecond $ arr $ transposeModulation sr freq) . Zip.arrowFirstShorten (env sr vel) . reorderEnvelopeControl) (CausalP.processIO (let env = F.lift (arr fst) fm = F.lift (arr (snd.snd.snd)) det = F.lift (CausalP.mapSimple SoV.replicate . arr (fst.snd.snd)) shape = F.lift (CausalP.mapSimple SoV.replicate . arr (snd.fst.snd)) depth = CausalP.envelope $& env &|& F.lift (CausalP.mapSimple SoV.replicate . arr (fst.fst.snd)) modu = MIDIL.frequencyFromBendModulationPacked (frequencyConst 5) $& fm osci :: Param.T (mod,fm) Real -> 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 p d = CausalPS.osciSimple WaveL.approxSine2 . ((CausalP.envelope . second (CausalPS.shapeModOsci WaveL.rationalApproxSine1 . second (CausalP.feedFst (SigPS.constant p))) <<^ (\((dp, ds), f) -> (dp, (ds, f)))) &&& arr snd) . second (CausalP.envelope . first (one + CausalPS.amplify d)) in F.compile $ CausalP.envelopeStereo $& env &|& (phaserOsci osci $& (depth &|& shape) &|& (det &|& modu)))) stringControlledEnvelope sampledSound :: IO (SampledSound -> SampleRate Real -> Real -> Real -> PIO.T (Zip.T PAlsa.GateChunk (Zip.T (Control Real) (Control (BM.T Real)))) (SV.Vector (Stereo.T Vector))) sampledSound = liftA2 (\osc freqMod smp sr vel freq -> {- 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 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 osci smpBody = osc (sr, (amp, smpBody)) in mappend (osci (attack `SigSt.append` SVL.cycle (SigSt.take (sampleLoopLength pos) sustain)) . Gate.shorten) (osci release <<^ Zip.second) . Zip.arrowSecond ((id :: PIO.T (SV.Vector (Stereo.T Vector)) (SV.Vector (Stereo.T Vector))) . freqMod (sr, ()) . (Zip.arrowSecond $ arr $ transposeModulation sr (freq * samplePeriod smp)))) (CausalP.processIO (let amp = number fst smp = signal snd in CausalPS.amplifyStereo amp . CausalP.stereoFromMono (CausalPS.pack (CausalP.frequencyModulationLinear {- (SigP.fromStorableVector $ fmap (SV.concat . SVL.chunks . SVL.take 1000000) smp) -} (SigP.fromStorableVectorLazy smp) {- (SigP.osciSimple WaveL.saw 0 (1 / 324 {- samplePeriod smp -})) -})))) (CausalP.processIO (stereoFrequenciesFromDetuneBendModulation (frequencyConst 3))) makeSampledSounds :: FilePath -> SampleInfo -> IO [SampleRate Real -> Real -> Real -> PIO.T (Zip.T PAlsa.GateChunk (Zip.T (Control Real) (Control (BM.T Real)))) (SV.Vector (Stereo.T Vector))] makeSampledSounds dir (file, positions, period) = do liftA2 (\makeSmp smp -> map (\pos -> makeSmp (SampledSound smp pos period)) positions) sampledSound (loadSound (dir file))