MIDI.hs

{- |
Convert MIDI events of a MIDI controller to a control signal.
-}
{-# LANGUAGE NoImplicitPrelude #-}
module Synthesizer.Dimensional.ALSA.MIDI where

import Synthesizer.EventList.ALSA.MIDI (Channel, Controller, Note(Note), Program, )
import qualified Synthesizer.EventList.ALSA.MIDI as AlsaEL
import qualified Synthesizer.Storable.ALSA.MIDI as AlsaSt

import qualified Sound.Alsa.Sequencer as ALSA

import qualified Synthesizer.Dimensional.Causal.Process    as Causal
import qualified Synthesizer.Dimensional.Causal.Filter     as Filt

import qualified Synthesizer.Dimensional.Rate as Rate
import qualified Synthesizer.Dimensional.Rate.Oscillator as OsciR
import qualified Synthesizer.Dimensional.Signal.Private as SigA
import qualified Synthesizer.Dimensional.Process as Proc
import qualified Synthesizer.Dimensional.Amplitude as Amp
import qualified Synthesizer.Dimensional.Amplitude.Displacement as DispA
import qualified Synthesizer.Dimensional.Amplitude.Filter as FiltA
import qualified Synthesizer.Dimensional.Wave as WaveD
-- import qualified Synthesizer.Dimensional.RateAmplitude.Cut as CutA

import qualified Synthesizer.Basic.Wave          as Wave

import Synthesizer.Dimensional.Causal.Process ((<<<), )
import Synthesizer.Dimensional.Process (($:), )

import qualified Synthesizer.ChunkySize as ChunkySize

import qualified Synthesizer.Generic.Signal       as SigG
import qualified Synthesizer.Storable.Cut         as CutSt
import qualified Synthesizer.Storable.Signal      as SigSt
-- import qualified Data.StorableVector.Lazy.Pattern as SigStV
import qualified Data.StorableVector.Lazy         as SVL

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

import qualified Data.EventList.Relative.TimeBody  as EventList
import qualified Data.EventList.Relative.TimeTime  as EventListTT
import qualified Data.EventList.Relative.TimeMixed as EventListTM
-- import qualified Data.EventList.Relative.MixedTime as EventListMT
-- import qualified Data.EventList.Relative.BodyTime  as EventListBT

import Foreign.Storable (Storable, )

-- import qualified Algebra.NonNegative as NonNeg
import qualified Number.NonNegative as NonNegW
import qualified Number.NonNegativeChunky as Chunky

-- import qualified Numeric.NonNegative.Class as NonNeg98
-- import qualified Numeric.NonNegative.Wrapper as NonNegW98
import qualified Numeric.NonNegative.Chunky as Chunky98

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

import qualified Algebra.Transcendental as Trans
import qualified Algebra.Module         as Module
import qualified Algebra.RealField      as RealField
import qualified Algebra.Field          as Field
import qualified Algebra.Additive       as Additive

import Control.Applicative (Applicative, pure, (<*>), liftA2, )
import Control.Monad.Trans.State (State, evalState, state, gets, )
import Control.Monad (liftM, )

import PreludeBase
import NumericPrelude
import Prelude (RealFrac, )


type Signal s v y yv =
   AmpSignal s (Amp.Dimensional v y) yv

type AmpSignal s amp yv =
   SigA.T (Rate.Phantom s) amp (SigSt.T yv)

{- |
This type ensures that all signals generated from the event list
share the same sample rate.
-}
newtype Filter s u t a =
   Filter (AlsaEL.Filter (Proc.T s u t a))

{-# INLINE runFilter #-}
runFilter ::
   EventList.T AlsaEL.StrictTime (Maybe ALSA.Event) ->
   Filter s u t a -> Proc.T s u t a
runFilter evs (Filter f) =
   evalState f evs

instance Functor (Filter s u t) where
   fmap f (Filter flt) =
      Filter (fmap (fmap f) flt)

instance Applicative (Filter s u t) where
   pure x = Filter (pure (pure x))
   Filter f <*> Filter x =
      Filter (liftA2 (<*>) f x)


{-# INLINE controllerValueToSample #-}
controllerValueToSample ::
   (Field.C y, Dim.C v) =>
   DN.T v y -> (DN.T v y, DN.T v y) -> Int -> y
controllerValueToSample amp (lower,upper) n =
   let k = fromIntegral n / 127
   in  DN.divToScalar (DN.scale (1-k) lower + DN.scale k upper) amp

{-# INLINE getControllerSignal #-}
getControllerSignal ::
   (Storable y, Field.C y, Ord y, Dim.C u, Dim.C v) =>
   Channel -> Controller ->
   (DN.T v y, DN.T v y) -> DN.T v y ->
   Filter s u t (Signal s v y y)
getControllerSignal chan ctrl bnd initial =
   Filter $
   liftM
      (let amp = max initial (uncurry max bnd)
       in  return . SigA.fromBody amp .
           AlsaSt.controllerValuesToSignal (DN.divToScalar initial amp) .
           EventListTT.mapBody (controllerValueToSample amp bnd)) $
   AlsaEL.getControllerEvents chan ctrl


{-# INLINE controllerValueToSampleExp #-}
controllerValueToSampleExp ::
   (Trans.C y, Dim.C v) =>
   DN.T v y -> (DN.T v y, DN.T v y) -> Int -> y
controllerValueToSampleExp amp (lower,upper) n =
   let k = fromIntegral n / 127
   in  DN.divToScalar lower amp ** (1-k) *
       DN.divToScalar upper amp ** k

{-# INLINE getControllerSignalExp #-}
getControllerSignalExp ::
   (Storable y, Trans.C y, Ord y, Dim.C u, Dim.C v) =>
   Channel -> Controller ->
   (DN.T v y, DN.T v y) -> DN.T v y ->
   Filter s u t (Signal s v y y)
getControllerSignalExp chan ctrl bnd initial =
   Filter $
   liftM
      (let amp = max initial (uncurry max bnd)
       in  return . SigA.fromBody amp .
           AlsaSt.controllerValuesToSignal (DN.divToScalar initial amp) .
           EventListTT.mapBody (controllerValueToSampleExp amp bnd)) $
   AlsaEL.getControllerEvents chan ctrl


{-# INLINE pitchBendValueToSample #-}
pitchBendValueToSample ::
   (Trans.C y, Dim.C v) =>
   DN.T v y -> y -> DN.T v y -> Int -> y
pitchBendValueToSample amp range center n =
   DN.divToScalar center amp * range ** (fromIntegral n / 8192)

{- |
@getPitchBendSignal channel range center@:
emits frequencies on an exponential scale from
@center/range@ to @center*range@.
-}
{-# INLINE getPitchBendSignal #-}
getPitchBendSignal ::
   (Storable y, Trans.C y, Ord y, Dim.C u, Dim.C v) =>
   Channel ->
   y -> DN.T v y ->
   Filter s u t (Signal s v y y)
getPitchBendSignal chan range center =
   Filter $
   liftM
      (let amp = DN.scale (max range (recip range)) center
       in  return . SigA.fromBody amp .
           AlsaSt.controllerValuesToSignal (DN.divToScalar center amp) .
           EventListTT.mapBody (pitchBendValueToSample amp range center)) $
   AlsaEL.getSlice (AlsaEL.maybePitchBend chan)
--   AlsaEL.getPitchBendEvents chan


{-# INLINE getChannelPressureSignal #-}
getChannelPressureSignal ::
   (Storable y, Trans.C y, Ord y, Dim.C u, Dim.C v) =>
   Channel ->
   DN.T v y -> DN.T v y ->
   Filter s u t (Signal s v y y)
getChannelPressureSignal chan maxVal initVal =
   Filter $
   liftM
      (return . SigA.fromBody maxVal .
       AlsaSt.controllerValuesToSignal (DN.divToScalar initVal maxVal) .
       EventListTT.mapBody (controllerValueToSample maxVal (zero,maxVal))) $
   AlsaEL.getSlice (AlsaEL.maybeChannelPressure chan)
--   AlsaEL.getPitchBendEvents chan


{-# INLINE getFMSignalFromBendWheelPressure #-}
getFMSignalFromBendWheelPressure ::
   (Storable q, RealField.C q, Trans.C q, Module.C q q, Dim.C u) =>
   Channel ->
   Int -> DN.T (Dim.Recip u) q -> q -> q ->
   Filter s u q (Signal s Dim.Scalar q q)
getFMSignalFromBendWheelPressure chan
     pitchRange speed wheelDepth pressDepth =
   pure
      (\bend fm press  osci env ->
         let modu =
                DispA.raise 1 $
                FiltA.envelope
                   osci
                   (DispA.mix
                      (SigA.restore fm)
                      (SigA.restore press))

         in  Causal.apply
                (env <<< Causal.feedSnd modu <<< Causal.canonicalizeFlat)
                bend)

    $: getPitchBendSignal chan (2^?(fromIntegral pitchRange/12)) (DN.scalar 1)
    $: getControllerSignal chan VoiceMsg.modulation (zero, DN.scalar wheelDepth) zero
    $: getChannelPressureSignal chan (DN.scalar pressDepth) 0

    $: Filter (return $ OsciR.static (WaveD.flat Wave.sine) zero speed)
    $: Filter (return $ Filt.envelope)


type LazyTime s = SigA.T (Rate.Phantom s) Amp.Abstract ChunkySize.T
-- type LazyTime s = SigA.T (Rate.Phantom s) Amp.Abstract SigStV.LazySize
-- type LazyTime s = SigA.T (Rate.Phantom s) Amp.Abstract AlsaEL.LazyTime

type Instrument s u v q y =
   ModulatedInstrument s u q (Signal s v q y)

type ModulatedInstrument s u q signal =
   q -> DN.T (Dim.Recip u) q ->
   Proc.T s u q (LazyTime s -> signal)

type Bank s u q signal =
   Program -> ModulatedInstrument s u q signal


{-# INLINE chunkySizeFromLazyTime #-}
chunkySizeFromLazyTime :: AlsaEL.LazyTime -> ChunkySize.T
chunkySizeFromLazyTime =
   Chunky.fromChunks .
   map (SigG.LazySize . fromInteger . NonNegW.toNumber) .
   Chunky98.toChunks .
   Chunky98.normalize


{-# INLINE renderInstrument #-}
renderInstrument ::
   (Trans.C q) =>
   Bank s Dim.Time q signal ->
   Note ->
   Proc.T s Dim.Time q signal
renderInstrument instrument (Note pgm pitch vel dur) =
   fmap ($ SigA.abstractFromBody $ chunkySizeFromLazyTime dur) $
   instrument pgm
      (fromIntegral (VoiceMsg.fromVelocity vel - 64)/63)
      {- This is the default tuning according to MIDI 1.0 Detailed Specification -}
      (DN.scale
         (2 ** (fromIntegral (VoiceMsg.fromPitch pitch + 3 - 6*12) / 12))
         (DN.frequency 440))

{- |
Instrument parameters are:
velocity from -1 to 1
(0 is the normal pressure, no pressure aka NoteOff is not supported),
frequency is given in Hertz
-}
{-# INLINE makeInstrumentSounds #-}
makeInstrumentSounds ::
   (Trans.C q) =>
   Bank s Dim.Time q signal ->
   EventListTT.T time Note ->
   Proc.T s Dim.Time q (EventListTT.T time signal)
makeInstrumentSounds bank =
   EventListTT.mapBodyM (renderInstrument bank)


{-# INLINE getNoteSignal #-}
getNoteSignal ::
   (RealFrac q, Storable y, Module.C q y, Trans.C q, Dim.C v) =>
   SVL.ChunkSize ->
   DN.T v q ->
   Channel ->
   Instrument s Dim.Time v q y ->
   Filter s Dim.Time q (Signal s v q y)
getNoteSignal chunkSize amp chan instr =
   fmap (renderNoteSignal chunkSize amp) $
   prepareTones chan AlsaSt.errorNoProgram (const instr)

{-
{-# INLINE getNoteSignal #-}
getNoteSignal ::
   (RealFrac q, Storable y, Module.C q y, Trans.C q, Dim.C v) =>
   SVL.ChunkSize ->
   DN.T v q ->
   Channel ->
   Instrument s Dim.Time v q y ->
   Filter (Proc.T s Dim.Time q (Signal s v q y))
getNoteSignal chunkSize amp chan instr =
   fmap ((CutA.arrangeStorableVolume undefined  {- chunkSize -} amp undefined $:) .
         fmap
            (EventListTM.switchTimeR const .
             EventListTT.mapTime fromIntegral .
             AlsaSt.insertBreaksGen (SigA.fromBody amp SigSt.empty)) .
         makeInstrumentSounds instr .
         AlsaEL.matchNoteEvents) $
   AlsaEL.getNoteEvents chan
-}


{-# INLINE getNoteSignalModulated #-}
getNoteSignalModulated ::
   (RealFrac q, Storable y, Storable c,
    Module.C q y, Trans.C q, Dim.C v) =>
   SVL.ChunkSize ->
   DN.T v q ->
   Channel ->
   ModulatedInstrument s Dim.Time q
      (AmpSignal s amp c -> Signal s v q y) ->
   Filter s Dim.Time q
      (AmpSignal s amp c -> Signal s v q y)
getNoteSignalModulated chunkSize amp chan instr =
   fmap (flip $ \ctrl ->
      renderNoteSignal chunkSize amp .
      applyModulation ctrl) $
   prepareTones chan AlsaSt.errorNoProgram (const instr)

{-# INLINE getNoteSignalModulated2 #-}
getNoteSignalModulated2 ::
   (RealFrac q, Storable y, Storable c0, Storable c1,
    Module.C q y, Trans.C q, Dim.C v) =>
   SVL.ChunkSize ->
   DN.T v q ->
   Channel ->
   ModulatedInstrument s Dim.Time q
      (AmpSignal s amp0 c0 -> AmpSignal s amp1 c1 -> Signal s v q y) ->
   Filter s Dim.Time q
      (AmpSignal s amp0 c0 -> AmpSignal s amp1 c1 -> Signal s v q y)
getNoteSignalModulated2 chunkSize amp chan instr =
   fmap (\evs ctrl0 ctrl1 ->
      renderNoteSignal chunkSize amp .
      applyModulation ctrl1 .
      applyModulation ctrl0
      $ evs) $
   prepareTones chan AlsaSt.errorNoProgram (const instr)


{-# INLINE getNoteSignalMultiModulated #-}
getNoteSignalMultiModulated ::
   (RealFrac q, Storable y,
    Module.C q y, Trans.C q, Dim.C v) =>
   SVL.ChunkSize ->
   DN.T v q ->
   Channel ->
   ModulatedInstrument s Dim.Time q instrument ->
   Filter s Dim.Time q
      (EventListTT.T AlsaEL.LazyTime instrument ->
       EventListTT.T AlsaEL.LazyTime (Signal s v q y)) ->
   Filter s Dim.Time q (Signal s v q y)
getNoteSignalMultiModulated chunkSize amp chan instr modu =
   fmap (renderNoteSignal chunkSize amp) $
   (modu $:
    prepareTones chan AlsaSt.errorNoProgram (const instr))

{-# INLINE prepareTones #-}
prepareTones ::
   (RealFrac q, Trans.C q) =>
   -- ToDo: use time value
   Channel ->
   Program ->
   Bank s Dim.Time q signal ->
   Filter s Dim.Time q (EventListTT.T AlsaEL.LazyTime signal)
prepareTones chan initPgm instr =
   Filter $
   fmap (makeInstrumentSounds instr .
         AlsaEL.matchNoteEvents .
         AlsaEL.embedPrograms initPgm) $
   AlsaEL.getNoteEvents chan

{-# INLINE applyModulation #-}
applyModulation ::
   (Storable y) =>
   AmpSignal s amp y ->
   EventListTT.T AlsaEL.LazyTime (AmpSignal s amp y -> body) ->
   EventListTT.T AlsaEL.LazyTime body
applyModulation ctrl =
   flip evalState ctrl .
   EventListTT.mapM advanceModulationChunky gets

{-# INLINE renderNoteSignal #-}
renderNoteSignal ::
   (Storable y, Module.C q y, Dim.C u, Field.C q) =>
   SVL.ChunkSize ->
   DN.T u q ->
   EventListTT.T AlsaEL.LazyTime (Signal s u q y) ->
   Signal s u q y
renderNoteSignal chunkSize amp =
   SigA.fromBody amp .
   CutSt.arrangeEquidist chunkSize .
   EventListTM.switchTimeR const .
   EventListTT.mapTime fromIntegral .
   AlsaSt.insertBreaks .
   EventListTT.mapBody (SigA.vectorSamples (flip DN.divToScalar amp))


{-# INLINE advanceModulationChunky #-}
advanceModulationChunky ::
   (Storable y) =>
   AlsaEL.LazyTime -> State (AmpSignal s amp y) AlsaEL.LazyTime
advanceModulationChunky =
   liftM Chunky98.fromChunks .
   mapM advanceModulationChunk .
   Chunky98.toChunks

{-# INLINE advanceModulationChunk #-}
advanceModulationChunk ::
   (Storable y) =>
   NonNegW.Integer -> State (AmpSignal s amp y) NonNegW.Integer
advanceModulationChunk t = state $ \xs ->
   let ys = SigA.processBody (SigSt.drop (fromIntegral t)) xs
   in  (AlsaSt.evaluateVectorHead (SigA.body ys) t, ys)


{-# INLINE getNoteSignalMultiProgram #-}
getNoteSignalMultiProgram ::
   (RealFrac q, Storable y, Module.C q y, Trans.C q, Dim.C v) =>
   SVL.ChunkSize ->
   DN.T v q ->
   Channel ->
   Program ->
--   Bank s Dim.Time q (Signal s v q y) ->
   [Instrument s Dim.Time v q y] ->
   Filter s Dim.Time q (Signal s v q y)
getNoteSignalMultiProgram chunkSize amp chan initPgm instrs =
   let bank = AlsaEL.makeInstrumentArray instrs
   in  fmap (renderNoteSignal chunkSize amp) $
       prepareTones chan initPgm $
       AlsaEL.getInstrumentFromArray bank initPgm