synthesizer-llvm-0.3: 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.
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.Common
import qualified Synthesizer.LLVM.ALSA.BendModulation as BM
import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC
import qualified Synthesizer.EventList.ALSA.MIDI as Ev
import qualified Sound.Sox.Read as SoxRead
import qualified Sound.Sox.Option.Format as SoxOption
import System.FilePath ((</>), )
import Control.Exception (bracket, )
import Synthesizer.Storable.ALSA.MIDI (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.ALSA.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.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.SerialVector as Serial
import qualified Synthesizer.LLVM.Wave as WaveL
import Synthesizer.LLVM.CausalParameterized.Process (($<), ($>), ($*), )
import Synthesizer.LLVM.Parameterized.Signal (($#), )
import qualified LLVM.Extra.ScalarOrVector as SoV
import qualified LLVM.Extra.Monad as LM
import qualified LLVM.Extra.Arithmetic as A
import qualified LLVM.Core as LLVM
import qualified Data.TypeLevel.Num as TypeNum
import Control.Arrow.Monad ((=<<<), listen, )
import qualified Data.HList as HL
import qualified Synthesizer.Generic.Cut as CutG
import qualified Synthesizer.Storable.Signal as SigSt
import qualified Data.StorableVector.Lazy.Pattern as SVP
import qualified Data.StorableVector.Lazy as SVL
import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter
import Control.Arrow ((<<<), (^<<), (<<^), (&&&), (***), arr, first, second, )
import Control.Category (id, )
import Control.Applicative (liftA2, liftA3, )
import Data.Traversable (traverse, )
import qualified Data.List.Match as Match
import Data.Tuple.HT (mapPair, fst3, snd3, thd3, )
import Data.Int (Int32, )
{-
import qualified Numeric.NonNegative.Class as NonNeg
import qualified Numeric.NonNegative.Wrapper as NonNegW
-}
import qualified Numeric.NonNegative.Chunky as NonNegChunky
import qualified Algebra.Additive as Additive
import NumericPrelude.Numeric (zero, one, round, (^?), (+), (-), (*), )
import Prelude hiding (Real, round, break, id, (+), (-), (*), )
sumNested :: (Additive.C a) => [a] -> a
sumNested [] = Additive.zero
sumNested xs@(_:rs) =
let ys = xs ++ Match.take rs (sum2 ys)
in last ys
sum2 :: (Additive.C a) => [a] -> [a]
sum2 (x:y:rest) = (x+y) : sum2 rest
sum2 xs = xs
type Param p = Param.T (SampleRate Real, p)
type SigP p = SigP.T (SampleRate Real, p)
type CausalP p = CausalP.T (SampleRate Real, p)
type Vector = LLVM.Vector VectorSize Real
type VectorSize = TypeNum.D4
vectorSize :: Int
vectorSize = TypeNum.toInt (undefined :: VectorSize)
vectorRate :: Fractional a => SampleRate a -> a
vectorRate (SampleRate sampleRate) =
sampleRate / fromIntegral vectorSize
vectorTime :: (p -> Real) -> Param p Real
vectorTime param =
arr (\(SampleRate sampleRate, p) ->
param p * sampleRate / fromIntegral vectorSize)
noiseReference :: Real -> Param p Real
noiseReference freq =
arr (\(SampleRate sampleRate, _p) -> sampleRate/freq)
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 (Value a)) =>
-}
Param p Real ->
Param p (PC.T (BM.T Real)) ->
SigP p (LLVM.Value Vector)
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 (LLVM.Value Vector))
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 (LLVM.Value Vector)
{-
(Storable a,
Class.MakeValueTuple a al,
Memory.C al am,
LLVM.IsSized am as) =>
Param.T p (PC.T a) -> SigP.T p (LLVM.Vector 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)
decay = time (snd.fst3)
shape = control snd3
fm = detuneModulation thd3
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 =
((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
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 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 sel v d =
CausalP.envelope
<<<
(arr sel ***
(CausalPS.amplify v
<<<
(CausalPS.osciSimple WaveL.approxSine4 $< zero)
<<<
CausalPS.amplify d))
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 Frame.subsampleVector
<<<
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 (LLVM.Value Vector) (LLVM.Value Vector)
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 (LLVM.Value Vector))
(Stereo.T (LLVM.Value Vector))
tineControlledProc index depth vel =
CausalP.stereoFromMono
(CausalPS.osciSimple WaveL.approxSine2)
<<<
Stereo.interleave
^<<
((CausalP.envelopeStereo
$< SigP.envelope
(piecewiseConstantVector depth)
(SigPS.exponential2 (timeConst 1) (vel+1)))
<<<
CausalP.stereoFromMono
(CausalPS.osciSimple WaveL.approxSine2 $< zero)
<<<
(CausalP.envelopeStereo
$< piecewiseConstantVector index))
&&& id
tineControlledFnProc index depth vel =
((\freq ->
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)
<<<
listen freq)
&&&
listen freq)
-- =<<< listen HL.hNil
=<<< arr HL.hHead)
<<< arr (\freq -> HL.hCons freq HL.hNil)
tineControlledFM ::
IO (Real -> Real ->
PC.T Real ->
PC.T Real -> PC.T Real ->
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 (LLVM.Value Vector))
(Stereo.T (LLVM.Value Vector))
fenderProc fade index depth vel =
((\stereoFreq ->
let channel_n_1 freq =
CausalPS.osciSimple WaveL.approxSine2
<<<
((CausalP.envelope
$< SigP.envelope
(piecewiseConstantVector depth)
(SigPS.exponential2 (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
(channel_n_1 id)
(channel_1_2 id))
$< piecewiseConstantVector fade)
<<<
listen stereoFreq)
=<<< arr HL.hHead)
<<< arr (\freq -> HL.hCons freq HL.hNil)
fenderFM ::
IO (Real -> Real ->
PC.T Real ->
PC.T Real -> PC.T Real -> PC.T Real ->
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 (LLVM.Value Vector))
(Stereo.T (LLVM.Value Vector))
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 ::
LLVM.Value Vector -> Int32 -> LLVM.Value Vector ->
LLVM.CodeGenFunction r (LLVM.Value Vector)
partial amp n t =
A.mul amp =<<
WaveL.partial WaveL.approxSine2 (LLVM.valueOf n) t
in CausalP.envelopeStereo $>
(CausalP.stereoFromMono
(CausalPS.shapeModOsci
(\(p1,(p2,(p3,p4))) t -> do
y1 <- A.mul p1 =<< WaveL.approxSine2 t
y2 <- partial p2 2 t
y3 <- partial p3 3 t
y4 <- partial p4 4 t
A.add y1 =<< A.add y2 =<< A.add y3 y4)
$<
(SigP.zip (piecewiseConstantVector partial1) $
SigP.zip (piecewiseConstantVector partial2) $
SigP.zip (piecewiseConstantVector partial3)
(piecewiseConstantVector partial4)))
<<<
Stereo.interleave
^<<
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 (LLVM.Value Vector))
(Stereo.T (LLVM.Value Vector))
resonantFMSynthProc reson index depth vel =
((\stereoFreq ->
let chan freq =
CausalPS.osciSimple WaveL.approxSine2
<<<
((CausalP.envelope
$< SigP.envelope
(piecewiseConstantVector depth)
(SigPS.exponential2 (timeConst 1) (vel+1)))
<<<
UniFilter.lowpass
^<<
CtrlPS.process
<<<
(CausalP.zipWithSimple UniFilterL.parameter
<<<
CausalP.feedFst (piecewiseConstant reson)
<<<
(CausalP.envelope $< piecewiseConstant index)
<<<
CausalP.mapSimple Frame.subsampleVector
<<<
freq)
&&&
((CausalPS.osciSimple WaveL.saw $< zero)
<<<
freq))
&&&
freq
in CausalP.stereoFromMono (chan id)
<<<
listen stereoFreq)
=<<< arr HL.hHead)
<<< arr (\freq -> HL.hCons freq HL.hNil)
resonantFMSynth ::
IO (Real -> Real ->
PC.T Real ->
PC.T Real -> PC.T Real -> PC.T Real ->
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 (LLVM.Value Vector)) ->
CausalP.T p a (Stereo.T (LLVM.Value Vector))
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)
(LLVM.Value Vector, LLVM.Value Vector)
(LLVM.Value Vector)
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.
LLVM.Value Vector ->
LLVM.CodeGenFunction r (LLVM.Value Vector)) ->
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.
LLVM.Value Vector ->
LLVM.Value Vector ->
LLVM.CodeGenFunction r (LLVM.Value Vector)) ->
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)
(LLVM.Value Vector,
{- wave shape parameter -}
(LLVM.Value Vector, LLVM.Value Vector)
{- detune, frequency modulation -})
(LLVM.Value Vector)
osci d =
CausalPS.shapeModOsci wave
<<<
second
(CausalP.feedFst 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)
((LLVM.Value Vector, LLVM.Value Vector)
{- phase modulation depth, modulator distortion -},
(LLVM.Value Vector, LLVM.Value Vector)
{- detune, frequency modulation -})
(LLVM.Value Vector)
osci d =
CausalPS.osciSimple WaveL.approxSine2
<<<
(CausalP.envelope
<<<
second
(CausalPS.shapeModOsci WaveL.rationalApproxSine1
<<< second (CausalP.feedFst 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 (LLVM.Value Vector))
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 (LLVM.Value Vector))
windCore reson fm =
CausalP.stereoFromMonoControlled CtrlPS.process
$< SigP.zipWithSimple
(MoogL.parameter TypeNum.d8)
(piecewiseConstant reson)
(SigP.mapSimple Frame.subsampleVector
(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 SoV.replicate)
<<^
(\((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
(LLVM.Value Vector,
{- wave shrink/replication factor -}
(LLVM.Value Vector, LLVM.Value Vector)
{- detune, frequency modulation -})
(LLVM.Value Vector)
osci d =
CausalPS.shapeModOsci WaveL.rationalApproxSine1
<<<
second
(CausalP.feedFst 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
data SamplePositions =
SamplePositions {
sampleStart, sampleLength,
sampleLoopStart, sampleLoopLength :: Int
}
data SampledSound =
SampledSound {
sampleData :: SigSt.T Real,
samplePositions :: SamplePositions,
samplePeriod :: Real
}
sampledSound ::
IO (SampledSound ->
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*samplePeriod smp)) :: SigSt.T Vector
pos = samplePositions smp
amp = 2 * amplitudeFromVelocity vel
(attack,sustain) =
mapPair
(SigSt.drop (sampleStart pos),
SigSt.take (sampleLoopLength pos)) $
SigSt.splitAt (sampleLoopStart pos) $
sampleData smp
release =
SigSt.drop (sampleLoopStart pos + sampleLoopLength pos) $
SigSt.take (sampleStart pos + sampleLength pos) $
sampleData smp
in (\cont -> osc cont
(sr,
(amp,
attack `SigSt.append`
SVL.cycle (SigSt.take (sampleLoopLength 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 (SampledSound ->
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*samplePeriod smp)) :: SigSt.T Vector)
pos = samplePositions smp
amp = 2 * amplitudeFromVelocity vel
(attack,sustain) =
mapPair
(SigSt.drop (sampleStart pos),
SigSt.take (sampleLoopLength pos)) $
SigSt.splitAt (sampleLoopStart pos) $
sampleData smp
release =
SigSt.drop (sampleLoopStart pos + sampleLoopLength pos) $
SigSt.take (sampleStart pos + sampleLength pos) $
sampleData smp
in osc
(sr,
(amp,
attack `SigSt.append`
SVL.cycle (SigSt.take (sampleLoopLength 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)))
loadSound :: FilePath -> IO (SVL.Vector Real)
loadSound path =
bracket (SoxRead.open SoxOption.none path) SoxRead.close $
SoxRead.withHandle1 (SVL.hGetContentsSync SVL.defaultChunkSize)
type SampleInfo = (FilePath, [SamplePositions], Real)
-- ToDo: flag failure if files cannot be found, or just remain silent
makeSampledSounds ::
FilePath ->
SampleInfo ->
IO [-- PC.T Real ->
PC.T (BM.T Real) ->
Instrument Real (Stereo.T Vector)]
makeSampledSounds dir (file, positions, period) = do
{-
sound <-
(SoxRead.withHandle1 (SVL.hGetContentsSync chunkSize) =<<
SoxRead.open SoxOption.none "speech/tomatensalat2.wav")
play (44100::Real) (sound::SVL.Vector Real)
-}
liftA2
(\makeSmp smp ->
map (\pos -> makeSmp (SampledSound smp pos period))
positions)
sampledSound
(loadSound (dir </> file))
tomatensalatPositions :: [SamplePositions]
tomatensalatPositions =
SamplePositions 0 29499 12501 15073 :
SamplePositions 29499 31672 38163 17312 :
SamplePositions 67379 28610 81811 10667 :
SamplePositions 95989 31253 106058 16111 :
SamplePositions 127242 38596 136689 11514 :
[]
tomatensalat :: SampleInfo
tomatensalat =
("tomatensalat2.wav", tomatensalatPositions, 324.5)
halPositions :: [SamplePositions]
halPositions =
-- SamplePositions 2371 25957 7362 6321 :
SamplePositions 2371 25957 (2371+25957) 1 :
SamplePositions 40546 34460 63540 9546 :
SamplePositions 79128 32348 94367 14016 :
SamplePositions 112027 21227 125880 5500 :
SamplePositions 146057 23235 168941 352 :
[]
hal :: SampleInfo
hal =
("haskell-in-leipzig2.wav", halPositions, 316)
graphentheoriePositions :: [SamplePositions]
graphentheoriePositions =
SamplePositions 0 29524 13267 14768 :
SamplePositions 29524 35333 47624 9968 :
SamplePositions 64857 31189 73818 16408 :
SamplePositions 96046 31312 106206 18504 :
SamplePositions 127358 32127 132469 16530 :
[]
graphentheorie :: SampleInfo
graphentheorie =
("graphentheorie0.wav", graphentheoriePositions, 301.15)