{-# 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 (
   tineStereoFM,
   helixNoise,
   ) where

import Synthesizer.LLVM.Server.CausalPacked.Instrument (
          Control, DetuneBendModControl,
          WithEnvelopeControl, StereoChunk,
          pingControlledEnvelope,
          stringControlledEnvelope,
          reorderEnvelopeControl, )
import Synthesizer.LLVM.Server.CommonPacked (
          Param, 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.Helix as Helix
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.Parameterized.Signal as SigP
import qualified Synthesizer.LLVM.Parameter as Param
import qualified Synthesizer.LLVM.Interpolation as Interpolation
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 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))
          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))) ->
         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))


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, vel)
         .
         Zip.arrowFirstShorten (env sr vel)
         .
         reorderEnvelopeControl)
      (FP.withArgs $ \(env, (speed0, (detune,fm))) ->
         let freqs =
                stereoFrequenciesFromDetuneBendModulation
                   (frequencyConst 5)
                   (FP.plug detune,
                    FP.plug $ liftA2 (uncurry transposeModulation) FP.askParameter fm)
             speed = CausalP.mapSimple Serial.upsample $& FP.plug speed0
         in  CausalP.envelopeStereo $&
                FP.plug env &|& Stereo.liftApplicative (helixOsci speed) freqs)
      stringControlledEnvelope

helixOsci ::
   FP.T pp pl inp VectorValue ->
   FP.T pp pl inp VectorValue ->
   FP.T pp pl inp VectorValue
helixOsci speed freq =
   CausalPS.pack
      (Helix.dynamicLimited Interpolation.cubic Interpolation.cubic
          64 (64 :: Param.T p Real) (SigP.noise 66 0.2))
   $&
   speed &|&
   (CausalPS.osciCore $& 0 &|& freq)