{-# LANGUAGE Rank2Types #-}
module Synthesizer.LLVM.Server.Packed.Instrument where

import Synthesizer.LLVM.Server.Common

import qualified Synthesizer.EventList.ALSA.MIDI as Ev
import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC

import qualified Synthesizer.LLVM.Frame.Stereo as Stereo

import qualified Sound.Sox.Read          as SoxRead
import qualified Sound.Sox.Option.Format as SoxOption

import Synthesizer.Storable.ALSA.MIDI (Instrument, chunkSizesFromLazyTime, )

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.ALSA.MIDI as MIDIL
import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS
import qualified Synthesizer.LLVM.CausalParameterized.ControlledPacked as CtrlPS
import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS
import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP
import qualified Synthesizer.LLVM.Parameterized.Signal as SigP
import qualified Synthesizer.LLVM.Storable.Signal as SigStL
import qualified Synthesizer.LLVM.Sample as Sample
import qualified Synthesizer.LLVM.Wave as WaveL
import qualified Synthesizer.LLVM.Parameter as Param
import Synthesizer.LLVM.CausalParameterized.Process (($<), ($>), ($*), )
import Synthesizer.LLVM.Parameterized.Signal (($#), )

import qualified LLVM.Extra.ScalarOrVector as SoV
import qualified LLVM.Extra.Monad as LM
import qualified LLVM.Extra.Arithmetic as A
import qualified LLVM.Core as LLVM
import qualified Data.TypeLevel.Num as TypeNum

import Control.Arrow.Monad ((=<<<), listen, )
import qualified Data.HList as HL

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 Control.Arrow ((<<<), (^<<), (<<^), (&&&), (***), arr, first, second, )
import Control.Applicative (liftA2, liftA3, )

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

import Data.Int (Int32, )

{-
import qualified Numeric.NonNegative.Class   as NonNeg
import qualified Numeric.NonNegative.Wrapper as NonNegW
-}
import qualified Numeric.NonNegative.Chunky as NonNegChunky

import qualified Algebra.RealRing as RealRing
import qualified Algebra.Additive  as Additive

import NumericPrelude.Numeric (zero, round, (^?), )
import Prelude hiding (Real, round, break, )



type Vector = LLVM.Vector VectorSize Real
type VectorSize = TypeNum.D4


vectorSize :: Int
vectorSize = TypeNum.toInt (undefined :: VectorSize)

vectorChunkSize :: SVL.ChunkSize
vectorChunkSize =
   let (SVL.ChunkSize size) = chunkSize
   in  SVL.ChunkSize (div size vectorSize)

vectorRate :: Fractional a => a
vectorRate = sampleRate / fromIntegral vectorSize


frequencyFromBendModulation ::
{-
   (Storable a,
    LLVM.MakeValueTuple a (Value a)) =>
-}
   Param.T p Real ->
   Param.T p (PC.T (PC.BendModulation Real), Real) ->
   SigP.T p (LLVM.Value Vector)
frequencyFromBendModulation speed fmFreq =
   MIDIL.frequencyFromBendModulationPacked (speed/sampleRate)
      $* piecewiseConstant
            (fmap (\(fm,freq) -> transposeModulation freq fm) fmFreq)

stereoFrequenciesFromDetuneBendModulation ::
   Param.T p Real ->
   Param.T p (PC.T Real, PC.T (PC.BendModulation Real), Real) ->
   SigP.T p (Stereo.T (LLVM.Value Vector))
stereoFrequenciesFromDetuneBendModulation speed detFmFreq =
   (CausalP.envelopeStereo
      $< frequencyFromBendModulation speed
           (fmap (\(_det,fm,freq) -> (fm,freq)) detFmFreq))
   <<<
   CausalP.zipWithSimple Sample.zipStereo
   <<<
   CausalPS.raise 1 &&&
   (CausalPS.raise 1 <<< CausalP.mapSimple LLVM.neg)
   $* piecewiseConstantVector
         (fmap (\(det,_fm,_freq) -> det) detFmFreq)


pingReleaseEnvelope ::
   IO (Real -> Real -> Real -> Ev.LazyTime -> SigSt.T Vector)
pingReleaseEnvelope =
   liftA2
      (\pressed release decay rel vel dur ->
         SigStL.continuePacked
            (pressed (chunkSizesFromLazyTime dur) (decay,vel))
            (\x -> release vectorChunkSize (rel,x)))
      (SigP.runChunkyPattern $
       let decay = arr fst
           velocity = arr snd
       in  SigPS.exponential2 (decay*sampleRate)
              (amplitudeFromVelocity ^<< velocity))
      (SigP.runChunky $
       let release = arr fst
           amplitude = arr snd
       in  (CausalP.take (round ^<< (release*5*vectorRate)) $*
            SigPS.exponential2 (release*sampleRate) amplitude))

pingRelease ::
   IO (Real -> Real -> Instrument Real Vector)
pingRelease =
   liftA2
      (\osc env dec rel vel freq dur ->
         osc freq (env dec rel vel dur))
      (CausalP.runStorableChunky
         (let freq = arr id
          in  CausalP.envelope $>
              SigPS.osciSimple WaveL.saw zero (freq/sampleRate)))
      pingReleaseEnvelope

pingStereoRelease ::
   IO (Real -> Real -> Instrument Real (Stereo.T Vector))
pingStereoRelease =
   liftA2
      (\osc env dec rel vel freq dur ->
         osc freq (env dec rel vel dur))
      (CausalP.runStorableChunky
         (let freq = arr id
          in  CausalP.envelopeStereo $>
              SigP.zipWithSimple Sample.zipStereo
                 (SigPS.osciSimple WaveL.saw zero
                     (0.999*freq/sampleRate))
                 (SigPS.osciSimple WaveL.saw zero
                     (1.001*freq/sampleRate))))
      pingReleaseEnvelope

pingStereoReleaseFM ::
   IO (Real -> Real ->
       PC.T Real ->
       PC.T Real ->
       Real -> Real ->
       PC.T (PC.BendModulation Real) ->
       Instrument Real (Stereo.T Vector))
pingStereoReleaseFM =
   liftA2
      (\osc env dec rel detune shape phase phaseDecay fm vel freq dur ->
         osc
            ((phase, phaseDecay), shape, (detune,fm,freq))
            (env dec rel vel dur))
      (CausalP.runStorableChunky
         (let phs = arr (fst.fst3)
              dec = arr (snd.fst3)
              shp = arr snd3
              fm  = arr thd3
          in  CausalP.envelopeStereo $>
              ((CausalP.stereoFromMonoControlled
                  (CausalPS.shapeModOsci WaveL.rationalApproxSine1)
                    $< piecewiseConstantVector shp)
                  <<^ Stereo.interleave
                $< (CausalP.zipWithSimple Sample.zipStereo
                    <<<
                    arr id &&& CausalP.mapSimple LLVM.neg
                     $* SigPS.exponential2 (dec*sampleRate) phs)
                $* stereoFrequenciesFromDetuneBendModulation 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 ->
       PC.T (PC.BendModulation Real) ->
       Instrument Real (Stereo.T Vector))
squareStereoReleaseFM =
   liftA2
      (\osc env dec rel detune shape phase fm vel freq dur ->
         osc
            ((phase, shape), (detune,fm,freq))
            (env dec rel vel dur))
      (CausalP.runStorableChunky
         (let phs = arr (fst.fst)
              shp = arr (snd.fst)
              fm  = arr snd
              chanOsci =
                 CausalP.mix
                 <<<
                 (CausalPS.shapeModOsci WaveL.rationalApproxSine1
                  <<<
                  second (first (CausalP.mapSimple LLVM.neg)))
                 &&&
                 (CausalP.mapSimple LLVM.neg
                  <<<
                  CausalPS.shapeModOsci WaveL.rationalApproxSine1)
                 <<^
                 (\((p,s),f) -> (s,(p,f)))
          in  CausalP.envelopeStereo $>
              ((CausalP.stereoFromMonoControlled chanOsci
                   $< SigP.zip
                         (piecewiseConstantVector phs)
                         (piecewiseConstantVector shp))
                $* stereoFrequenciesFromDetuneBendModulation 10 fm)))
      pingReleaseEnvelope

bellStereoFM ::
   IO (Real -> Real ->
       PC.T Real ->
       PC.T (PC.BendModulation Real) ->
       Instrument Real (Stereo.T Vector))
bellStereoFM =
   liftA2
      (\osc env dec rel detune fm vel freq dur ->
         osc ((detune, fm, freq), vel,
              (env (dec/4) rel vel dur,
               env (dec/7) rel vel dur))
             (env dec rel vel dur))
      (CausalP.runStorableChunky
         (let fm   = arr fst3
              vel  = arr snd3
              env4 = arr (fst.thd3)
              env7 = arr (snd.thd3)
              mix x y = CausalP.mixStereo <<< x&&&y
              osci sel v d =
                 CausalP.envelopeStereo
                 <<<
                 (arr sel ***
                    (CausalPS.amplifyStereo v
                     <<<
                     CausalP.stereoFromMono
                        (CausalPS.osciSimple WaveL.approxSine4
                           $< SigPS.constant zero)
                     <<<
                     CausalPS.amplifyStereo d))
          in  (osci fst3  0.6              1 `mix`
               osci snd3 (0.02 *  50^?vel) 4 `mix`
               osci thd3 (0.02 * 100^?vel) 7)
              <<<
              CausalP.feedSnd (stereoFrequenciesFromDetuneBendModulation 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 ->
       PC.T (PC.BendModulation Real) ->
       Instrument Real (Stereo.T Vector))
bellNoiseStereoFM =
   liftA2
      (\osc env dec rel noiseAmp noiseReson fm vel freq dur ->
         osc ((fm, freq),
              (noiseAmp,noiseReson),
              (vel,
               env (dec/4) rel vel dur,
               env (dec/7) rel vel dur))
             (env dec rel vel dur))
      (CausalP.runStorableChunky
         (let fm   = arr fst3
              noiseAmp   = arr (fst.snd3)
              noiseReson = arr (snd.snd3)
              vel  = arr (fst3.thd3)
              env4 = arr (snd3.thd3)
              env7 = arr (thd3.thd3)
              mix x y = CausalP.mix <<< x&&&y
              osci sel v d =
                 CausalP.envelope
                 <<<
                 (arr sel ***
                    (CausalPS.amplify v
                     <<<
                     (CausalPS.osciSimple WaveL.approxSine4
                        $< SigPS.constant zero)
                     <<<
                     CausalPS.amplify d))
              noise sel d =
                 (CausalP.envelope $<
                    piecewiseConstantVector noiseAmp)
                 <<<
                 CausalP.envelope
                 <<<
                 (arr sel ***
                    ({- UniFilter.lowpass
                        ^<< -}
                     (CtrlPS.process
                        $> SigPS.noise 12 (sampleRate/20000))
                     <<<
--                     CausalP.zipWithSimple UniFilterL.parameter
                     CausalP.zipWithSimple (MoogL.parameter TypeNum.d8)
{-
FIXME:
This leads to a run-time crash even without LLVM optimizations.
However, I cannot reproduce this in the Test module.
                     (CausalP.quantizeLift $# (1 :: Real)) (arr id)

                     (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 Sample.subsampleVector
                     <<<
                     CausalPS.amplify d))
          in  CausalP.zipWithSimple Sample.zipStereo
              <<<
              (osci fst3  0.6              (1*0.999) `mix`
               osci snd3 (0.02 *  50^?vel) (4*0.999) `mix`
               osci thd3 (0.02 * 100^?vel) (7*0.999) `mix`
               noise fst3 0.999) &&&
              (osci fst3  0.6              (1*1.001) `mix`
               osci snd3 (0.02 *  50^?vel) (4*1.001) `mix`
               osci thd3 (0.02 * 100^?vel) (7*1.001) `mix`
               noise fst3 1.001)
              <<<
              CausalP.feedSnd (frequencyFromBendModulation 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 -> Instrument Real Vector)
tine =
   liftA2
      (\osc env dec rel vel freq dur ->
         osc (vel,freq) (env dec rel 0 dur))
      (CausalP.runStorableChunky
         (let freq = arr snd
              vel  = arr fst
          in  CausalP.envelope $>
                 (CausalPS.osciSimple WaveL.approxSine2
                    $> (SigPS.constant (freq/sampleRate))
                    $* (CausalP.envelope
                          $< SigPS.exponential2 (1*sampleRate) (vel+1)
                          $* SigPS.osciSimple WaveL.approxSine2 zero
                                (2*freq/sampleRate)))))
      pingReleaseEnvelope

tineStereo :: IO (Real -> Real -> Instrument Real (Stereo.T Vector))
tineStereo =
   liftA2
      (\osc env dec rel vel freq dur ->
         osc (vel,freq) (env dec rel 0 dur))
      (CausalP.runStorableChunky
         (let freq = arr snd
              vel  = arr fst
              chanOsci d =
                 CausalPS.osciSimple WaveL.approxSine2
                    $> SigPS.constant (freq*d/sampleRate)
          in  CausalP.envelopeStereo $>
                 ((CausalP.zipWithSimple Sample.zipStereo <<<
                    (chanOsci 0.995 &&& chanOsci 1.005))
                  $* SigP.envelope
                        (SigPS.exponential2 (1*sampleRate) (vel+1))
                        (SigPS.osciSimple WaveL.approxSine2 zero
                           (2*freq/sampleRate)))))
      pingReleaseEnvelope


softStringReleaseEnvelope ::
   IO (Real -> Real -> Ev.LazyTime -> SigSt.T Vector)
softStringReleaseEnvelope =
   liftA2
      (\rev env attackTime vel dur ->
         let attackTimeVector =
                div (round (attackTime*sampleRate)) vectorSize
             amp = amplitudeFromVelocity vel
             {-
             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) (amp, attackTimeVector)
             release = rev attack
         in  attack `SigSt.append` sustain `SigSt.append` release)
      SigStL.makeReversePacked
      (let amp = arr fst
           attackTimeVector = arr snd
       in  SigP.runChunkyPattern $
           flip SigP.append (SigPS.constant amp) $
           (CausalPS.amplify amp <<<
            CausalP.take attackTimeVector
            $* SigPS.parabolaFadeInInf
                  (fmap fromIntegral attackTimeVector *
                   fromIntegral vectorSize)))

softString :: IO (Instrument Real (Stereo.T Vector))
softString =
   liftA2
      (\osc env vel freq dur ->
         osc freq (env 1 vel dur))
      (let freq = arr id
           osci d =
              SigPS.osciSimple WaveL.saw zero (d * freq / sampleRate)
       in  CausalP.runStorableChunky $
           (CausalP.envelopeStereo $>
              (SigP.zipWithSimple Sample.zipStereo
                 (SigP.mix
                    (osci 1.005)
                    (osci 0.998))
                 (SigP.mix
                    (osci 1.002)
                    (osci 0.995)))))
      softStringReleaseEnvelope


softStringFM ::
   IO (PC.T (PC.BendModulation Real) ->
       Instrument Real (Stereo.T Vector))
softStringFM =
   liftA2
      (\osc env fm vel freq dur ->
         osc (fm,freq) (env 1 vel dur))
      (let fm = arr id
           osci ::
              Param.T fm Real ->
              CausalP.T fm (LLVM.Value Vector) (LLVM.Value Vector)
           osci d =
              (CausalPS.osciSimple WaveL.saw $<
                  (SigPS.constant $# (zero::Real))) <<<
              CausalPS.amplify d
       in  CausalP.runStorableChunky $
           (CausalP.envelopeStereo $>
              (CausalP.zipWithSimple Sample.zipStereo
               <<<
               (CausalP.mix  <<<  osci 1.005 &&& osci 0.998) &&&
               (CausalP.mix  <<<  osci 1.002 &&& osci 0.995)
               $* frequencyFromBendModulation 5 fm)))
      softStringReleaseEnvelope


tineStereoFM ::
   IO (Real -> Real ->
       PC.T (PC.BendModulation Real) ->
       Instrument Real (Stereo.T Vector))
tineStereoFM =
   liftA2
      (\osc env dec rel fm vel freq dur ->
         osc (vel,(fm,freq)) (env dec rel 0 dur))
      (CausalP.runStorableChunky
         (let vel  = arr fst
              fm   = arr snd
              chanOsci d =
                 CausalPS.osciSimple WaveL.approxSine2
                    <<< second (CausalPS.amplify d)
          in  CausalP.envelopeStereo $>
                 ((CausalP.zipWithSimple Sample.zipStereo <<<
                    chanOsci 0.995 &&& chanOsci 1.005)
                  <<<
                  (((CausalP.envelope
                       $< SigPS.exponential2 (1*sampleRate) (vel+1))
                     <<< (CausalPS.osciSimple WaveL.approxSine2
                             $< (SigPS.constant $# (zero::Real)))
                     <<< CausalPS.amplify 2)
                   &&& arr id)
                  $* frequencyFromBendModulation 5 fm)))
      pingReleaseEnvelope


tineControlledProc, tineControlledFnProc ::
   Param.T p (PC.T Real) ->
   Param.T p (PC.T Real) ->
   Param.T p Real ->
   CausalP.T p
      (Stereo.T (LLVM.Value Vector))
      (Stereo.T (LLVM.Value Vector))
tineControlledProc index depth vel =
   CausalP.stereoFromMono
      (CausalPS.osciSimple WaveL.approxSine2)
   <<<
   Stereo.interleave
   ^<<
   ((CausalP.envelopeStereo
       $< SigP.envelope
             (piecewiseConstantVector depth)
             (SigPS.exponential2 (1*sampleRate) (vel+1)))
    <<<
    CausalP.stereoFromMono
       (CausalPS.osciSimple WaveL.approxSine2
          $< (SigPS.constant $# (zero::Real)))
    <<<
    (CausalP.envelopeStereo
       $< piecewiseConstantVector index))
            &&& arr id

tineControlledFnProc index depth vel =
   ((\freq ->
        CausalP.stereoFromMono
           (CausalPS.osciSimple WaveL.approxSine2)
        <<<
        Stereo.interleave
        ^<<
         ((CausalP.envelopeStereo
             $< SigP.envelope
                   (piecewiseConstantVector depth)
                   (SigPS.exponential2 (1*sampleRate) (vel+1)))
          <<<
          CausalP.stereoFromMono
             (CausalPS.osciSimple WaveL.approxSine2
                $< (SigPS.constant $# (zero::Real)))
          <<<
          (CausalP.envelopeStereo
             $< piecewiseConstantVector index)
          <<<
          listen freq)
         &&&
         listen freq)
--    =<<< listen HL.hNil
    =<<< arr HL.hHead)
   <<< arr (\freq -> HL.hCons freq HL.hNil)

tineControlledFM ::
   IO (Real -> Real ->
       PC.T Real ->
       PC.T Real -> PC.T Real ->
       PC.T (PC.BendModulation Real) ->
       Instrument Real (Stereo.T Vector))
tineControlledFM =
   liftA2
      (\osc env dec rel detune index depth fm vel freq dur ->
         osc
            ((index, depth), vel, (detune,fm,freq))
            (env dec rel 0 dur))
      (CausalP.runStorableChunky
         (let index = arr (fst.fst3)
              depth = arr (snd.fst3)
              vel   = arr snd3
              fm    = arr thd3
          in  CausalP.envelopeStereo $>
                 (tineControlledFnProc index depth vel $*
                  stereoFrequenciesFromDetuneBendModulation 5 fm)))
      pingReleaseEnvelope


fenderProc ::
   Param.T p (PC.T Real) ->
   Param.T p (PC.T Real) ->
   Param.T p (PC.T Real) ->
   Param.T p Real ->
   CausalP.T p
      (Stereo.T (LLVM.Value Vector))
      (Stereo.T (LLVM.Value Vector))
fenderProc fade index depth vel =
   ((\stereoFreq ->
       let channel_n_1 freq =
              CausalPS.osciSimple WaveL.approxSine2
              <<<
              ((CausalP.envelope
                  $< SigP.envelope
                        (piecewiseConstantVector depth)
                        (SigPS.exponential2 (1*sampleRate) (vel+1)))
               <<<
               (CausalPS.osciSimple WaveL.approxSine2
                  $< (SigPS.constant $# (zero::Real)))
               <<<
               (CausalP.envelope
                  $< piecewiseConstantVector index)
               <<<
               freq)
              &&&
              freq
           channel_1_2 freq =
              CausalPS.osciSimple WaveL.approxSine2
              <<<
              ((CausalP.envelope
                  $< SigP.envelope
                        (piecewiseConstantVector depth)
                        (SigPS.exponential2 (1*sampleRate) (vel+1)))
               <<<
               (CausalPS.osciSimple WaveL.approxSine2
                  $< (SigPS.constant $# (zero::Real)))
               <<<
               freq)
              &&&
              (CausalPS.amplify 2 <<< freq)
       in  (CausalP.stereoFromMonoControlled
              (fadeProcess
                 (channel_n_1 (arr id))
                 (channel_1_2 (arr id)))
              $< piecewiseConstantVector fade)
           <<<
           listen stereoFreq)
    =<<< arr HL.hHead)
   <<< arr (\freq -> HL.hCons freq HL.hNil)

fenderFM ::
   IO (Real -> Real ->
       PC.T Real ->
       PC.T Real -> PC.T Real -> PC.T Real ->
       PC.T (PC.BendModulation Real) ->
       Instrument Real (Stereo.T Vector))
fenderFM =
   liftA2
      (\osc env dec rel detune index depth fade fm vel freq dur ->
         osc
            (((index, depth), fade), vel, (detune,fm,freq))
            (env dec rel 0 dur))
      (CausalP.runStorableChunky
         (let index = arr (fst.fst.fst3)
              depth = arr (snd.fst.fst3)
              fade  = arr (snd.fst3)
              vel   = arr snd3
              fm    = arr thd3
          in  CausalP.envelopeStereo $>
                 (fenderProc fade index depth vel $*
                  stereoFrequenciesFromDetuneBendModulation 5 fm)))
      pingReleaseEnvelope


tineModulatorBankFM ::
   IO (Real -> Real ->
       PC.T Real ->
       PC.T Real -> PC.T Real -> PC.T Real -> PC.T Real ->
       PC.T (PC.BendModulation Real) ->
       Instrument Real (Stereo.T Vector))
tineModulatorBankFM =
   liftA2
      (\osc env
            dec rel detune
            depth1 depth2 depth3 depth4
            fm vel freq dur ->
         osc
            ((depth1,(depth2,(depth3,(depth4,())))), vel, (detune,fm,freq))
            (env dec rel 0 dur))
      (CausalP.runStorableChunky
         (let depth1 = arr (fst.fst3)
              depth2 = arr (fst.snd.fst3)
              depth3 = arr (fst.snd.snd.fst3)
              depth4 = arr (fst.snd.snd.snd.fst3)
              vel = arr snd3
              fm  = arr thd3
              mix x y = CausalP.mixStereo <<< x&&&y
              modulator n depth =
                 (CausalP.envelopeStereo
                    $< SigP.envelope
                          (piecewiseConstantVector depth)
                          (SigPS.exponential2 (1*sampleRate) (vel+1)))
                 <<<
                 CausalP.stereoFromMono
                    (CausalPS.osciSimple WaveL.approxSine2
                       $< (SigPS.constant $# (zero::Real)))
                 <<<
                 CausalP.amplifyStereo n
          in  CausalP.envelopeStereo $>
                 (CausalP.stereoFromMono
                     (CausalPS.osciSimple WaveL.approxSine2)
                  <<<
                  Stereo.interleave
                  ^<<
                  (modulator 1 depth1 `mix`
                   modulator 2 depth2 `mix`
                   modulator 3 depth3 `mix`
                   modulator 4 depth4)
                      &&& arr id
                  $*
                  stereoFrequenciesFromDetuneBendModulation 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 ->
       PC.T (PC.BendModulation Real) ->
       Instrument Real (Stereo.T Vector))
tineBankFM =
   liftA2
      (\osc env
            dec rel detune
            depth1 depth2 depth3 depth4
            partial1 partial2 partial3 partial4
            fm vel freq dur ->
         osc
            ((depth1,(depth2,(depth3,(depth4,())))),
             (partial1,(partial2,(partial3,(partial4,())))),
             (vel, (detune,fm,freq)))
            (env dec rel 0 dur))
      (CausalP.runStorableChunky
         (let depth1 = arr (fst.fst3)
              depth2 = arr (fst.snd.fst3)
              depth3 = arr (fst.snd.snd.fst3)
              depth4 = arr (fst.snd.snd.snd.fst3)
              partial1 = arr (fst.snd3)
              partial2 = arr (fst.snd.snd3)
              partial3 = arr (fst.snd.snd.snd3)
              partial4 = arr (fst.snd.snd.snd.snd3)
              vel = arr (fst.thd3)
              fm  = arr (snd.thd3)
              mixStereo x y = CausalP.mixStereo <<< x&&&y
              modulator n depth =
                 (CausalP.envelopeStereo
                    $< SigP.envelope
                          (piecewiseConstantVector depth)
                          (SigPS.exponential2 (1*sampleRate) (vel+1)))
                 <<<
                 CausalP.stereoFromMono
                    (CausalPS.osciSimple WaveL.approxSine2
                       $< (SigPS.constant $# (zero::Real)))
                 <<<
                 CausalP.amplifyStereo n
              partial ::
                 LLVM.Value Vector -> Int32 -> LLVM.Value Vector ->
                 LLVM.CodeGenFunction r (LLVM.Value Vector)
              partial amp n t =
                 A.mul amp =<<
                 WaveL.partial WaveL.approxSine2 (LLVM.valueOf 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
                  ^<<
                  (modulator 1 depth1 `mixStereo`
                   modulator 2 depth2 `mixStereo`
                   modulator 3 depth3 `mixStereo`
                   modulator 4 depth4)
                      &&& arr id
                  $*
                  stereoFrequenciesFromDetuneBendModulation 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.T p (PC.T Real) ->
   Param.T p (PC.T Real) ->
   Param.T p (PC.T Real) ->
   Param.T p Real ->
   CausalP.T p
      (Stereo.T (LLVM.Value Vector))
      (Stereo.T (LLVM.Value Vector))
resonantFMSynthProc reson index depth vel =
   ((\stereoFreq ->
       let chan freq =
              CausalPS.osciSimple WaveL.approxSine2
              <<<
              ((CausalP.envelope
                  $< SigP.envelope
                        (piecewiseConstantVector depth)
                        (SigPS.exponential2 (1*sampleRate) (vel+1)))
               <<<
               UniFilter.lowpass
               ^<<
               CtrlPS.process
               <<<
               (CausalP.zipWithSimple UniFilterL.parameter
                   <<<
                   CausalP.feedFst (piecewiseConstant reson)
                   <<<
                   (CausalP.envelope $< piecewiseConstant index)
                   <<<
                   CausalP.mapSimple Sample.subsampleVector
                   <<<
                   freq)
               &&&
               ((CausalPS.osciSimple WaveL.saw
                   $< (SigPS.constant $# (zero::Real)))
                <<<
                freq))
              &&&
              freq
       in  CausalP.stereoFromMono (chan (arr id))
           <<<
           listen stereoFreq)
    =<<< arr HL.hHead)
   <<< arr (\freq -> HL.hCons freq HL.hNil)

resonantFMSynth ::
   IO (Real -> Real ->
       PC.T Real ->
       PC.T Real -> PC.T Real -> PC.T Real ->
       PC.T (PC.BendModulation Real) ->
       Instrument Real (Stereo.T Vector))
resonantFMSynth =
   liftA2
      (\osc env dec rel detune reson index depth fm vel freq dur ->
         osc
            ((reson, index, depth), vel, (detune,fm,freq))
            (env dec rel 0 dur))
      (CausalP.runStorableChunky
         (let reson = arr (fst3.fst3)
              index = arr (snd3.fst3)
              depth = arr (thd3.fst3)
              vel   = arr snd3
              fm    = arr thd3
          in  CausalP.envelopeStereo $>
                 (resonantFMSynthProc reson index depth vel $*
                  stereoFrequenciesFromDetuneBendModulation 5 fm)))
      pingReleaseEnvelope


piecewiseConstantVector ::
   Param.T p (PC.T Real) -> SigP.T p (LLVM.Value Vector)
{-
   (Storable a,
    LLVM.MakeValueTuple a al,
    Rep.Memory al am,
    LLVM.IsSized am as) =>
   Param.T p (PC.T a) -> SigP.T p (LLVM.Vector n al)
-}
piecewiseConstantVector pc =
   SigP.mapSimple SoV.replicate $
   piecewiseConstant pc


softStringDetuneFM ::
   IO (Real ->
       PC.T Real ->
       PC.T (PC.BendModulation Real) ->
       Instrument Real (Stereo.T Vector))
softStringDetuneFM =
   liftA2
      (\osc env att det fm vel freq dur ->
         osc (det, (fm,freq)) (env att vel dur))
      (let det = arr fst
           fm  = arr snd
           mix x y = CausalP.mix <<< x&&&y
           osci ::
              Param.T (det,fm) Real ->
              CausalP.T (det,fm)
                 (LLVM.Value Vector, LLVM.Value Vector)
                 (LLVM.Value Vector)
           osci d =
              (CausalPS.osciSimple WaveL.saw $<
                  (SigPS.constant $# (zero::Real)))
              <<<
              CausalP.envelope
              <<<
              first (CausalPS.raise 1 <<< CausalPS.amplify d)
       in  CausalP.runStorableChunky $
           (CausalP.envelopeStereo $>
              (CausalPS.amplifyStereo 0.25
               <<<
               CausalP.zipWithSimple Sample.zipStereo
               <<<
               ((osci 1.0 `mix` osci (-0.4)) `mix`
                (osci 0.5 `mix` osci (-0.7))) &&&
               ((osci 0.4 `mix` osci (-1.0)) `mix`
                (osci 0.7 `mix` osci (-0.5)))
               <<<
               CausalP.feedFst (piecewiseConstantVector det)
               $* frequencyFromBendModulation 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 (PC.BendModulation 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.
    LLVM.Value Vector ->
    LLVM.CodeGenFunction r (LLVM.Value Vector)) ->
   IO (Real ->
       PC.T Real ->
       PC.T Real ->
       PC.T (PC.BendModulation Real) ->
       Instrument Real (Stereo.T Vector))
arcStringStereoFM wave =
   softStringShapeCore
      (\k p ->
         LM.liftR2 Sample.amplifyMono
            (WaveL.approxSine4 =<< WaveL.halfEnvelope p)
            (wave =<< WaveL.replicate k p))

softStringShapeCore ::
   (forall r.
    LLVM.Value Vector ->
    LLVM.Value Vector ->
    LLVM.CodeGenFunction r (LLVM.Value Vector)) ->
   IO (Real ->
       PC.T Real ->
       PC.T Real ->
       PC.T (PC.BendModulation Real) ->
       Instrument Real (Stereo.T Vector))
softStringShapeCore wave =
   liftA2
      (\osc env att det dist fm vel freq dur ->
         osc ((det, dist), (fm,freq)) (env att vel dur))
      (let det  = arr (fst.fst)
           dist = arr (snd.fst)
           fm   = arr snd
           mix x y = CausalP.mix <<< x&&&y
           osci ::
              Param.T (mod,fm) Real ->
              CausalP.T (mod,fm)
                 (LLVM.Value Vector,
                       {- wave shape parameter -}
                  (LLVM.Value Vector, LLVM.Value Vector)
                       {- detune, frequency modulation -})
                 (LLVM.Value Vector)
           osci d =
              CausalPS.shapeModOsci wave
              <<<
              second
                 (CausalP.feedFst (SigPS.constant $# (zero::Real))
                  <<<
                  CausalP.envelope
                  <<<
                  first (CausalPS.raise 1 <<< CausalPS.amplify d))
       in  CausalP.runStorableChunky $
           (CausalP.envelopeStereo $>
              (CausalPS.amplifyStereo 0.25
               <<<
               CausalP.zipWithSimple Sample.zipStereo
               <<<
               ((osci 1.0 `mix` osci (-0.4)) `mix`
                (osci 0.5 `mix` osci (-0.7))) &&&
               ((osci 0.4 `mix` osci (-1.0)) `mix`
                (osci 0.7 `mix` osci (-0.5)))
               $< piecewiseConstantVector dist
               $< piecewiseConstantVector det
               $* frequencyFromBendModulation 5 fm)))
      softStringReleaseEnvelope

fmStringStereoFM ::
   IO (Real ->
       PC.T Real ->
       PC.T Real ->
       PC.T Real ->
       PC.T (PC.BendModulation Real) ->
       Instrument Real (Stereo.T Vector))
fmStringStereoFM =
   liftA2
      (\osc env att det depth dist fm vel freq dur ->
         osc ((det, depth, dist), (fm, freq)) (env att vel dur))
      (let det   = arr (fst3.fst)
           depth = arr (snd3.fst)
           dist  = arr (thd3.fst)
           fm  = arr snd
           mix x y = CausalP.mix <<< x&&&y
           osci ::
              Param.T (mod,fm) Real ->
              CausalP.T (mod,fm)
                 ((LLVM.Value Vector, LLVM.Value Vector)
                       {- phase modulation depth, modulator distortion -},
                  (LLVM.Value Vector, LLVM.Value Vector)
                       {- detune, frequency modulation -})
                 (LLVM.Value Vector)
           osci d =
              CausalPS.osciSimple WaveL.approxSine2
              <<<
              (CausalP.envelope
               <<<
               second
                  (CausalPS.shapeModOsci WaveL.rationalApproxSine1
                     <<< second (CausalP.feedFst (SigPS.constant 0)))
               <<^
               (\((dp, ds), f) -> (dp, (ds, f))))
               &&& arr snd
              <<<
              second
                 (CausalP.envelope <<<
                  first (CausalPS.raise 1 <<< CausalPS.amplify d))
       in  CausalP.runStorableChunky
              (CausalP.envelopeStereo <<<
                 (arr id &&&
                  (CausalPS.amplifyStereo 0.25
                   <<<
                   CausalP.zipWithSimple Sample.zipStereo
                   <<<
                   ((osci 1.0 `mix` osci (-0.4)) `mix`
                    (osci 0.5 `mix` osci (-0.7))) &&&
                   ((osci 0.4 `mix` osci (-1.0)) `mix`
                    (osci 0.7 `mix` osci (-0.5)))
                   <<<
                   CausalP.feedSnd
                      (SigP.zip
                         (piecewiseConstantVector det)
                         (frequencyFromBendModulation 5 fm))
                   <<<
                   CausalP.feedSnd (piecewiseConstantVector dist)
                   <<<
                   (CausalP.envelope
                       $< piecewiseConstantVector depth)))))
      softStringReleaseEnvelope


wind ::
   IO (Real ->
       PC.T Real ->
       PC.T (PC.BendModulation Real) ->
       Instrument Real (Stereo.T Vector))
wind =
   liftA2
      (\osc env att reson fm vel freq dur ->
         osc (reson, (fm,freq)) (env att vel dur))
      (let reson = arr fst
           fm = arr snd
       in  CausalP.runStorableChunky $
           (CausalP.envelopeStereo $>
              (CausalP.stereoFromMonoControlled CtrlPS.process
                $< SigP.zipWithSimple
                      (MoogL.parameter TypeNum.d8)
                      (piecewiseConstant reson)
                      (SigP.mapSimple Sample.subsampleVector
                         (frequencyFromBendModulation 0.2 fm))
                $* SigP.zipWithSimple Sample.zipStereo
                      (SigPS.noise 13 (sampleRate/20000))
                      (SigPS.noise 14 (sampleRate/20000)
                          :: SigP.T p (LLVM.Value Vector)))))
      softStringReleaseEnvelope


fadeProcess ::
   (Num b, LLVM.IsConst b,
    LLVM.IsArithmetic v, SoV.Replicate b v) =>
   CausalP.T p a (LLVM.Value v) ->
   CausalP.T p a (LLVM.Value v) ->
   CausalP.T p (LLVM.Value v, a) (LLVM.Value v)
fadeProcess proc0 proc1 =
   CausalP.mapSimple
      (\(k,(a0,a1)) -> do
         b0 <- A.mul a0 =<< A.sub (SoV.replicateOf 1) k
         b1 <- A.mul a1 k
         A.add b0 b1)
   <<<
   second (proc0 &&& proc1)

windPhaser ::
   IO (Real ->
       PC.T Real ->
       PC.T Real ->
       PC.T Real ->
       PC.T (PC.BendModulation Real) ->
       Instrument Real (Stereo.T Vector))
windPhaser =
   liftA2
      (\osc env att phaserMix phaserFreq reson fm vel freq dur ->
         osc ((phaserMix,phaserFreq), reson, (fm,freq)) (env att vel dur))
      (let phaserMix = arr (fst.fst3)
           phaserFreq = arr (snd.fst3)
           reson = arr snd3
           fm = arr thd3
       in  CausalP.runStorableChunky $
           (CausalP.envelopeStereo $>
              ((CausalP.stereoFromMonoControlled
                   (fadeProcess (arr snd) CtrlPS.process
                    <<<
                    first (CausalP.mapSimple SoV.replicate)
                    <<^
                    (\((k,p),x) -> (k,(p,x))))
                  $< SigP.zip
                        (piecewiseConstant phaserMix)
                        (piecewiseConstant
                           (fmap
                               (Allpass.flangerParameterPlain TypeNum.d8 .
                                (/sampleRate))
                               ^<< phaserFreq)))
               <<<
               CausalP.stereoFromMonoControlled CtrlPS.process
                 $< SigP.zipWithSimple
                       (MoogL.parameter TypeNum.d8)
                       (piecewiseConstant reson)
                       (SigP.mapSimple Sample.subsampleVector
                          (frequencyFromBendModulation 0.2 fm))
                 $* SigP.zipWithSimple Sample.zipStereo
                       (SigPS.noise 13 (sampleRate/20000))
                       (SigPS.noise 14 (sampleRate/20000)
                           :: SigP.T p (LLVM.Value Vector)))))
      softStringReleaseEnvelope


filterSawStereoFM ::
   IO (Real -> Real ->
       PC.T Real ->
       Real -> Real ->
       PC.T (PC.BendModulation Real) ->
       Instrument Real (Stereo.T Vector))
filterSawStereoFM =
   liftA2
      (\osc env dec rel detune bright brightDecay fm vel freq dur ->
         osc ((bright, brightDecay), (detune,fm,freq)) (env dec rel vel dur))
      (CausalP.runStorableChunky
         (let bright    = arr (fst.fst)
              brightDec = arr (snd.fst)
              fm = arr snd
          in  CausalP.envelopeStereo $>
              (CausalP.stereoFromMono
                  (UniFilter.lowpass
                   ^<<
                   (CtrlPS.processCtrlRate $# (100::Real))
                      (\k -> SigP.mapSimple
                          (UniFilterL.parameter (LLVM.valueOf 10))
                          {- bound control in order to avoid too low resonant frequency,
                             which makes the filter instable -}
                          (SigP.exponentialBounded2
                              (100/sampleRate)
                              (brightDec*sampleRate/k)
                              (bright/sampleRate)))
                   <<<
                   CausalPS.osciSimple WaveL.saw $< SigPS.constant zero)
               $* stereoFrequenciesFromDetuneBendModulation 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 ->
       Real -> Ev.LazyTime -> SigSt.T Vector)
adsr =
   liftA3
      (\attack decay release
           attackTime attackPeak attackHalfLife
           decayHalfLife releaseHalfLife vel dur ->
         let amp = amplitudeFromVelocity vel
             (attackDur, decayDur) =
                CutG.splitAt (round (attackTime*vectorRate)) dur
         in  SigStL.continuePacked
                (attack (chunkSizesFromLazyTime attackDur)
                    (attackHalfLife,
                     attackPeak * amp / (1 - 2^?(-attackTime/attackHalfLife)))
                 `SigSt.append`
                 decay (chunkSizesFromLazyTime decayDur)
                    (decayHalfLife,
                     ((attackPeak-1)*amp, amp)))
                (\x -> release vectorChunkSize (releaseHalfLife,x)))
      (SigP.runChunkyPattern $
       let halfLife  = arr fst
           amplitude = arr snd
       in  SigP.zipWithSimple A.sub
              (SigPS.constant amplitude)
              (SigPS.exponential2 (halfLife*sampleRate) amplitude))
      (SigP.runChunkyPattern $
       let halfLife   = arr fst
           amplitude  = arr (fst.snd)
           saturation = arr (snd.snd)
       in  SigP.mix (SigPS.constant saturation) $
           SigPS.exponential2 (halfLife*sampleRate) amplitude)
      (SigP.runChunky $
       let release   = arr fst
           amplitude = arr snd
       in  (CausalP.take (round ^<< (release*5*vectorRate)) $*
            SigPS.exponential2 (release*sampleRate) amplitude))

brass ::
   IO (Real -> Real ->
       Real -> Real -> Real -> Real ->
       PC.T Real ->
       PC.T Real ->
       PC.T (PC.BendModulation Real) ->
       Instrument Real (Stereo.T Vector))
brass =
   liftA2
      (\osc env attTime attPeak attHL dec rel emph det dist fm vel freq dur ->
         osc
            ((det, dist), (fm,freq),
             env attTime emph attHL dec rel vel dur)
            (env attTime attPeak attHL dec rel vel dur))
      (let det  = arr (fst.fst3)
           dist = arr (snd.fst3)
           fm   = arr snd3
           emph = arr thd3
           mix x y = CausalP.mix <<< x&&&y
           osci ::
              Param.T p Real ->
              CausalP.T p
                 (LLVM.Value Vector,
                       {- wave shrink/replication factor -}
                  (LLVM.Value Vector, LLVM.Value Vector)
                       {- detune, frequency modulation -})
                 (LLVM.Value Vector)
           osci d =
              CausalPS.shapeModOsci WaveL.rationalApproxSine1
              <<<
              second
                 (CausalP.feedFst (SigPS.constant $# (zero::Real))
                  <<<
                  CausalP.envelope
                  <<<
                  first (CausalPS.raise 1 <<< CausalPS.amplify d))
       in  CausalP.runStorableChunky $
           (CausalP.envelopeStereo $>
              (CausalPS.amplifyStereo 0.25
               <<<
               CausalP.zipWithSimple Sample.zipStereo
               <<<
               ((osci 1.0 `mix` osci (-0.4)) `mix`
                (osci 0.5 `mix` osci (-0.7))) &&&
               ((osci 0.4 `mix` osci (-1.0)) `mix`
                (osci 0.7 `mix` osci (-0.5)))
               <<<
               CausalP.feedFst (piecewiseConstantVector dist)
               <<<
               CausalP.feedSnd (frequencyFromBendModulation 5 fm)
               <<<
               (CausalP.envelope $< piecewiseConstantVector det)
               $*
               SigP.fromStorableVectorLazy emph)))
      adsr


data SamplePositions =
   SamplePositions {
      sampleStart, sampleLength,
      sampleLoopStart, sampleLoopLength :: Int
   }

data SampledSound =
   SampledSound {
      sampleData :: SigSt.T Real,
      samplePositions :: SamplePositions,
      samplePeriod :: Real
   }


sampledSound ::
   IO (SampledSound ->
       PC.T (PC.BendModulation Real) ->
       Instrument Real (Stereo.T Vector))
sampledSound =
   liftA2
      (\osc freqMod smp fm 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))
                   (fm, freq*samplePeriod smp) :: SigSt.T Vector
             pos = samplePositions smp
             amp = 2 * amplitudeFromVelocity vel
             (attack,sustain) =
                mapPair
                   (SigSt.drop (sampleStart pos),
                    SigSt.take (sampleLoopLength pos)) $
                SigSt.splitAt (sampleLoopStart pos) $
                sampleData smp
             release =
                SigSt.drop (sampleLoopStart pos + sampleLoopLength pos) $
                SigSt.take (sampleStart     pos + sampleLength     pos) $
                sampleData smp
         in  (\cont -> osc cont
                (amp,
                 attack `SigSt.append`
                 SVL.cycle (SigSt.take (sampleLoopLength pos) sustain),
                 chunkSizesFromLazyTime dur)
                fmSig)
             (osc (const SigSt.empty)
                (amp, release, NonNegChunky.fromChunks (repeat 1000))))
      (CausalP.runStorableChunkyCont
         (let amp = arr fst3
              smp = arr snd3
              dur = arr thd3
          in  CausalPS.amplifyStereo amp
              <<<
              CausalP.stereoFromMono
                 (CausalPS.pack
                    (CausalP.frequencyModulationLinear
                       (SigP.fromStorableVectorLazy smp)))
              <<<
              CausalP.zipWithSimple Sample.zipStereo
              <<<
              CausalPS.amplify 0.999 &&&
              CausalPS.amplify 1.001
              <<<
              arr fst
              <<<
              CausalP.feedSnd (SigP.lazySize dur)))
      (SigP.runChunkyPattern
         (frequencyFromBendModulation 3 (arr id)))


sampledSoundLeaky ::
   IO (SampledSound ->
       PC.T (PC.BendModulation Real) ->
       Instrument Real (Stereo.T Vector))
sampledSoundLeaky =
   liftA2
      (\osc freqMod smp fm 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))
                   (fm, freq*samplePeriod smp) :: SigSt.T Vector)
             pos = samplePositions smp
             amp = 2 * amplitudeFromVelocity vel
             (attack,sustain) =
                mapPair
                   (SigSt.drop (sampleStart pos),
                    SigSt.take (sampleLoopLength pos)) $
                SigSt.splitAt (sampleLoopStart pos) $
                sampleData smp
             release =
                SigSt.drop (sampleLoopStart pos + sampleLoopLength pos) $
                SigSt.take (sampleStart     pos + sampleLength     pos) $
                sampleData smp
         in  osc
                (amp,
                 attack `SigSt.append`
                 SVL.cycle (SigSt.take (sampleLoopLength pos) sustain))
                sustainFM
             `SigSt.append`
             osc (amp,release) releaseFM)
      (CausalP.runStorableChunky
         (let smp = arr snd
              amp = arr fst
          in  CausalPS.amplifyStereo amp
              <<<
              CausalP.stereoFromMono
                 (CausalPS.pack
                    (CausalP.frequencyModulationLinear
                       (SigP.fromStorableVectorLazy smp)))
              <<<
              CausalP.zipWithSimple Sample.zipStereo
              <<<
              CausalPS.amplify 0.999 &&&
              CausalPS.amplify 1.001))
      (SigP.runChunkyPattern
         (frequencyFromBendModulation 3 (arr id)))


type SampleInfo = (FilePath, [SamplePositions], Real)

makeSampledSounds ::
   SampleInfo ->
   IO [-- PC.T Real ->
       PC.T (PC.BendModulation Real) ->
       Instrument Real (Stereo.T Vector)]
makeSampledSounds (path, positions, period) = do
{-
   sound <-
      (SoxRead.withHandle1 (SVL.hGetContentsSync chunkSize) =<<
       SoxRead.open SoxOption.none "speech/tomatensalat2.wav")
   play (44100::Real) (sound::SVL.Vector Real)
-}
   liftA2
      (\makeSmp smp ->
          map (\pos -> makeSmp (SampledSound smp pos period))
             positions)
      sampledSound
      (SoxRead.withHandle1 (SVL.hGetContentsSync chunkSize) =<<
       SoxRead.open SoxOption.none path)


tomatensalatPositions :: [SamplePositions]
tomatensalatPositions =
   SamplePositions      0 29499  12501 15073 :
   SamplePositions  29499 31672  38163 17312 :
   SamplePositions  67379 28610  81811 10667 :
   SamplePositions  95989 31253 106058 16111 :
   SamplePositions 127242 38596 136689 11514 :
   []

tomatensalat :: SampleInfo
tomatensalat =
   ("speech/tomatensalat2.wav", tomatensalatPositions, 324.5)


halPositions :: [SamplePositions]
halPositions =
--   SamplePositions   2371 25957   7362  6321 :
   SamplePositions   2371 25957 (2371+25957) 1 :
   SamplePositions  40546 34460  63540  9546 :
   SamplePositions  79128 32348  94367 14016 :
   SamplePositions 112027 21227 125880  5500 :
   SamplePositions 146057 23235 168941   352 :
   []

hal :: SampleInfo
hal =
   ("speech/haskell-in-leipzig2.wav", halPositions, 316)


graphentheoriePositions :: [SamplePositions]
graphentheoriePositions =
   SamplePositions      0 29524  13267 14768 :
   SamplePositions  29524 35333  47624  9968 :
   SamplePositions  64857 31189  73818 16408 :
   SamplePositions  96046 31312 106206 18504 :
   SamplePositions 127358 32127 132469 16530 :
   []

graphentheorie :: SampleInfo
graphentheorie =
   ("speech/graphentheorie0.wav", graphentheoriePositions, 301.15)