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

import Synthesizer.EventList.ALSA.MIDI

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 Synthesizer.State.Signal       as SigS
import qualified Synthesizer.State.Oscillator   as OsciS
import qualified Synthesizer.State.Displacement as DispS
import qualified Synthesizer.State.Filter.NonRecursive as FiltNRS
import qualified Synthesizer.Basic.Wave         as Wave

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

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 Numeric.NonNegative.Class   as NonNeg
import qualified Numeric.NonNegative.Wrapper as NonNegW
import qualified Numeric.NonNegative.Chunky as NonNegChunky

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

import Control.Monad.Trans.State (State, evalState, state, modify, gets, )
import Control.Monad (liftM, )

import PreludeBase
import NumericPrelude
import Prelude ()



{-
readMIDIController ::
   Storable a =>
   Int -> Int -> Int -> IO (SigSt.T a)
readMIDIController chunkSize sampleRate ctrl =
   withInPort ALSA.Block $ \ h _p ->
   do let loop = do putStrLn "waiting for an event:"
                    e <- ALSA.event_input h
                    print e
                    loop
      loop
      return SigSt.empty
-}

chunkSizesFromLazyTime :: LazyTime -> NonNegChunky.T SigSt.ChunkSize
chunkSizesFromLazyTime =
   NonNegChunky.fromChunks .
   map (SVL.ChunkSize . fromInteger . NonNegW.toNumber) .
   NonNegChunky.toChunks .
   NonNegChunky.normalize


{-# INLINE controllerValuesToSignal #-}
controllerValuesToSignal ::
   (Storable y) =>
   y -> EventListTT.T LazyTime y -> SigSt.T y
controllerValuesToSignal initial =
   EventListBT.foldrPair
      (\y t -> SigSt.append (SigStV.replicate (chunkSizesFromLazyTime t) y)) SigSt.empty .
   EventListMT.consBody initial


{-# INLINE controllerValueToSample #-}
controllerValueToSample ::
   (Field.C y) =>
   (y,y) -> Int -> y
controllerValueToSample (lower,upper) n =
   let k = fromIntegral n / 127
   in  (1-k) * lower + k * upper

{-# INLINE getControllerSignal #-}
getControllerSignal ::
   (Storable y, Field.C y) =>
   Channel -> Controller ->
   (y,y) -> y ->
   Filter (SigSt.T y)
getControllerSignal chan ctrl bnd initial =
   liftM (controllerValuesToSignal initial .
          EventListTT.mapBody (controllerValueToSample bnd)) $
   getControllerEvents chan ctrl


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

{-# INLINE getControllerSignalExp #-}
getControllerSignalExp ::
   (Storable y, Trans.C y) =>
   Channel -> Controller ->
   (y,y) -> y ->
   Filter (SigSt.T y)
getControllerSignalExp chan ctrl bnd initial =
   liftM (controllerValuesToSignal initial .
          EventListTT.mapBody (controllerValueToSampleExp bnd)) $
   getControllerEvents chan ctrl


{-# INLINE pitchBendValueToSample #-}
pitchBendValueToSample ::
   (Trans.C y) =>
   y -> y -> Int -> y
pitchBendValueToSample range center n =
   center * 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) =>
   Channel ->
   y -> y ->
   Filter (SigSt.T y)
getPitchBendSignal chan range center =
   liftM (controllerValuesToSignal center .
          EventListTT.mapBody (pitchBendValueToSample range center)) $
   getSlice (maybePitchBend chan)
--   getPitchBendEvents chan

{-# INLINE getChannelPressureSignal #-}
getChannelPressureSignal ::
   (Storable y, Trans.C y) =>
   Channel ->
   y -> y ->
   Filter (SigSt.T y)
getChannelPressureSignal chan maxVal initVal =
   liftM (controllerValuesToSignal initVal .
          EventListTT.mapBody (controllerValueToSample (0,maxVal))) $
   getSlice (maybeChannelPressure chan)


{-# INLINE getFMSignalFromBendWheelPressure #-}
getFMSignalFromBendWheelPressure ::
   (Storable y, RealField.C y, Trans.C y) =>
   Channel ->
   Int -> y -> y -> y ->
   Filter (SigSt.T y)
getFMSignalFromBendWheelPressure chan
     pitchRange speed wheelDepth pressDepth =
   do bend  <- getPitchBendSignal chan (2^?(fromIntegral pitchRange/12)) 1
      fm    <- getControllerSignal chan VoiceMsg.modulation (0,wheelDepth) 0
      press <- getChannelPressureSignal chan pressDepth 0
      return $
         flip (SigS.zipWithStorable (*)) bend $
         SigS.map (1+) $
         FiltNRS.envelope
            (DispS.mix
               (SigS.fromStorableSignal fm)
               (SigS.fromStorableSignal press))
            (OsciS.static Wave.sine zero speed)


type Instrument y yv = y -> y -> LazyTime -> SigSt.T yv
type Bank y yv = Program -> Instrument y yv

renderInstrument ::
   (Trans.C y) =>
   Bank y yv ->
   Note ->
   SigSt.T yv
renderInstrument instrument (Note pgm pitch vel dur) =
   instrument pgm
      (fromIntegral (VoiceMsg.fromVelocity vel - 64)/63)
      {- This is the default tuning according to MIDI 1.0 Detailed Specification -}
      (440 * 2 ^? (fromIntegral (VoiceMsg.fromPitch pitch + 3 - 6*12) / 12))
      dur

renderInstrumentIgnoreProgram ::
   (Trans.C y) =>
   Instrument y yv ->
   Note ->
   SigSt.T yv
renderInstrumentIgnoreProgram instrument =
   renderInstrument (const instrument)

{- |
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
-}
makeInstrumentSounds ::
   (Trans.C y) =>
   Instrument y yv ->
   EventListTT.T time Note ->
   EventListTT.T time (SigSt.T yv)
makeInstrumentSounds instrument =
   EventListTT.mapBody (renderInstrument (const instrument))


{- |
Turn an event list with lazy times
to an event list with strict times.
This is much like the version we started on.
We could avoid this function with a more sophisticated version of 'arrange'.
-}
insertBreaksGen ::
   signal ->
   EventListTT.T LazyTime   signal ->
   EventListTT.T StrictTime signal
insertBreaksGen empty =
   EventListTT.foldr
      (\lt r ->
         {- uncurry matches lazy, thus the constructor represented by consTime
            can be generated before the particular time is known -}
         uncurry EventListMT.consTime $
         case NonNegChunky.toChunks (NonNegChunky.normalize lt) of
            [] -> (0, r)
            (t:ts) ->
               (,) t $
               foldr (\dt ->
                   EventListMT.consBody empty .
                   EventListMT.consTime dt) r ts)
      EventListMT.consBody
      EventListBT.empty

insertBreaks ::
   (Storable y) =>
   EventListTT.T LazyTime   (SigSt.T y) ->
   EventListTT.T StrictTime (SigSt.T y)
insertBreaks =
   insertBreaksGen SigSt.empty

{-# INLINE getNoteSignalCore #-}
getNoteSignalCore ::
   (Storable yv, Additive.C yv) =>
   SVL.ChunkSize ->
   Channel ->
   Program ->
   (EventListTT.T LazyTime Note ->
    EventListTT.T LazyTime (SigSt.T yv)) ->
   Filter (SigSt.T yv)
getNoteSignalCore chunkSize chan initPgm modulator =
   fmap (CutSt.arrangeEquidist chunkSize .
         EventListTM.switchTimeR const .
         EventListTT.mapTime fromIntegral .
         insertBreaks .
         modulator .
         matchNoteEvents .
         embedPrograms initPgm) $
   getNoteEvents chan


errorNoProgram :: Program
errorNoProgram =
   error "MIDI program not initialized"

{-# INLINE getNoteSignal #-}
getNoteSignal ::
   (Storable yv, Additive.C yv, Trans.C y) =>
   SVL.ChunkSize ->
   Channel ->
   Instrument y yv ->
   Filter (SigSt.T yv)
getNoteSignal chunkSize chan instr =
   getNoteSignalCore chunkSize chan errorNoProgram (makeInstrumentSounds instr)


{-# INLINE getNoteSignalModulated #-}
getNoteSignalModulated ::
   (Storable c, Storable yv, Additive.C yv, Trans.C y) =>
   SVL.ChunkSize ->
   SigSt.T c ->
   Channel ->
   (SigSt.T c -> Instrument y yv) ->
   Filter (SigSt.T yv)
getNoteSignalModulated chunkSize ctrl chan instr =
   getNoteSignalCore chunkSize chan errorNoProgram
   (flip evalState ctrl .
    EventListTT.mapM
       advanceModulationChunky
       (\note -> gets $ \c -> renderInstrumentIgnoreProgram (instr c) note))


{-# INLINE getNoteSignalMultiModulated #-}
getNoteSignalMultiModulated ::
   (Storable yv, Additive.C yv, Trans.C y) =>
   SVL.ChunkSize ->
   Channel ->
   instrument ->
   (EventListTT.T LazyTime (instrument, Note) ->
    EventListTT.T LazyTime (Instrument y yv, Note)) ->
   Filter (SigSt.T yv)
getNoteSignalMultiModulated chunkSize chan instr modulator =
   getNoteSignalCore chunkSize chan errorNoProgram
      (EventListTT.mapBody (uncurry renderInstrumentIgnoreProgram) .
       modulator .
       EventListTT.mapBody ((,) instr))

applyModulation ::
   (Storable c) =>
   SigSt.T c ->
   EventListTT.T LazyTime (SigSt.T c -> instr, note) ->
   EventListTT.T LazyTime (instr, note)
applyModulation ctrl =
   flip evalState ctrl .
   EventListTT.mapM
      advanceModulationChunky
      (\(instr,note) -> gets $ \c -> (instr c, note))

evaluateVectorHead ::
   (Storable a) =>
   SigSt.T a -> t -> t
evaluateVectorHead xs t =
   if SigSt.null xs then t else t

advanceModulationLazy, advanceModulationStrict, advanceModulationChunky ::
   (Storable a) =>
   LazyTime -> State (SigSt.T a) LazyTime

{-
This one drops lazily,
such that the control signal will be cached until it is used.
That is, if for a long time no new note is played,
more and more memory will be allocated.
-}
advanceModulationLazy t =
   modify (SigStV.drop (chunkSizesFromLazyTime t)) >> return t

{-
This one is too strict,
because the complete drop is forced
also if only the first chunk of the lazy time is requested.
-}
advanceModulationStrict t = state $ \xs ->
   let ys = SigStV.drop (chunkSizesFromLazyTime t) xs
   in  (evaluateVectorHead ys t, ys)

advanceModulationChunky =
   liftM NonNegChunky.fromChunks .
   mapM advanceModulationChunk .
   NonNegChunky.toChunks

advanceModulationChunk ::
   (Storable a) =>
   NonNegW.Integer -> State (SigSt.T a) NonNegW.Integer
advanceModulationChunk t = state $ \xs ->
   let ys = SigSt.drop (fromIntegral t) xs
   in  (evaluateVectorHead ys t, ys)


{-# INLINE getNoteSignalMultiProgram #-}
getNoteSignalMultiProgram ::
   (Storable yv, Additive.C yv, Trans.C y) =>
   SVL.ChunkSize ->
   Channel ->
   Program ->
   [Instrument y yv] ->
   Filter (SigSt.T yv)
getNoteSignalMultiProgram chunkSize chan initPgm instrs =
   let bank = makeInstrumentArray instrs
   in  getNoteSignalCore chunkSize chan initPgm
          (EventListTT.mapBody (renderInstrument
              (getInstrumentFromArray bank initPgm)))