{- |
Treat a stream of MIDI events as parallel streams of MIDI controller events.
-}
{-# LANGUAGE NoImplicitPrelude #-}
module Synthesizer.PiecewiseConstant.ALSA.MIDIControllerSet (
   T,
   Controller(Controller,PitchBend,Pressure),
   fromChannel,
   controllerLinear,
   controllerExponential,
   pitchBend,
   channelPressure,
   PC.BendModulation(PC.BendModulation),
   PC.shiftBendModulation,
   bendWheelPressure,
   ) where

import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC
import qualified Synthesizer.EventList.ALSA.MIDI as Ev
import Synthesizer.EventList.ALSA.MIDI (StrictTime, Channel, )

import qualified Synthesizer.MIDIValue as MV
import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg

import qualified Synthesizer.Generic.Cut as CutG
import Control.DeepSeq (NFData, rnf, )

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 EventListTB

import qualified Numeric.NonNegative.Class   as NonNeg98
-- import qualified Numeric.NonNegative.Wrapper as NonNegW
-- import qualified Numeric.NonNegative.Chunky as NonNegChunky
-- import Numeric.NonNegative.Class ((-|), )

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 Data.Set as Set
import qualified Data.Map as Map
import Data.Map (Map, )

import Control.Monad.Trans.State (State, evalState, state, get, put, )
import Control.Monad (liftM2, msum, fmap, )
import Data.Traversable (traverse, )
import Data.Foldable (traverse_, )
import Data.Monoid (Monoid, mempty, mappend, )

import Data.Maybe.HT (toMaybe, )
import Data.Tuple.HT (mapFst, mapPair, )
import qualified Data.List.HT as ListHT
import qualified Data.List as List

import NumericPrelude.Numeric
import NumericPrelude.Base
import qualified Prelude as P
          (Num, Integral, fromInteger, fromIntegral, toInteger, sum, )


{-
This data structure stores the initial values of all supported controllers
and an event list of all changes of individal controllers.
-}
data T key a =
   Cons {
      initial :: Map key a,
      stream :: EventListTT.T StrictTime [(key, a)]
   }
   deriving Show


mapStream ::
   (EventListTT.T StrictTime [(key, a)] ->
    EventListTT.T StrictTime [(key, a)]) ->
   T key a -> T key a
mapStream f s = Cons (initial s) (f (stream s))


data Controller =
     Controller VoiceMsg.Controller
   | PitchBend
   | Pressure
   deriving (Show, Eq, Ord)

instance NFData Controller where
   rnf (Controller c) =
      rnf (VoiceMsg.fromController c)
   rnf _ = ()


fromChannel ::
   Channel ->
   Ev.Filter (T Controller Int)
fromChannel chan =
   fmap (Cons Map.empty) $
   fmap (flip EventListTM.snocTime NonNeg98.zero) $
   Ev.getSlice (\e -> msum $
      (fmap (mapFst Controller) $ Ev.maybeAnyController chan e) :
      (fmap ((,) PitchBend) $ Ev.maybePitchBend chan e) :
      (fmap ((,) Pressure) $ Ev.maybeChannelPressure chan e) :
      [])


instance CutG.Read (T key a) where
   null =
      List.null . List.filter (> P.fromInteger 0) .
      EventListTT.getTimes . stream
   length =
      fromIntegral . P.toInteger .
      P.sum . EventListTT.getTimes . stream

instance Monoid (T key y) where
   mempty = Cons Map.empty (EventListTT.pause mempty)
   mappend x y =
      Cons
         (initial x)
         (EventListTT.append (stream x) (flatten y))

instance (NFData key, NFData a) => CutG.NormalForm (T key a) where
   evaluateHead xs = rnf (initial xs)

{- |
Prepend the initial values as events to the event-list.
-}
flatten ::
   T key a -> EventListTT.T StrictTime [(key, a)]
flatten xs =
   EventListTT.cons
      mempty (Map.toList $ initial xs)
      (stream xs)


mapInsertMany ::
   (Ord key) =>
   [(key,a)] -> Map key a -> Map key a
mapInsertMany assignments inits =
   foldl (flip (uncurry Map.insert)) inits assignments


reverseList ::
   (Ord key) =>
   (Map key a, [(key,a)]) ->
   (Map key a, [(key,a)])
reverseList (inits,xs) =
   foldl
      (\(inits0,ys) (key,a) ->
         let (ma,inits1) =
                Map.insertLookupWithKey
                   (\ _k new _old -> new) key a inits0
         in  (inits1,
              maybe
                 (error "MIDIControllerSet.reverse: uninitialized controller")
                 ((,) key) ma
                 : ys))
      (inits, [])
      xs

{- |
For reverse you must make sure,
that all controller events have an corresponding initial value.
Controllers that miss an initial value
their last constant piece will be undefined.
-}
instance (Ord key) => CutG.Transform (T key y) where
   take n =
      mapStream (EventListTT.takeTime (P.fromIntegral n))

   drop n0 xs =
      let recourse n inits =
             EventListMT.switchTimeL $ \t xs1 ->
             let (b,d) = snd $ NonNeg98.split t n
             in  mapStream (EventListTT.forceTimeHead) $
                 if not b
                   then Cons inits (EventListMT.consTime d xs1)
                   else
                     flip (EventListMT.switchBodyL
                        (Cons inits (EventListTT.pause mempty))) xs1 $ \assignments xs2 ->
                     recourse d (mapInsertMany assignments inits) xs2
      in  recourse (P.fromIntegral n0) (initial xs) (stream xs)

   -- cf. ChunkySize.dropMarginRem
   dropMarginRem n m xs =
      List.foldl'
         (\(mi,xsi) k -> (mi-k, CutG.drop k xsi))
         (m, xs)
         (List.map P.fromIntegral $ EventListTT.getTimes $
          EventListTT.takeTime (P.fromIntegral m) $
          EventListTT.dropTime (P.fromIntegral n) $
          stream xs)

   -- cf. StorableVector.Lazy.splitAt
   splitAt n0 xs =
      let recourse n inits =
             EventListMT.switchTimeL $ \t xs1 ->
             let (m, ~(b,d)) = NonNeg98.split t n
             in  mapPair
                    (EventListMT.consTime m,
                     mapStream (EventListTT.forceTimeHead)) $
                 if not b
                   then
                     (EventListBT.empty,
                      Cons inits (EventListMT.consTime d xs1))
                   else
                     flip (EventListMT.switchBodyL
                        (EventListBT.empty,
                         Cons inits (EventListTT.pause mempty))) xs1 $ \keyAs xs2 ->
                     mapFst (EventListMT.consBody keyAs) $
                     recourse d (mapInsertMany keyAs inits) xs2
      in  mapFst (Cons (initial xs)) $
          recourse (P.fromIntegral n0) (initial xs) (stream xs)

   reverse xs =
      EventListTT.foldl
         (\(inits,ys) t -> Cons inits $ EventListMT.consTime t ys)
         (\(Cons inits0 ys) evs0 ->
            let (inits1, evs1) = reverseList (inits0, evs0)
            in  (inits1, EventListMT.consBody evs1 ys))
         (initial xs, EventListBT.empty)
         (stream xs)
{-
*Synthesizer.PiecewiseConstant.ALSA.MIDIControllerSet Data.EventList.Relative.MixedTime> CutG.reverse $ Cons (Map.singleton 'a' GT) (2 /. [('a',EQ)] ./ 3 /. empty) :: T Char Ordering
-}



type Filter = State (T Controller Int)


_errorUninitialized :: Controller -> Int
_errorUninitialized c =
   error $
   "getSlice: uninitialized controller " ++ show c

getSlice ::
   Controller ->
   (Int -> a) ->
   a -> Filter (PC.T a)
getSlice c f deflt =
   state (\xs ->
      let (ys,zs) =
             EventListTT.unzip $
             fmap
                (ListHT.partitionMaybe
                   (\(ci,a) -> toMaybe (c==ci) a))
                (stream xs)
          (yin0,zis) =
             Map.updateLookupWithKey
                (\ _k _a -> Nothing) c
                (initial xs)
          yin1 = maybe deflt f yin0
          fill =
             flip evalState yin1 .
             traverse
                (\ys0 -> traverse_ (put . f) ys0 >> get)
      in  (EventListMT.consBody yin1 (fill ys),
           Cons zis zs))


{-# INLINE controllerLinear #-}
controllerLinear ::
   (Field.C y) =>
   Ev.Controller -> (y,y) -> y -> Filter (PC.T y)
controllerLinear ctrl bnd =
   getSlice (Controller ctrl) (MV.controllerLinear bnd)


{-# INLINE controllerExponential #-}
controllerExponential ::
   (Trans.C y) =>
   Ev.Controller -> (y,y) -> y -> Filter (PC.T y)
controllerExponential ctrl bnd =
   getSlice (Controller ctrl) (MV.controllerExponential bnd)



{- |
@pitchBend channel range center@:
emits frequencies on an exponential scale from
@center/range@ to @center*range@.
-}
{-# INLINE pitchBend #-}
pitchBend ::
   (Trans.C y) =>
   y -> y ->
   Filter (PC.T y)
pitchBend range center =
   getSlice PitchBend (MV.pitchBend range center) center

{-# INLINE channelPressure #-}
channelPressure ::
   (Trans.C y) =>
   y -> y ->
   Filter (PC.T y)
channelPressure maxVal =
   getSlice Pressure (MV.controllerLinear (Additive.zero,maxVal))



{-# INLINE bendWheelPressure #-}
bendWheelPressure ::
   (RealRing.C y, Trans.C y) =>
   Int -> y -> y ->
   Filter (PC.T (PC.BendModulation y))
bendWheelPressure pitchRange wheelDepth pressDepth =
   liftM2 (PC.zipWith PC.BendModulation)
      (pitchBend (2 ^? (fromIntegral pitchRange / 12)) 1)
      (liftM2 (PC.zipWith (+))
         (controllerLinear VoiceMsg.modulation (0,wheelDepth) 0)
         (channelPressure pressDepth 0))