MIDI.hs

{- |
Convert MIDI events of a MIDI controller to a control signal.
-}
{-# LANGUAGE NoImplicitPrelude #-}
module Synthesizer.Storable.ALSA.MIDI (
   chunkSizesFromLazyTime,
   piecewiseConstant,
   piecewiseConstantInit,
   piecewiseConstantInitWith,
   controllerLinear,
   controllerExponential,
   pitchBend,
   channelPressure,
   bendWheelPressure,

   Instrument, Bank,
   sequenceCore,
   sequence,
   sequenceModulated,
   sequenceMultiModulated,
   applyModulation,
   advanceModulationLazy,
   advanceModulationStrict,
   advanceModulationChunky,
   sequenceMultiProgram,

   Gen.renderInstrument,
   Gen.renderInstrumentIgnoreProgram,
   Gen.evaluateVectorHead,
   Gen.advanceModulationChunk,
   ) where

import Synthesizer.EventList.ALSA.MIDI
          (LazyTime, StrictTime, Filter, Note,
           Program, Channel, Controller,
           getControllerEvents, getSlice,
           maybePitchBend, maybeChannelPressure,
           chopLongTime, )
import qualified Synthesizer.Generic.ALSA.MIDI as Gen
import qualified Synthesizer.MIDIValue as MV

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.MixedTime as EventListMT
-- import qualified Data.EventList.Relative.MixedBody as EventListMB
import qualified Data.EventList.Relative.BodyTime  as EventListBT
-- import qualified Data.EventList.Relative.BodyMixed as EventListBM
-- import qualified Data.EventList.Relative.TimeMixed as EventListTM
import qualified Data.EventList.Relative.TimeBody  as EventList

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.RealRing      as RealRing
import qualified Algebra.Field          as Field
import qualified Algebra.Additive       as Additive

import Control.Monad.Trans.State (State, evalState, state, modify, put, get, )
import Control.Monad (liftM, )
import Data.Traversable (traverse, )
import Data.Foldable (traverse_, )

import NumericPrelude.Base hiding (sequence, )
import NumericPrelude.Numeric



chunkSizesFromStrictTime :: StrictTime -> NonNegChunky.T SigSt.ChunkSize
chunkSizesFromStrictTime =
   NonNegChunky.fromChunks .
   map (SVL.ChunkSize . fromInteger . NonNegW.toNumber) .
   chopLongTime


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



{-
ToDo: move to Storable.Signal
-}
{-# INLINE piecewiseConstant #-}
piecewiseConstant ::
   (Storable y) =>
   EventListBT.T StrictTime y -> SigSt.T y
piecewiseConstant =
   EventListBT.foldrPair
      (\y t -> SigSt.append (SigStV.replicate (chunkSizesFromStrictTime t) y))
      SigSt.empty

{-# INLINE piecewiseConstantInit #-}
piecewiseConstantInit ::
   (Storable y) =>
   y -> EventList.T StrictTime y -> SigSt.T y
piecewiseConstantInit initial =
   (\ ~(t,rest) ->
      SigSt.append (SigStV.replicate (chunkSizesFromStrictTime t) initial) rest)
   .
   EventList.foldr
      (,)
      (\y ~(t,rest) ->
         SigSt.append (SigStV.replicate (chunkSizesFromStrictTime t) y) rest)
      (0, SigSt.empty)
{-
   piecewiseConstant .
--   EventListBM.switchBodyR const .
--   EventListBM.snocTime NonNeg.zero .
--   EventListMB.consBody initial .
   -- switchBodyR causes a space leak
   EventListTM.switchBodyR EventListBT.empty
      (\xs _ -> EventListMT.consBody initial xs)
-}

{-# INLINE piecewiseConstantInitWith #-}
piecewiseConstantInitWith ::
   (Storable c) =>
   (y -> c) ->
   c -> EventList.T StrictTime [y] -> SigSt.T c
piecewiseConstantInitWith f initial =
   piecewiseConstantInit initial .
   flip evalState initial .
   traverse (\evs -> traverse_ (put . f) evs >> get)


{-# INLINE controllerLinear #-}
controllerLinear ::
   (Storable y, Field.C y) =>
   Channel -> Controller ->
   (y,y) -> y ->
   Filter (SigSt.T y)
controllerLinear chan ctrl bnd initial =
   liftM (piecewiseConstantInitWith (MV.controllerLinear bnd) initial) $
   getControllerEvents chan ctrl


{-# INLINE controllerExponential #-}
controllerExponential ::
   (Storable y, Trans.C y) =>
   Channel -> Controller ->
   (y,y) -> y ->
   Filter (SigSt.T y)
controllerExponential chan ctrl bnd initial =
   liftM (piecewiseConstantInitWith (MV.controllerExponential bnd) initial) $
   getControllerEvents chan ctrl


{- |
@pitchBend channel range center@:
emits frequencies on an exponential scale from
@center/range@ to @center*range@.
-}
{-# INLINE pitchBend #-}
pitchBend ::
   (Storable y, Trans.C y) =>
   Channel ->
   y -> y ->
   Filter (SigSt.T y)
pitchBend chan range center =
   liftM (piecewiseConstantInitWith (MV.pitchBend range center) center) $
   getSlice (maybePitchBend chan)
--   getPitchBendEvents chan

{-# INLINE channelPressure #-}
channelPressure ::
   (Storable y, Trans.C y) =>
   Channel ->
   y -> y ->
   Filter (SigSt.T y)
channelPressure chan maxVal initVal =
   liftM (piecewiseConstantInitWith (MV.controllerLinear (0,maxVal)) initVal) $
   getSlice (maybeChannelPressure chan)


{-
We could use 'getBendWheelPressureSignal' here,
but this may be less efficient.
-}
{-# INLINE bendWheelPressure #-}
bendWheelPressure ::
   (Storable y, RealRing.C y, Trans.C y) =>
   Channel ->
   Int -> y -> y -> y ->
   Filter (SigSt.T y)
bendWheelPressure chan
     pitchRange speed wheelDepth pressDepth =
   do bend  <- pitchBend chan (2^?(fromIntegral pitchRange/12)) 1
      fm    <- controllerLinear chan VoiceMsg.modulation (0,wheelDepth) 0
      press <- channelPressure 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 = Gen.Instrument y (SigSt.T yv)
type Bank y yv = Gen.Bank y (SigSt.T yv)


{-# INLINE sequenceCore #-}
sequenceCore ::
   (Storable yv, Additive.C yv) =>
   SVL.ChunkSize ->
   Channel ->
   Program ->
   Gen.Modulator Note (SigSt.T yv) ->
   Filter (SigSt.T yv)
sequenceCore chunkSize =
   Gen.sequenceCore (CutSt.arrangeEquidist chunkSize)


{-# INLINE sequence #-}
sequence ::
   (Storable yv, Additive.C yv, Trans.C y) =>
   SVL.ChunkSize ->
   Channel ->
   Instrument y yv ->
   Filter (SigSt.T yv)
sequence chunkSize =
   Gen.sequence (CutSt.arrangeEquidist chunkSize)


{-# INLINE sequenceModulated #-}
sequenceModulated ::
   (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)
sequenceModulated chunkSize =
   Gen.sequenceModulated (CutSt.arrangeEquidist chunkSize)


{-# INLINE sequenceMultiModulated #-}
sequenceMultiModulated ::
   (Storable yv, Additive.C yv, Trans.C y) =>
   SVL.ChunkSize ->
   Channel ->
   instrument ->
   Gen.Modulator (instrument, Note) (Instrument y yv, Note) ->
   Filter (SigSt.T yv)
sequenceMultiModulated chunkSize =
   Gen.sequenceMultiModulated (CutSt.arrangeEquidist chunkSize)


applyModulation ::
   (Storable c) =>
   SigSt.T c ->
   Gen.Modulator (SigSt.T c -> instr, note) (instr, note)
applyModulation =
   Gen.applyModulation

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  (Gen.evaluateVectorHead ys t, ys)

advanceModulationChunky =
   Gen.advanceModulation


{-# INLINE sequenceMultiProgram #-}
sequenceMultiProgram ::
   (Storable yv, Additive.C yv, Trans.C y) =>
   SVL.ChunkSize ->
   Channel ->
   Program ->
   [Instrument y yv] ->
   Filter (SigSt.T yv)
sequenceMultiProgram chunkSize =
   Gen.sequenceMultiProgram (CutSt.arrangeEquidist chunkSize)