InstrumentPlug.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE Rank2Types #-}
{- |
The Instruments in this module have the same causal arrow interface
as the ones in "Synthesizer.LLVM.Server.CausalPacked.Instrument",
but here we use the higher level interface
of the "Synthesizer.LLVM.CausalParameterized.FunctionalPlug" module.
-}
module Synthesizer.LLVM.Server.CausalPacked.InstrumentPlug where

import Synthesizer.LLVM.Server.CausalPacked.Instrument (
          Control, DetuneBendModControl,
          WithEnvelopeControl,
          pingControlledEnvelope,
          reorderEnvelopeControl, )
import Synthesizer.LLVM.Server.CommonPacked (
          Param, Vector, VectorValue, )
import Synthesizer.LLVM.Server.Common (
          SampleRate, Real,
          frequencyConst, timeConst,
          number, transposeModulation, )

import qualified Synthesizer.CausalIO.Process as PIO

import Synthesizer.LLVM.CausalParameterized.FunctionalPlug (($&), (&|&), )
import qualified Synthesizer.LLVM.Frame.Stereo as Stereo
import qualified Synthesizer.LLVM.Frame.SerialVector as Serial
import qualified Synthesizer.LLVM.CausalParameterized.FunctionalPlug as FP
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.Wave as WaveL

import qualified Synthesizer.LLVM.MIDI.BendModulation as BM
import qualified Synthesizer.LLVM.MIDI as MIDIL
import qualified Synthesizer.Zip as Zip

import qualified Data.StorableVector as SV

import qualified LLVM.Core as LLVM

import qualified Data.Traversable as Trav
import Control.Category (id, (.), )
import Control.Applicative (liftA2, )

import NumericPrelude.Numeric
import NumericPrelude.Base hiding (id, (.), )


type FuncP pp pl = FP.T pp (SampleRate Real, pl)


stereoFrequenciesFromDetuneBendModulation ::
   Param pl Real ->
   (FuncP pp pl inp (LLVM.Value Real),
    FuncP pp pl inp (BM.T (LLVM.Value Real))) ->
   FuncP pp pl inp (Stereo.T VectorValue)
stereoFrequenciesFromDetuneBendModulation speed (detune, freq) =
   CausalP.envelopeStereo $&
      (MIDIL.frequencyFromBendModulationPacked speed $& freq)
      &|&
      (CausalP.mapSimple (Trav.mapM 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))
          (SV.Vector (Stereo.T Vector)))
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))) ->
         let vel = number id
             freqs =
                stereoFrequenciesFromDetuneBendModulation
                   (frequencyConst 5)
                   (FP.plug detune,
                    FP.plug $ liftA2 (uncurry transposeModulation) FP.askParameter fm)
             index = CausalP.mapSimple Serial.upsample $& FP.plug index0
             depth = CausalP.mapSimple Serial.upsample $& FP.plug depth0
             expo =
                FP.fromSignal $
                SigPS.exponential2 (timeConst 1) (1 + vel)
             osci freq =
                CausalPS.osciSimple WaveL.approxSine2 $&
                   expo * depth *
                      (CausalPS.osciSimple WaveL.approxSine2
                       $& zero &|& index*freq)
                   &|&
                   freq
         in  CausalP.envelopeStereo $&
                FP.plug env &|& Stereo.liftApplicative osci freqs)
      (pingControlledEnvelope (Just 0.01))