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