Process.hs

{-# LANGUAGE ExistentialQuantification #-}
module Synthesizer.CausalIO.ALSA.Process (
   Events,
   playFromEvents,

   slice,
   controllerLinear,
   controllerExponential,
   pitchBend,
   channelPressure,
   bendWheelPressure,
   constant,

   Instrument,
   Bank,
   GateChunk,
   noteEvents,
   embedPrograms,
   applyInstrument,
   applyModulatedInstrument,
   flattenControlSchedule,
   applyModulation,
   arrangeStorable,
   sequenceCore,
   sequenceModulated,
   sequenceModulatedMultiProgram,
   sequenceStorable,

   -- auxiliary function
   initWith,
   mapMaybe,
   ) where

import qualified Synthesizer.CausalIO.Gate as Gate
import qualified Synthesizer.CausalIO.Process as PIO

import qualified Synthesizer.PiecewiseConstant.Signal as PC
import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as AlsaPC
import qualified Synthesizer.EventList.ALSA.MIDI as MIDIEv
import qualified Synthesizer.Storable.ALSA.Play as Play
import qualified Synthesizer.Storable.Cut as CutSt
import qualified Synthesizer.Generic.Cut as CutG
import qualified Synthesizer.Zip as Zip
import Synthesizer.EventList.ALSA.MIDI (StrictTime, )

import qualified Synthesizer.MIDIValue.BendModulation as BM
import qualified Synthesizer.MIDIValue.BendWheelPressure as BWP
import qualified Synthesizer.MIDIValue as MV

import qualified Sound.ALSA.PCM as PCM
import qualified Sound.ALSA.Sequencer.Event as Event

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

import Control.DeepSeq (NFData, rnf, )

import qualified Data.EventList.Relative.TimeBody  as EventList
import qualified Data.EventList.Relative.BodyTime  as EventListBT
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.Absolute.TimeBody  as AbsEventList

import qualified Numeric.NonNegative.Wrapper as NonNegW
import qualified Numeric.NonNegative.Class as NonNeg

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

import qualified Data.StorableVector as SV
import qualified Data.StorableVector.ST.Strict as SVST
import Foreign.Storable (Storable, )

import Control.Exception (bracket, )

import qualified Control.Monad.Trans.Writer as MW
import qualified Control.Monad.Trans.State as MS
import qualified Control.Monad.Trans.Class as MT
import Control.Monad.IO.Class (liftIO, )

import qualified Data.Traversable as Trav
import Data.Traversable (Traversable, )
import Data.Foldable (traverse_, )

import Control.Arrow (Arrow, arr, (^<<), (<<^), )
import Control.Category ((.), )

import qualified Data.Map as Map

import qualified Data.List.HT as ListHT
import qualified Data.Maybe as Maybe
import Data.Monoid (Monoid, mempty, mappend, )
import Data.Maybe (maybeToList, )
import Data.Tuple.HT (mapFst, mapPair, )

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


type Events = EventListTT.T StrictTime [Event.T]

playFromEvents ::
   (RealField.C time, PCM.SampleFmt a, Additive.C a) =>
   Play.Device -> MIDIEv.ClientName -> time -> time -> PCM.SampleFreq ->
   PIO.T Events (SV.Vector a) ->
   IO ()
playFromEvents device name latency beat rate
      (PIO.Cons next create delete) =
   let sink = Play.makeSink device beat rate
       rateFloat = fromIntegral rate
   in  MIDIEv.withMIDIEventsChunked name beat rateFloat $ \getEventsList ->
       PCM.withSoundSink sink $ \to ->
{-
       Play.writeLazy sink to
          (SVL.replicate
              (SVL.chunkSize $ round (beat * rateFloat))
              (round (latency * rateFloat))
              (zero::Float))
-}
       Play.write sink to
          (SV.replicate (round (latency * rateFloat)) zero) >>
       (bracket create delete $ \state ->
        let loop getEvs0 s0 =
               case getEvs0 of
                  [] -> return ()
                  getEvents : getEvs1 -> do
                     evs <- getEvents
                     (pcm, s1) <- next evs s0
                     Play.write sink to pcm
                     loop getEvs1 s1
        in  loop getEventsList state)


initWith ::
   (y -> c) ->
   c ->
   PIO.T
      (EventListTT.T StrictTime [y])
      (EventListBT.T PC.ShortStrictTime c)
initWith f initial =
   PIO.traverse initial $
      \evs0 -> do
         y0 <- MS.get
         fmap (PC.subdivideLongStrict . EventListMT.consBody y0) $
            Trav.traverse (\ys -> traverse_ (MS.put . f) ys >> MS.get) evs0

slice ::
   (Event.T -> Maybe Int) ->
   (Int -> y) -> y ->
   PIO.T
      Events
      (EventListBT.T PC.ShortStrictTime y)
slice select f initial =
   initWith f initial . mapMaybe select



mapMaybe ::
   (Arrow arrow, Functor f) =>
   (a -> Maybe b) ->
   arrow (f [a]) (f [b])
mapMaybe f =
   arr $ fmap $ Maybe.mapMaybe f

catMaybes ::
   (Arrow arrow, Functor f) =>
   arrow (f [Maybe a]) (f [a])
catMaybes =
   arr $ fmap Maybe.catMaybes

traverse ::
   (Traversable f) =>
   s -> (a -> MS.State s b) ->
   PIO.T (f [a]) (f [b])
traverse initial f =
   PIO.traverse initial (Trav.traverse (Trav.traverse f))


controllerLinear ::
   (Field.C y) =>
   MIDIEv.Channel ->
   MIDIEv.Controller ->
   (y,y) -> y ->
   PIO.T
      Events
      (EventListBT.T PC.ShortStrictTime y)
controllerLinear chan ctrl bnd initial =
   slice (Check.controller chan ctrl)
      (MV.controllerLinear bnd) initial

controllerExponential ::
   (Trans.C y) =>
   MIDIEv.Channel ->
   MIDIEv.Controller ->
   (y,y) -> y ->
   PIO.T
      Events
      (EventListBT.T PC.ShortStrictTime y)
controllerExponential chan ctrl bnd initial =
   slice (Check.controller chan ctrl)
      (MV.controllerExponential bnd) initial

pitchBend ::
   (Trans.C y) =>
   MIDIEv.Channel ->
   y -> y ->
   PIO.T
      Events
      (EventListBT.T PC.ShortStrictTime y)
pitchBend chan range center =
   slice (Check.pitchBend chan)
      (MV.pitchBend range center) center

channelPressure ::
   (Trans.C y) =>
   MIDIEv.Channel ->
   y -> y ->
   PIO.T
      Events
      (EventListBT.T PC.ShortStrictTime y)
channelPressure chan maxVal initial =
   slice (Check.channelPressure chan)
      (MV.controllerLinear (zero,maxVal)) initial

bendWheelPressure ::
   (RealRing.C y, Trans.C y) =>
   MIDIEv.Channel ->
   Int -> y -> y ->
   PIO.T
      Events
      (EventListBT.T PC.ShortStrictTime (BM.T y))
bendWheelPressure chan
      pitchRange wheelDepth pressDepth =
   let toBM = BM.fromBendWheelPressure pitchRange wheelDepth pressDepth
   in  initWith toBM (toBM BWP.deflt)
       .
       catMaybes
       .
       traverse BWP.deflt (AlsaPC.checkBendWheelPressure chan)


-- might be moved to synthesizer-core
constant ::
   (Arrow arrow) =>
   y -> arrow Events (EventListBT.T PC.ShortStrictTime y)
constant y = arr $
   EventListBT.singleton y .
   NonNegW.fromNumberMsg "CausalIO.ALSA.constant" .
   fromIntegral .
   EventListTT.duration

_constant ::
   (Arrow arrow, CutG.Read input) =>
   y -> arrow input (EventListBT.T PC.ShortStrictTime y)
_constant y = arr $
   EventListBT.singleton y .
   NonNegW.fromNumberMsg "CausalIO.ALSA.constant" .
   CutG.length



noteEvents ::
   (Arrow arrow) =>
   MIDIEv.Channel ->
   arrow
      (EventListTT.T StrictTime [Event.T])
      (EventListTT.T StrictTime
         [Either MIDIEv.Program (MIDIEv.NoteBoundary Bool)])
noteEvents chan =
   mapMaybe $ MIDIEv.checkNoteEvent chan


embedPrograms ::
   MIDIEv.Program ->
   PIO.T
      (EventListTT.T StrictTime
         [Either MIDIEv.Program (MIDIEv.NoteBoundary Bool)])
      (EventListTT.T StrictTime
         [MIDIEv.NoteBoundary (Maybe MIDIEv.Program)])
embedPrograms initPgm =
   catMaybes .
   traverse initPgm MIDIEv.embedProgramState


type GateChunk = Gate.Chunk MIDIEv.Velocity
type Instrument y chunk = y -> y -> PIO.T GateChunk chunk
type Bank y chunk = MIDIEv.Program -> Instrument y chunk



{-
for distinction of notes with the same pitch

We must use Integer instead of Int, in order to avoid an overflow
that would invalidate the check for unmatched NoteOffs
that is based on comparison of the NoteIds.
We cannot re-use NoteIds easily,
since the events at one time point are handled out of order.
-}
newtype NoteId = NoteId Integer
   deriving (Show, Eq, Ord)

succNoteId :: NoteId -> NoteId
succNoteId (NoteId n) = NoteId (n+1)

flattenNoteIdRange :: (NoteId,NoteId) -> [NoteId]
flattenNoteIdRange (start,afterEnd) =
   takeWhile (<afterEnd) $ iterate succNoteId start


newtype NoteOffList =
   NoteOffList {
      unwrapNoteOffList :: EventListTT.T StrictTime [NoteBoundary NoteId]
   }


instance CutG.Read NoteOffList where
   null (NoteOffList evs) =
      EventListTT.isPause evs && EventListTT.duration evs == 0
   length = fromIntegral . EventListTT.duration . unwrapNoteOffList

instance CutG.NormalForm NoteOffList where
   evaluateHead =
      EventListMT.switchTimeL (\t _ -> rnf (NonNegW.toNumber t)) .
      unwrapNoteOffList

instance Monoid NoteOffList where
   mempty = NoteOffList (EventListTT.pause mempty)
   mappend (NoteOffList xs) (NoteOffList ys) =
      NoteOffList (mappend xs ys)

{- |
The function defined here are based on the interpretation
of event lists as piecewise constant signals.
They do not fit to the interpretation of atomic events.
Because e.g. it makes no sense to split an atomic event into two instances by splitAt,
and it is also not clear, whether dropping the first chunk
shall leave a chunk of length zero
or remove that chunk completely.
-}
instance CutG.Transform NoteOffList where
   take n (NoteOffList xs) =
      NoteOffList $
      EventListTT.takeTime
         (NonNegW.fromNumberMsg "NoteOffList.take" $ fromIntegral n) xs
   drop n (NoteOffList xs) =
      NoteOffList $
      EventListTT.dropTime
         (NonNegW.fromNumberMsg "NoteOffList.drop" $ fromIntegral n) xs
   splitAt n (NoteOffList xs) =
      mapPair (NoteOffList, NoteOffList) $
      EventListTT.splitAtTime
         (NonNegW.fromNumberMsg "NoteOffList.splitAtTime" $ fromIntegral n) xs

   -- cf. ChunkySize.dropMarginRem
   dropMarginRem =
      CutG.dropMarginRemChunky
         (fmap fromIntegral . EventListTT.getTimes . unwrapNoteOffList)

   reverse (NoteOffList xs) =
      NoteOffList . EventListTT.reverse $ xs


findEvent ::
   (a -> Bool) ->
   EventListTT.T StrictTime [a] ->
   (EventListTT.T StrictTime [a], Maybe a)
findEvent p =
   EventListTT.foldr
      (\t -> mapFst (EventListMT.consTime t))
      (\evs rest ->
         case ListHT.break p evs of
            (prefix, suffix) ->
               mapFst (EventListMT.consBody prefix) $
               case suffix of
                  [] -> rest
                  ev:_ -> (EventListTT.pause mempty, Just ev))
      (EventListBT.empty, Nothing)

gateFromNoteOffs ::
   (MIDIEv.Pitch, NoteId) ->
   NoteOffList ->
   GateChunk
gateFromNoteOffs pitchNoteId (NoteOffList noteOffs) =
   let dur = EventListTT.duration noteOffs
       (sustain, mEnd) =
          findEvent
             (\bnd ->
                case bnd of
                   -- AllNotesOff -> True
                   NoteBoundary endPitch _ noteId ->
                      pitchNoteId == (endPitch, noteId))
          noteOffs
   in  Gate.chunk dur $
       flip fmap mEnd $ \end ->
       (EventListTT.duration sustain,
        case end of
           NoteBoundary _ endVel _ -> endVel
           {-
           AllNotesOff ->
              VoiceMsg.toVelocity VoiceMsg.normalVelocity -} )


data NoteBoundary a =
     NoteBoundary VoiceMsg.Pitch VoiceMsg.Velocity a
--   | AllSoundOff
   deriving (Eq, Show)

{- |
We count NoteIds per pitch,
such that the pair (pitch,noteId) identifies a note.
We treat nested notes in a first-in-first-out order (FIFO).
E.g.

> On, On, On, Off, Off, Off

is interpreted as

> On 0, On 1, On 2, Off 0, Off 1, Off 2

NoteOffs without previous NoteOns are thrown away.
-}
assignNoteIds ::
   (Traversable f) =>
   PIO.T
      (f [MIDIEv.NoteBoundary (Maybe MIDIEv.Program)])
      (f [NoteBoundary (NoteId, Maybe MIDIEv.Program)])
assignNoteIds =
   fmap concat
   ^<<
   traverse Map.empty (\bnd ->
      case bnd of
         MIDIEv.AllNotesOff -> do
            notes <- MS.get
            MS.put Map.empty
            return $
               concatMap (\(pitch, range) ->
                  map
                     (\noteId ->
                        NoteBoundary pitch
                           (VoiceMsg.toVelocity VoiceMsg.normalVelocity)
                           (noteId, Nothing))
                     (flattenNoteIdRange range)) $
               Map.toList notes
         MIDIEv.NoteBoundary pitch vel mpgm ->
            fmap (fmap (\noteId ->
               NoteBoundary pitch vel (noteId,mpgm))) $
            case mpgm of
               Nothing -> do
                  mNoteId <- MS.gets (Map.lookup pitch)
                  case mNoteId of
                     Nothing -> return []
                     Just (nextNoteOffId, nextNoteOnId) ->
                        if nextNoteOffId >= nextNoteOnId
                          then return []
                          else do
                             MS.modify (Map.insert pitch (succNoteId nextNoteOffId, nextNoteOnId))
                             return [nextNoteOffId]
               Just _ -> do
                  mNoteId <- MS.gets (Map.lookup pitch)
                  let (nextNoteOffId, nextNoteOnId) =
                         case mNoteId of
                            Nothing -> (NoteId 0, NoteId 0)
                            Just ids -> ids

                  MS.modify (Map.insert pitch (nextNoteOffId, succNoteId nextNoteOnId))
                  return [nextNoteOnId])

applyInstrumentCore ::
   (Arrow arrow, Trans.C y) =>
   ((MIDIEv.Pitch, NoteId) -> noteOffListCtrl -> gateCtrl) ->
   (MIDIEv.Program -> y -> y -> PIO.T gateCtrl chunk) ->
   arrow
      (EventListTT.T StrictTime
         [NoteBoundary (NoteId, Maybe MIDIEv.Program)])
      (Zip.T
         NoteOffList
         (EventListTT.T StrictTime [PIO.T noteOffListCtrl chunk]))
applyInstrumentCore makeGate bank = arr $
   uncurry Zip.Cons .
   mapFst NoteOffList .
   EventListTT.unzip .
   fmap (ListHT.unzipEithers . fmap (\ev ->
      case ev of
--         MIDIEv.AllNotesOff -> Left MIDIEv.AllNotesOff
         NoteBoundary pitch vel (noteId, mpgm) ->
            case mpgm of
               Nothing -> Left $ NoteBoundary pitch vel noteId
               Just pgm ->
                  Right $
                     bank pgm (MV.velocity vel)
                        (MV.frequencyFromPitch pitch)
                     <<^
                     makeGate (pitch, noteId)))

applyInstrument ::
   (Arrow arrow, Trans.C y) =>
   Bank y chunk ->
   arrow
      (EventListTT.T StrictTime
         [NoteBoundary (NoteId, Maybe MIDIEv.Program)])
      (Zip.T
         NoteOffList
         (EventListTT.T StrictTime [PIO.T NoteOffList chunk]))
applyInstrument = applyInstrumentCore gateFromNoteOffs


type ModulatedBank y ctrl chunk =
        MIDIEv.Program -> y -> y ->
        PIO.T (Zip.T GateChunk ctrl) chunk

applyModulatedInstrument ::
   (Arrow arrow, Trans.C y, CutG.Read ctrl) =>
   ModulatedBank y ctrl chunk ->
   arrow
      (Zip.T
         (EventListTT.T StrictTime
            [NoteBoundary (NoteId, Maybe MIDIEv.Program)])
         ctrl)
      (Zip.T
         (Zip.T NoteOffList ctrl)
         (EventListTT.T StrictTime
            [PIO.T (Zip.T NoteOffList ctrl) chunk]))
applyModulatedInstrument bank =
   (\(Zip.Cons (Zip.Cons noteOffs events) ctrl) ->
      Zip.Cons (Zip.Cons noteOffs ctrl) events)
   ^<<
   Zip.arrowFirst
      (applyInstrumentCore
         (Zip.arrowFirst . gateFromNoteOffs) bank)


{- |
Turn an event list with bundles of elements
into an event list with single events.
ToDo: Move to event-list package?
-}
flatten ::
   (NonNeg.C time) =>
   a ->
   EventListTT.T time [a] ->
   EventListTT.T time a
flatten empty =
   EventListTT.foldr
      EventListMT.consTime
      (\bt xs ->
         uncurry EventListMT.consBody $
         case bt of
            [] -> (empty, xs)
            b:bs -> (b, foldr (\c rest -> EventListTT.cons NonNeg.zero c rest) xs bs))
      EventListBT.empty


flattenControlSchedule ::
   (Monoid chunk, Arrow arrow) =>
   arrow
      (Zip.T ctrl
         (EventListTT.T StrictTime [PIO.T ctrl chunk]))
      (Zip.T ctrl
         (EventListTT.T StrictTime (PIO.T ctrl chunk)))
flattenControlSchedule = arr $
   \(Zip.Cons ctrl evs) ->
      -- Zip.consChecked "flattenControlSchedule" ctrl $
      Zip.Cons ctrl $
      flatten (arr (const mempty)) evs



data CausalState a b =
   forall state.
   CausalState
      (a -> state -> IO (b, state))
      (state -> IO ())
      state

_applyChunkSimple :: CausalState a b -> a -> IO (b, CausalState a b)
_applyChunkSimple (CausalState next delete state0) input = do
   (output, state1) <- next input state0
   return (output, CausalState next delete state1)

applyChunk ::
   (CutG.Read a, CutG.Read b) =>
   CausalState a b -> a -> IO (b, Maybe (CausalState a b))
applyChunk (CausalState next delete state0) input = do
   (output, state1) <- next input state0
   cs <-
      if CutG.length output < CutG.length input
        then do
           delete state1
           return Nothing
        else return $ Just $ CausalState next delete state1
   return (output, cs)

-- could be moved to synthesizer-core
applyModulation ::
   (CutG.Transform ctrl, CutG.NormalForm ctrl,
    CutG.Read chunk,
    Monoid time, ToInteger.C time) =>
   PIO.T
      (Zip.T ctrl (EventListTT.T time (PIO.T ctrl chunk)))
      (EventListTT.T time chunk)
applyModulation = PIO.Cons
   (\(Zip.Cons ctrl evs) acc0 -> do
      acc1 <- mapM (flip applyChunk ctrl) acc0
      let (accChunks, acc2) = unzip acc1

      (newChunks, newAcc) <-
         MW.runWriterT $
         flip MS.evalStateT ctrl $
         EventListTT.mapM
            (\time -> do
               ctrl_ <- MS.gets (CutG.drop (fromIntegral time))
               MS.put ctrl_
               return (case CutG.evaluateHead ctrl_ of () -> time))
            (\(PIO.Cons next create delete) -> do
               state0 <- liftIO create
               (chunk, state1) <-
                  liftIO . applyChunk (CausalState next delete state0)
                  =<< MS.get
               MT.lift $ MW.tell $ maybeToList state1
               return chunk)
            evs

      return
         (EventListTM.prependBodyEnd
             (EventList.fromPairList $
              map ((,) mempty) accChunks)
             newChunks,
          Maybe.catMaybes acc2 ++ newAcc))

   (return [])
   (mapM_ (\(CausalState _ close state) -> close state))

arrangeStorable ::
   (Arrow arrow, Storable a, Additive.C a) =>
   arrow
      (EventListTT.T StrictTime (SV.Vector a))
      (SV.Vector a)
arrangeStorable =
   arr $ \evs ->
   SVST.runSTVector (do
      v <- SVST.new (fromIntegral $ EventListTT.duration evs) zero
      mapM_ (uncurry $ CutSt.addChunkToBuffer v) $
         AbsEventList.toPairList $
         AbsEventList.mapTime fromIntegral $
         EventList.toAbsoluteEventList 0 $
         EventListTM.switchTimeR const evs
      return v)



sequenceCore ::
   (Monoid chunk, CutG.Read chunk, Trans.C y) =>
   MIDIEv.Channel ->
   Bank y chunk ->
   PIO.T Events (EventListTT.T StrictTime chunk)
sequenceCore channel bank =
   applyModulation
   .
   flattenControlSchedule
   .
   applyInstrument bank
   .
   assignNoteIds
   .
   embedPrograms (VoiceMsg.toProgram 0)
   .
   noteEvents channel


sequenceModulated ::
   (Monoid chunk, CutG.Read chunk,
    CutG.Transform ctrl, CutG.NormalForm ctrl, Trans.C y) =>
   MIDIEv.Channel ->
   ModulatedBank y ctrl chunk ->
   PIO.T (Zip.T Events ctrl) (EventListTT.T StrictTime chunk)
sequenceModulated channel bank =
   applyModulation
   .
   flattenControlSchedule
   .
   applyModulatedInstrument bank
   .
   Zip.arrowFirst
      (assignNoteIds
       .
       embedPrograms (VoiceMsg.toProgram 0)
       .
       noteEvents channel)


sequenceModulatedMultiProgram ::
   (Monoid chunk, CutG.Read chunk,
    CutG.Transform ctrl, CutG.NormalForm ctrl, Trans.C y) =>
   MIDIEv.Channel ->
   MIDIEv.Program ->
   ModulatedBank y ctrl chunk ->
   PIO.T (Zip.T Events ctrl) (EventListTT.T StrictTime chunk)
sequenceModulatedMultiProgram channel initPgm bank =
   applyModulation
   .
   flattenControlSchedule
   .
   applyModulatedInstrument bank
   .
   Zip.arrowFirst
      (assignNoteIds
       .
       embedPrograms initPgm
       .
       noteEvents channel)


sequenceStorable ::
   (Storable a, Additive.C a, Trans.C y) =>
   MIDIEv.Channel ->
   Bank y (SV.Vector a) ->
   PIO.T Events (SV.Vector a)
sequenceStorable channel bank =
   arrangeStorable
   .
   sequenceCore channel bank