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

   initWith,
   controllerLinear,
   controllerExponential,
   pitchBend,
   channelPressure,
   BendModulation(BendModulation),
   shiftBendModulation,
   bendWheelPressure,
   ) where

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

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

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 Numeric.NonNegative.Class ((-|), )

import qualified Algebra.Transcendental as Trans
import qualified Algebra.RealRing      as RealRing
import qualified Algebra.Field          as Field
import qualified Algebra.Ring           as Ring
import qualified Algebra.Additive       as Additive

import Control.Monad.Trans.State (evalState, get, put, )
import Control.Monad (liftM, liftM2, )
import Data.Traversable (traverse, )
import Data.Foldable (traverse_, )
import Control.DeepSeq (NFData, rnf, )

import Data.Maybe.HT (toMaybe, )
import qualified Data.List as List
import Data.Maybe (Maybe(Just, Nothing), maybe, )
import Data.Ord (Ordering(LT,GT,EQ), min, compare, )
import Data.Bool (Bool(False,True), (||), )
import Data.Function ((.), ($), flip, id, )

import NumericPrelude.Numeric
import Prelude as P
   (Eq, Show, uncurry, fmap, return, (>>), )


type T = EventListBT.T StrictTime


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

{-
ToDo: move to PiecewiseConstant.Signal or so.
-}
{-# INLINE subdivide #-}
subdivide ::
   EventListBT.T LazyTime y -> EventListBT.T StrictTime y
subdivide =
   EventListBT.foldrPair
      (\y lt r ->
         List.foldr
            (\dt ->
               EventListMT.consBody y .
               EventListMT.consTime dt) r $
         NonNegChunky.toChunks (NonNegChunky.normalize lt))
      EventListBT.empty

{- |
Subdivide lazy times into chunks that fit into the number range
representable by @Int@.
-}
{-# INLINE subdivideInt #-}
subdivideInt ::
   EventListBT.T LazyTime y -> EventListBT.T NonNegW.Int y
subdivideInt =
   EventListBT.mapTime
      (NonNegW.fromNumber .
       fromIntegral .
       NonNegW.toNumber) .
   subdivide .
   EventListBT.mapTime
      (NonNegChunky.fromChunks .
       List.concatMap Ev.chopLongTime .
       NonNegChunky.toChunks)


{-# 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 (Ev.maybePitchBend 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 (Ev.maybeChannelPressure chan)


data BendModulation a = BendModulation a a
   deriving (P.Show, P.Eq)

instance (NFData a) => NFData (BendModulation a) where
   rnf (BendModulation bend depth) =
      case rnf bend of () -> rnf depth


{- |
Multiply the pitch bend by a given factor.
This way you can e.g. shift the pitch bend from around 1
to the actual frequency.
-}
shiftBendModulation ::
   (Ring.C a) =>
   a -> BendModulation a -> BendModulation a
shiftBendModulation k (BendModulation bend depth) =
   BendModulation (k*bend) depth


_subdivideMaybe ::
   EventListBT.T LazyTime y -> EventListBT.T StrictTime (Maybe y)
_subdivideMaybe =
   EventListBT.foldrPair
      (\y lt r ->
         case NonNegChunky.toChunks (NonNegChunky.normalize lt) of
            [] -> r
            (t:ts) ->
               EventListBT.cons (Just y) t $
               List.foldr (EventListBT.cons Nothing) r ts)
      EventListBT.empty

{- |
When a lazy time value is split into chunks
then do not just replicate the sample for the whole time,
but insert 'Nothing's.
-}
{-# INLINE subdivideMaybe #-}
subdivideMaybe ::
   EventListTT.T LazyTime y ->
   EventListTT.T StrictTime (Maybe y)
subdivideMaybe =
   EventListTT.foldr
      (\lt r ->
         uncurry EventListMT.consTime $
         case NonNegChunky.toChunks (NonNegChunky.normalize lt) of
            [] ->
               (NonNegW.fromNumber zero, r)
            (t:ts) ->
               (t, List.foldr (EventListBT.cons Nothing) r ts))
      (\y r -> EventListMT.consBody (Just y) r)
      EventListBT.empty

{-# INLINE unionMaybe #-}
unionMaybe ::
   EventListTT.T StrictTime (Maybe y) ->
   EventListTT.T LazyTime y
unionMaybe =
   EventListTT.foldr
      (\t ->
         EventListMT.mapTimeHead
            (NonNegChunky.fromChunks . (t:) . NonNegChunky.toChunks))
      (\my ->
         case my of
            Nothing -> id
            Just y ->
               EventListMT.consTime NonNegChunky.zero .
               EventListMT.consBody y)
      (EventListTT.pause NonNegChunky.zero)

{-
ToDo: move to PiecewiseConstant.Signal or so.
-}
zipWithCore ::
   (a -> b -> c) ->
   a -> b ->
   EventListTT.T StrictTime (Maybe a) ->
   EventListTT.T StrictTime (Maybe b) ->
   EventListTT.T StrictTime (Maybe c)
zipWithCore f =
   let switch ac ar g =
          flip (EventListMT.switchBodyL EventListBT.empty) ar $ \am ar1 ->
          g (maybe (False,ac) ((,) True) am) ar1
       cont j ac bc as bs =
          EventListMT.consBody (toMaybe j $ f ac bc) $
          recourse ac bc as bs
       recourse ac bc as bs =
          flip EventListMT.switchTimeL as $ \at ar ->
          flip EventListMT.switchTimeL bs $ \bt br ->
          let ct = min at bt
          in  -- ToDo: redundant comparison of 'at' and 'bt'
              EventListMT.consTime ct $
              case compare at bt of
                 LT ->
                    switch ac ar $ \(ab,a) ar1 ->
                       cont ab a bc ar1 (EventListMT.consTime (bt-|ct) br)
                 GT ->
                    switch bc br $ \(bb,b) br1 ->
                       cont bb ac b (EventListMT.consTime (at-|ct) ar) br1
                 EQ ->
                    switch ac ar $ \(ab,a) ar1 ->
                    switch bc br $ \(bb,b) br1 ->
                       cont (ab||bb) a b ar1 br1
   in  recourse

zipWith ::
   (a -> b -> c) ->
   EventListBT.T StrictTime a ->
   EventListBT.T StrictTime b ->
   EventListBT.T StrictTime c
zipWith f as0 bs0 =
   flip (EventListMT.switchBodyL EventListBT.empty) as0 $ \a0 as1 ->
   flip (EventListMT.switchBodyL EventListBT.empty) bs0 $ \b0 bs1 ->
   let c0 = f a0 b0
   in  EventListMT.consBody c0 $
       flip evalState c0 $
       traverse (\mc -> maybe (return ()) put mc >> get) $
       zipWithCore f a0 b0 (fmap Just as1) (fmap Just bs1)

_zipWithLazy ::
   (a -> b -> c) ->
   EventListBT.T LazyTime a ->
   EventListBT.T LazyTime b ->
   EventListBT.T LazyTime c
_zipWithLazy f as0 bs0 =
   flip (EventListMT.switchBodyL EventListBT.empty) as0 $ \a0 as1 ->
   flip (EventListMT.switchBodyL EventListBT.empty) bs0 $ \b0 bs1 ->
   EventListMT.consBody (f a0 b0) $ unionMaybe $
   zipWithCore f a0 b0 (subdivideMaybe as1) (subdivideMaybe bs1)
{-
*Synthesizer.PiecewiseConstant.ALSA.MIDI Data.EventList.Relative.MixedTime> zipWithLazy (,) ('a' ./ 2 /. 'b' ./ 7 /. EventListBT.empty) ('c' ./ (1 P.+ 1) /. 'd' ./ 1 /. EventListBT.empty)
-}


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