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

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

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

import qualified Sound.MIDI.Message.Class.Check as Check
import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg
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.PiecewiseConstant.Signal as PC

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.Chunky as NonNegChunky

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

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

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

import NumericPrelude.Numeric
import NumericPrelude.Base (fmap, (>>), )


type T = EventListBT.T StrictTime


duration :: T y -> LazyTime
duration :: forall y. T y -> LazyTime
duration =
   forall a. C a => [a] -> T a
NonNegChunky.fromChunks forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall time body. T time body -> [time]
EventListBT.getTimes


{-# INLINE initWith #-}
initWith ::
   (y -> c) ->
   c -> EventList.T StrictTime [y] -> T c
initWith :: forall y c. (y -> c) -> c -> T Integer [y] -> T c
initWith y -> c
f c
initial =
{-
   EventListTM.switchBodyR EventListBT.empty
      (\xs _ -> EventListMT.consBody initial xs) .
-}
   forall body time. body -> T time body -> T time body
EventListMT.consBody c
initial forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   forall a b c. (a -> b -> c) -> b -> a -> c
flip forall time body. T time body -> time -> T time body
EventListTM.snocTime forall a. C a => a
NonNeg.zero forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> a
evalState c
initial forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
      (\[y]
ys -> forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put forall b c a. (b -> c) -> (a -> b) -> a -> c
. y -> c
f) [y]
ys forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) s. Monad m => StateT s m s
get)


{-# INLINE controllerLinear #-}
controllerLinear ::
   (Check.C event, Field.C y) =>
   Channel -> Ev.Controller ->
   (y,y) -> y ->
   Filter event (T y)
controllerLinear :: forall event y.
(C event, C y) =>
Channel -> Controller -> (y, y) -> y -> Filter event (T y)
controllerLinear Channel
chan Controller
ctrl (y, y)
bnd y
initial =
   forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall y c. (y -> c) -> c -> T Integer [y] -> T c
initWith (forall y. C y => (y, y) -> Int -> y
MV.controllerLinear (y, y)
bnd) y
initial) forall a b. (a -> b) -> a -> b
$
   forall event.
C event =>
Channel -> Controller -> Filter event (T Integer [Int])
Ev.getControllerEvents Channel
chan Controller
ctrl


{-# INLINE controllerExponential #-}
controllerExponential ::
   (Check.C event, Trans.C y) =>
   Channel -> Ev.Controller ->
   (y,y) -> y ->
   Filter event (T y)
controllerExponential :: forall event y.
(C event, C y) =>
Channel -> Controller -> (y, y) -> y -> Filter event (T y)
controllerExponential Channel
chan Controller
ctrl (y, y)
bnd y
initial =
   forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall y c. (y -> c) -> c -> T Integer [y] -> T c
initWith (forall y. C y => (y, y) -> Int -> y
MV.controllerExponential (y, y)
bnd) y
initial) forall a b. (a -> b) -> a -> b
$
   forall event.
C event =>
Channel -> Controller -> Filter event (T Integer [Int])
Ev.getControllerEvents Channel
chan Controller
ctrl


{- |
@pitchBend channel range center@:
emits frequencies on an exponential scale from
@center/range@ to @center*range@.
-}
{-# INLINE pitchBend #-}
pitchBend ::
   (Check.C event, Trans.C y) =>
   Channel ->
   y -> y ->
   Filter event (T y)
pitchBend :: forall event y.
(C event, C y) =>
Channel -> y -> y -> Filter event (T y)
pitchBend Channel
chan y
range y
center =
   forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall y c. (y -> c) -> c -> T Integer [y] -> T c
initWith (forall y. C y => y -> y -> Int -> y
MV.pitchBend y
range y
center) y
center) forall a b. (a -> b) -> a -> b
$
   forall event a. (event -> Maybe a) -> Filter event (T Integer [a])
Ev.getSlice (forall event. C event => Channel -> event -> Maybe Int
Check.pitchBend Channel
chan)
--   getPitchBendEvents chan

{-# INLINE channelPressure #-}
channelPressure ::
   (Check.C event, Trans.C y) =>
   Channel ->
   y -> y ->
   Filter event (T y)
channelPressure :: forall event y.
(C event, C y) =>
Channel -> y -> y -> Filter event (T y)
channelPressure Channel
chan y
maxVal y
initVal =
   forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall y c. (y -> c) -> c -> T Integer [y] -> T c
initWith (forall y. C y => (y, y) -> Int -> y
MV.controllerLinear (y
0,y
maxVal)) y
initVal) forall a b. (a -> b) -> a -> b
$
   forall event a. (event -> Maybe a) -> Filter event (T Integer [a])
Ev.getSlice (forall event. C event => Channel -> event -> Maybe Int
Check.channelPressure Channel
chan)


{-# INLINE bendWheelPressure #-}
bendWheelPressure ::
   (Check.C event, RealRing.C y, Trans.C y) =>
   Channel ->
   Int -> y -> y ->
   Filter event (T (BM.T y))
bendWheelPressure :: forall event y.
(C event, C y, C y) =>
Channel -> Int -> y -> y -> Filter event (T (T y))
bendWheelPressure Channel
chan
      Int
pitchRange y
wheelDepth y
pressDepth =
   let toBM :: T -> T y
toBM = forall a. (C a, C a) => Int -> a -> a -> T -> T a
BM.fromBendWheelPressure Int
pitchRange y
wheelDepth y
pressDepth
   in  forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall y c. (y -> c) -> c -> T Integer [y] -> T c
initWith T -> T y
toBM (T -> T y
toBM T
BWP.deflt)) forall a b. (a -> b) -> a -> b
$
       forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state forall a b. (a -> b) -> a -> b
$
       forall time body0 body1.
T time (body0, body1) -> (T time body0, T time body1)
EventList.unzip forall b c a. (b -> c) -> (a -> b) -> a -> c
.
       forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. [Either a b] -> ([a], [b])
ListHT.unzipEithers forall b c a. (b -> c) -> (a -> b) -> a -> c
.
       forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> a
evalState T
BWP.deflt forall b c a. (b -> c) -> (a -> b) -> a -> c
.
       forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall event.
C event =>
Channel -> event -> State T (Either T event)
separateBWP Channel
chan))

separateBWP ::
   Check.C event =>
   Channel -> event -> State BWP.T (Either BWP.T event)
separateBWP :: forall event.
C event =>
Channel -> event -> State T (Either T event)
separateBWP Channel
chan event
ev =
   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. b -> Either a b
Right event
ev) forall a b. a -> Either a b
Left) forall a b. (a -> b) -> a -> b
$
   forall event. C event => Channel -> event -> State T (Maybe T)
BWP.check Channel
chan event
ev


{- |
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 ::
   (Check.C event, RealRing.C y, Trans.C y) =>
   Channel ->
   Int -> y -> y ->
   Filter event (T (BM.T y))
bendWheelPressureZip :: forall event y.
(C event, C y, C y) =>
Channel -> Int -> y -> y -> Filter event (T (T y))
bendWheelPressureZip Channel
chan
     Int
pitchRange y
wheelDepth y
pressDepth =
   forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (forall time a b c.
C time =>
(a -> b -> c) -> T time a -> T time b -> T time c
PC.zipWith forall a. a -> a -> T a
BM.Cons)
      (forall event y.
(C event, C y) =>
Channel -> y -> y -> Filter event (T y)
pitchBend Channel
chan (y
2forall a. C a => a -> a -> a
^?(forall a b. (C a, C b) => a -> b
fromIntegral Int
pitchRangeforall a. C a => a -> a -> a
/y
12)) y
1)
      (forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (forall time a b c.
C time =>
(a -> b -> c) -> T time a -> T time b -> T time c
PC.zipWith forall a. C a => a -> a -> a
(+))
         (forall event y.
(C event, C y) =>
Channel -> Controller -> (y, y) -> y -> Filter event (T y)
controllerLinear Channel
chan Controller
VoiceMsg.modulation (y
0,y
wheelDepth) y
0)
         (forall event y.
(C event, C y) =>
Channel -> y -> y -> Filter event (T y)
channelPressure Channel
chan y
pressDepth y
0))