{-
ToDo:
organization:
   compile instrument when switching a MIDI program
      However caching and sharing might be a good idea
         like for quickly changing between tomatensalat syllabels.
      Ideally we just need to run instrument generation using unsafeInterleaveIO.
         This however will trigger instrument compilation
         when the sound is played the first time.
         This may cause buffer underruns.
         On the other hand, forcing instrument compilation on program changes
         might still cause buffer underruns.


instruments:
   tonal noise can be produced by modulating pink noise
      experimental: multiply with waveforms other than sine
   use bits of an ASCII code as waveform
   use a greymap picture as source of waveforms
   mix of detuned noisy-waverforms, try different and uniform waveforms
   mix of sawtooth, where every sawtooth is modulated with red noise
   mix of sine with harmonics where every harmonic is modulated differently
   Flute: sine + filtered noise
   Drum with various parameters
   derive percussive instruments from fmString and arcString (for bass synths)
   an FM sound with a slowly changing timbre
      by using a very slightly detuned frequency for the modulator
   making a tone out of noise using time stretch with helix algorithm
      a chorus effect could be applied by two successive helix stretches
      or by mixture of two stretches signals
      additionally a resonant filter could be applied
   a kind of Karplus-Strong algorithm with a non-linear function of past values
      e.g. y(t) = f(y(t-d), y(t-2*d))
      where d is the tone period and f is non-linear, maybe chaotic function.
      In order to limit the appearance of chaotic waveforms,
      we could combine this with a lowpass filter.
   let attack and release depend on On and Off velocity
   tineStereoFM:
      continuous control of the modulation index
      by linear interpolation of waves between modulations with integral indices.
      E.g. modulation index 2.3 means
      0.7*modulation with index 2 and 0.3*modulation with index 3.

effects:
   reverb and controllable delay
   phaser or Chebyshev filter
   reverb where many single combs are mixed
      every comb has ever-increasing frequency, but is faded in and out.
      Should give an endless effect where the reverb becomes higher and higher.

continuous sounds:
   fly
   water/bubbles
      when I accidentally did not scale filter frequency with sample rate,
      the filter sound much like water bubbles.
      I think a control curve consisting of some ramps will do the same.
   hail, Geiger counter, pitch applied by comb filter
      at a very high impulse rate the impulses itself
      can generate an almost periodic signal


Speech sounds improvements (tomatensalat)
   use PSOLA for transposition
   To this end divide signal into tonal part and residue (noise)
   by a comb filter.
   Maybe a non-linear comb filter may help,
   that selects the center value from the filter window,
   if the side values are similar
   and returns zero, if the the side values differ too much.
   Process the tonal part by PSOLA and
   simply mix it with the non-tonal part on replay.

Harmonizer-like:
   We like to input an audio signal of speech
   and a set of keys, and the speech is extended to chords
   according to the pressed keys.
   The lowest key is interpreted as base frequency of the input audio speech.
   A PSOLA method transposes the audio input.

Resonant filter controlled by keys
   applied to an audio input signal
   or an ordinary audio signal generated by other keys.
   The splitting of keys however could be performed
   by a MIDI event stream editor.
-}

{-# 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,

   -- * helper functions
   stereoNoise,
   frequencyFromBendModulation,
   piecewiseConstantVector,

   -- * for testing
   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

{- |
Square like wave constructed as difference
of two phase shifted sawtooth like oscillations.
-}
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))
               $> {-
                  Be careful, those storable vectors shorten the whole sound
                  if they have shorter release than the main envelope.
                  -}
                  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 ***
                    ({- UniFilter.lowpass
                        ^<< -}
                     (CtrlPS.process $> SigPS.noise 12 noiseRef)
                     <<<
{-
                     (Causal.quantizeLift
                        (Causal.zipWith UniFilterL.parameter)
                        $<# (128 / fromIntegral vectorSize :: Real))
-}
                     (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))
               $> {-
                  Be careful, those storable vectors shorten the whole sound
                  if they have shorter release than the main envelope.
                  -}
                  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)
             {-
             release <- take attackTime beginning
             would yield a space leak, thus we first split 'beginning'
             and then concatenate it again
             -}
             {-
             We can not easily generate attack and sustain separately,
             because we want to use the chunk structure implied by 'dur'.
             -}
             (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


{- |
FM synthesis where the modulator is a resonantly filtered sawtooth.
This way we get a sinus-like modulator where the sine frequency
(that is, something like the modulation index) can be controlled continously.
-}
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

{-
We might decouple the frequency of the enveloped tone
from the frequency of the envelope,
in order to get something like formants.
-}
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,
                       {- wave shape parameter -}
                  (VectorValue, VectorValue)
                       {- detune, frequency modulation -})
                 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)
                       {- phase modulation depth, modulator distortion -},
                  (VectorValue, VectorValue)
                       {- detune, frequency modulation -})
                 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) $*
                           {- bound control in order to avoid too low resonant frequency,
                              which makes the filter instable -}
                           Sig.exponentialBounded2
                              cutoff (brightDec/k) bright)
                   <<<
                   CausalPS.osci WaveL.saw $< zero)
               $* stereoFrequenciesFromDetuneBendModulation speed fm)))
      pingReleaseEnvelope


{- |
The ADSR curve is composed from three parts:
Attack, Decay(+Sustain), Release.
Attack starts when the key is pressed
and lasts attackTime seconds
where it reaches height attackPeak*amplitudeOfVelocity.
It should be attackPeak>1 because in the following phase
we want to approach 1 from above.
Say the curve would approach the limit value L
if it would continue after the end of the attack phase,
the slope is determined by the halfLife with respect to this upper bound.
That is, attackHalfLife is the time in seconds where the attack curve
reaches or would reach L/2.
After Attack the Decay part starts at the same level
and decays to amplitudeOfVelocity.
The slope is again a halfLife,
that is, decayHalfLife is the time where the curve
drops from attackPeak*amplitudeOfVelocity to (attackPeak+1)/2*amplitudeOfVelocity.
This phase lasts as long as the key is pressed.
If the key is released the curve decays with half life releaseHalfLife.
-}
{-
1 - 2^(-attackTime/attackHalfLife) = peak
-}
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,
                       {- wave shrink/replication factor -}
                  (VectorValue, VectorValue)
                       {- detune, frequency modulation -})
                 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 ->
         {-
         We split the frequency modulation signal
         in order to get a smooth frequency modulation curve.
         Without (periodic) frequency modulation
         we could just split the piecewise constant control curve @fm@.
         -}
         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 ->
         {-
         We split the frequency modulation signal
         in order to get a smooth frequency modulation curve.
         Without (periodic) frequency modulation
         we could just split the piecewise constant control curve @fm@.
         -}
         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)