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

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

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

   -- auxiliary function
   initWith,
   mapMaybe,
   ) where

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

import qualified Synthesizer.MIDI.Value.BendModulation as BM
import qualified Synthesizer.MIDI.Value.BendWheelPressure as BWP
import qualified Synthesizer.MIDI.Value as MV

import qualified Synthesizer.MIDI.EventList as MIDIEv
import Synthesizer.MIDI.EventList (StrictTime, )

import qualified Synthesizer.PiecewiseConstant.Signal as PC
import qualified Synthesizer.Storable.Cut as CutSt
import qualified Synthesizer.Generic.Cut as CutG
import qualified Synthesizer.Zip as Zip

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

import Control.DeepSeq (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.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 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 event = EventListTT.T StrictTime [event]


initWith ::
   (y -> c) ->
   c ->
   PIO.T
      (Events 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 ::
   (Check.C event) =>
   (event -> Maybe Int) ->
   (Int -> y) -> y ->
   PIO.T
      (Events event)
      (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 ::
   (Check.C event, Field.C y) =>
   MIDIEv.Channel ->
   MIDIEv.Controller ->
   (y,y) -> y ->
   PIO.T
      (Events event)
      (EventListBT.T PC.ShortStrictTime y)
controllerLinear chan ctrl bnd initial =
   slice (Check.controller chan ctrl)
      (MV.controllerLinear bnd) initial

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

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

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

bendWheelPressure ::
   (Check.C event, RealRing.C y, Trans.C y) =>
   MIDIEv.Channel ->
   Int -> y -> y ->
   PIO.T
      (Events event)
      (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 (BWP.check chan)


-- might be moved to synthesizer-core
constant ::
   (Arrow arrow) =>
   y -> arrow (Events event) (EventListBT.T PC.ShortStrictTime y)
constant y = arr $
   EventListBT.singleton y .
   NonNegW.fromNumberMsg "MIDI.CausalIO.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 "MIDI.CausalIO.constant" .
   CutG.length



noteEvents ::
   (Check.C event, Arrow arrow) =>
   MIDIEv.Channel ->
   arrow
      (Events event)
      (Events (Either MIDIEv.Program (MIDIEv.NoteBoundary Bool)))
noteEvents chan =
   mapMaybe $ MIDIEv.checkNoteEvent chan


embedPrograms ::
   MIDIEv.Program ->
   PIO.T
      (Events (Either MIDIEv.Program (MIDIEv.NoteBoundary Bool)))
      (Events (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 :: Events (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) ->
   Events a -> (Events 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.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.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])

{-# INLINE velFreqBank #-}
velFreqBank ::
   (Trans.C y) =>
   (MIDIEv.Program -> y -> y -> process) ->
   (MIDIEv.Program -> MIDIEv.Velocity -> MIDIEv.Pitch -> process)
velFreqBank bank pgm vel pitch =
   bank pgm (MV.velocity vel) (MV.frequencyFromPitch pitch)

applyInstrumentCore ::
   (Arrow arrow) =>
   ((MIDIEv.Pitch, NoteId) -> noteOffListCtrl -> gateCtrl) ->
   (MIDIEv.Program -> MIDIEv.Velocity -> MIDIEv.Pitch ->
    PIO.T gateCtrl chunk) ->
   arrow
      (Events (NoteBoundary (NoteId, Maybe MIDIEv.Program)))
      (Zip.T
         NoteOffList
         (Events (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 vel pitch
                     <<^
                     makeGate (pitch, noteId)))

applyInstrument ::
   (Arrow arrow) =>
   (MIDIEv.Program -> MIDIEv.Velocity -> MIDIEv.Pitch ->
    PIO.T GateChunk chunk) ->
   arrow
      (Events (NoteBoundary (NoteId, Maybe MIDIEv.Program)))
      (Zip.T
         NoteOffList
         (Events (PIO.T NoteOffList chunk)))
applyInstrument bank =
   applyInstrumentCore gateFromNoteOffs bank


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

applyModulatedInstrument ::
   (Arrow arrow, CutG.Read ctrl) =>
   (MIDIEv.Program -> MIDIEv.Velocity -> MIDIEv.Pitch ->
    PIO.T (Zip.T GateChunk ctrl) chunk) ->
   arrow
      (Zip.T
         (Events (NoteBoundary (NoteId, Maybe MIDIEv.Program)))
         ctrl)
      (Zip.T
         (Zip.T NoteOffList ctrl)
         (Events (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))

-- move synthesizer-core:CausalIO
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 ::
   (Check.C event, Monoid chunk, CutG.Read chunk, Trans.C y) =>
   MIDIEv.Channel ->
   Bank y chunk ->
   PIO.T (Events event) (EventListTT.T StrictTime chunk)
sequenceCore channel bank =
   applyModulation
   .
   flattenControlSchedule
   .
   applyInstrument (velFreqBank bank)
   .
   assignNoteIds
   .
   embedPrograms (VoiceMsg.toProgram 0)
   .
   noteEvents channel


sequenceModulated ::
   (Check.C event, 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 event) ctrl) (EventListTT.T StrictTime chunk)
sequenceModulated channel bank =
   applyModulation
   .
   flattenControlSchedule
   .
   applyModulatedInstrument (velFreqBank bank)
   .
   Zip.arrowFirst
      (assignNoteIds
       .
       embedPrograms (VoiceMsg.toProgram 0)
       .
       noteEvents channel)


sequenceModulatedMultiProgram ::
   (Check.C event, 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 event) ctrl) (EventListTT.T StrictTime chunk)
sequenceModulatedMultiProgram channel initPgm bank =
   applyModulation
   .
   flattenControlSchedule
   .
   applyModulatedInstrument (velFreqBank bank)
   .
   Zip.arrowFirst
      (assignNoteIds
       .
       embedPrograms initPgm
       .
       noteEvents channel)


-- | may replace the other functions
sequenceModulatedMultiProgramVelocityPitch ::
   (Check.C event, Monoid chunk, CutG.Read chunk,
    CutG.Transform ctrl, CutG.NormalForm ctrl) =>
   MIDIEv.Channel ->
   MIDIEv.Program ->
   (MIDIEv.Program -> MIDIEv.Velocity -> MIDIEv.Pitch ->
    PIO.T (Zip.T GateChunk ctrl) chunk) ->
   PIO.T (Zip.T (Events event) ctrl) (EventListTT.T StrictTime chunk)
sequenceModulatedMultiProgramVelocityPitch channel initPgm bank =
   applyModulation
   .
   flattenControlSchedule
   .
   applyModulatedInstrument bank
   .
   Zip.arrowFirst
      (assignNoteIds
       .
       embedPrograms initPgm
       .
       noteEvents channel)


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