Run.hs

module Synthesizer.LLVM.Server.Packed.Run where

import qualified Synthesizer.LLVM.Server.Packed.Instrument as Instr
import qualified Synthesizer.LLVM.Server.Option as Option
import Synthesizer.LLVM.Server.Packed.Instrument
          (Vector, VectorSize, vectorSize, )
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.StereoInterleaved as StereoInt
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 Data.StorableVector.Lazy as SVL

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

import qualified Sound.MIDI.Controller as Ctrl
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 Algebra.IntegralDomain (divUp, )

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



vectorChunkSize :: Option.T -> SVL.ChunkSize
vectorChunkSize opts =
   case Option.chunkSize opts of
      SVL.ChunkSize size ->
         SVL.ChunkSize (divUp size vectorSize)

sampleRate :: Num a => Option.T -> a
sampleRate opt =
   case Option.sampleRate opt of
      SampleRate sr -> sr


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


type StereoVector = StereoInt.T VectorSize Real

{-# INLINE withMIDIEventsStereo #-}
withMIDIEventsStereo ::
   Option.T ->
   (Option.T -> Double -> SigSt.T (Stereo.T Real) -> IO b) ->
   (EventList.T Ev.StrictTime [Event.T] -> SigSt.T StereoVector) ->
   IO b
withMIDIEventsStereo opt action proc =
   let rate = sampleRate opt
   in  do
          putStrLn startMessage
          Ev.withMIDIEvents
             (Option.clientName opt)
             (Option.periodTime opt) (rate / fromIntegral vectorSize) $
                action opt rate . SigStL.unpackStereo . 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
   opt <- Option.get
   osc <-
      SigP.runChunky
         ((CausalPS.osciSimple WaveL.triangle $<# (LLVM.vector [zero] :: Vector))
           $* Instr.frequencyFromBendModulation
                 (frequencyConst 10)
                 (Instr.modulation (\fm -> (fm,880))))
   withMIDIEventsMono opt play $
      osc (vectorChunkSize opt) . (,) (Option.sampleRate opt) .
      evalState (PC.bendWheelPressure (Option.channel opt) 2 0.04 (0.03::Real))



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

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


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

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


controllerAttack, controllerDetune, controllerTimbre0, controllerTimbre1,
   controllerFilterCutoff, controllerFilterResonance,
   controllerVolume :: VoiceMsg.Controller
controllerAttack = Ctrl.attackTime
controllerDetune = Ctrl.chorusDepth   -- Ctrl.effect3Depth
controllerTimbre0 = Ctrl.soundVariation
controllerTimbre1 = Ctrl.timbre
controllerFilterCutoff = Ctrl.effect4Depth
controllerFilterResonance = Ctrl.effect5Depth
controllerVolume = Ctrl.volume

controllerFMDepth1, controllerFMDepth2, controllerFMDepth3, controllerFMDepth4,
   controllerFMPartial1, controllerFMPartial2, controllerFMPartial3, controllerFMPartial4
   :: VoiceMsg.Controller
controllerFMDepth1 = Ctrl.soundController3
controllerFMDepth2 = Ctrl.soundController5
controllerFMDepth3 = Ctrl.soundController7
controllerFMDepth4 = Ctrl.soundController8
controllerFMPartial1 = Ctrl.generalPurpose1
controllerFMPartial2 = Ctrl.generalPurpose2
controllerFMPartial3 = Ctrl.effect1Depth
controllerFMPartial4 = Ctrl.effect2Depth

keyboardDetuneFMCore ::
   FilePath ->
   SVL.ChunkSize ->
   IO (ChannelMsg.Channel -> VoiceMsg.Program ->
       SampleRate Real ->
       Ev.Filter (SigSt.T StereoVector))
keyboardDetuneFMCore smpDir vcsize = 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 smpDir Instr.tomatensalat
   hal0 <- Instr.makeSampledSounds smpDir Instr.hal
   grp0 <- Instr.makeSampledSounds smpDir Instr.graphentheorie

   let evHead =
          fmap (EventListMT.switchBodyL
             (error "empty controller stream") const)
       flt = evalState $
          liftA6 (\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)
             (pure vcsize)
             (PCS.bendWheelPressure 2 0.04 0.03)
       png =
          (\rel -> png0 (4*rel) rel vcsize) .
          evalState
             (evHead $
              PCS.controllerExponential controllerAttack (0.03,0.3) 0.1)
       pngFM = evalState $
          liftA6 (\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 (1/pi,0.001) 0.05)
             (pure vcsize)
             (PCS.bendWheelPressure 2 0.04 0.03)
       sqr = evalState $
          liftA6 (\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 (1/pi,0.001) 0.05)
             (PCS.controllerLinear controllerTimbre1 (0,0.25) 0.25)
             (pure vcsize)
             (PCS.bendWheelPressure 2 0.04 0.03)
       tin = evalState $
          liftA3 (\rel -> tin0 (4*rel) rel)
             (evHead $
              PCS.controllerExponential controllerAttack (0.03,0.3) 0.1)
             (pure vcsize)
             (PCS.bendWheelPressure 2 0.04 0.03)
       tnc = evalState $
          liftA6 (\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)
             (pure vcsize)
             (PCS.bendWheelPressure 2 0.04 0.03)
       fnd = evalState $
          pure (\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)
             <*> (pure vcsize)
             <*> (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)
             <*> (pure vcsize)
             <*> (PCS.bendWheelPressure 2 0.04 0.03)
       rfm = evalState $
          pure (\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)
             <*> (pure vcsize)
             <*> (PCS.bendWheelPressure 2 0.04 0.03)
       bel = evalState $
          liftA4 (\rel -> bel0 (2*rel) rel)
             (evHead $
              PCS.controllerExponential controllerAttack (0.03,1.0) 0.3)
             (PCS.controllerLinear controllerDetune (0,0.005) 0.001)
             (pure vcsize)
             (PCS.bendWheelPressure 2 0.05 0.02)
       ben = evalState $
          liftA5 (\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)
             (pure vcsize)
             (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 (1/pi,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 $
          liftA6
             (\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 (1/pi,0.001) 0.05)
             (evHead $
              PCS.controllerLinear controllerTimbre1 (1,5) 3)
             (pure vcsize)
             (PCS.bendWheelPressure 2 0.04 0.03)
       freqMod =
          evalState
             (PCS.bendWheelPressure 2 0.04 0.03)

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

         ctrls <- PCS.fromChannel chan

         fmap (amp volume . arrange vcsize) $
            Gen.sequenceModulatedMultiProgram
               ctrls chan pgm
               (map (\sound fm -> sound fm $ sr) $
                [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
   opt <- Option.get
   proc <- keyboardDetuneFMCore (Option.sampleDirectory opt) (vectorChunkSize opt)
   withMIDIEventsStereo opt play $
      evalState (proc (Option.channel opt) (VoiceMsg.toProgram 0) (Option.sampleRate opt))

keyboardFilter :: IO ()
keyboardFilter = do
   opt <- Option.get
   proc <- keyboardDetuneFMCore (Option.sampleDirectory opt) (vectorChunkSize opt)
   mix <- CausalP.runStorableChunky
      (CausalP.mapSimple StereoInt.interleave <<<
       CausalP.mix <<<
            first (CausalPS.amplifyStereo 0.5 <<<
                   CausalP.mapSimple StereoInt.deinterleave)
         $< 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)))
      <<<
      CausalP.mapSimple StereoInt.deinterleave
   let lowpass ::
          PC.T Real -> PC.T Real ->
          SigSt.T StereoVector -> SigSt.T (Stereo.T Vector)
       lowpass resons freqs =
          lowpass0 (fmap UniFilter.parameter
             (PC.zipWith FiltR.Pole resons
                (fmap (/ sampleRate opt) freqs)))

   withMIDIEventsStereo opt play $
      evalState
         (do {-
             It is important to retrieve the global controllers
             before they are filtered out by PCS.fromChannel.
             -}
             let freqBnd v = 880 * 2^?(v/24)
             freq <-
                PC.controllerExponential (Option.extraChannel opt)
                   controllerFilterCutoff
                   (freqBnd (-64), freqBnd 63) 5000
             resonance <-
                PC.controllerExponential (Option.extraChannel opt)
                   controllerFilterResonance
                   (1, 100) 1
             filterMusic <-
                proc (Option.extraChannel opt) (VoiceMsg.toProgram 8) (Option.sampleRate opt)
             pureMusic <-
                proc (Option.channel opt) (VoiceMsg.toProgram 0) (Option.sampleRate opt)
             return
                (pureMusic `mix`
                 lowpass resonance freq filterMusic))