module Synthesizer.LLVM.Server.CausalPacked.Arrange where

import Synthesizer.LLVM.Server.CommonPacked (VectorSize, Vector, VectorValue, stair, )

import qualified Sound.MIDI.Controller as Ctrl

import qualified Synthesizer.LLVM.Server.CausalPacked.Speech as Speech
import qualified Synthesizer.LLVM.Server.CausalPacked.Instrument as Instr
import qualified Synthesizer.LLVM.Server.CausalPacked.InstrumentPlug as InstrPlug
import qualified Synthesizer.LLVM.Server.SampledSound as Sample
import Synthesizer.LLVM.Server.Common

import qualified Synthesizer.MIDI.PiecewiseConstant.ControllerSet as PCS
import qualified Synthesizer.MIDI.CausalIO.ControllerSet as MCS
import qualified Synthesizer.MIDI.CausalIO.Process as MIO
import qualified Synthesizer.MIDI.Value as MV
import qualified Synthesizer.CausalIO.Process as PIO
import qualified Synthesizer.PiecewiseConstant.Signal as PC

import qualified Synthesizer.LLVM.Plug.Output as POut
import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP
import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS
import qualified Synthesizer.LLVM.Storable.Process as CausalSt
import qualified Synthesizer.LLVM.Storable.Signal as SigStL

import qualified Synthesizer.LLVM.Frame.StereoInterleaved as StereoInt
import qualified Synthesizer.LLVM.Frame.Stereo as Stereo
import qualified Synthesizer.LLVM.Frame.SerialVector as Serial

import qualified Data.EventList.Relative.TimeTime  as EventListTT

import qualified Data.StorableVector as SV

import qualified Synthesizer.Zip as Zip

import qualified Synthesizer.MIDI.Dimensional.ValuePlain as DMV
import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg
import qualified Sound.MIDI.Message.Channel as ChannelMsg
import qualified Sound.MIDI.Message.Class.Construct as Construct
import qualified Sound.MIDI.Message.Class.Check as Check

import Control.Arrow (Arrow, arr, first, (<<<), (^<<), )
import Control.Category (id, )
import Control.Applicative ((<*>), )

import qualified Data.List.HT as ListHT
import Data.Maybe.HT (toMaybe, )

import qualified Data.Map as Map

import qualified Number.DimensionTerm as DN
import qualified Algebra.DimensionTerm as Dim

import qualified Algebra.Transcendental as Trans

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

import Prelude hiding (Real, id, )



type StereoVector = StereoInt.T VectorSize Real


keyboard ::
   (Check.C msg) =>
   IO (ChannelMsg.Channel ->
       SampleRate Real ->
       PIO.T (MIO.Events msg) (SV.Vector Vector))
keyboard = do
   arrange <- CausalSt.makeArranger
   amp <- CausalP.processIO (CausalPS.amplify 0.2)

   ping <- Instr.pingRelease

   return $ \ chan sampleRate ->
      amp ()
      <<<
      arrange
      <<<
      arr shortTime
      <<<
      MIO.sequenceCore chan
         (\ _pgm -> ping 0.8 0.1 sampleRate)


infixr 3 &+&

(&+&) ::
   (Arrow arrow) =>
   arrow a b -> arrow a c -> arrow a (Zip.T b c)
(&+&) = Zip.arrowFanout


controllerExponentialDirect ::
   (Check.C msg, Trans.C y, Dim.C v) =>
   ChannelMsg.Channel ->
   VoiceMsg.Controller ->
   (DN.T v y, DN.T v y) ->
   DN.T v y ->
   PIO.T (MIO.Events msg) (Instr.Control (DN.T v y))
controllerExponentialDirect chan ctrl bnds initial =
   MIO.slice
      (Check.controller chan ctrl)
      (DMV.controllerExponential bnds)
      initial

shortTime ::
   EventListTT.T PC.StrictTime body ->
   EventListTT.T PC.ShortStrictTime body
shortTime =
   EventListTT.mapTime
      (NonNegW.fromNumberUnsafe . fromInteger . NonNegW.toNumber)

keyboardFM ::
   (Check.C msg, POut.Default b) =>
   CausalP.T () (Stereo.T VectorValue) (POut.Element b) ->
   ChannelMsg.Channel ->
   IO (SampleRate Real -> PIO.T (MIO.Events msg) b)
keyboardFM emitStereo chan = do
   arrange <- CausalSt.makeArranger
   amp <-
      CausalP.processIO
         (emitStereo <<< CausalPS.amplifyStereo 0.2)

   ping <- Instr.pingStereoReleaseFM

   return $ \ sampleRate ->
      amp ()
      <<<
      arrange
      <<<
      arr shortTime
      <<<
      -- ToDo: fetch parameters from controllers
      MIO.sequenceModulated chan
         (\ _pgm -> ping sampleRate)
      <<<
      id &+&
         ((controllerExponentialDirect chan
             Ctrl.attackTime (DN.time 0.25, DN.time 2.5) (DN.time 0.8)
           &+&
           controllerExponentialDirect chan
             Ctrl.releaseTime (DN.time 0.03, DN.time 0.3) (DN.time 0.1))
          &+&
          ((MIO.controllerExponential chan controllerTimbre0 (1/pi,0.01) 0.05
            &+&
            controllerExponentialDirect chan controllerTimbre1
               (DN.time 0.01, DN.time 10)
               (DN.time 5))
           &+&
           ((MIO.controllerLinear chan Ctrl.soundController5 (0,2) 1
             &+&
             controllerExponentialDirect chan Ctrl.soundController7
                (DN.time 0.25, DN.time 2.5)
                (DN.time 0.8))
            &+&
            (MIO.controllerLinear chan controllerDetune (0,0.005) 0.001
             &+&
             MIO.bendWheelPressure chan 2 0.04 0.03))))


controllerExponentialDim ::
   (Arrow arrow,
    Trans.C y, Dim.C v) =>
   VoiceMsg.Controller ->
   (DN.T v y, DN.T v y) ->
   DN.T v y ->
   MCS.T arrow (DN.T v y)
controllerExponentialDim ctrl bnds initial =
   MCS.slice
      (MCS.Controller ctrl)
      (DMV.controllerExponential bnds)
      initial


timeControlPercussive, timeControlString ::
   PIO.T
      (PCS.T MCS.Controller Int)
      (Zip.T
         (Instr.Control Instr.Time)
         (Instr.Control Instr.Time))

timeControlPercussive =
   controllerExponentialDim Ctrl.attackTime
      (DN.time 0.1, DN.time 2.5) (DN.time 0.8)
   &+&
   controllerExponentialDim Ctrl.releaseTime
      (DN.time 0.03, DN.time 0.3) (DN.time 0.1)

timeControlString =
   controllerExponentialDim Ctrl.attackTime
      (DN.time 0.005, DN.time 0.1) (DN.time 0.1)
   &+&
   controllerExponentialDim Ctrl.releaseTime
      (DN.time 0.03, DN.time 0.3) (DN.time 0.2)


keyboardDetuneFMCore ::
   (Check.C msg, POut.Default b) =>
   CausalP.T () (Stereo.T VectorValue) (POut.Element b) ->
   FilePath ->
   IO (ChannelMsg.Channel -> VoiceMsg.Program ->
       SampleRate Real -> PIO.T (MIO.Events msg) b)
keyboardDetuneFMCore emitStereo smpDir = do
   arrange <- keyboardDetuneFMConstVolume smpDir
   amp <-
      CausalP.processIO
         (emitStereo <<<
          CausalP.envelopeStereo <<<
          first (CausalP.mapSimple Serial.upsample))
   return $ \chan initPgm rate ->
      amp ()
      <<<
      MIO.controllerExponential chan controllerVolume (0.001, 1) (0.2::Float)
      &+&
      arrange chan initPgm rate

keyboardDetuneFMConstVolume ::
   (Check.C msg) =>
   FilePath ->
   IO (ChannelMsg.Channel -> VoiceMsg.Program -> SampleRate Real ->
       PIO.T (MIO.Events msg) (SV.Vector (Stereo.T Vector)))
keyboardDetuneFMConstVolume smpDir = do
   arrange <- CausalSt.makeArranger

   tine <- Instr.tineStereoFM
   ping <- Instr.pingStereoReleaseFM
   filterSaw <- Instr.filterSawStereoFM
   bellNoise <- Instr.bellNoiseStereoFM

   wind <- Instr.wind
   windPhaser <- Instr.windPhaser
   string <- Instr.softStringShapeFM
   fmString <- Instr.fmStringStereoFM
   helixNoise <- InstrPlug.helixNoise
   arcs <- sequence $
      Instr.cosineStringStereoFM :
      Instr.arcSawStringStereoFM :
      Instr.arcSineStringStereoFM :
      Instr.arcSquareStringStereoFM :
      Instr.arcTriangleStringStereoFM :
      []

   helixSound <- Instr.helixSound
   sampledSound <- Instr.sampledSound

   syllables <-
      fmap concat $
      mapM (Sample.loadRanges smpDir) $
      Sample.tomatensalat :
      Sample.hal :
      Sample.graphentheorie :
      []

   let frequencyControlPercussive =
          MCS.controllerLinear controllerDetune (0,0.005) 0.001
          &+&
          MCS.bendWheelPressure 2 0.04 0.03

       frequencyControlString =
          MCS.controllerLinear controllerDetune (0,0.01) 0.005
          &+&
          MCS.bendWheelPressure 2 0.04 0.03

   let tineProc rate vel freq =
          tine rate vel freq
          <<<
          Zip.arrowSecond
             (timeControlPercussive
              &+&
              (((fmap stair ^<<
                 MCS.controllerLinear controllerTimbre0 (0.5,6.5) 2)
                &+&
                MCS.controllerLinear controllerTimbre1 (0,1.5) 1)
               &+&
               frequencyControlPercussive))

       pingProc rate vel freq =
          ping rate vel freq
          <<<
          Zip.arrowSecond
             (timeControlPercussive
              &+&
              ((MCS.controllerExponential controllerTimbre0 (1/pi,10) 0.05
                &+&
                controllerExponentialDim controllerTimbre1
                    (DN.time 0.01, DN.time 10) (DN.time 5))
               &+&
               ((MCS.controllerLinear Ctrl.soundController5 (0,10) 2
                 &+&
                 controllerExponentialDim Ctrl.soundController7
                    (DN.time 0.03, DN.time 1) (DN.time 0.5))
                &+&
                frequencyControlPercussive)))

       filterSawProc rate vel freq =
          filterSaw rate vel freq
          <<<
          Zip.arrowSecond
             (timeControlPercussive
              &+&
              ((controllerExponentialDim controllerTimbre0
                   (DN.frequency 100, DN.frequency 10000)
                   (DN.frequency 1000)
                &+&
                controllerExponentialDim controllerTimbre1
                   (DN.time 0.1, DN.time 1)
                   (DN.time 0.6))
               &+&
               frequencyControlPercussive))

       bellNoiseProc rate vel freq =
          bellNoise rate vel freq
          <<<
          Zip.arrowSecond
             (timeControlPercussive
              &+&
              ((MCS.controllerLinear controllerTimbre0 (0,1) 0.3
                &+&
                MCS.controllerExponential controllerTimbre1 (1,1000) 100)
               &+&
               frequencyControlPercussive))

       windProc rate vel freq =
          wind rate vel freq
          <<<
          Zip.arrowSecond
             (timeControlString
              &+&
              (MCS.controllerExponential controllerTimbre1 (1,1000) 100
               &+&
               MCS.bendWheelPressure 12 0.8 0))

       windPhaserProc rate vel freq =
          windPhaser rate vel freq
          <<<
          Zip.arrowSecond
             (timeControlString
              &+&
              (MCS.controllerLinear controllerTimbre0 (0,1) 0.5
               &+&
               (controllerExponentialDim controllerDetune
                   (DN.frequency 50, DN.frequency 5000) (DN.frequency 500)
                &+&
                (MCS.controllerExponential controllerTimbre1 (1,1000) 100
                 &+&
                 MCS.bendWheelPressure 12 0.8 0))))

       stringProc rate vel freq =
          string rate vel freq
          <<<
          Zip.arrowSecond
             (timeControlString
              &+&
              (MCS.controllerExponential controllerTimbre0 (1/pi,10) 0.05
               &+&
               frequencyControlString))

       fmStringProc rate vel freq =
          fmString rate vel freq
          <<<
          Zip.arrowSecond
             (timeControlString
              &+&
              ((MCS.controllerLinear controllerTimbre0 (0,0.5) 0.2
                &+&
                MCS.controllerExponential controllerTimbre1 (1/pi,10) 0.05)
               &+&
               frequencyControlString))

       helixNoiseProc rate vel freq =
          helixNoise rate vel freq
          <<<
          Zip.arrowSecond
             (timeControlString
              &+&
              (MCS.controllerExponential controllerTimbre0 (1,0.01) 0.1
               &+&
               frequencyControlString))

       makeArc proc rate vel freq =
          proc rate vel freq
          <<<
          Zip.arrowSecond
             (timeControlString
              &+&
              (MCS.controllerLinear controllerTimbre0 (0.5,9.5) 1.5
               &+&
               frequencyControlString))

       sampled smp rate vel freq =
          smp rate vel freq
          <<<
          Zip.arrowSecond frequencyControlPercussive

       helixed smp rate vel freq =
          smp rate vel freq
          <<<
          Zip.arrowSecond
             (MCS.controllerExponential Ctrl.attackTime (0.25, 4) 1
              &+&
              frequencyControlPercussive)

       bank =
          Map.fromAscList $ zip [VoiceMsg.toProgram 0 ..] $
          [tineProc, pingProc, filterSawProc, bellNoiseProc,
           stringProc, fmStringProc, helixNoiseProc] ++
          map makeArc arcs ++ windProc : windPhaserProc :
          ([helixed . helixSound, sampled . sampledSound] <*> syllables)

   return $ \chan initPgm rate ->
      arrange
      <<<
      arr shortTime
      <<<
      MIO.sequenceModulatedMultiProgram chan initPgm
         (\pgm -> Map.findWithDefault pingProc pgm bank rate)
      <<<
      id &+& MCS.fromChannel chan


keyboardMultiChannel ::
   (Check.C msg) =>
   FilePath ->
   IO (SampleRate Real ->
       PIO.T (MIO.Events msg) (SV.Vector (Stereo.T Real)))
keyboardMultiChannel smpDir = do
   proc <-
      keyboardDetuneFMCore
         (CausalP.mapSimple StereoInt.interleave)
         smpDir
   mix <- CausalP.processIO CausalP.mix

   return $ \ sampleRate ->
      arr SigStL.unpackStereoStrict
      <<<
      foldl1
         (\x y -> mix () <<< Zip.arrowFanout x y)
         (map
             (\chan ->
                proc (ChannelMsg.toChannel chan) (VoiceMsg.toProgram 0)
                     sampleRate)
             [0 .. 3])



data Phoneme = Phoneme Bool VoiceMsg.Velocity VoiceMsg.Pitch

instance Check.C Phoneme where
   note _chan (Phoneme on v p) = Just (v, p, on)


voderSplit ::
   (Check.C msg, Construct.C msg, Arrow arrow) =>
   ChannelMsg.Channel ->
   arrow
      (MIO.Events msg)
      (Zip.T
          (MIO.Events Phoneme)
          (MIO.Events msg))
voderSplit chan =
   arr $
   uncurry Zip.Cons .
   EventListTT.unzip .
   fmap
      (ListHT.unzipEithers .
       fmap (\ev ->
          case Check.note chan ev of
             Nothing -> Right ev
             Just (v,p,b) ->
                if p >= VoiceMsg.toPitch 36
                  then
                     let p0 = VoiceMsg.increasePitch (-36) p
                     in  if p0 <= VoiceMsg.toPitch 29
                           then Left $ Phoneme b v p0
                           else Right $ Construct.note chan
                                   (v, VoiceMsg.increasePitch (-12) p, b)
                  else Right ev))

voder ::
   (Check.C msg, Construct.C msg, POut.Default b) =>
   CausalP.T () (Stereo.T VectorValue) (POut.Element b) ->
   Speech.VowelSynth ->
   FilePath ->
   IO (ChannelMsg.Channel -> VoiceMsg.Program ->
       SampleRate Real -> PIO.T (MIO.Events msg) b)
voder emitStereo voice smpDir = do
   carrier <- keyboardDetuneFMCore id smpDir
   arrange <- CausalSt.makeArranger
   interleave <- CausalP.processIO emitStereo

   return $ \chan initPgm sampleRate ->
      interleave ()
      <<<
      arrange
      <<<
      arr shortTime
      <<<
      MIO.sequenceModulatedMultiProgramVelocityPitch
         chan (VoiceMsg.toProgram 0)
         (\ _pgm _vel -> voice sampleRate)
      <<<
      Zip.arrowSecond (carrier chan initPgm sampleRate)
      <<<
      voderSplit chan

voderBand ::
   (Check.C msg, Construct.C msg, POut.Default b) =>
   CausalP.T () (Stereo.T VectorValue) (POut.Element b) ->
   FilePath ->
   IO (ChannelMsg.Channel -> VoiceMsg.Program ->
       SampleRate Real -> PIO.T (MIO.Events msg) b)
voderBand emitStereo smpDir = do
   voice <- Speech.vowelBand
   voder emitStereo voice smpDir

voderMask ::
   (Check.C msg, Construct.C msg, POut.Default b) =>
   CausalP.T () (Stereo.T VectorValue) (POut.Element b) ->
   FilePath ->
   IO (ChannelMsg.Channel -> VoiceMsg.Program ->
       SampleRate Real -> PIO.T (MIO.Events msg) b)
voderMask emitStereo smpDir = do
   voice <-
      Speech.vowelMask <*>
      fmap
         (Map.mapMaybe (\(typ,smp) ->
            toMaybe (typ==Speech.Filtered Speech.Continuous Speech.Voiced) smp))
         Speech.loadMasksKeyboard
   voder emitStereo voice smpDir


voderEnv ::
   (Check.C msg, Construct.C msg, POut.Default b) =>
   CausalP.T () (Stereo.T VectorValue) (POut.Element b) ->
   Speech.VowelSynthEnv ->
   FilePath ->
   IO (ChannelMsg.Channel -> VoiceMsg.Program ->
       SampleRate Real -> PIO.T (MIO.Events msg) b)
voderEnv emitStereo voice smpDir = do
   carrier <- keyboardDetuneFMConstVolume smpDir
   arrange <- CausalSt.makeArranger
   amp <-
      CausalP.processIO
         (emitStereo <<<
          CausalP.envelopeStereo <<<
          first (CausalP.mapSimple Serial.upsample))

   return $ \chan initPgm sampleRate ->
      amp ()
      <<<
      MIO.controllerExponential chan controllerVolume (0.001, 1) (0.2::Float)
      &+&
      (arrange
       <<<
       arr shortTime
       <<<
       MIO.sequenceModulatedMultiProgramVelocityPitch
          chan (VoiceMsg.toProgram 0)
          (\ _pgm vel -> voice sampleRate (MV.velocity vel))
       <<<
       Zip.arrowSecond
          (Zip.arrowFanout
             (timeControlString <<< MCS.fromChannel chan)
             (carrier chan initPgm sampleRate))
       <<<
       voderSplit chan)

voderMaskEnv ::
   (Check.C msg, Construct.C msg, POut.Default b) =>
   CausalP.T () (Stereo.T VectorValue) (POut.Element b) ->
   FilePath ->
   IO (ChannelMsg.Channel -> VoiceMsg.Program ->
       SampleRate Real -> PIO.T (MIO.Events msg) b)
voderMaskEnv emitStereo smpDir = do
   voice <- Speech.phonemeMask <*> Speech.loadMasksKeyboard
   voderEnv emitStereo voice smpDir


voderSeparated ::
   (Check.C msg, Construct.C msg, POut.Default b) =>
   CausalP.T (SampleRate Real) (Stereo.T VectorValue) (POut.Element b) ->
   Speech.VowelSynthEnv ->
   FilePath ->
   IO (ChannelMsg.Channel -> ChannelMsg.Channel -> VoiceMsg.Program ->
       SampleRate Real -> PIO.T (MIO.Events msg) b)
voderSeparated emitStereo voice smpDir = do
   carrier <- keyboardDetuneFMCore id smpDir
   arrange <- CausalSt.makeArranger
   amp <-
      CausalP.processIO
         (emitStereo <<<
          CausalP.envelopeStereo <<<
          first (CausalP.mapSimple Serial.upsample))

   return $ \carrierChan phonemeChan initPgm sampleRate ->
      amp sampleRate
      <<<
      MIO.controllerExponential phonemeChan controllerVolume (0.001, 1) (0.2::Float)
      &+&
      (arrange
       <<<
       arr shortTime
       <<<
       MIO.sequenceModulatedMultiProgramVelocityPitch
          phonemeChan (VoiceMsg.toProgram 0)
          (\ _pgm vel -> voice sampleRate (MV.velocity vel))
       <<<
       Zip.arrowFanout id
          (Zip.arrowFanout
             (timeControlString <<< MCS.fromChannel phonemeChan)
             (carrier carrierChan initPgm sampleRate)))

voderMaskSeparated ::
   (Check.C msg, Construct.C msg, POut.Default b) =>
   CausalP.T (SampleRate Real) (Stereo.T VectorValue) (POut.Element b) ->
   FilePath ->
   IO (ChannelMsg.Channel -> ChannelMsg.Channel -> VoiceMsg.Program ->
       SampleRate Real -> PIO.T (MIO.Events msg) b)
voderMaskSeparated emitStereo smpDir = do
   voice <- Speech.phonemeMask <*> Speech.loadMasksGrouped
   voderSeparated emitStereo voice smpDir

voderMaskMulti ::
   (Check.C msg, Construct.C msg) =>
   FilePath ->
   IO (SampleRate Real ->
       PIO.T (MIO.Events msg) (SV.Vector (Stereo.T Real)))
voderMaskMulti smpDir = do
   mix <- CausalP.processIO CausalP.mix
   proc <-
      voderMaskSeparated
         (CausalP.mapSimple StereoInt.interleave)
         smpDir

   return $ \ sampleRate ->
      arr SigStL.unpackStereoStrict
      <<<
      foldl1
         (\x y -> mix () <<< Zip.arrowFanout x y)
         (map
             (\chan ->
                proc
                   (ChannelMsg.toChannel chan)
                   (ChannelMsg.toChannel $ succ chan)
                   (VoiceMsg.toProgram 4)
                   sampleRate)
             [0, 2, 4, 6])