MIDI.hs

{- |
Convert MIDI events of a MIDI controller to a control signal.
-}
{-# LANGUAGE NoImplicitPrelude #-}
module Synthesizer.PiecewiseConstant.ALSA.MIDI (
   T,
   duration,
   PC.zipWith,

   initWith,
   controllerLinear,
   controllerExponential,
   pitchBend,
   channelPressure,
   bendWheelPressure,
   checkBendWheelPressure,
   bendWheelPressureZip,
   ) where

import qualified Synthesizer.EventList.ALSA.MIDI as Ev
import Synthesizer.EventList.ALSA.MIDI (LazyTime, StrictTime, Filter, Channel, )

import qualified Sound.MIDI.ALSA.Check as Check
import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg
import qualified Sound.ALSA.Sequencer.Event as Event
import qualified Synthesizer.MIDIValue.BendModulation as BM
import qualified Synthesizer.MIDIValue.BendWheelPressure as BWP
import qualified Synthesizer.MIDIValue as MV

import qualified Synthesizer.PiecewiseConstant.Signal as PC

-- 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 qualified Data.EventList.Relative.TimeBody  as EventList

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 Data.Accessor.Monad.Trans.State as AccState
import Control.Monad.Trans.State (State, evalState, state, get, put, )
import Control.Monad (liftM, liftM2, msum, )
import Data.Traversable (traverse, sequence, )
import Data.Foldable (traverse_, )

import qualified Data.List.HT as ListHT
import qualified Data.List as List
import Data.Either (Either(Left, Right), )
import Data.Maybe (maybe, )
import Data.Function ((.), ($), flip, )

import NumericPrelude.Numeric
import Prelude as P (Maybe, fmap, (>>), )


type T = EventListBT.T StrictTime


duration :: T y -> LazyTime
duration =
   NonNegChunky.fromChunks . EventListBT.getTimes


{-# INLINE initWith #-}
initWith ::
   (y -> c) ->
   c -> EventList.T StrictTime [y] -> T c
initWith f initial =
{-
   EventListTM.switchBodyR EventListBT.empty
      (\xs _ -> EventListMT.consBody initial xs) .
-}
   EventListMT.consBody initial .
   flip EventListTM.snocTime NonNeg.zero .
   flip evalState initial .
   traverse
      (\ys -> traverse_ (put . f) ys >> get)


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


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


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

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


{-# INLINE bendWheelPressure #-}
bendWheelPressure ::
   (RealRing.C y, Trans.C y) =>
   Channel ->
   Int -> y -> y ->
   Filter (T (BM.T y))
bendWheelPressure chan
      pitchRange wheelDepth pressDepth =
   let toBM = BM.fromBendWheelPressure pitchRange wheelDepth pressDepth
   in  liftM (initWith toBM (toBM BWP.deflt)) $
       state $
       EventList.unzip .
       fmap ListHT.unzipEithers .
       flip evalState BWP.deflt .
       traverse (traverse (separateBWP chan))

separateBWP :: Channel -> Event.T -> State BWP.T (Either BWP.T Event.T)
separateBWP chan ev =
   fmap (maybe (Right ev) Left) $
   checkBendWheelPressure chan ev

{- |
I hesitate to move this to MIDIValue or BendWheelPressure module
because it depends on ALSA specific Event.
-}
checkBendWheelPressure ::
   Channel -> Event.T -> State BWP.T (Maybe BWP.T)
checkBendWheelPressure chan ev =
   sequence $
   (fmap (>> get)) $
   msum $ List.map ($ev) $
      (fmap (AccState.set BWP.bend) . Check.pitchBend chan) :
      (fmap (AccState.set BWP.wheel) . Check.controller chan VoiceMsg.modulation) :
      (fmap (AccState.set BWP.pressure) . Check.channelPressure chan) :
      []

{- |
This one is certainly not as efficient as 'bendWheelPressure'
since it first slices the event list
and then zips the slices together.
-}
{-# INLINE bendWheelPressureZip #-}
bendWheelPressureZip ::
   (RealRing.C y, Trans.C y) =>
   Channel ->
   Int -> y -> y ->
   Filter (T (BM.T y))
bendWheelPressureZip chan
     pitchRange wheelDepth pressDepth =
   liftM2 (PC.zipWith BM.Cons)
      (pitchBend chan (2^?(fromIntegral pitchRange/12)) 1)
      (liftM2 (PC.zipWith (+))
         (controllerLinear chan VoiceMsg.modulation (0,wheelDepth) 0)
         (channelPressure chan pressDepth 0))