module Synthesizer.LLVM.Server.Packed.Run where

import qualified Synthesizer.LLVM.Server.Packed.Instrument as Instr
import Synthesizer.LLVM.Server.Packed.Instrument
          (Vector, vectorSize, vectorChunkSize, )
import Synthesizer.LLVM.Server.Common

import qualified Sound.ALSA.Sequencer.Event as Event
import qualified Synthesizer.EventList.ALSA.MIDI as Ev
import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC
import qualified Synthesizer.PiecewiseConstant.ALSA.MIDIControllerSet as PCS
import qualified Synthesizer.Generic.ALSA.MIDI as Gen

import qualified Synthesizer.LLVM.Frame.Stereo as Stereo

import qualified Synthesizer.LLVM.Filter.Universal as UniFilterL
import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS
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.Wave as WaveL
import Synthesizer.LLVM.CausalParameterized.Process (($<#), ($<), ($*), )
import Synthesizer.LLVM.Parameterized.Signal (($#), )

import qualified LLVM.Core as LLVM

import qualified Synthesizer.Storable.Signal      as SigSt

import qualified Synthesizer.Plain.Filter.Recursive    as FiltR
import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter

import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg
import qualified Sound.MIDI.Message.Channel       as ChannelMsg

import qualified Data.EventList.Relative.TimeBody  as EventList
import qualified Data.EventList.Relative.MixedTime as EventListMT

import Synthesizer.ApplicativeUtility (liftA4, liftA5, liftA6, )
import Control.Arrow ((<<<), (^<<), {- (<<^), -} (&&&), {- (***), -} arr, first, {- second, -} )
import Control.Applicative (pure, {- liftA, -} liftA2, liftA3, (<*>), )
import Control.Monad.Trans.State (evalState, )

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

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

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

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



{-# INLINE withMIDIEventsMono #-}
withMIDIEventsMono ::
   (Double -> Double -> SigSt.T Real -> IO b) ->
   (EventList.T Ev.StrictTime [Event.T] -> SigSt.T Vector) -> IO b
withMIDIEventsMono action proc =
   let rate = sampleRate
       per  = periodTime
   in  Ev.withMIDIEvents per (rate / fromIntegral vectorSize) $
       action per rate . SigStL.unpack . proc

{-# INLINE withMIDIEventsStereo #-}
withMIDIEventsStereo ::
   (Double -> Double -> SigSt.T (Stereo.T Real) -> IO b) ->
   (EventList.T Ev.StrictTime [Event.T] -> SigSt.T (Stereo.T Vector)) ->
   IO b
withMIDIEventsStereo action proc =
   let rate = sampleRate
       per  = periodTime
   in  do unpack <- SigStL.makeUnpackGeneric
          Ev.withMIDIEvents per (rate / fromIntegral vectorSize) $
             action per rate . unpack . proc


-- maybe this can be merged into a PCS.controllerDiscrete
stair :: Real -> Real
stair i =
   let n = fromIntegral (round i :: Int)
       r = i - n
   in  n + 0.01*r


frequencyModulation :: IO ()
frequencyModulation = do
   osc <-
      SigP.runChunky
         ((CausalPS.osciSimple WaveL.triangle $<# (LLVM.vector [zero] :: Vector))
           $* Instr.frequencyFromBendModulation 10 (arr id &&& pure 880))
   withMIDIEventsMono play $
      osc vectorChunkSize .
      evalState (PC.bendWheelPressure channel 2 0.04 (0.03::Real))



keyboard :: IO ()
keyboard = do
   sound <- Instr.pingRelease $/ 0.4 $/ 0.1
   amp <- CausalP.runStorableChunky (CausalPS.amplify $# 0.2)
   arrange <- SigStL.makeArranger
   withMIDIEventsMono play $
      (amp () :: SigSt.T Vector -> SigSt.T Vector) .
      evalState (Gen.sequence (arrange vectorChunkSize) channel sound)

keyboardStereo :: IO ()
keyboardStereo = do
   sound <- Instr.pingStereoRelease $/ 0.4 $/ 0.1
   amp <- CausalP.runStorableChunky (CausalP.amplifyStereo $# 0.2)
   arrange <- SigStL.makeArranger
   withMIDIEventsStereo play $
      (amp () :: SigSt.T (Stereo.T Vector) -> SigSt.T (Stereo.T Vector)) .
      evalState (Gen.sequence (arrange vectorChunkSize) channel sound)


keyboardFM :: IO ()
keyboardFM = do
   str <- Instr.softStringFM
   amp <- CausalP.runStorableChunky (CausalP.amplifyStereo $# 0.2)
   arrange <- SigStL.makeArranger
   withMIDIEventsStereo play $
      (amp () :: SigSt.T (Stereo.T Vector) -> SigSt.T (Stereo.T Vector)) .
      evalState
         (do fm <- PC.bendWheelPressure channel 2 0.04 0.03
             Gen.sequenceModulated (arrange vectorChunkSize) fm channel str)

keyboardFMMulti :: IO ()
keyboardFMMulti = do
   str <- Instr.softStringFM
   tin <- Instr.tineStereoFM $/ 0.4 $/ 0.1
   amp <- CausalP.runStorableChunky (CausalP.amplifyStereo $# 0.2)
   arrange <- SigStL.makeArranger
   withMIDIEventsStereo play $
      (amp () :: SigSt.T (Stereo.T Vector) -> SigSt.T (Stereo.T Vector)) .
      evalState
         (do fm <- PC.bendWheelPressure channel 2 0.04 0.03
             Gen.sequenceModulatedMultiProgram
                (arrange vectorChunkSize) fm channel
                (VoiceMsg.toProgram 1)
                [str, tin])


controllerAttack, controllerDetune, controllerTimbre0, controllerTimbre1,
   controllerFilterCutoff, controllerFilterResonance,
   controllerGlobal, controllerVolume :: VoiceMsg.Controller
[controllerAttack, controllerDetune, controllerTimbre0, controllerTimbre1,
   controllerFilterCutoff, controllerFilterResonance,
   controllerGlobal, controllerVolume] =
      map VoiceMsg.toController [21, 22, 23, 24, 91, 93, 82, 83]

controllerFMDepth1, controllerFMDepth2, controllerFMDepth3, controllerFMDepth4,
   controllerFMPartial1, controllerFMPartial2, controllerFMPartial3, controllerFMPartial4
   :: VoiceMsg.Controller
[controllerFMDepth1, controllerFMDepth2, controllerFMDepth3, controllerFMDepth4,
   controllerFMPartial1, controllerFMPartial2, controllerFMPartial3, controllerFMPartial4] =
      map VoiceMsg.toController [25, 26, 27, 28, 70, 71, 72, 73]

keyboardDetuneFMCore ::
   IO (ChannelMsg.Channel -> VoiceMsg.Program ->
       Ev.Filter (SigSt.T (Stereo.T Vector)))
keyboardDetuneFMCore = do
   str0 <- Instr.softStringDetuneFM
   ssh0 <- Instr.softStringShapeFM
   css0 <- Instr.cosineStringStereoFM
   asw0 <- Instr.arcSawStringStereoFM
   asn0 <- Instr.arcSineStringStereoFM
   asq0 <- Instr.arcSquareStringStereoFM
   atr0 <- Instr.arcTriangleStringStereoFM
   wnd0 <- Instr.wind
   wnp0 <- Instr.windPhaser
   fms0 <- Instr.fmStringStereoFM
   tin0 <- Instr.tineStereoFM
   tnc0 <- Instr.tineControlledFM
   fnd0 <- Instr.fenderFM
   tnb0 <- Instr.tineBankFM
   rfm0 <- Instr.resonantFMSynth
   png0 <- Instr.pingStereoRelease
   pngFM0 <- Instr.pingStereoReleaseFM
   sqr0 <- Instr.squareStereoReleaseFM
   bel0 <- Instr.bellStereoFM
   ben0 <- Instr.bellNoiseStereoFM
   flt0 <- Instr.filterSawStereoFM
   brs0 <- Instr.brass
   tmt0 <- Instr.makeSampledSounds Instr.tomatensalat
   hal0 <- Instr.makeSampledSounds Instr.hal
   grp0 <- Instr.makeSampledSounds Instr.graphentheorie

   let evHead =
          fmap (EventListMT.switchBodyL
             (error "empty controller stream") const)
       flt = evalState $
          liftA5 (\rel -> flt0 (4*rel) rel)
             (evHead $
              PCS.controllerExponential controllerAttack (0.03,0.3) 0.1)
             (PCS.controllerLinear controllerDetune (0,0.005) 0.001)
             (evHead $
              PCS.controllerExponential controllerTimbre0 (100,10000) 1000)
             (evHead $
              PCS.controllerExponential controllerTimbre1 (0.1,1) 0.1)
             (PCS.bendWheelPressure 2 0.04 0.03)
       png =
          (\rel -> png0 (4*rel) rel) .
          evalState
             (evHead $
              PCS.controllerExponential controllerAttack (0.03,0.3) 0.1)
       pngFM = evalState $
          liftA5 (\rel det phs shp -> pngFM0 (4*rel) rel det shp 2 phs)
             (evHead $
              PCS.controllerExponential controllerAttack (0.03,0.3) 0.1)
             (PCS.controllerLinear controllerDetune (0,0.005) 0.001)
             (evHead $
              PCS.controllerLinear controllerTimbre0 (0,1) 1)
             (PCS.controllerExponential controllerTimbre1 (0.3,0.001) 0.05)
             (PCS.bendWheelPressure 2 0.04 0.03)
       sqr = evalState $
          liftA5 (\rel -> sqr0 (4*rel) rel)
             (evHead $
              PCS.controllerExponential controllerAttack (0.03,0.3) 0.1)
             (PCS.controllerLinear controllerDetune (0,0.005) 0.001)
             (PCS.controllerExponential controllerTimbre0 (0.3,0.001) 0.05)
             (PCS.controllerLinear controllerTimbre1 (0,0.25) 0.25)
             (PCS.bendWheelPressure 2 0.04 0.03)
       tin = evalState $
          liftA2 (\rel -> tin0 (4*rel) rel)
             (evHead $
              PCS.controllerExponential controllerAttack (0.03,0.3) 0.1)
             (PCS.bendWheelPressure 2 0.04 0.03)
       tnc = evalState $
          liftA5 (\rel -> tnc0 (4*rel) rel)
             (evHead $
              PCS.controllerExponential controllerAttack (0.03,0.3) 0.1)
             (PCS.controllerLinear controllerDetune (0,0.005) 0.001)
             (fmap (fmap stair) $
              PCS.controllerLinear controllerTimbre0 (0.5,6.5) 2)
             (PCS.controllerLinear controllerTimbre1 (0,1.5) 1)
             (PCS.bendWheelPressure 2 0.04 0.03)
       fnd = evalState $
          liftA6 (\rel -> fnd0 (4*rel) rel)
             (evHead $
              PCS.controllerExponential controllerAttack (0.03,0.3) 0.1)
             (PCS.controllerLinear controllerDetune (0,0.005) 0.001)
             (fmap (fmap stair) $
              PCS.controllerLinear controllerTimbre0 (0.5,20.5) 14)
             (PCS.controllerLinear controllerTimbre1 (0,1.5) 0.3)
             (PCS.controllerLinear controllerFMDepth1 (0,1) 0.25)
             (PCS.bendWheelPressure 2 0.04 0.03)
       tnb = evalState $
          pure (\rel -> tnb0 (4*rel) rel)
             <*> (evHead $
              PCS.controllerExponential controllerAttack (0.03,0.3) 0.1)
             <*> (PCS.controllerLinear controllerDetune (0,0.005) 0.001)
             <*> (PCS.controllerLinear controllerFMDepth1 (0,2) 0)
             <*> (PCS.controllerLinear controllerFMDepth2 (0,2) 0)
             <*> (PCS.controllerLinear controllerFMDepth3 (0,2) 0)
             <*> (PCS.controllerLinear controllerFMDepth4 (0,2) 0)
             <*> (PCS.controllerLinear controllerFMPartial1 (0,1) 1)
             <*> (PCS.controllerLinear controllerFMPartial2 (0,1) 0)
             <*> (PCS.controllerLinear controllerFMPartial3 (0,1) 0)
             <*> (PCS.controllerLinear controllerFMPartial4 (0,1) 0)
             <*> (PCS.bendWheelPressure 2 0.04 0.03)
       rfm = evalState $
          liftA6 (\rel -> rfm0 (4*rel) rel)
             (evHead $
              PCS.controllerExponential controllerAttack (0.03,0.3) 0.1)
             (PCS.controllerLinear controllerDetune (0,0.005) 0.001)
             (PCS.controllerExponential controllerTimbre1 (1,100) 30)
             (PCS.controllerLinear controllerTimbre0 (1,15) 3)
             (PCS.controllerExponential controllerFMDepth1 (0.005,0.5) 0.1)
             (PCS.bendWheelPressure 2 0.04 0.03)
       bel = evalState $
          liftA3 (\rel -> bel0 (2*rel) rel)
             (evHead $
              PCS.controllerExponential controllerAttack (0.03,1.0) 0.3)
             (PCS.controllerLinear controllerDetune (0,0.005) 0.001)
             (PCS.bendWheelPressure 2 0.05 0.02)
       ben = evalState $
          liftA4 (\rel -> ben0 (2*rel) rel)
             (evHead $
              PCS.controllerExponential controllerAttack (0.03,1.0) 0.3)
             (PCS.controllerLinear controllerTimbre0 (0,1) 0.3)
             (PCS.controllerExponential controllerTimbre1 (1,1000) 100)
             (PCS.bendWheelPressure 2 0.05 0.02)
       str = evalState $
          liftA3 str0
             (evHead $
              PCS.controllerExponential controllerAttack (0.02,2) 0.5)
             (PCS.controllerLinear controllerDetune (0,0.01) 0.005)
             (PCS.bendWheelPressure 2 0.04 0.03)
       ssh = evalState $
          liftA4 ssh0
             (evHead $
              PCS.controllerExponential controllerAttack (0.02,2) 0.5)
             (PCS.controllerLinear controllerDetune (0,0.01) 0.005)
             (PCS.controllerExponential controllerTimbre0 (0.3,0.001) 0.05)
             (PCS.bendWheelPressure 2 0.04 0.03)
       makeArc gen = evalState $
          liftA4 gen
             (evHead $
              PCS.controllerExponential controllerAttack (0.02,2) 0.5)
             (PCS.controllerLinear controllerDetune (0,0.01) 0.005)
             (PCS.controllerLinear controllerTimbre0 (0.5,9.5) 1.5)
             (PCS.bendWheelPressure 2 0.04 0.03)
       css = makeArc css0
       asw = makeArc asw0
       asn = makeArc asn0
       asq = makeArc asq0
       atr = makeArc atr0
       fms = evalState $
          liftA5 fms0
             (evHead $
              PCS.controllerExponential controllerAttack (0.02,2) 0.5)
             (PCS.controllerLinear controllerDetune (0,0.01) 0.005)
             (PCS.controllerLinear controllerTimbre0 (0,0.5) 0.2)
             (PCS.controllerExponential controllerTimbre1 (0.001,10) 0.1)
             (PCS.bendWheelPressure 2 0.04 0.03)
       wnd = evalState $
          liftA3 wnd0
             (evHead $
              PCS.controllerExponential controllerAttack (0.02,2) 0.5)
             (PCS.controllerExponential controllerTimbre1 (1,1000) 100)
             (PCS.bendWheelPressure 12 0.8 0)
       wnp = evalState $
          liftA5 wnp0
             (evHead $
              PCS.controllerExponential controllerAttack (0.02,2) 0.5)
             (PCS.controllerLinear controllerTimbre0 (0,1) 0.5)
             (PCS.controllerExponential controllerDetune (50,5000) 500)
             (PCS.controllerExponential controllerTimbre1 (1,1000) 100)
             (PCS.bendWheelPressure 12 0.8 0)
       brs = evalState $
          liftA5
             (\rel det t0 peak -> brs0 (rel/2) 1.5 (rel/2) rel rel peak det t0)
             (evHead $
              PCS.controllerExponential controllerAttack (0.01,0.1) 0.01)
             (PCS.controllerLinear controllerDetune (0,0.01) 0.005)
             (PCS.controllerExponential controllerTimbre0 (0.3,0.001) 0.05)
             (evHead $
              PCS.controllerLinear controllerTimbre1 (1,5) 3)
             (PCS.bendWheelPressure 2 0.04 0.03)
       freqMod =
          evalState
             (PCS.bendWheelPressure 2 0.04 0.03)

   arrange <- SigStL.makeArranger
   amp <-
      CausalP.runStorableChunky
         (CausalP.envelopeStereo $<
            Instr.piecewiseConstantVector (arr id))
   return
      (\chan pgm -> do
         volume <-
            PC.controllerExponential chan
               controllerVolume
               (0.001, 1) 0.2

         ctrls <- PCS.fromChannel chan

         fmap (amp volume) $
            Gen.sequenceModulatedMultiProgram
               (arrange vectorChunkSize) ctrls chan pgm
               ([tnc, fnd, pngFM, flt, bel, ben, sqr, brs,
                 ssh, fms, css, asn, atr, asq, asw, wnp] ++
                map (.freqMod) tmt0 ++
                map (.freqMod) hal0 ++
                map (.freqMod) grp0 ++
                [str, wnd, png, rfm, tin, tnb]))


keyboardDetuneFM :: IO ()
keyboardDetuneFM = do
   proc <- keyboardDetuneFMCore
   withMIDIEventsStereo play $
      evalState (proc channel (VoiceMsg.toProgram 0))

keyboardFilter :: IO ()
keyboardFilter = do
   proc <- keyboardDetuneFMCore
   mix <- CausalP.runStorableChunky
      (CausalP.mixStereo <<< first (CausalPS.amplifyStereo 0.5)
         $< SigP.fromStorableVectorLazy (arr id))

   lowpass0 <-
      CausalP.runStorableChunky $
--      CausalPS.amplifyStereo 0.1 <<<
      CausalPS.pack
         (CausalP.stereoFromMonoControlled
             (UniFilter.lowpass ^<< UniFilterL.causalP) $<
          (SigP.interpolateConstant $# (fromIntegral vectorSize :: Real))
             (piecewiseConstant (arr id)))
   let lowpass ::
          PC.T Real -> PC.T Real ->
          SigSt.T (Stereo.T Vector) -> SigSt.T (Stereo.T Vector)
       lowpass resons freqs =
          lowpass0 (fmap UniFilter.parameter
             (PC.zipWith FiltR.Pole resons (fmap (/sampleRate) freqs)))

   withMIDIEventsStereo (playAndRecord "/gentoo/server-llvm.f32") $
--   withMIDIEventsStereo play $
      evalState
         (do {-
             It is important to retrieve the global controllers
             before they are filtered out by PCS.fromChannel.
             -}
             let altChannel = (ChannelMsg.toChannel 1)
             freq <-
                PC.controllerExponential altChannel
                   controllerFilterCutoff
                   (100, 5000) 5000
             resonance <-
                PC.controllerExponential altChannel
                   controllerFilterResonance
                   (1, 100) 1
             filterMusic <- proc altChannel (VoiceMsg.toProgram 8)
             pureMusic <- proc channel (VoiceMsg.toProgram 0)
             return
                (pureMusic `mix`
                 lowpass resonance freq filterMusic))