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,
stereoNoise,
frequencyFromBendModulation,
modulation,
piecewiseConstantVector,
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 ::
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
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
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))
$>
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 ***
(
(CtrlPS.process
$> SigPS.noise 12 (noiseReference 20000))
<<<
(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))
$>
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)
(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 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 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
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 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
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,
(VectorValue, VectorValue)
)
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)
,
(VectorValue, VectorValue)
)
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 (onek)*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))
(SigP.exponentialBounded2
(frequencyConst 100)
(brightDec/k)
(bright)))
<<<
CausalPS.osciSimple WaveL.saw $< zero)
$* stereoFrequenciesFromDetuneBendModulation (frequencyConst 10) fm)))
pingReleaseEnvelope
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,
((attackPeak1)*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,
(VectorValue, VectorValue)
)
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 ->
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 ->
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)))