{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE Rank2Types #-}
module Synthesizer.LLVM.Server.CausalPacked.InstrumentPlug (
tineStereoFM,
helixNoise,
) where
import Synthesizer.LLVM.Server.CausalPacked.Instrument (
Control, DetuneBendModControl,
WithEnvelopeControl, StereoChunk,
pingControlledEnvelope,
stringControlledEnvelope,
reorderEnvelopeControl)
import Synthesizer.LLVM.Server.CausalPacked.Common (transposeModulation)
import Synthesizer.LLVM.Server.CommonPacked (VectorValue)
import Synthesizer.LLVM.Server.Common (
SampleRate, expSampleRate, Real,
Arg(Number), wrapped,
constant, frequency, time)
import qualified Synthesizer.CausalIO.Process as PIO
import qualified Synthesizer.LLVM.Frame.Stereo as Stereo
import qualified Synthesizer.LLVM.Frame.SerialVector as Serial
import qualified Synthesizer.LLVM.Causal.Helix as Helix
import qualified Synthesizer.LLVM.Causal.FunctionalPlug as FP
import qualified Synthesizer.LLVM.Causal.ProcessPacked as CausalPS
import qualified Synthesizer.LLVM.Causal.Process as Causal
import qualified Synthesizer.LLVM.Generator.SignalPacked as SigPS
import qualified Synthesizer.LLVM.Generator.Signal as Sig
import qualified Synthesizer.LLVM.Interpolation as Interpolation
import qualified Synthesizer.LLVM.Wave as WaveL
import Synthesizer.LLVM.Causal.FunctionalPlug (($&), (&|&))
import qualified Synthesizer.LLVM.MIDI.BendModulation as BM
import qualified Synthesizer.LLVM.MIDI as MIDIL
import qualified Synthesizer.Zip as Zip
import qualified LLVM.DSL.Expression as Expr
import LLVM.DSL.Expression (Exp)
import qualified LLVM.Extra.Multi.Value as MultiValue
import Control.Category ((.))
import Control.Applicative (liftA2, (<$>))
import NumericPrelude.Numeric
import NumericPrelude.Base hiding (id, (.))
stereoFrequenciesFromDetuneBendModulation ::
Exp Real ->
(FP.T p inp (MultiValue.T Real),
FP.T p inp (MultiValue.T (BM.T Real))) ->
FP.T p inp (Stereo.T VectorValue)
stereoFrequenciesFromDetuneBendModulation speed (detune, freq) =
Causal.envelopeStereo $&
(MIDIL.frequencyFromBendModulationPacked speed $&
(BM.unMultiValue <$> freq))
&|&
(Causal.map (fmap Serial.upsample) $&
liftA2 Stereo.cons (one + detune) (one - detune))
tineStereoFM ::
IO (SampleRate Real -> Real -> Real ->
PIO.T
(WithEnvelopeControl
(Zip.T
(Zip.T (Control Real) (Control Real))
DetuneBendModControl))
StereoChunk)
tineStereoFM =
liftA2
(\osc env sr vel freq ->
osc (sr, freq) (sr, vel)
.
Zip.arrowFirstShorten (env sr vel)
.
reorderEnvelopeControl)
(FP.withArgs $ \(env, ((index0,depth0), (detune,fm))) pl ->
(\f -> case Expr.unzip pl of (sr,vel) -> f (expSampleRate sr) vel) $
wrapped $ \(Number vel) ->
constant time 1 $ \halfLife ->
constant frequency 5 $ \speed _sr ->
let freqs =
stereoFrequenciesFromDetuneBendModulation
speed
(FP.plug detune,
FP.plug $
liftA2 (uncurry transposeModulation) FP.askParameter fm)
index = Causal.map Serial.upsample $& FP.plug index0
depth = Causal.map Serial.upsample $& FP.plug depth0
expo = FP.fromSignal $ SigPS.exponential2 halfLife (1 + vel)
osci freq =
CausalPS.osci WaveL.approxSine2 $&
expo * depth *
(CausalPS.osci WaveL.approxSine2
$& zero &|& index*freq)
&|&
freq
in fmap Stereo.multiValue $
Causal.envelopeStereo $&
FP.plug env &|& Stereo.liftApplicative osci freqs)
(pingControlledEnvelope (Just 0.01))
helixNoise ::
IO (SampleRate Real -> Real -> Real ->
PIO.T
(WithEnvelopeControl
(Zip.T (Control Real) DetuneBendModControl))
StereoChunk)
helixNoise =
liftA2
(\osc env sr vel freq ->
osc (sr, freq) sr
.
Zip.arrowFirstShorten (env sr vel)
.
reorderEnvelopeControl)
(FP.withArgs $ \(env, (speed0, (detune,fm))) sr ->
(\f -> f (expSampleRate sr)) $
constant frequency 5 $ \modSpeed _sr ->
let freqs =
stereoFrequenciesFromDetuneBendModulation
modSpeed
(FP.plug detune,
FP.plug $
liftA2 (uncurry transposeModulation) FP.askParameter fm)
speed = Causal.map Serial.upsample $& FP.plug speed0
in fmap Stereo.multiValue $
Causal.envelopeStereo $&
FP.plug env &|& Stereo.liftApplicative (helixOsci speed) freqs)
stringControlledEnvelope
helixOsci ::
FP.T pp inp VectorValue ->
FP.T pp inp VectorValue ->
FP.T pp inp VectorValue
helixOsci speed freq =
CausalPS.pack
(Helix.dynamicLimited Interpolation.cubic Interpolation.cubic
64 (64 :: Exp Real) (Sig.noise 66 0.2))
$&
speed &|&
(CausalPS.osciCore $& 0 &|& freq)