{-
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:
   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

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 FlexibleContexts #-}
{-# LANGUAGE Rank2Types #-}
module Synthesizer.LLVM.Server.Packed.Instrument (
   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,
   modulation,
   piecewiseConstantVector,

   -- * for testing
   pingReleaseEnvelope,
   adsr,
   ) where

import qualified Synthesizer.LLVM.Server.Parameter as ParamS
import Synthesizer.LLVM.Server.CommonPacked
import Synthesizer.LLVM.Server.Common
import Synthesizer.LLVM.Server.Parameter
         (Number(Number), Signal(Signal), Control(Control))

import qualified Synthesizer.LLVM.Server.SampledSound as Sample
import qualified Synthesizer.LLVM.MIDI.BendModulation as BM
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.CausalParameterized.ControlledPacked as CtrlPS
import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS
import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP
import qualified Synthesizer.LLVM.CausalParameterized.Functional as F
import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS
import qualified Synthesizer.LLVM.Parameterized.Signal as SigP
import qualified Synthesizer.LLVM.Simple.Signal as Sig
import qualified Synthesizer.LLVM.Parameter as Param
import qualified Synthesizer.LLVM.Storable.Signal as SigStL
import qualified Synthesizer.LLVM.Frame as Frame
import qualified Synthesizer.LLVM.Frame.SerialVector as Serial
import qualified Synthesizer.LLVM.Wave as WaveL
import Synthesizer.LLVM.CausalParameterized.Process (($<), ($>), ($*), )
import Synthesizer.LLVM.CausalParameterized.Functional (($&), (&|&), )
import Synthesizer.LLVM.Parameter (($#), )

import qualified LLVM.Extra.Arithmetic as A
import qualified LLVM.Core as LLVM
import qualified Type.Data.Num.Decimal as TypeNum

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 Data.Traversable (traverse, )
import qualified Data.Traversable as Trav

import Data.Tuple.HT (fst3, snd3, thd3, )

{-
import qualified Numeric.NonNegative.Class   as NonNeg
import qualified Numeric.NonNegative.Wrapper as NonNegW
-}
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 :: (p -> PC.T Real) -> Param p (PC.T Real)
frequencyControl param =
   arr (\(SampleRate sampleRate, p) -> fmap (/sampleRate) $ param p)

modulation ::
   (p -> (PC.T (BM.T Real), Real)) -> Param p (PC.T (BM.T Real))
modulation param =
   arr (\(sr, p) ->
      (\(fm,freq) -> transposeModulation sr freq fm) $ param p)

newtype Modulation p = Modulation (Param p (PC.T (BM.T Real)))

instance ParamS.Tuple (Modulation p) where
   type Composed (Modulation p) = (PC.T (BM.T Real), Real)
   type Source (Modulation p) = p
   decompose sampleRate x =
      Modulation $
         liftA2 (\sr (fm,freq) -> transposeModulation sr freq fm) sampleRate x

detuneModulation ::
   (p -> (PC.T Real, PC.T (BM.T Real), Real)) ->
   Param p (PC.T Real, PC.T (BM.T Real))
detuneModulation param =
   arr $ \(sr, p) ->
      case param p of
         (det,fm,freq) -> (det, transposeModulation sr freq fm)

newtype
   DetuneModulation p =
      DetuneModulation (Param p (PC.T Real, PC.T (BM.T Real)))

instance ParamS.Tuple (DetuneModulation p) where
   type Composed (DetuneModulation p) = (PC.T Real, PC.T (BM.T Real), Real)
   type Source (DetuneModulation p) = p
   decompose sampleRate x =
      DetuneModulation $
         liftA2
            (\sr (det,fm,freq) -> (det, transposeModulation sr freq fm))
            sampleRate x



frequencyFromBendModulation ::
{-
   (Storable a,
    Class.MakeValueTuple a, ValueTuple a ~ (Value a)) =>
-}
   Param p Real ->
   Param p (PC.T (BM.T Real)) ->
   SigP p VectorValue
frequencyFromBendModulation speed fmFreq =
   MIDIL.frequencyFromBendModulationPacked speed
      $* piecewiseConstant fmFreq

stereoFrequenciesFromDetuneBendModulation ::
   Param p Real ->
   Param p (PC.T Real, PC.T (BM.T Real)) ->
   SigP p (Stereo.T VectorValue)
stereoFrequenciesFromDetuneBendModulation speed detFmFreq =
   (CausalP.envelopeStereo
      $< frequencyFromBendModulation speed
           (fmap (\(_det,fm) -> (fm)) detFmFreq))
   <<<
   liftA2 Stereo.cons (one + id) (one - id)
   $* piecewiseConstantVector
         (fmap (\(det,_fm) -> det) detFmFreq)

piecewiseConstantVector ::
   Param.T p (PC.T Real) -> SigP.T p VectorValue
{-
   (Storable a,
    Class.MakeValueTuple a, Class.ValueTuple a ~ al,
    Memory.C al am,
    LLVM.IsSized am as) =>
   Param.T p (PC.T a) -> SigP.T p (Serial.Value n al)
-}
piecewiseConstantVector =
   piecewiseConstant . fmap (fmap (Serial.replicate))


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
            (pressed (chunkSizesFromLazyTime dur) (sr, (decay,vel)))
            (\x -> release vcsize (sr, (rel,x))))
      (SigP.runChunkyPattern $
       let decay = time fst
           velocity = number snd
       in  SigPS.exponential2 decay
              (amplitudeFromVelocity ^<< velocity))
      (SigP.runChunky $
       let releaseTime = vectorTime fst * 5
           releaseHL = time fst
           amplitude = number snd
       in  CausalP.take (round ^<< 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 ->
         osc (sr,freq) (env dec rel vcsize sr vel dur))
      (CausalP.runStorableChunky
         (let freq = frequency id
          in  CausalP.envelope $>
              SigPS.osciSimple 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 ->
         osc (sr,freq) (env dec rel vcsize sr vel dur))
      (CausalP.runStorableChunky
         (let freq = frequency id
          in  CausalP.envelopeStereo $>
              liftA2 Stereo.cons
                 (SigPS.osciSimple WaveL.saw zero (0.999*freq))
                 (SigPS.osciSimple 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 ->
         osc
            (sr, ((phase, phaseDecay), shape, (detune,fm,freq)))
            (env dec rel vcsize sr vel dur))
      (CausalP.runStorableChunky $
       ParamS.withTuple2 $
         \((Number phase, ParamS.Time decay),
            Control shape, DetuneModulation fm) ->
              CausalP.envelopeStereo $>
              ((CausalP.stereoFromMonoControlled
                  (CausalPS.shapeModOsci WaveL.rationalApproxSine1)
                    $< piecewiseConstantVector shape)
                  <<^ Stereo.interleave
                $< (liftA2 Stereo.cons id (Additive.negate id)
                     $* SigPS.exponential2 decay phase)
                $* stereoFrequenciesFromDetuneBendModulation (frequencyConst 10) 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 ->
         osc
            (sr, ((phase, shape), (detune,fm,freq)))
            (env dec rel vcsize sr vel dur))
      (CausalP.runStorableChunky $
       ParamS.withTuple2 $ \((Control phs, Control shp), DetuneModulation fm) ->
         (let chanOsci ::
                 CausalP p
                    ((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  CausalP.envelopeStereo $>
              ((CausalP.stereoFromMonoControlled chanOsci
                   $< SigP.zip
                         (piecewiseConstantVector phs)
                         (piecewiseConstantVector shp))
                $* stereoFrequenciesFromDetuneBendModulation (frequencyConst 10) 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 ->
         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))
      (CausalP.runStorableChunky $
       ParamS.withTuple2 $
       \(DetuneModulation fm, Number vel, (Signal env4, Signal env7)) ->
         (let osci ::
                 (Triple VectorValue -> VectorValue) ->
                 Param.T p Real ->
                 Param.T p Real ->
                 CausalP.T p
                    (Triple VectorValue, Stereo.T VectorValue)
                    (Stereo.T VectorValue)
              osci sel v d =
                 CausalP.envelopeStereo
                 <<<
                 (arr sel ***
                    (CausalPS.amplifyStereo v
                     <<<
                     CausalP.stereoFromMono
                        (CausalPS.osciSimple WaveL.approxSine4 $< zero)
                     <<<
                     CausalPS.amplifyStereo d))
          in  sumNested
                 [osci fst3  0.6              1,
                  osci snd3 (0.02 *  50^?vel) 4,
                  osci thd3 (0.02 * 100^?vel) 7]
              <<<
              CausalP.feedSnd (stereoFrequenciesFromDetuneBendModulation (frequencyConst 5) 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.
                  -}
                  SigP.zip
                     (SigP.fromStorableVectorLazy env4)
                     (SigP.fromStorableVectorLazy 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 ->
         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))
      (CausalP.runStorableChunky $
       ParamS.withTuple2 $
       \(Modulation fm,
         (Control noiseAmp, Control noiseReson),
         (Number vel, Signal env4, Signal env7)) ->
         (let osci ::
                 (Triple VectorValue -> VectorValue) ->
                 Param.T p Real ->
                 Param.T p Real ->
                 CausalP.T p
                    (Triple VectorValue, VectorValue)
                    VectorValue
              osci sel v d =
                 CausalP.envelope
                 <<<
                 (arr sel ***
                    (CausalPS.amplify v
                     <<<
                     (CausalPS.osciSimple WaveL.approxSine4 $< zero)
                     <<<
                     CausalPS.amplify d))

              noise ::
                 (p ~
                     ((PC.T (BM.T Real), Real),
                      (PC.T Real, PC.T Real),
                      (Real, SigSt.T Vector, SigSt.T Vector))) =>
                 (Triple VectorValue -> VectorValue) ->
                 Param p Real ->
                 CausalP p (Triple VectorValue, VectorValue) VectorValue
              noise sel d =
                 (CausalP.envelope $< piecewiseConstantVector noiseAmp)
                 <<<
                 CausalP.envelope
                 <<<
                 (arr sel ***
                    ({- UniFilter.lowpass
                        ^<< -}
                     (CtrlPS.process
                        $> SigPS.noise 12 (noiseReference 20000))
                     <<<
{-
                     (CausalP.quantizeLift
                        $# (128 / fromIntegral vectorSize :: Real))
                           (CausalP.zipWithSimple UniFilterL.parameter)
-}
                     (CausalP.quantizeLift
                        $# (128 / fromIntegral vectorSize :: Real))
                           (CausalP.zipWithSimple (MoogL.parameter TypeNum.d8))
                     <<<
                     CausalP.feedFst (piecewiseConstant noiseReson)
                     <<<
                     CausalP.mapSimple Serial.subsample
                     <<<
                     CausalPS.amplify d))
          in  liftA2 Stereo.cons
                 (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])
              <<<
              CausalP.feedSnd (frequencyFromBendModulation (frequencyConst 5) 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.
                  -}
                  SigP.zip
                     (SigP.fromStorableVectorLazy env4)
                     (SigP.fromStorableVectorLazy env7)))
      pingReleaseEnvelope


tine :: IO (Real -> Real -> SigSt.ChunkSize -> Instrument Real Vector)
tine =
   liftA2
      (\osc env dec rel vcsize sr vel freq dur ->
         osc (sr, (vel,freq)) (env dec rel vcsize sr 0 dur))
      (CausalP.runStorableChunky
         (let freq = frequency snd
              vel  = number fst
          in  CausalP.envelope $>
                 (CausalPS.osciSimple WaveL.approxSine2
                    $> SigPS.constant freq
                    $* (CausalP.envelope
                          $< SigPS.exponential2 (timeConst 1) (vel+1)
                          $* SigPS.osciSimple 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 ->
         osc (sr, (vel,freq)) (env dec rel vcsize sr 0 dur))
      (CausalP.runStorableChunky
         (let freq = frequency snd
              vel  = number fst
              chanOsci d =
                 CausalPS.osciSimple WaveL.approxSine2
                    $> SigPS.constant (freq*d)
          in  CausalP.envelopeStereo $>
                 (liftA2 Stereo.cons
                    (chanOsci 0.995) (chanOsci 1.005)
                  $* SigP.envelope
                        (SigPS.exponential2 (timeConst 1) (vel+1))
                        (SigPS.osciSimple 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 =
                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 attackTimeVector $
                env (chunkSizesFromLazyTime dur)
                    (sr, (amplitudeFromVelocity vel, attackTimeVector))
             release = rev attack
         in  attack `SigSt.append` sustain `SigSt.append` release)
      SigStL.makeReversePacked
      (let amp = number fst
           attackTimeVector = parameter snd
       in  SigP.runChunkyPattern $
           flip SigP.append (SigPS.constant amp) $
           (CausalPS.amplify amp <<<
            CausalP.take attackTimeVector
            $* SigPS.parabolaFadeInInf
                  (fmap (fromIntegral . (vectorSize*)) attackTimeVector)))

softString :: IO (Instrument Real (Stereo.T Vector))
softString =
   liftA2
      (\osc env sr vel freq dur ->
         osc (sr, freq) (env 1 sr vel dur))
      (let freq = frequency id
           osci d = SigPS.osciSimple WaveL.saw zero (d * freq)
       in  CausalP.runStorableChunky $
           (CausalP.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 ->
         osc (sr, (fm,freq)) (env 1 sr vel dur))
      (let fm = modulation id
           osci ::
              Param.T fm Real ->
              CausalP.T fm VectorValue VectorValue
           osci d =
              (CausalPS.osciSimple WaveL.saw $< zero) <<<
              CausalPS.amplify d
       in  CausalP.runStorableChunky $
           (CausalP.envelopeStereo $>
              (liftA2 Stereo.cons
                  (osci 1.005 + osci 0.998)
                  (osci 1.002 + osci 0.995)
               $* frequencyFromBendModulation (frequencyConst 5) 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 ->
         osc (sr, (vel,(fm,freq))) (env dec rel vcsize sr 0 dur))
      (CausalP.runStorableChunky
         (let vel  = number fst
              fm   = modulation snd
              chanOsci d =
                 CausalPS.osciSimple WaveL.approxSine2
                    <<< second (CausalPS.amplify d)
          in  CausalP.envelopeStereo $>
                 (liftA2 Stereo.cons
                     (chanOsci 0.995) (chanOsci 1.005)
                  <<<
                  (((CausalP.envelope
                       $< SigPS.exponential2 (timeConst 1) (vel+1))
                     <<< (CausalPS.osciSimple WaveL.approxSine2 $< zero)
                     <<< CausalPS.amplify 2)
                   &&& id)
                  $* frequencyFromBendModulation (frequencyConst 5) fm)))
      pingReleaseEnvelope


_tineControlledProc, tineControlledFnProc ::
   Param p (PC.T Real) ->
   Param p (PC.T Real) ->
   Param p Real ->
   CausalP p
      (Stereo.T VectorValue)
      (Stereo.T VectorValue)
_tineControlledProc index depth vel =
   CausalP.stereoFromMono
      (CausalPS.osciSimple WaveL.approxSine2)
   <<<
   Stereo.interleave
   ^<<
   ((CausalP.envelopeStereo
       $< SigP.envelope
             (piecewiseConstantVector depth)
             (SigPS.exponential2 (timeConst 1) (vel+1)))
    <<<
    CausalP.stereoFromMono
       (CausalPS.osciSimple WaveL.approxSine2 $< zero)
    <<<
    (CausalP.envelopeStereo
       $< piecewiseConstantVector index))
            &&& id

tineControlledFnProc index depth vel =
   F.withGuidedArgs F.atom $ \freq ->
      CausalP.stereoFromMono
         (CausalPS.osciSimple WaveL.approxSine2)
      $&
      liftA2 (liftA2 (,))
         ((CausalP.envelopeStereo
             $< SigP.envelope
                   (piecewiseConstantVector depth)
                   (SigPS.exponential2 (timeConst 1) (vel+1)))
          <<<
          CausalP.stereoFromMono
             (CausalPS.osciSimple WaveL.approxSine2 $< zero)
          <<<
          (CausalP.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 ->
         osc
            (sr, ((index, depth), vel, (detune,fm,freq)))
            (env dec rel vcsize sr 0 dur))
      (CausalP.runStorableChunky $
       ParamS.withTuple2 $
       \((Control index, Control depth), Number vel, DetuneModulation fm) ->
         CausalP.envelopeStereo $>
            (tineControlledFnProc index depth vel $*
             stereoFrequenciesFromDetuneBendModulation (frequencyConst 5) fm))
      pingReleaseEnvelope


fenderProc ::
   Param p (PC.T Real) ->
   Param p (PC.T Real) ->
   Param p (PC.T Real) ->
   Param p Real ->
   CausalP p
      (Stereo.T VectorValue)
      (Stereo.T VectorValue)
fenderProc fade index depth vel =
   F.withGuidedArgs F.atom $ \stereoFreq ->
       let {-
           channel_n_1 ::
              FuncP p VectorValue VectorValue ->
              FuncP p VectorValue VectorValue
           -}
           channel_n_1 freq =
              CausalPS.osciSimple WaveL.approxSine2
              $&
              ((CausalP.envelope
                  $< SigP.envelope
                        (piecewiseConstantVector depth)
                        (SigPS.exponential2 (timeConst 1) (vel+1)))
               <<<
               (CausalPS.osciSimple WaveL.approxSine2 $< zero)
               <<<
               (CausalP.envelope
                  $< piecewiseConstantVector index)
               $&
               freq)
              &|&
              freq
           {-
           channel_1_2 ::
              FuncP p VectorValue VectorValue ->
              FuncP p VectorValue VectorValue
           -}
           channel_1_2 freq =
              CausalPS.osciSimple WaveL.approxSine2
              $&
              ((CausalP.envelope
                  $< SigP.envelope
                        (piecewiseConstantVector depth)
                        (SigPS.exponential2 (timeConst 1) (vel+1)))
               <<<
               (CausalPS.osciSimple WaveL.approxSine2 $< zero)
               $&
               freq)
              &|&
              (CausalPS.amplify 2 $& freq)
       in  (CausalP.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 ->
         osc
            (sr, (((index, depth), fade), vel, (detune,fm,freq)))
            (env dec rel vcsize sr 0 dur))
      (CausalP.runStorableChunky $
       ParamS.withTuple2 $
       \(((Control index, Control depth), Control fade),
            Number vel, DetuneModulation fm) ->
         CausalP.envelopeStereo $>
            (fenderProc fade index depth vel $*
             stereoFrequenciesFromDetuneBendModulation (frequencyConst 5) fm))
      pingReleaseEnvelope


fmModulator ::
   Param p Real ->
   Param p Real ->
   Param p (PC.T Real) ->
   CausalP p
      (Stereo.T VectorValue)
      (Stereo.T VectorValue)
fmModulator vel n depth =
   (CausalP.envelopeStereo
      $< SigP.envelope
            (piecewiseConstantVector depth)
            (SigPS.exponential2 (timeConst 1) (vel+1)))
   <<<
   CausalP.stereoFromMono
      (CausalPS.osciSimple 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 ->
         osc
            (sr, ((depth1,(depth2,(depth3,(depth4)))), vel, (detune,fm,freq)))
            (env dec rel vcsize sr 0 dur))
      (CausalP.runStorableChunky $
       ParamS.withTuple2 $
       \((Control depth1, (Control depth2, (Control depth3, Control depth4))),
            Number vel, DetuneModulation fm) ->
              (CausalP.envelopeStereo $>
                 (CausalP.stereoFromMono
                     (CausalPS.osciSimple WaveL.approxSine2)
                  <<<
                  Stereo.interleave
                  ^<<
                  sumNested
                     [fmModulator vel 1 depth1,
                      fmModulator vel 2 depth2,
                      fmModulator vel 3 depth3,
                      fmModulator vel 4 depth4]
                    &&& id
                  $*
                  stereoFrequenciesFromDetuneBendModulation (frequencyConst 5) 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 ->
         osc
            (sr,
             ((depth1,(depth2,(depth3,(depth4)))),
              (partial1,(partial2,(partial3,(partial4)))),
              (vel, (detune,fm,freq))))
            (env dec rel vcsize sr 0 dur))
      (CausalP.runStorableChunky $
       ParamS.withTuple2 $
         \((Control depth1, (Control depth2, (Control depth3, Control depth4))),
           (Control partial1,(Control  partial2, (Control partial3, Control partial4))),
           (Number vel, DetuneModulation fm)) ->

         (let partial ::
                 VectorValue -> Int -> VectorValue ->
                 LLVM.CodeGenFunction r VectorValue
              partial amp n t =
                 A.mul amp =<<
                 WaveL.partial WaveL.approxSine2 n t
          in  CausalP.envelopeStereo $>
                 (CausalP.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)
                        $<
                           (SigP.zip (piecewiseConstantVector partial1) $
                            SigP.zip (piecewiseConstantVector partial2) $
                            SigP.zip (piecewiseConstantVector partial3)
                                     (piecewiseConstantVector partial4)))
                  <<<
                  Stereo.interleave
                  ^<<
                  sumNested
                     [fmModulator vel 1 depth1,
                      fmModulator vel 2 depth2,
                      fmModulator vel 3 depth3,
                      fmModulator vel 4 depth4]
                    &&& id
                  $*
                  stereoFrequenciesFromDetuneBendModulation (frequencyConst 5) 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 ::
   Param p (PC.T Real) ->
   Param p (PC.T Real) ->
   Param p (PC.T Real) ->
   Param p Real ->
   CausalP p
      (Stereo.T VectorValue)
      (Stereo.T VectorValue)
resonantFMSynthProc reson index depth vel =
   F.withGuidedArgs (Stereo.cons F.atom F.atom) $ \stereoFreq ->
       let -- chan :: FuncP p inp VectorValue -> FuncP p inp VectorValue
           chan freq =
              CausalPS.osciSimple WaveL.approxSine2
              $&
              ((CausalP.envelope
                  $< SigP.envelope
                        (piecewiseConstantVector depth)
                        (SigPS.exponential2 (timeConst 1) (vel+1)))
               <<<
               UniFilter.lowpass
               ^<<
               CtrlPS.process
               $&
               (CausalP.zipWithSimple UniFilterL.parameter
                   <<<
                   CausalP.feedFst (piecewiseConstant reson)
                   <<<
                   (CausalP.envelope $< piecewiseConstant index)
                   <<<
                   CausalP.mapSimple Serial.subsample
                   $&
                   freq)
               &|&
               ((CausalPS.osciSimple 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 ->
         osc
            (sr, ((reson, index, depth), vel, (detune,fm,freq)))
            (env dec rel vcsize sr 0 dur))
      (CausalP.runStorableChunky $
       ParamS.withTuple2 $
       \((Control reson, Control index, Control depth),
         Number vel, DetuneModulation fm) ->
            CausalP.envelopeStereo $>
               (resonantFMSynthProc reson index depth vel $*
                stereoFrequenciesFromDetuneBendModulation (frequencyConst 5) fm))
      pingReleaseEnvelope


phaserOsci ::
   (Param.T p Real -> CausalP.T p a VectorValue) ->
   CausalP.T p 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 ->
         osc (sr, (det, (fm,freq))) (env att sr vel dur))
      (let det = control fst
           fm  = modulation snd
           osci ::
              Param.T (det,fm) Real ->
              CausalP.T (det,fm)
                 (VectorValue, VectorValue)
                 VectorValue
           osci d =
              (CausalPS.osciSimple WaveL.saw $< zero)
              <<<
              CausalP.envelope
              <<<
              first (one + CausalPS.amplify d)
       in  CausalP.runStorableChunky $
           (CausalP.envelopeStereo $>
              (phaserOsci osci
               <<<
               CausalP.feedFst (piecewiseConstantVector det)
               $* frequencyFromBendModulation (frequencyConst 5) 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 ->
         osc (sr, ((det, dist), (fm,freq))) (env att sr vel dur))
      (let det  = control (fst.fst)
           dist = control (snd.fst)
           fm   = modulation snd
           osci ::
              Param.T (mod,fm) Real ->
              CausalP.T (mod,fm)
                 (VectorValue,
                       {- wave shape parameter -}
                  (VectorValue, VectorValue)
                       {- detune, frequency modulation -})
                 VectorValue
           osci d =
              CausalPS.shapeModOsci wave
              <<<
              second
                 (CausalP.feedFst zero
                  <<<
                  CausalP.envelope
                  <<<
                  first (one + CausalPS.amplify d))
       in  CausalP.runStorableChunky $
           (CausalP.envelopeStereo $>
              (phaserOsci osci
               $< piecewiseConstantVector dist
               $< piecewiseConstantVector det
               $* frequencyFromBendModulation (frequencyConst 5) 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 ->
         osc (sr, ((det, depth, dist), (fm, freq))) (env att sr vel dur))
      (let det   = control (fst3.fst)
           depth = control (snd3.fst)
           dist  = control (thd3.fst)
           fm  = modulation snd
           osci ::
              Param.T (mod,fm) Real ->
              CausalP.T (mod,fm)
                 ((VectorValue, VectorValue)
                       {- phase modulation depth, modulator distortion -},
                  (VectorValue, VectorValue)
                       {- detune, frequency modulation -})
                 VectorValue
           osci d =
              CausalPS.osciSimple WaveL.approxSine2
              <<<
              (CausalP.envelope
               <<<
               second
                  (CausalPS.shapeModOsci WaveL.rationalApproxSine1
                     <<< second (CausalP.feedFst zero))
               <<^
               (\((dp, ds), f) -> (dp, (ds, f))))
               &&& arr snd
              <<<
              second
                 (CausalP.envelope <<<
                  first (one + CausalPS.amplify d))
       in  CausalP.runStorableChunky
              (CausalP.envelopeStereo <<<
                 (id &&&
                  (phaserOsci osci
                   <<<
                   CausalP.feedSnd
                      (SigP.zip
                         (piecewiseConstantVector det)
                         (frequencyFromBendModulation (frequencyConst 5) fm))
                   <<<
                   CausalP.feedSnd (piecewiseConstantVector dist)
                   <<<
                   (CausalP.envelope
                       $< piecewiseConstantVector depth)))))
      softStringReleaseEnvelope


stereoNoise :: SigP p (Stereo.T VectorValue)
stereoNoise =
   traverse
      (\uid -> SigPS.noise uid (noiseReference 20000))
      (Stereo.cons 13 14)

windCore ::
   Param p (PC.T Real) ->
   Param p (PC.T (BM.T Real)) ->
   SigP p (Stereo.T VectorValue)
windCore reson fm =
   CausalP.stereoFromMonoControlled CtrlPS.process
    $< Sig.zipWith
          (MoogL.parameter TypeNum.d8)
          (piecewiseConstant reson)
          (Sig.map Serial.subsample
             (frequencyFromBendModulation (frequencyConst 0.2) fm))
    $* stereoNoise

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 ->
         osc (sr, (reson, (fm,freq))) (env att sr vel dur))
      (let reson = control fst
           fm = modulation snd
       in  CausalP.runStorableChunky $
           (CausalP.envelopeStereo $> windCore reson fm))
      softStringReleaseEnvelope


fadeProcess ::
   (A.PseudoRing v, A.IntegerConstant v) =>
   CausalP.T p a v ->
   CausalP.T p a v ->
   CausalP.T p (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 ->
         osc (sr, ((phaserMix,phaserFreq), reson, (fm,freq))) (env att sr vel dur))
      (let phaserMix = control (fst.fst3)
           phaserFreq = frequencyControl (snd.fst3)
           reson = control snd3
           fm = modulation thd3
       in  CausalP.runStorableChunky $
           (CausalP.envelopeStereo $>
              ((CausalP.stereoFromMonoControlled
                   (fadeProcess (arr snd) CtrlPS.process
                    <<<
                    first (CausalP.mapSimple Serial.upsample)
                    <<^
                    (\((k,p),x) -> (k,(p,x))))
                  $< SigP.zip
                        (piecewiseConstant phaserMix)
                        (piecewiseConstant
                           (fmap (Allpass.flangerParameterPlain TypeNum.d8)
                               ^<< phaserFreq)))
               $*
               windCore reson fm)))
      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 ->
         osc
            (sr, ((bright, brightDecay), (detune,fm,freq)))
            (env dec rel vcsize sr vel dur))
      (CausalP.runStorableChunky
         (let bright    = frequency (fst.fst)
              brightDec = time (snd.fst)
              fm = detuneModulation snd
          in  CausalP.envelopeStereo $>
              (CausalP.stereoFromMono
                  (UniFilter.lowpass
                   ^<<
                   (CtrlPS.processCtrlRate $# (100::Real))
                      (\k -> Sig.map
                          (UniFilterL.parameter (LLVM.valueOf 10))
                          {- bound control in order to avoid too low resonant frequency,
                             which makes the filter instable -}
                          (SigP.exponentialBounded2
                              (frequencyConst 100)
                              (brightDec/k)
                              (bright)))
                   <<<
                   CausalPS.osciSimple WaveL.saw $< zero)
               $* stereoFrequenciesFromDetuneBendModulation (frequencyConst 10) 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
                (attack (chunkSizesFromLazyTime attackDur)
                    (sr,
                     (attackHalfLife,
                      attackPeak * amp / (1 - 2^?(-attackTime/attackHalfLife))))
                 `SigSt.append`
                 decay (chunkSizesFromLazyTime decayDur)
                    (sr,
                     (decayHalfLife,
                      ((attackPeak-1)*amp, amp))))
                (\x -> release vcsize (sr,(releaseHalfLife,x))))
      (SigP.runChunkyPattern $
       let halfLife  = time fst
           amplitude = number snd
       in  SigPS.constant amplitude -
           SigPS.exponential2 halfLife amplitude)
      (SigP.runChunkyPattern $
       let halfLife   = time fst
           amplitude  = number (fst.snd)
           saturation = number (snd.snd)
       in  SigPS.constant saturation +
           SigPS.exponential2 halfLife amplitude)
      (SigP.runChunky $
       let releaseTime = vectorTime fst * 5
           releaseHL   = time fst
           amplitude   = number snd
       in  CausalP.take (round ^<< 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 ->
         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 det  = control (fst.fst3)
           dist = control (snd.fst3)
           fm   = modulation snd3
           emph = signal thd3
           osci ::
              Param.T p Real ->
              CausalP.T p
                 (VectorValue,
                       {- wave shrink/replication factor -}
                  (VectorValue, VectorValue)
                       {- detune, frequency modulation -})
                 VectorValue
           osci d =
              CausalPS.shapeModOsci WaveL.rationalApproxSine1
              <<<
              second
                 (CausalP.feedFst zero
                  <<<
                  CausalP.envelope
                  <<<
                  first (one + CausalPS.amplify d))
       in  CausalP.runStorableChunky $
           (CausalP.envelopeStereo $>
              (phaserOsci osci
               <<<
               CausalP.feedFst (piecewiseConstantVector dist)
               <<<
               CausalP.feedSnd (frequencyFromBendModulation (frequencyConst 5) fm)
               <<<
               (CausalP.envelope $< piecewiseConstantVector det)
               $*
               SigP.fromStorableVectorLazy 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 =
                freqMod
                   (chunkSizesFromLazyTime (PC.duration fm))
                   (sr, (fm, freq * Sample.period pos)) :: SigSt.T Vector
             pos = Sample.positions smp
             amp = 2 * amplitudeFromVelocity vel
             (attack, sustain, release) = Sample.parts smp
         in  (\cont -> osc cont
                (sr,
                 (amp,
                  attack `SigSt.append`
                  SVL.cycle (SigSt.take (Sample.loopLength pos) sustain),
                  chunkSizesFromLazyTime dur))
                fmSig)
             (osc (const SigSt.empty)
                (sr, (amp, release, NonNegChunky.fromChunks (repeat 1000)))))
      (CausalP.runStorableChunkyCont
         (let amp = number fst3
              smp = signal snd3
              dur = parameter thd3
          in  CausalPS.amplifyStereo amp
              <<<
              CausalP.stereoFromMono
                 (CausalPS.pack
                    (CausalP.frequencyModulationLinear
                       (SigP.fromStorableVectorLazy smp)))
              <<<
              liftA2 Stereo.cons
                 (CausalPS.amplify 0.999)
                 (CausalPS.amplify 1.001)
              <<<
              arr fst
              <<<
              CausalP.feedSnd (SigP.lazySize dur)))
      (SigP.runChunkyPattern
         (frequencyFromBendModulation (frequencyConst 3) (modulation id)))


_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) =
                SVP.splitAt (chunkSizesFromLazyTime dur) $
                (freqMod
                   (chunkSizesFromLazyTime (PC.duration fm))
                   (sr, (fm, freq * Sample.period pos)) :: SigSt.T Vector)
             pos = Sample.positions smp
             amp = 2 * amplitudeFromVelocity vel
             (attack, sustain, release) = Sample.parts smp
         in  osc
                (sr,
                 (amp,
                  attack `SigSt.append`
                  SVL.cycle (SigSt.take (Sample.loopLength pos) sustain)))
                sustainFM
             `SigSt.append`
             osc (sr, (amp,release)) releaseFM)
      (CausalP.runStorableChunky
         (let smp = signal snd
              amp = number fst
          in  CausalPS.amplifyStereo amp
              <<<
              CausalP.stereoFromMono
                 (CausalPS.pack
                    (CausalP.frequencyModulationLinear
                       (SigP.fromStorableVectorLazy smp)))
              <<<
              liftA2 Stereo.cons
                 (CausalPS.amplify 0.999)
                 (CausalPS.amplify 1.001)))
      (SigP.runChunkyPattern
         (frequencyFromBendModulation (frequencyConst 3) (modulation id)))