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