{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE EmptyDataDecls #-}
module Synthesizer.LLVM.Server.Packed.Instrument (
InputArg(..),
FrequencyControl,
Modulation,
DetuneModulation,
pingRelease,
pingStereoRelease,
pingStereoReleaseFM,
squareStereoReleaseFM,
bellStereoFM,
bellNoiseStereoFM,
tine,
tineStereo,
softString,
softStringFM,
tineStereoFM,
tineControlledFM,
fenderFM,
tineModulatorBankFM,
tineBankFM,
resonantFMSynth,
softStringDetuneFM,
softStringShapeFM, cosineStringStereoFM,
arcSineStringStereoFM, arcTriangleStringStereoFM,
arcSquareStringStereoFM, arcSawStringStereoFM,
fmStringStereoFM,
wind,
windPhaser,
filterSawStereoFM,
brass,
sampledSound,
stereoNoise,
frequencyFromBendModulation,
piecewiseConstantVector,
pingReleaseEnvelope,
adsr,
) 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.LLVM.ConstantPiece as Const
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.Causal.Render as CausalRender
import qualified Synthesizer.LLVM.Causal.ControlledPacked as CtrlPS
import qualified Synthesizer.LLVM.Causal.ProcessPacked as CausalPS
import qualified Synthesizer.LLVM.Causal.Process as Causal
import qualified Synthesizer.LLVM.Causal.Functional as F
import qualified Synthesizer.LLVM.Generator.Render as Render
import qualified Synthesizer.LLVM.Generator.SignalPacked as SigPS
import qualified Synthesizer.LLVM.Generator.Signal as Sig
import qualified Synthesizer.LLVM.Storable.Signal as SigStL
import qualified Synthesizer.LLVM.Frame.SerialVector as Serial
import qualified Synthesizer.LLVM.Frame as Frame
import qualified Synthesizer.LLVM.Wave as WaveL
import Synthesizer.LLVM.Causal.Process (($<#), ($*), ($<), ($>))
import Synthesizer.LLVM.Causal.Functional (($&), (&|&))
import qualified LLVM.DSL.Expression as Expr
import qualified LLVM.Extra.Multi.Value as MultiValue
import LLVM.DSL.Expression (Exp)
import qualified LLVM.Extra.Arithmetic as A
import qualified LLVM.Core as LLVM
import qualified Type.Data.Num.Decimal as TypeNum
import qualified Synthesizer.Causal.Class as CausalClass
import qualified Synthesizer.Generic.Cut as CutG
import qualified Synthesizer.Storable.Signal as SigSt
import qualified Data.StorableVector.Lazy.Pattern as SVP
import qualified Data.StorableVector.Lazy as SVL
import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter
import qualified Control.Monad.HT as M
import Control.Arrow ((<<<), (^<<), (<<^), (&&&), (***), arr, first, second)
import Control.Category (id)
import Control.Applicative (liftA2, liftA3)
import qualified Data.Traversable as Trav
import Data.Traversable (traverse)
import Data.Semigroup ((<>))
import Data.Tuple.HT (fst3, snd3, thd3)
import qualified Numeric.NonNegative.Chunky as NonNegChunky
import qualified Algebra.Additive as Additive
import NumericPrelude.Numeric (zero, one, round, (^?), (+), (-), (*))
import Prelude hiding (Real, round, break, id, (+), (-), (*))
frequencyControl ::
(MultiValue.Field a, MultiValue.RationalConstant a) =>
SampleRate (Exp a) ->
Sig.T (Const.T (MultiValue.T a)) ->
Sig.T (Const.T (MultiValue.T a))
frequencyControl sr xs = Const.causalMap (frequency sr) $* xs
data FrequencyControl a
instance
(a ~ Exp b, MultiValue.Field b, MultiValue.RationalConstant b) =>
Input (FrequencyControl b) a where
data InputArg (FrequencyControl b) a =
FrequencyControl (Sig.T (Const.T (MultiValue.T b)))
type InputSource (FrequencyControl b) a =
Sig.T (Const.T (MultiValue.T b))
evalInput sampleRate =
FrequencyControl . frequencyControl sampleRate
modulation ::
(MultiValue.Field a, MultiValue.RationalConstant a) =>
SampleRate (Exp a) ->
(Sig.T (Const.T (MultiValue.T (BM.T a))), Exp a) ->
Sig.T (Const.T (BM.T (MultiValue.T a)))
modulation sr (fm,freq) =
transposeModulation sr freq (fmap BM.unMultiValue <$> fm)
data Modulation a
instance
(a ~ Exp b, MultiValue.Field b, MultiValue.RationalConstant b) =>
Input (Modulation b) a where
data InputArg (Modulation b) a =
Modulation (Sig.T (Const.T (BM.T (MultiValue.T b))))
type InputSource (Modulation b) a =
(Sig.T (Const.T (MultiValue.T (BM.T b))), Exp b)
evalInput sampleRate (fm,freq) =
Modulation $ modulation sampleRate (fm,freq)
detuneModulation ::
(MultiValue.Field a, MultiValue.RationalConstant a) =>
SampleRate (Exp a) ->
(b, Sig.T (Const.T (MultiValue.T (BM.T a))), Exp a) ->
(b, Sig.T (Const.T (BM.T (MultiValue.T a))))
detuneModulation sr (det,fm,freq) =
(det, transposeModulation sr freq (fmap BM.unMultiValue <$> fm))
data DetuneModulation a
instance
(a ~ Exp b, MultiValue.Field b, MultiValue.RationalConstant b) =>
Input (DetuneModulation b) a where
data InputArg (DetuneModulation b) a =
DetuneModulation
(Sig.T (Const.T (MultiValue.T b)),
Sig.T (Const.T (BM.T (MultiValue.T b))))
type InputSource (DetuneModulation b) a =
(Sig.T (Const.T (MultiValue.T b)),
Sig.T (Const.T (MultiValue.T (BM.T b))),
Exp b)
evalInput sampleRate (det,fm,freq) =
DetuneModulation $ detuneModulation sampleRate (det,fm,freq)
type RealValue = MultiValue.T Real
frequencyFromBendModulation ::
Exp Real ->
Sig.T (Const.T (BM.T RealValue)) ->
Sig.T VectorValue
frequencyFromBendModulation speed fmFreq =
MIDIL.frequencyFromBendModulationPacked speed $* piecewiseConstant fmFreq
stereoFrequenciesFromDetuneBendModulation ::
Exp Real ->
(Sig.T (Const.T RealValue), Sig.T (Const.T (BM.T RealValue))) ->
Sig.T (Stereo.T VectorValue)
stereoFrequenciesFromDetuneBendModulation speed (det,fm) =
(Causal.envelopeStereo $< frequencyFromBendModulation speed fm)
<<<
liftA2 Stereo.cons (one + id) (one - id)
$* piecewiseConstantVector det
piecewiseConstantVector :: Sig.T (Const.T RealValue) -> Sig.T VectorValue
piecewiseConstantVector xs =
piecewiseConstant (Const.causalMap Serial.upsample $* xs)
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
(pioApplyToLazyTime (pressed sr decay vel) dur)
(\x -> release vcsize sr rel x))
(CausalRender.run $
wrapped $ \(Time decay) (Number velocity) (SampleRate _sr) ->
Causal.fromSignal
(SigPS.exponential2 decay (amplitudeFromVelocity velocity)))
(Render.run $
wrapped $ \(Time releaseHL) (Number amplitude) (SampleRate _sr) ->
let releaseTime = releaseHL * 5 / fromIntegral vectorSize
in Causal.take (Expr.roundToIntFast 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 ->
pioApply (osc sr freq) (env dec rel vcsize sr vel dur))
(CausalRender.run $ wrapped $ \(Frequency freq) (SampleRate _sr) ->
Causal.envelope $> SigPS.osci 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 ->
pioApply (osc sr freq) (env dec rel vcsize sr vel dur))
(CausalRender.run $ wrapped $ \(Frequency freq) (SampleRate _sr) ->
Stereo.multiValue <$>
Causal.envelopeStereo $>
liftA2 Stereo.cons
(SigPS.osci WaveL.saw zero (0.999*freq))
(SigPS.osci 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 ->
pioApply
(osc sr (phase, phaseDecay) shape (detune, fm, freq))
(env dec rel vcsize sr vel dur))
(CausalRender.run $
wrapped $
\(Number phase, Time decay) (Control shape) (DetuneModulation fm) ->
constant frequency 10 $ \speed _sr ->
Stereo.multiValue <$>
Causal.envelopeStereo $>
((Causal.stereoFromMonoControlled
(CausalPS.shapeModOsci WaveL.rationalApproxSine1)
$< piecewiseConstantVector shape)
<<^ Stereo.interleave
$< (liftA2 Stereo.cons id (Additive.negate id)
$* SigPS.exponential2 decay phase)
$* stereoFrequenciesFromDetuneBendModulation speed fm))
pingReleaseEnvelope
squareStereoReleaseFM ::
IO (Real -> Real ->
PC.T Real ->
PC.T Real ->
PC.T Real ->
SigSt.ChunkSize ->
PC.T (BM.T Real) ->
Instrument Real (Stereo.T Vector))
squareStereoReleaseFM =
liftA2
(\osc env dec rel detune shape phase vcsize fm sr vel freq dur ->
pioApply
(osc sr (phase, shape) (detune, fm, freq))
(env dec rel vcsize sr vel dur))
(CausalRender.run $
wrapped $ \(Control phs, Control shp) (DetuneModulation fm) ->
constant frequency 10 $ \speed _sr ->
(let chanOsci ::
Causal.T
((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 Stereo.multiValue <$>
Causal.envelopeStereo $>
((Causal.stereoFromMonoControlled chanOsci
$< liftA2 (,)
(piecewiseConstantVector phs)
(piecewiseConstantVector shp))
$* stereoFrequenciesFromDetuneBendModulation speed 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 ->
pioApply
(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))
(CausalRender.run $
wrapped $
\(DetuneModulation fm) (Number vel) (Signal env4) (Signal env7) ->
constant frequency 5 $ \speed _sr ->
(let osci ::
(Triple VectorValue -> VectorValue) ->
Exp Real ->
Exp Real ->
Causal.T
(Triple VectorValue, Stereo.T VectorValue)
(Stereo.T VectorValue)
osci sel v d =
Causal.envelopeStereo
<<<
(arr sel ***
(CausalPS.amplifyStereo v
<<<
Causal.stereoFromMono
(CausalPS.osci WaveL.approxSine4 $< zero)
<<<
CausalPS.amplifyStereo d))
in Stereo.multiValue <$>
sumNested
[osci fst3 0.6 1,
osci snd3 (0.02 * 50^?vel) 4,
osci thd3 (0.02 * 100^?vel) 7]
<<<
CausalClass.feedSnd
(stereoFrequenciesFromDetuneBendModulation speed fm)
<<<
arr (\(e1,(e4,e7)) -> (e1,e4,e7))
$>
liftA2 (,) env4 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 ->
pioApply
(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))
(CausalRender.run $
wrapped $
\(Modulation fm) (Control noiseAmp, Control noiseReson)
(Number vel) (Signal env4) (Signal env7) ->
constant noiseReference 20000 $ \noiseRef ->
constant frequency 5 $ \speed _sr ->
(let osci ::
(Triple VectorValue -> VectorValue) ->
Exp Real ->
Exp Real ->
Causal.T (Triple VectorValue, VectorValue) VectorValue
osci sel v d =
Causal.envelope
<<<
(arr sel ***
(CausalPS.amplify v
<<<
(CausalPS.osci WaveL.approxSine4 $< zero)
<<<
CausalPS.amplify d))
noise ::
(Triple VectorValue -> VectorValue) ->
Exp Real ->
Causal.T (Triple VectorValue, VectorValue) VectorValue
noise sel d =
(Causal.envelope $< piecewiseConstantVector noiseAmp)
<<<
Causal.envelope
<<<
(arr sel ***
(
(CtrlPS.process $> SigPS.noise 12 noiseRef)
<<<
(Causal.quantizeLift
(Causal.zipWith (MoogL.parameter TypeNum.d8))
$<# (128 / fromIntegral vectorSize :: Real))
<<<
CausalClass.feedFst (piecewiseConstant noiseReson)
<<<
Causal.map Serial.subsample
<<<
CausalPS.amplify d))
in liftA2 Stereo.consMultiValue
(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])
<<<
CausalClass.feedSnd (frequencyFromBendModulation speed fm)
<<<
arr (\(e1,(e4,e7)) -> (e1,e4,e7))
$>
liftA2 (,) env4 env7))
pingReleaseEnvelope
tine :: IO (Real -> Real -> SigSt.ChunkSize -> Instrument Real Vector)
tine =
liftA2
(\osc env dec rel vcsize sr vel freq dur ->
pioApply (osc sr vel freq) (env dec rel vcsize sr 0 dur))
(CausalRender.run $
wrapped $ \(Number vel) (Frequency freq) ->
constant time 1 $ \halfLife _sr ->
(Causal.envelope $>
(CausalPS.osci WaveL.approxSine2
$> SigPS.constant freq
$* (Causal.envelope
$< SigPS.exponential2 halfLife (vel+1)
$* SigPS.osci 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 ->
pioApply (osc sr vel freq) (env dec rel vcsize sr 0 dur))
(CausalRender.run $
wrapped $ \(Number vel) (Frequency freq) ->
constant time 1 $ \halfLife _sr ->
(let chanOsci d =
CausalPS.osci WaveL.approxSine2 $> SigPS.constant (freq*d)
in Stereo.multiValue <$>
Causal.envelopeStereo $>
(liftA2 Stereo.cons (chanOsci 0.995) (chanOsci 1.005)
$* (SigPS.exponential2 halfLife (vel+1) *
SigPS.osci 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 :: Word
attackTimeVector = round (attackTime * vectorRate sr)
(attack, sustain) =
SigSt.splitAt (fromIntegral attackTimeVector) $
pioApplyToLazyTime
(env sr (amplitudeFromVelocity vel) attackTimeVector)
dur
release = rev attack
in attack <> sustain <> release)
SigStL.makeReversePacked
(CausalRender.run $
wrapped $ \(Number amp) (Parameter attackTimeVector) (SampleRate _sr) ->
Causal.fromSignal $
(<> SigPS.constant amp) $
(CausalPS.amplify amp <<<
Causal.take attackTimeVector
$* SigPS.parabolaFadeInInf
(fromIntegral vectorSize *
Expr.fromIntegral attackTimeVector)))
softString :: IO (Instrument Real (Stereo.T Vector))
softString =
liftA2
(\osc env sr vel freq dur ->
pioApply (osc sr freq) (env 1 sr vel dur))
(CausalRender.run $
wrapped $ \(Frequency freq) (SampleRate _sr) ->
let osci d = SigPS.osci WaveL.saw zero (d * freq)
in Stereo.multiValue <$>
Causal.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 ->
pioApply (osc sr (fm, freq)) (env 1 sr vel dur))
(CausalRender.run $
wrapped $ \(Modulation fm) ->
constant frequency 5 $ \speed _sr ->
let osci d = (CausalPS.osci WaveL.saw $< zero) <<< CausalPS.amplify d
in Stereo.multiValue <$>
(Causal.envelopeStereo $>
(liftA2 Stereo.cons
(osci 1.005 + osci 0.998)
(osci 1.002 + osci 0.995)
$* frequencyFromBendModulation speed 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 ->
pioApply (osc sr vel (fm, freq)) (env dec rel vcsize sr 0 dur))
(CausalRender.run $
wrapped $ \(Number vel) (Modulation fm) ->
constant time 1 $ \halfLife ->
constant frequency 5 $ \speed _sr ->
(let chanOsci d =
CausalPS.osci WaveL.approxSine2
<<< second (CausalPS.amplify d)
in Stereo.multiValue <$>
Causal.envelopeStereo $>
(liftA2 Stereo.cons (chanOsci 0.995) (chanOsci 1.005)
<<<
(((Causal.envelope
$< SigPS.exponential2 halfLife (vel+1))
<<< (CausalPS.osci WaveL.approxSine2 $< zero)
<<< CausalPS.amplify 2)
&&& id)
$* frequencyFromBendModulation speed fm)))
pingReleaseEnvelope
_tineControlledProc, tineControlledFnProc ::
Sig.T (Const.T RealValue) ->
Sig.T (Const.T RealValue) ->
Exp Real ->
SampleRate (Exp Real) ->
Causal.T (Stereo.T VectorValue) (Stereo.T VectorValue)
_tineControlledProc index depth vel = constant time 1 $ \halfLife _sr ->
Causal.stereoFromMono (CausalPS.osci WaveL.approxSine2)
<<<
Stereo.interleave
^<<
((Causal.envelopeStereo
$< (piecewiseConstantVector depth
*
SigPS.exponential2 halfLife (vel+1)))
<<<
Causal.stereoFromMono (CausalPS.osci WaveL.approxSine2 $< zero)
<<<
(Causal.envelopeStereo $< piecewiseConstantVector index))
&&& id
tineControlledFnProc index depth vel = constant time 1 $ \halfLife _sr ->
F.withGuidedArgs F.atom $ \freq ->
Causal.stereoFromMono (CausalPS.osci WaveL.approxSine2)
$&
liftA2 (liftA2 (,))
((Causal.envelopeStereo
$< (piecewiseConstantVector depth
*
SigPS.exponential2 halfLife (vel+1)))
<<<
Causal.stereoFromMono (CausalPS.osci WaveL.approxSine2 $< zero)
<<<
(Causal.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 ->
pioApply
(osc sr (index, depth) vel (detune, fm, freq))
(env dec rel vcsize sr 0 dur))
(CausalRender.run $
wrapped $ \(Control index, Control depth)
(Number vel) (DetuneModulation fm) ->
constant frequency 5 $ \speed sr ->
Stereo.multiValue <$>
Causal.envelopeStereo $>
(tineControlledFnProc index depth vel sr $*
stereoFrequenciesFromDetuneBendModulation speed fm))
pingReleaseEnvelope
fenderProc ::
Sig.T (Const.T RealValue) ->
Sig.T (Const.T RealValue) ->
Sig.T (Const.T RealValue) ->
Exp Real ->
SampleRate (Exp Real) ->
Causal.T (Stereo.T VectorValue) (Stereo.T VectorValue)
fenderProc fade index depth vel = constant time 1 $ \halfLife _sr ->
F.withGuidedArgs F.atom $ \stereoFreq ->
let channel_n_1 ::
F.T VectorValue VectorValue ->
F.T VectorValue VectorValue
channel_n_1 freq =
CausalPS.osci WaveL.approxSine2
$&
((Causal.envelope
$< (piecewiseConstantVector depth
*
SigPS.exponential2 halfLife (vel+1)))
<<<
(CausalPS.osci WaveL.approxSine2 $< zero)
<<<
(Causal.envelope $< piecewiseConstantVector index)
$&
freq)
&|&
freq
channel_1_2 ::
F.T VectorValue VectorValue ->
F.T VectorValue VectorValue
channel_1_2 freq =
CausalPS.osci WaveL.approxSine2
$&
((Causal.envelope
$< (piecewiseConstantVector depth
*
SigPS.exponential2 halfLife (vel+1)))
<<<
(CausalPS.osci WaveL.approxSine2 $< zero)
$&
freq)
&|&
(CausalPS.amplify 2 $& freq)
in (Causal.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 ->
pioApply
(osc sr (index, depth) fade vel (detune, fm, freq))
(env dec rel vcsize sr 0 dur))
(CausalRender.run $
wrapped $ \(Control index, Control depth) (Control fade)
(Number vel) (DetuneModulation fm) ->
constant frequency 5 $ \speed sr ->
Stereo.multiValue <$>
Causal.envelopeStereo $>
(fenderProc fade index depth vel sr $*
stereoFrequenciesFromDetuneBendModulation speed fm))
pingReleaseEnvelope
fmModulator ::
Exp Real ->
Exp Real ->
Sig.T (Const.T RealValue) ->
SampleRate (Exp Real) ->
Causal.T (Stereo.T VectorValue) (Stereo.T VectorValue)
fmModulator vel n depth = constant time 1 $ \halfLife _sr ->
(Causal.envelopeStereo
$< (piecewiseConstantVector depth
*
SigPS.exponential2 halfLife (vel+1)))
<<<
Causal.stereoFromMono (CausalPS.osci 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 ->
pioApply
(osc sr depth1 depth2 depth3 depth4 vel (detune, fm, freq))
(env dec rel vcsize sr 0 dur))
(CausalRender.run $
wrapped $
\(Control depth1) (Control depth2) (Control depth3) (Control depth4)
(Number vel) (DetuneModulation fm) ->
constant frequency 5 $ \speed sr ->
Stereo.multiValue <$>
(Causal.envelopeStereo $>
(Causal.stereoFromMono (CausalPS.osci WaveL.approxSine2)
<<<
Stereo.interleave
^<<
sumNested
[fmModulator vel 1 depth1 sr,
fmModulator vel 2 depth2 sr,
fmModulator vel 3 depth3 sr,
fmModulator vel 4 depth4 sr]
&&& id
$*
stereoFrequenciesFromDetuneBendModulation speed 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 ->
pioApply
(osc sr depth1 depth2 depth3 depth4
partial1 partial2 partial3 partial4
vel (detune, fm, freq))
(env dec rel vcsize sr 0 dur))
(CausalRender.run $
wrapped $
\(Control depth1) (Control depth2) (Control depth3) (Control depth4)
(Control partial1) (Control partial2)
(Control partial3) (Control partial4)
(Number vel) (DetuneModulation fm) ->
constant frequency 5 $ \speed sr ->
(let partial ::
VectorValue -> Int -> VectorValue ->
LLVM.CodeGenFunction r VectorValue
partial amp n t =
A.mul amp =<<
WaveL.partial WaveL.approxSine2 n t
in Stereo.multiValue <$>
Causal.envelopeStereo $>
(Causal.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)
$<
(liftA2 (,) (piecewiseConstantVector partial1) $
liftA2 (,) (piecewiseConstantVector partial2) $
liftA2 (,) (piecewiseConstantVector partial3)
(piecewiseConstantVector partial4)))
<<<
Stereo.interleave
^<<
sumNested
[fmModulator vel 1 depth1 sr,
fmModulator vel 2 depth2 sr,
fmModulator vel 3 depth3 sr,
fmModulator vel 4 depth4 sr]
&&& id
$*
stereoFrequenciesFromDetuneBendModulation speed fm)))
pingReleaseEnvelope
resonantFMSynthProc ::
Sig.T (Const.T RealValue) ->
Sig.T (Const.T RealValue) ->
Sig.T (Const.T RealValue) ->
Exp Real ->
SampleRate (Exp Real) ->
Causal.T (Stereo.T VectorValue) (Stereo.T VectorValue)
resonantFMSynthProc reson index depth vel =
constant time 1 $ \halfLife _sr ->
F.withGuidedArgs (Stereo.cons F.atom F.atom) $ \stereoFreq ->
let chan :: F.T inp VectorValue -> F.T inp VectorValue
chan freq =
CausalPS.osci WaveL.approxSine2
$&
((Causal.envelope
$< (piecewiseConstantVector depth
*
SigPS.exponential2 halfLife (vel+1)))
<<<
UniFilter.lowpass
^<<
CtrlPS.process
$&
(Causal.zipWith UniFilterL.parameter
<<<
CausalClass.feedFst (piecewiseConstant reson)
<<<
(Causal.envelope $< piecewiseConstant index)
<<<
Causal.map Serial.subsample
$&
freq)
&|&
((CausalPS.osci WaveL.saw $< zero)
$&
freq))
&|&
freq
in Trav.traverse chan stereoFreq
resonantFMSynth ::
IO (Real -> Real ->
PC.T Real ->
PC.T Real -> PC.T Real -> PC.T Real ->
SigSt.ChunkSize ->
PC.T (BM.T Real) ->
Instrument Real (Stereo.T Vector))
resonantFMSynth =
liftA2
(\osc env dec rel detune reson index depth vcsize fm sr vel freq dur ->
pioApply
(osc sr (reson, index, depth) vel (detune, fm, freq))
(env dec rel vcsize sr 0 dur))
(CausalRender.run $
wrapped $
\(Control reson, Control index, Control depth)
(Number vel) (DetuneModulation fm) ->
constant frequency 5 $ \speed sr ->
Stereo.multiValue <$>
Causal.envelopeStereo $>
(resonantFMSynthProc reson index depth vel sr $*
stereoFrequenciesFromDetuneBendModulation speed fm))
pingReleaseEnvelope
phaserOsci ::
(Exp Real -> Causal.T a VectorValue) ->
Causal.T 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 ->
pioApply (osc sr det (fm, freq)) (env att sr vel dur))
(let osci :: Exp Real -> Causal.T (VectorValue, VectorValue) VectorValue
osci d =
(CausalPS.osci WaveL.saw $< zero)
<<<
Causal.envelope
<<<
first (one + CausalPS.amplify d)
in CausalRender.run $
wrapped $ \(Control det) (Modulation fm) ->
constant frequency 5 $ \speed _sr ->
Stereo.multiValue <$>
(Causal.envelopeStereo $>
(phaserOsci osci
$< piecewiseConstantVector det
$* frequencyFromBendModulation speed fm)))
softStringReleaseEnvelope
softStringShapeFM, cosineStringStereoFM,
arcSineStringStereoFM, arcTriangleStringStereoFM,
arcSquareStringStereoFM, arcSawStringStereoFM ::
IO (Real ->
PC.T Real ->
PC.T Real ->
PC.T (BM.T Real) ->
Instrument Real (Stereo.T Vector))
softStringShapeFM =
softStringShapeCore WaveL.rationalApproxSine1
cosineStringStereoFM =
softStringShapeCore
(\k p -> WaveL.approxSine2 =<< WaveL.replicate k p)
arcSawStringStereoFM = arcStringStereoFM WaveL.saw
arcSineStringStereoFM = arcStringStereoFM WaveL.approxSine2
arcSquareStringStereoFM = arcStringStereoFM WaveL.square
arcTriangleStringStereoFM = arcStringStereoFM WaveL.triangle
arcStringStereoFM ::
(forall r.
VectorValue ->
LLVM.CodeGenFunction r VectorValue) ->
IO (Real ->
PC.T Real ->
PC.T Real ->
PC.T (BM.T Real) ->
Instrument Real (Stereo.T Vector))
arcStringStereoFM wave =
softStringShapeCore
(\k p ->
M.liftJoin2 Frame.amplifyMono
(WaveL.approxSine4 =<< WaveL.halfEnvelope p)
(wave =<< WaveL.replicate k p))
softStringShapeCore ::
(forall r.
VectorValue ->
VectorValue ->
LLVM.CodeGenFunction r VectorValue) ->
IO (Real ->
PC.T Real ->
PC.T Real ->
PC.T (BM.T Real) ->
Instrument Real (Stereo.T Vector))
softStringShapeCore wave =
liftA2
(\osc env att det dist fm sr vel freq dur ->
pioApply (osc sr det dist (fm, freq)) (env att sr vel dur))
(let osci ::
Exp Real ->
Causal.T
(VectorValue,
(VectorValue, VectorValue)
)
VectorValue
osci d =
CausalPS.shapeModOsci wave
<<<
second
(CausalClass.feedFst zero
<<<
Causal.envelope
<<<
first (one + CausalPS.amplify d))
in CausalRender.run $
wrapped $ \(Control det) (Control dist) (Modulation fm) ->
constant frequency 5 $ \speed _sr ->
Stereo.multiValue <$>
(Causal.envelopeStereo $>
(phaserOsci osci
$< piecewiseConstantVector dist
$< piecewiseConstantVector det
$* frequencyFromBendModulation speed 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 ->
pioApply (osc sr det depth dist (fm, freq)) (env att sr vel dur))
(let osci ::
Exp Real ->
Causal.T
((VectorValue, VectorValue)
,
(VectorValue, VectorValue)
)
VectorValue
osci d =
CausalPS.osci WaveL.approxSine2
<<<
(Causal.envelope
<<<
second
(CausalPS.shapeModOsci WaveL.rationalApproxSine1
<<< second (CausalClass.feedFst zero))
<<^
(\((dp, ds), f) -> (dp, (ds, f))))
&&& arr snd
<<<
second (Causal.envelope <<< first (one + CausalPS.amplify d))
in CausalRender.run $
wrapped $
\(Control det) (Control depth) (Control dist) (Modulation fm) ->
constant frequency 5 $ \speed _sr ->
Stereo.multiValue <$>
(Causal.envelopeStereo <<<
(id &&&
(phaserOsci osci
<<<
CausalClass.feedSnd
(liftA2 (,)
(piecewiseConstantVector det)
(frequencyFromBendModulation speed fm))
<<<
CausalClass.feedSnd (piecewiseConstantVector dist)
<<<
(Causal.envelope $< piecewiseConstantVector depth)))))
softStringReleaseEnvelope
stereoNoise :: SampleRate (Exp Real) -> Sig.T (Stereo.T VectorValue)
stereoNoise =
constant noiseReference 20000 $ \noiseRef _sr ->
traverse
(\uid -> SigPS.noise uid noiseRef)
(Stereo.cons 13 14)
windCore ::
Sig.T (Const.T RealValue) ->
Sig.T (Const.T (BM.T RealValue)) ->
SampleRate (Exp Real) ->
Sig.T (Stereo.T VectorValue)
windCore reson fm =
constant frequency 0.2 $ \speed sr ->
Causal.stereoFromMonoControlled CtrlPS.process
$< (Causal.zipWith (MoogL.parameter TypeNum.d8)
$< piecewiseConstant reson
$* (Causal.map Serial.subsample $*
frequencyFromBendModulation speed fm))
$* stereoNoise sr
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 ->
pioApply (osc sr reson (fm, freq)) (env att sr vel dur))
(CausalRender.run $
wrapped $ \(Control reson) (Modulation fm) sr ->
Stereo.multiValue <$>
Causal.envelopeStereo $> windCore reson fm sr)
softStringReleaseEnvelope
fadeProcess ::
(A.PseudoRing v, A.IntegerConstant v) =>
Causal.T a v ->
Causal.T a v ->
Causal.T (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 ->
pioApply
(osc sr phaserMix phaserFreq reson (fm, freq))
(env att sr vel dur))
(CausalRender.run $
wrapped $
\(Control phaserMix) (FrequencyControl phaserFreq)
(Control reson) (Modulation fm) sr ->
Stereo.multiValue <$>
(Causal.envelopeStereo $>
((Causal.stereoFromMonoControlled
(fadeProcess (arr snd) CtrlPS.process
<<<
first (Causal.map Serial.upsample)
<<^
(\((k,p),x) -> (k,(p,x))))
$< liftA2 (,)
(piecewiseConstant phaserMix)
(piecewiseConstant
(Const.causalMap
(Allpass.flangerParameter TypeNum.d8)
$* phaserFreq)))
$*
windCore reson fm sr)))
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 ->
pioApply
(osc sr bright brightDecay (detune, fm, freq))
(env dec rel vcsize sr vel dur))
(CausalRender.run $
wrapped $ \(Frequency bright) (Time brightDec) (DetuneModulation fm) ->
constant frequency 10 $ \speed ->
constant frequency 100 $ \cutoff _sr ->
(Stereo.multiValue <$>
Causal.envelopeStereo $>
(Causal.stereoFromMono
(UniFilter.lowpass
^<<
CtrlPS.processCtrlRate 100
(\k ->
Causal.map (UniFilterL.parameter 10) $*
Sig.exponentialBounded2
cutoff (brightDec/k) bright)
<<<
CausalPS.osci WaveL.saw $< zero)
$* stereoFrequenciesFromDetuneBendModulation speed fm)))
pingReleaseEnvelope
adsr ::
IO (Real -> Real -> Real ->
Real -> Real ->
SigSt.ChunkSize ->
SampleRate Real -> Real -> Ev.LazyTime -> SigSt.T Vector)
adsr =
liftA3
(\attack decay release
attackTime attackPeak attackHalfLife
decayHalfLife releaseHalfLife vcsize sr vel dur ->
let amp = amplitudeFromVelocity vel
(attackDur, decayDur) =
CutG.splitAt (round (attackTime * vectorRate sr)) dur
in SigStL.continuePacked
(pioApplyToLazyTime
(attack sr
attackHalfLife
(attackPeak * amp / (1 - 2^?(-attackTime/attackHalfLife))))
attackDur
<>
pioApplyToLazyTime
(decay sr
decayHalfLife
((attackPeak-1)*amp)
amp)
decayDur)
(\x -> release vcsize sr releaseHalfLife x))
(CausalRender.run $
wrapped $ \(Time halfLife) (Number amplitude) (SampleRate _sr) ->
Causal.fromSignal $
SigPS.constant amplitude - SigPS.exponential2 halfLife amplitude)
(CausalRender.run $ wrapped $
\(Time halfLife) (Number amplitude) (Number saturation)
(SampleRate _sr) ->
Causal.fromSignal $
SigPS.constant saturation + SigPS.exponential2 halfLife amplitude)
(Render.run $
wrapped $ \(Time releaseHL) (Number amplitude) (SampleRate _sr) ->
let releaseTime = releaseHL * 5 / fromIntegral vectorSize
in Causal.take (Expr.roundToIntFast 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 ->
pioApply
(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 osci ::
Exp Real ->
Causal.T
(VectorValue,
(VectorValue, VectorValue)
)
VectorValue
osci d =
CausalPS.shapeModOsci WaveL.rationalApproxSine1
<<<
second
(CausalClass.feedFst zero
<<<
Causal.envelope
<<<
first (one + CausalPS.amplify d))
in CausalRender.run $
wrapped $
\(Control det) (Control dist) (Modulation fm) (Signal emph) ->
constant frequency 5 $ \speed _sr ->
Stereo.multiValue <$>
Causal.envelopeStereo $>
(phaserOsci osci
<<<
CausalClass.feedFst (piecewiseConstantVector dist)
<<<
CausalClass.feedSnd (frequencyFromBendModulation speed fm)
<<<
(Causal.envelope $< piecewiseConstantVector det)
$*
emph))
adsr
sampledSound ::
IO (Sample.T ->
PC.T (BM.T Real) ->
Instrument Real (Stereo.T Vector))
sampledSound =
liftA2
(\osc freqMod smp fm sr vel freq dur ->
let fmSig :: SigSt.T Vector
fmSig =
pioApplyToLazyTime
(freqMod sr (fm, freq * Sample.period pos))
(PC.duration fm)
pos = Sample.positions smp
amp = 2 * amplitudeFromVelocity vel
(attack, sustain, release) = Sample.parts smp
in (\cont ->
pioApplyCont cont
(osc sr amp
(attack <>
SVL.cycle (SigSt.take (Sample.loopLength pos) sustain))
(chunkSizesFromLazyTime dur))
fmSig)
(pioApplyCont (const SigSt.empty)
(osc sr amp release (NonNegChunky.fromChunks (repeat 1000)))))
(CausalRender.run $
wrapped $ \(Number amp) (Signal smp) (Signal dur) (SampleRate _sr) ->
Stereo.multiValue <$>
CausalPS.amplifyStereo amp
<<<
Causal.stereoFromMono
(CausalPS.pack (Causal.frequencyModulationLinear smp))
<<<
liftA2 Stereo.cons
(CausalPS.amplify 0.999)
(CausalPS.amplify 1.001)
<<<
arr fst
<<<
CausalClass.feedSnd (Const.flatten dur))
(CausalRender.run $
wrapped $ \(Modulation fm) ->
constant frequency 3 $ \speed _sr ->
Causal.fromSignal $ frequencyFromBendModulation speed fm)
_sampledSoundLeaky ::
IO (Sample.T ->
PC.T (BM.T Real) ->
Instrument Real (Stereo.T Vector))
_sampledSoundLeaky =
liftA2
(\osc freqMod smp fm sr vel freq dur ->
let sustainFM, releaseFM :: SigSt.T Vector
(sustainFM, releaseFM) =
SVP.splitAt (chunkSizesFromLazyTime dur) $
pioApplyToLazyTime
(freqMod sr (fm, freq * Sample.period pos))
(PC.duration fm)
pos = Sample.positions smp
amp = 2 * amplitudeFromVelocity vel
(attack, sustain, release) = Sample.parts smp
in pioApply
(osc sr amp
(attack <>
SVL.cycle (SigSt.take (Sample.loopLength pos) sustain)))
sustainFM
<>
pioApply (osc sr amp release) releaseFM)
(CausalRender.run $
wrapped $ \(Number amp) (Signal smp) (SampleRate _sr) ->
Stereo.multiValue <$>
CausalPS.amplifyStereo amp
<<<
Causal.stereoFromMono
(CausalPS.pack (Causal.frequencyModulationLinear smp))
<<<
liftA2 Stereo.cons
(CausalPS.amplify 0.999)
(CausalPS.amplify 1.001))
(CausalRender.run $
wrapped $ \(Modulation fm) ->
constant frequency 3 $ \speed _sr ->
Causal.fromSignal $ frequencyFromBendModulation speed fm)