{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE Rank2Types #-}
{- |
This module contains some instruments with Causal arrow interface.
The interface is a bit low-level
since you have to write the transformations of the Haskell-side
separately from the computations on the LLVM side.
A nicer integration is used in
"Synthesizer.LLVM.Server.CausalPacked.InstrumentPlug".
However, we preserve this module in order to show
how things work internally.
-}
module Synthesizer.LLVM.Server.CausalPacked.Instrument where

import Synthesizer.LLVM.Server.Packed.Instrument (stereoNoise, )
import Synthesizer.LLVM.Server.CommonPacked
import Synthesizer.LLVM.Server.Common hiding (Instrument, )

import qualified Synthesizer.LLVM.Server.SampledSound as Sample
import qualified Synthesizer.LLVM.Storable.Process as PSt
import qualified Synthesizer.MIDI.CausalIO.Process as MIO
import qualified Synthesizer.CausalIO.Gate as Gate
import qualified Synthesizer.CausalIO.Process as PIO

import Synthesizer.LLVM.CausalParameterized.Process (($<), )
import Synthesizer.LLVM.CausalParameterized.Functional (($&), (&|&), )
import qualified Synthesizer.LLVM.Filter.Universal as UniFilter
import qualified Synthesizer.LLVM.Filter.Allpass as Allpass
import qualified Synthesizer.LLVM.Filter.Moog as Moog
import qualified Synthesizer.LLVM.Generator.Exponential2 as Exp
import qualified Synthesizer.LLVM.Frame.Stereo as Stereo
import qualified Synthesizer.LLVM.Frame as Frame
import qualified Synthesizer.LLVM.Frame.SerialVector as Serial
import qualified Synthesizer.LLVM.CausalParameterized.Helix as Helix
import qualified Synthesizer.LLVM.CausalParameterized.Functional as F
import qualified Synthesizer.LLVM.CausalParameterized.ControlledPacked as CtrlPS
import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS
import qualified Synthesizer.LLVM.CausalParameterized.ProcessValue as CausalPV
import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP
import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS
import qualified Synthesizer.LLVM.Parameterized.Signal as SigP
import qualified Synthesizer.LLVM.Parameter as Param
import qualified Synthesizer.LLVM.Interpolation as Interpolation
import qualified Synthesizer.LLVM.Wave as WaveL
import qualified Synthesizer.LLVM.Simple.Value as Value
import Synthesizer.LLVM.Simple.Value ((%>), (%<=), )

import qualified Synthesizer.LLVM.MIDI.BendModulation as BM
import qualified Synthesizer.LLVM.MIDI as MIDIL
import qualified Synthesizer.PiecewiseConstant.Signal as PC
import qualified Synthesizer.Generic.Cut as CutG
import qualified Synthesizer.Zip as Zip
import qualified Data.EventList.Relative.BodyTime as EventListBT

import qualified Synthesizer.Storable.Signal as SigSt
import qualified Data.StorableVector.Lazy as SVL
import qualified Data.StorableVector as SV

import qualified LLVM.Extra.Monad as LM

import qualified LLVM.Core as LLVM

import qualified Types.Data.Num as TypeNum

import qualified Data.Traversable as Trav
import Control.Arrow (Arrow, arr, first, second, (&&&), (<<^), (^<<), )
import Control.Category (id, (.), )
import Control.Monad (liftM2, liftM3, liftM4, (<=<), )
import Control.Applicative (pure, liftA2, liftA3, )
import Data.Monoid (mappend, )
import Data.Tuple.HT (fst3, snd3, thd3, )

import qualified Number.DimensionTerm as DN

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


type Instrument a sig = SampleRate a -> MIO.Instrument a sig

type Control = EventListBT.T PC.ShortStrictTime

type Time = DN.Time Real
type Frequency = DN.Frequency Real

type Chunk = SV.Vector Vector
type StereoChunk = SV.Vector (Stereo.T Vector)
type BendModControl = Control (BM.T Real)
type DetuneBendModControl = Zip.T (Control Real) (Control (BM.T Real))

type PIOId a = PIO.T a a


stereoFrequenciesFromDetuneBendModulation ::
   Param p Real ->
   (FuncP p inp (LLVM.Value Real),
    FuncP p inp (BM.T (LLVM.Value Real))) ->
   FuncP p inp (Stereo.T VectorValue)
stereoFrequenciesFromDetuneBendModulation speed (detune, freq) =
   CausalP.envelopeStereo $&
      (MIDIL.frequencyFromBendModulationPacked speed $& freq)
      &|&
      (CausalP.mapSimple (Trav.mapM Serial.upsample) $&
       liftA2 Stereo.cons (one + detune) (one - detune))


frequencyFromSampleRate :: SampleRate a -> DN.Frequency a
frequencyFromSampleRate (SampleRate sr) = DN.frequency sr

halfLifeControl ::
   (Functor f) =>
   SampleRate Real ->
   f Time ->
   f (Exp.ParameterPacked Vector)
halfLifeControl sr =
   fmap (Exp.parameterPackedPlain .
         flip DN.mulToScalar (frequencyFromSampleRate sr))

frequencyControl ::
   (Functor f) =>
   SampleRate Real ->
   f Frequency ->
   f Real
frequencyControl sr =
   fmap (flip DN.divToScalar $ frequencyFromSampleRate sr)

takeThreshold ::
   Param.T p Real ->
   CausalP.T p VectorValue VectorValue
takeThreshold =
   CausalPV.takeWhile
      (\threshold y -> threshold %<= Value.lift1 Serial.subsample y)


type EnvelopeControl =
        Zip.T MIO.GateChunk
           (Zip.T (Control Time) (Control Time))

type WithEnvelopeControl remainder =
        Zip.T MIO.GateChunk
           (Zip.T
              (Zip.T (Control Time) (Control Time))
              remainder)

reorderEnvelopeControl ::
   (Arrow arrow, CutG.Read remainder) =>
   arrow
      (WithEnvelopeControl remainder)
      (Zip.T EnvelopeControl remainder)
reorderEnvelopeControl =
   arr $ \(Zip.Cons gate (Zip.Cons times ctrl)) ->
      Zip.consChecked "ping gate ctrl"
         (Zip.consChecked "ping gate times" gate times) ctrl


zipEnvelope ::
   (Arrow arrow, CutG.Transform a, CutG.Transform b) =>
   arrow EnvelopeControl a ->
   arrow (WithEnvelopeControl b) (Zip.T a b)
zipEnvelope env =
   Zip.arrowFirstShorten env
   .
   reorderEnvelopeControl


ping :: IO (Instrument Real Chunk)
ping =
   fmap (\proc sampleRate vel freq ->
      proc (sampleRate, (vel,freq))
      .
      Gate.toStorableVector) $
   CausalP.processIO $
      let vel = number fst
          freq = frequency snd
      in  CausalP.fromSignal $
          SigP.envelope
             (SigPS.exponential2 (timeConst 0.2) (fmap amplitudeFromVelocity vel)) $
          SigPS.osciSimple WaveL.saw zero freq


pingReleaseEnvelope ::
   IO (Real -> Real ->
       SampleRate Real -> Real ->
       PIO.T MIO.GateChunk Chunk)
pingReleaseEnvelope =
   liftM2
      (\sustain release dec rel sr vel ->
         PSt.continuePacked
            (sustain (sr,(dec,vel))
             .
             Gate.toChunkySize)
            (\y ->
               release (sr,(rel,y))
               .
               Gate.allToChunkySize))
      (CausalP.processIO $
         let vel = number snd
             decay = vectorTime fst
         in  CausalP.fromSignal $
             SigPS.exponential2 decay
                (fmap amplitudeFromVelocity vel))
      (CausalP.processIO $
         let level = number snd
             release = time fst
         in  CausalP.take (fmap round (vectorTime (const 1)))
             .
             CausalP.fromSignal
                (SigPS.exponential2 release level))

pingRelease :: IO (Real -> Real -> Instrument Real Chunk)
pingRelease =
   liftM2
      (\osci envelope dec rel sr vel freq ->
         osci (sr, freq)
         .
         envelope dec rel sr vel)
      (CausalP.processIO $
         let freq = frequency id
         in  CausalP.envelope
             .
             CausalP.feedFst (SigPS.osciSimple WaveL.saw zero freq))
      pingReleaseEnvelope


pingControlledEnvelope ::
   Maybe Real ->
   IO (SampleRate Real -> Real ->
       PIO.T EnvelopeControl Chunk)
pingControlledEnvelope threshold =
   liftM2
      (\sustain release sr vel ->
         PSt.continuePacked
            (sustain (sr,vel)
             .
             Gate.shorten
             .
             Zip.arrowSecond (arr (halfLifeControl sr . Zip.first)))
            (\y ->
             release (sr,y)
             <<^
             halfLifeControl sr . Zip.second . Zip.second))
      (CausalP.processIO $
         let vel = number id
         in  Exp.causalPackedP
                (fmap amplitudeFromVelocity vel))
      (CausalP.processIO $
         let level = number id
             expo = Exp.causalPackedP level
         in  case threshold of
                Just y -> takeThreshold (pure y) . expo
                Nothing -> expo)


pingStereoReleaseFM ::
   IO (SampleRate Real -> Real -> Real ->
       PIO.T
          (WithEnvelopeControl
             (Zip.T
                (Zip.T (Control Real) (Control Time))
                (Zip.T
                   (Zip.T (Control Real) (Control Time))
                   DetuneBendModControl)))
          StereoChunk)
pingStereoReleaseFM =
   liftA2
      (\osc env sr vel freq ->
         osc (sr, ())
         .
         Zip.arrowSecond
            (Zip.arrowSplit
               (Zip.arrowSecond $ arr $ halfLifeControl sr)
               ((Zip.arrowSecond $ Zip.arrowSecond $
                   arr $ transposeModulation sr freq)
                .
                (Zip.arrowFirst $ Zip.arrowSecond $
                   arr $ halfLifeControl sr)))
         .
         zipEnvelope (env sr vel))
      (CausalP.processIO
         (CausalP.envelopeStereo
          .
          second
             (F.withArgs $ \((shape0,shapeDecay),((phase,phaseDecay),fm)) ->
              let shape = CausalP.mapSimple Serial.upsample $& shape0
                  shapeCtrl =
                     1/pi + (shape-1/pi) *
                        (Exp.causalPackedP (1::Param.T p Real) $& shapeDecay)
                  freqs =
                     stereoFrequenciesFromDetuneBendModulation
                        (frequencyConst 10) fm
                  expo =
                     (CausalP.mapSimple Serial.upsample $& phase) *
                     (Exp.causalPackedP (1::Param.T p Real) $& phaseDecay)
                  osci = CausalPS.shapeModOsci WaveL.rationalApproxSine1
              in  liftA2 Stereo.cons
                     (osci $&  shapeCtrl &|& (expo &|& fmap Stereo.left freqs))
                     (osci $&  shapeCtrl &|& (negate expo &|& fmap Stereo.right freqs)))))
      (pingControlledEnvelope (Just 0.01))



filterSawStereoFM ::
   IO (SampleRate Real -> Real -> Real ->
       PIO.T
          (WithEnvelopeControl
             (Zip.T
                (Zip.T (Control Frequency) (Control Time))
                DetuneBendModControl))
          StereoChunk)
filterSawStereoFM =
   liftA2
      (\osc env sr vel freq ->
         osc (sr, ())
         .
         Zip.arrowSecond
            (Zip.arrowSplit
               (Zip.arrowSplit
                  (arr $ frequencyControl sr)
                  (arr $ halfLifeControl sr))
               (Zip.arrowSecond $
                  arr $ transposeModulation sr freq))
         .
         zipEnvelope (env sr vel))
      (CausalP.processIO
         (CausalP.envelopeStereo
          .
          second
             (F.withArgs $ \((cutoff,cutoffDecay),fm) ->
              let freqs =
                     stereoFrequenciesFromDetuneBendModulation
                        (frequencyConst 10) fm
                  {- bound control in order to avoid too low resonant frequency,
                     which makes the filter instable -}
                  expo =
                     takeThreshold (frequencyConst 100) $&
                     (CausalP.mapSimple Serial.upsample $& cutoff) *
                     (Exp.causalPackedP (1::Param.T p Real) $& cutoffDecay)
              in  CausalP.stereoFromMonoControlled
                     (UniFilter.lowpass ^<< CtrlPS.process)
                  $&
                  (CausalP.quantizeLift (100 / fromIntegral vectorSize :: Param.T p Real)
                      (CausalP.mapSimple
                          (UniFilter.parameter (LLVM.valueOf 10)
                           <=<
                           Serial.subsample))
                   $&
                   expo)
                  &|&
                  (CausalP.stereoFromMono
                     (CausalPS.osciSimple WaveL.saw $< zero) $&
                     freqs))))
      (pingControlledEnvelope (Just 0.01))

tineStereoFM ::
   IO (SampleRate Real -> Real -> Real ->
       PIO.T
          (WithEnvelopeControl
             (Zip.T
                (Zip.T (Control Real) (Control Real))
                DetuneBendModControl))
          StereoChunk)
tineStereoFM =
   liftA2
      (\osc env sr vel freq ->
         osc (sr, vel)
         .
         (Zip.arrowSecond $ Zip.arrowSecond $
          Zip.arrowSecond $
            arr $ transposeModulation sr freq)
         .
         zipEnvelope (env sr vel))
      (CausalP.processIO
         (CausalP.envelopeStereo
          .
          second
             (F.withArgs $ \((index0,depth0), fm) ->
              let vel = number id
                  freqs =
                     stereoFrequenciesFromDetuneBendModulation
                        (frequencyConst 5) fm
                  index = CausalP.mapSimple Serial.upsample $& index0
                  depth = CausalP.mapSimple Serial.upsample $& depth0
                  expo =
                     F.fromSignal $
                     SigPS.exponential2 (timeConst 1) (1 + vel)
                  osci freq =
                     CausalPS.osciSimple WaveL.approxSine2 $&
                        expo * depth *
                           (CausalPS.osciSimple WaveL.approxSine2
                            $& zero &|& index*freq)
                        &|&
                        freq
              in  Stereo.liftApplicative osci freqs)))
      (pingControlledEnvelope (Just 0.01))


bellNoiseStereoFM ::
   IO (SampleRate Real -> Real -> Real ->
       PIO.T
          (WithEnvelopeControl
             (Zip.T
                (Zip.T (Control Real) (Control Real))
                DetuneBendModControl))
          StereoChunk)
bellNoiseStereoFM =
   liftA3
      (\osc env envInf sr vel freq ->
         osc (sr, ())
         .
         (Zip.arrowSecond $ Zip.arrowSecond $
          Zip.arrowSecond $
            arr $ transposeModulation sr freq)
         .
         zipEnvelope
            (Zip.arrowFanoutShorten
               (env sr (vel*0.5))
               (let shortenTimes ::
                       Real ->
                       PIOId (Zip.T (Control Time) (Control Time))
                    shortenTimes n =
                       let rn = recip n
                       in  (Zip.arrowFirst $ arr $ fmap $ DN.scale rn)
                           .
                           (Zip.arrowSecond $ arr $ fmap $ DN.scale rn)
                in  PIO.zip
                      (envInf sr (vel*2)
                       .
                       Zip.arrowSecond (shortenTimes 4))
                      (envInf sr (vel*4)
                       .
                       Zip.arrowSecond (shortenTimes 7)))))
      (CausalP.processIO
         (F.withArgs $ \((env1,(env4,env7)),((noiseAmp0,noiseReson),fm)) ->
          let noiseAmp = CausalP.mapSimple Serial.upsample $& noiseAmp0
              noiseParam =
                 CausalP.quantizeLift
                    (100 / fromIntegral vectorSize :: Param.T p Real)
                    (CausalP.zipWithSimple (Moog.parameter TypeNum.d8))
              noise =
                 F.fromSignal (SigPS.noise 12 (noiseReference 20000))
              freqs =
                 stereoFrequenciesFromDetuneBendModulation
                    (frequencyConst 5) fm
              osci amp env n =
                 CausalPS.amplifyStereo amp $&
                 CausalP.envelopeStereo $&
                 env &|&
                 (CausalP.stereoFromMono
                    (CausalPS.osciSimple WaveL.approxSine4 $< zero)
                  $&
                  CausalPS.amplifyStereo n
                  $&
                  freqs)
          in  (CausalP.envelopeStereo $&
                 (noiseAmp * env1)
                 &|&
                 Stereo.liftApplicative
                    (\freq ->
                       CtrlPS.process $&
                          (noiseParam $& noiseReson &|&
                           (CausalP.mapSimple Serial.subsample $& freq))
                          &|&
                          noise)
                    freqs)
              + osci 1.00 env1 1
              + osci 0.10 env4 4
              + osci 0.01 env7 7))
      (pingControlledEnvelope (Just 0.01))
      (pingControlledEnvelope Nothing)



stringControlledEnvelope ::
   IO (SampleRate Real -> Real ->
       PIO.T EnvelopeControl Chunk)
stringControlledEnvelope =
   liftM3
      (\attack sustain release sr vel ->
         let amp = amplitudeFromVelocity vel
         in  PSt.continuePacked
                (mappend
                    (attack (sr,amp))
                    {- we could also feed the sustain process
                       with a signal with sample type () -}
                    (sustain (sr,amp))
                 .
                 Gate.shorten
                 .
                 Zip.arrowSecond (arr (halfLifeControl sr . Zip.first)))
                (\y ->
                 release (sr,y)
                 <<^
                 halfLifeControl sr . Zip.second . Zip.second))
      (CausalP.processIO $
         let amp = number id
         in  CausalP.fromSignal (SigPS.constant amp)
             -
             takeThreshold (1e-4 :: Param.T p Real)
             .
             Exp.causalPackedP amp)
      (CausalP.processIO $
         let amp = number id
         in  CausalP.fromSignal (SigPS.constant amp))
      (CausalP.processIO $
         let level = number id
         in  takeThreshold (0.01 :: Param.T p Real)
             .
             Exp.causalPackedP level)


windCore ::
   F.T (SampleRate Real, p) a (LLVM.Value Real) ->
   F.T (SampleRate Real, p) a (BM.T (LLVM.Value Real)) ->
   F.T (SampleRate Real, p) a (Stereo.T VectorValue)
windCore reson fm =
   let modu =
          CausalP.mapSimple Serial.subsample $&
          (fmap (`asTypeOf` (undefined :: VectorValue)) $
           (MIDIL.frequencyFromBendModulationPacked
              (frequencyConst 0.2) $& fm))
   in  CausalP.stereoFromMonoControlled CtrlPS.process $&
          (CausalP.zipWithSimple (Moog.parameter TypeNum.d8) $&
             reson &|& modu)
          &|&
          F.fromSignal stereoNoise

wind ::
   IO (SampleRate Real -> Real -> Real ->
       PIO.T
          (WithEnvelopeControl DetuneBendModControl)
          StereoChunk)
wind =
   liftA2
      (\osc env sr vel freq ->
         osc (sr, ())
         .
         (Zip.arrowSecond $ Zip.arrowSecond $
            arr $ transposeModulation sr freq)
         .
         zipEnvelope (env sr vel))
      (CausalP.processIO
         (F.withArgs $ \(env,(reson,fm)) ->
              CausalP.envelopeStereo $&
                 env &|&
                 windCore reson fm))
      stringControlledEnvelope


windPhaser ::
   IO (SampleRate Real -> Real -> Real ->
       PIO.T
          (WithEnvelopeControl
             (Zip.T (Control Real)
                (Zip.T (Control Frequency) DetuneBendModControl)))
          StereoChunk)
windPhaser =
   liftA2
      (\osc env sr vel freq ->
         osc (sr, ())
         .
         (Zip.arrowSecond $ Zip.arrowSecond $
          Zip.arrowSplit
             (arr $ fmap (Allpass.flangerParameterPlain TypeNum.d8) .
                    frequencyControl sr)
             (Zip.arrowSecond $
              arr $ transposeModulation sr freq))
         .
         zipEnvelope (env sr vel))
      (CausalP.processIO
         (F.withArgs $ \(env,(phaserMix0,(phaserFreq,(reson,fm)))) ->
          let phaserMix = CausalP.mapSimple Serial.upsample $& phaserMix0
              noise = windCore reson fm

          in  CausalP.envelopeStereo $&
                 env &|&
                 ((CausalP.envelopeStereo $& (1 - phaserMix) &|& noise)
                  +
                  (CausalP.envelopeStereo $&
                     phaserMix &|&
                     (Stereo.arrowFromMonoControlled CtrlPS.process $&
                        phaserFreq &|& noise)))))
      stringControlledEnvelope


phaserOsci ::
   (Param.T p Real -> Param.T p Real -> CausalP.T p a VectorValue) ->
   CausalP.T p a (Stereo.T VectorValue)
phaserOsci osci =
   CausalPS.amplifyStereo 0.25
   .
   Trav.traverse sumNested
      (Stereo.cons
         (zipWith osci [0.1, 0.7, 0.2, 0.3] [1.0, -0.4, 0.5, -0.7])
         (zipWith osci [0.4, 0.9, 0.6, 0.5] [0.4, -1.0, 0.7, -0.5]))


type
   StringInstrument =
      SampleRate Real -> Real -> Real ->
      PIO.T
         (WithEnvelopeControl
            (Zip.T (Control Real) DetuneBendModControl))
         StereoChunk

softStringShapeCore ::
   (forall r.
    VectorValue ->
    VectorValue ->
    LLVM.CodeGenFunction r VectorValue) ->
   IO StringInstrument
softStringShapeCore wave =
   liftA2
      (\osc env sr vel freq ->
         osc (sr, ())
         .
         (Zip.arrowSecond $ Zip.arrowSecond $
          Zip.arrowSecond $
            arr $ transposeModulation sr freq)
         .
         zipEnvelope (env sr vel))
      (CausalP.processIO
         (CausalP.envelopeStereo
          .
          second
             (F.withArgs $ \(shape0,(det0,fm)) ->
              let det = CausalP.mapSimple Serial.upsample $& det0
                  shape = CausalP.mapSimple Serial.upsample $& shape0
                  modu =
                     MIDIL.frequencyFromBendModulationPacked
                        (frequencyConst 5) $& fm
                  osci ::
                     Param.T (mod,fm) Real ->
                     Param.T (mod,fm) Real ->
                     CausalP.T (mod,fm)
                        (VectorValue,
                              {- wave shape parameter -}
                         (VectorValue, VectorValue)
                              {- detune, frequency modulation -})
                        VectorValue
                  osci p d =
                     CausalPS.shapeModOsci wave
                     .
                     second
                        (CausalP.feedFst (SigPS.constant p)
                         .
                         CausalP.envelope
                         .
                         first (one + CausalPS.amplify d))

              in  phaserOsci osci $&  shape &|& det &|& modu)))
      stringControlledEnvelope

arcStringStereoFM ::
   (forall r.
    VectorValue ->
    LLVM.CodeGenFunction r VectorValue) ->
   IO StringInstrument
arcStringStereoFM wave =
   softStringShapeCore
      (\k p ->
         LM.liftR2 Frame.amplifyMono
            (WaveL.approxSine4 =<< WaveL.halfEnvelope p)
            (wave =<< WaveL.replicate k p))

softStringShapeFM, cosineStringStereoFM,
   arcSawStringStereoFM, arcSineStringStereoFM,
   arcSquareStringStereoFM, arcTriangleStringStereoFM ::
      IO StringInstrument
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


fmStringStereoFM ::
   IO (SampleRate Real -> Real -> Real ->
       PIO.T
          (WithEnvelopeControl
             (Zip.T
                (Zip.T (Control Real) (Control Real))
                DetuneBendModControl))
          StereoChunk)
fmStringStereoFM =
   liftA2
      (\osc env sr vel freq ->
         osc (sr, ())
         .
         (Zip.arrowSecond $ Zip.arrowSecond $
          Zip.arrowSecond $
            arr $ transposeModulation sr freq)
         .
         zipEnvelope (env sr vel))
      (CausalP.processIO
         (F.withArgs $ \(env,((depth0,shape0),(det0,fm))) ->
          let det = CausalP.mapSimple Serial.upsample $& det0
              shape = CausalP.mapSimple Serial.upsample $& shape0
              depth =
                 CausalP.envelope $&
                    env &|&
                    (CausalP.mapSimple Serial.upsample $& depth0)
              modu =
                 MIDIL.frequencyFromBendModulationPacked
                    (frequencyConst 5) $& fm

              osci ::
                 Param.T (mod,fm) Real ->
                 Param.T (mod,fm) Real ->
                 CausalP.T (mod,fm)
                    ((VectorValue, VectorValue)
                          {- phase modulation depth, modulator distortion -},
                     (VectorValue, VectorValue)
                          {- detune, frequency modulation -})
                    VectorValue
              osci p d =
                 CausalPS.osciSimple WaveL.approxSine2
                 .
                 ((CausalP.envelope
                  .
                  second
                     (CausalPS.shapeModOsci WaveL.rationalApproxSine1
                        . second (CausalP.feedFst (SigPS.constant p)))
                  <<^
                  (\((dp, ds), f) -> (dp, (ds, f))))
                  &&& arr snd)
                 .
                 second
                    (CausalP.envelope .
                     first (one + CausalPS.amplify d))

          in  CausalP.envelopeStereo $&
                 env &|&
                 (phaserOsci osci $&  (depth &|& shape) &|& (det &|& modu))))
      stringControlledEnvelope



sampledSound ::
   IO (Sample.T ->
       SampleRate Real -> Real -> Real ->
       PIO.T
          (Zip.T MIO.GateChunk DetuneBendModControl)
          StereoChunk)
sampledSound =
   liftA2
      (\osc freqMod smp sr vel freq ->
         let pos = Sample.positions smp
         in  assembleParts osc smp sr vel
             .
             Zip.arrowSecond
                ((id :: PIOId StereoChunk)
                 .
                 freqMod (sr, ())
                 .
                 (Zip.arrowSecond $ arr $
                    transposeModulation sr (freq * Sample.period pos))))
      (CausalP.processIO (CausalP.stereoFromMono resamplingProc))
      (CausalP.processIO
         (F.withArgs $ stereoFrequenciesFromDetuneBendModulation (frequencyConst 3)))


{- |
mainly for testing purposes
-}
sampledSoundMono ::
   IO (Sample.T ->
       SampleRate Real -> Real -> Real ->
       PIO.T (Zip.T MIO.GateChunk BendModControl) Chunk)
sampledSoundMono =
   liftA2
      (\osc freqMod smp sr vel freq ->
         let pos = Sample.positions smp
         in  assembleParts osc smp sr vel
             .
             Zip.arrowSecond
                ((id :: PIOId Chunk)
                 .
                 freqMod (sr, ())
                 .
                 (arr $ transposeModulation sr (freq * Sample.period pos))))
      (CausalP.processIO resamplingProc)
      (CausalP.processIO
         (MIDIL.frequencyFromBendModulationPacked (frequencyConst 3)))

{-
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@.
-}
assembleParts ::
   (CutG.Transform a, CutG.Transform b) =>
   ((SampleRate Real, (Real, SVL.Vector Real)) -> PIO.T a b) ->
   Sample.T -> SampleRate Real -> Real ->
   PIO.T (Zip.T (Gate.Chunk gate) a) b
assembleParts osc smp sr vel =
   let pos = Sample.positions smp
       amp = 2 * amplitudeFromVelocity vel
       (attack, sustain, release) = Sample.parts smp
       osci smpBody = osc (sr, (amp, smpBody))
   in  mappend
          (osci
             (attack `SigSt.append`
              SVL.cycle (SigSt.take (Sample.loopLength pos) sustain))
           .
           Gate.shorten)
          (osci release <<^ Zip.second)

resamplingProc ::
   CausalP.T
      (SampleRate Real, (Real, SigSt.T Real))
      VectorValue VectorValue
resamplingProc =
   let amp = number fst
       smp = signal snd
   in  CausalPS.amplify amp
       .
       CausalPS.pack
          (CausalP.frequencyModulationLinear
             {-
             (SigP.fromStorableVector $
                fmap (SV.concat . SVL.chunks . SVL.take 1000000) smp)
             -}
             (SigP.fromStorableVectorLazy smp)
             {- (SigP.osciSimple WaveL.saw 0 (1 / 324 {- samplePeriod smp -})) -})

helixSound ::
   IO (Sample.T ->
       SampleRate Real -> Real -> Real ->
       PIO.T
          (Zip.T MIO.GateChunk
              (Zip.T (Control Real) DetuneBendModControl))
          StereoChunk)
helixSound =
   liftM4
      (\helix zigZag integrate freqMod smp sr vel freq ->
         let pos = Sample.positions smp
             amp = 2 * amplitudeFromVelocity vel
             rateFactor =
                DN.divToScalar
                   (Sample.sampleRate smp)
                   (frequencyFromSampleRate sr)
             releaseStart =
                fromIntegral $
                Sample.loopStart pos + Sample.loopLength pos
             releaseStop =
                fromIntegral $
                Sample.start pos + Sample.length pos
             poss =
                (fromIntegral $ Sample.start pos,
                 fromIntegral $ Sample.loopStart pos,
                 fromIntegral $ Sample.loopLength pos)
         in  helix (sr, ((amp, Sample.period pos), Sample.body smp))
             .
             Zip.arrowFirstShorten
                (mappend
                    (zigZag (sr, poss) . Gate.shorten)
                    (integrate (sr, (releaseStart, releaseStop))
                        <<^ Zip.second))
             .
             Zip.arrowSecond
                (freqMod (sr, ())
                 .
                 (Zip.arrowSecond $ arr $ transposeModulation sr freq))
             .
             arr (\(Zip.Cons gate (Zip.Cons speed fm)) ->
                       Zip.Cons (Zip.Cons gate (fmap (rateFactor*) speed)) fm))
      makeHelix
      makeZigZag
      makeIntegrate
      (CausalP.processIO
         (F.withArgs $ stereoFrequenciesFromDetuneBendModulation (frequencyConst 3)))

makeHelix ::
   IO ((SampleRate Real, ((Real, Real), SigSt.T Real)) ->
       PIO.T (Zip.T Chunk StereoChunk) StereoChunk)
makeHelix =
   CausalP.processIO
      (let amp = number (fst.fst)
           per = number (snd.fst)
           smp = signal snd
       in  CausalPS.amplifyStereo amp
           .
           CausalP.stereoFromMono
              (Helix.staticPacked
                  Interpolation.linear
                  Interpolation.linear
                  (fmap round per) per
                  (fmap (SV.concat . SVL.chunks) smp)
               .
               second (CausalPS.osciCore $< 0))
           .
           arr (\(shape, freq) -> fmap ((,) shape) freq))

makeZigZag ::
   IO ((SampleRate Real, (Real, Real, Real)) ->
       PIO.T (Control Real) Chunk)
makeZigZag =
   CausalP.processIO
      (let start = number fst3
           loopStart = number snd3
           loopLength = number thd3

       in  CausalPS.raise start
           .
           -- CausalPS.pack (Helix.zigZagLong (loopStart-start) loopLength)
           Helix.zigZagLongPacked (loopStart-start) loopLength
           .
           CausalP.mapSimple Serial.upsample)

makeIntegrate ::
   IO ((SampleRate Real, (Real, Real)) ->
       PIO.T (Control Real) Chunk)
makeIntegrate =
   CausalP.processIO
      (let start = number fst
           stop = number snd

       in  CausalPV.takeWhile
              (\s v ->  s %> Value.lift1 Serial.subsample v)
              stop
           .
           CausalPS.integrate start
           .
           CausalP.mapSimple Serial.upsample)