{- |
Convert MIDI events of a MIDI controller to a control signal.
-}
{-# LANGUAGE NoImplicitPrelude #-}
module Synthesizer.MIDI.Storable (
   chunkSizesFromLazyTime,
   piecewiseConstant,
   piecewiseConstantInit,
   piecewiseConstantInitWith,
   controllerLinear,
   controllerExponential,
   pitchBend,
   channelPressure,
   bendWheelPressure,

   Instrument, Bank,
   sequenceCore,
   sequence,
   sequenceModulated,
   sequenceMultiModulated,
   applyModulation,
   advanceModulationLazy,
   advanceModulationStrict,
   advanceModulationChunky,
   sequenceMultiProgram,

   Gen.renderInstrument,
   Gen.renderInstrumentIgnoreProgram,
   Gen.evaluateVectorHead,
   Gen.advanceModulationChunk,
   ) where

import Synthesizer.MIDI.EventList
          (LazyTime, StrictTime, Filter, Note,
           Program, Channel, Controller,
           getControllerEvents, getSlice, )
import qualified Synthesizer.MIDI.Generic as Gen
import qualified Synthesizer.MIDI.Value as MV

import qualified Synthesizer.Storable.Cut        as CutSt
import qualified Synthesizer.Storable.Signal     as SigSt
import qualified Data.StorableVector.Lazy.Pattern as SigStV
import qualified Data.StorableVector.Lazy        as SVL

import qualified Synthesizer.State.Signal       as SigS
import qualified Synthesizer.State.Oscillator   as OsciS
import qualified Synthesizer.State.Displacement as DispS
import qualified Synthesizer.State.Filter.NonRecursive as FiltNRS
import qualified Synthesizer.Basic.Wave         as Wave

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

import qualified Synthesizer.PiecewiseConstant.Signal as PC
import qualified Data.EventList.Relative.BodyTime  as EventListBT
import qualified Data.EventList.Relative.TimeBody  as EventList

import Foreign.Storable (Storable, )

import qualified Numeric.NonNegative.Wrapper as NonNegW
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 qualified Algebra.Additive       as Additive

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

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



chunkSizesFromStrictTime :: StrictTime -> NonNegChunky.T SigSt.ChunkSize
chunkSizesFromStrictTime :: Integer -> T ChunkSize
chunkSizesFromStrictTime =
   forall a. C a => [a] -> T a
NonNegChunky.fromChunks forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   forall a b. (a -> b) -> [a] -> [b]
map (Int -> ChunkSize
SVL.ChunkSize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. T a -> a
NonNegW.toNumber) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   Integer -> [T Int]
PC.chopLongTime


chunkSizesFromLazyTime :: LazyTime -> NonNegChunky.T SigSt.ChunkSize
chunkSizesFromLazyTime :: LazyTime -> T ChunkSize
chunkSizesFromLazyTime =
   forall a. C a => [a] -> T a
NonNegChunky.fromChunks forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   forall a b. (a -> b) -> [a] -> [b]
map (Int -> ChunkSize
SVL.ChunkSize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. T a -> a
NonNegW.toNumber) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Integer -> [T Int]
PC.chopLongTime forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   forall a. T a -> [a]
NonNegChunky.toChunks forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   forall a. C a => T a -> T a
NonNegChunky.normalize



{-
ToDo: move to Storable.Signal
-}
{-# INLINE piecewiseConstant #-}
piecewiseConstant ::
   (Storable y) =>
   EventListBT.T StrictTime y -> SigSt.T y
piecewiseConstant :: forall y. Storable y => T Integer y -> T y
piecewiseConstant =
   forall body time a.
(body -> time -> a -> a) -> a -> T time body -> a
EventListBT.foldrPair
      (\y
y Integer
t -> forall a. Storable a => Vector a -> Vector a -> Vector a
SigSt.append (forall a. Storable a => T ChunkSize -> a -> Vector a
SigStV.replicate (Integer -> T ChunkSize
chunkSizesFromStrictTime Integer
t) y
y))
      forall a. Storable a => Vector a
SigSt.empty

{-# INLINE piecewiseConstantInit #-}
piecewiseConstantInit ::
   (Storable y) =>
   y -> EventList.T StrictTime y -> SigSt.T y
piecewiseConstantInit :: forall y. Storable y => y -> T Integer y -> T y
piecewiseConstantInit y
initial =
   (\ ~(Integer
t,T y
rest) ->
      forall a. Storable a => Vector a -> Vector a -> Vector a
SigSt.append (forall a. Storable a => T ChunkSize -> a -> Vector a
SigStV.replicate (Integer -> T ChunkSize
chunkSizesFromStrictTime Integer
t) y
initial) T y
rest)
   forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   forall time a b body.
(time -> a -> b) -> (body -> b -> a) -> b -> T time body -> b
EventList.foldr
      (,)
      (\y
y ~(Integer
t,T y
rest) ->
         forall a. Storable a => Vector a -> Vector a -> Vector a
SigSt.append (forall a. Storable a => T ChunkSize -> a -> Vector a
SigStV.replicate (Integer -> T ChunkSize
chunkSizesFromStrictTime Integer
t) y
y) T y
rest)
      (Integer
0, forall a. Storable a => Vector a
SigSt.empty)
{-
   piecewiseConstant .
--   EventListBM.switchBodyR const .
--   EventListBM.snocTime NonNeg.zero .
--   EventListMB.consBody initial .
   -- switchBodyR causes a space leak
   EventListTM.switchBodyR EventListBT.empty
      (\xs _ -> EventListMT.consBody initial xs)
-}

{-# INLINE piecewiseConstantInitWith #-}
piecewiseConstantInitWith ::
   (Storable c) =>
   (y -> c) ->
   c -> EventList.T StrictTime [y] -> SigSt.T c
piecewiseConstantInitWith :: forall c y. Storable c => (y -> c) -> c -> T Integer [y] -> T c
piecewiseConstantInitWith y -> c
f c
initial =
   forall y. Storable y => y -> T Integer y -> T y
piecewiseConstantInit c
initial 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]
evs -> 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]
evs 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, Storable y, Field.C y) =>
   Channel -> Controller ->
   (y,y) -> y ->
   Filter event (SigSt.T y)
controllerLinear :: forall event y.
(C event, Storable y, 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 c y. Storable c => (y -> c) -> c -> T Integer [y] -> T c
piecewiseConstantInitWith (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])
getControllerEvents Channel
chan Controller
ctrl


{-# INLINE controllerExponential #-}
controllerExponential ::
   (Check.C event, Storable y, Trans.C y) =>
   Channel -> Controller ->
   (y,y) -> y ->
   Filter event (SigSt.T y)
controllerExponential :: forall event y.
(C event, Storable y, 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 c y. Storable c => (y -> c) -> c -> T Integer [y] -> T c
piecewiseConstantInitWith (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])
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, Storable y, Trans.C y) =>
   Channel ->
   y -> y ->
   Filter event (SigSt.T y)
pitchBend :: forall event y.
(C event, Storable y, 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 c y. Storable c => (y -> c) -> c -> T Integer [y] -> T c
piecewiseConstantInitWith (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])
getSlice (forall event. C event => Channel -> event -> Maybe Int
Check.pitchBend Channel
chan)
--   getPitchBendEvents chan

{-# INLINE channelPressure #-}
channelPressure ::
   (Check.C event, Storable y, Trans.C y) =>
   Channel ->
   y -> y ->
   Filter event (SigSt.T y)
channelPressure :: forall event y.
(C event, Storable y, 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 c y. Storable c => (y -> c) -> c -> T Integer [y] -> T c
piecewiseConstantInitWith (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])
getSlice (forall event. C event => Channel -> event -> Maybe Int
Check.channelPressure Channel
chan)


{-
We could use 'getBendWheelPressureSignal' here,
but this may be less efficient.
-}
{-# INLINE bendWheelPressure #-}
bendWheelPressure ::
   (Check.C event, Storable y, RealRing.C y, Trans.C y) =>
   Channel ->
   Int -> y -> y -> y ->
   Filter event (SigSt.T y)
bendWheelPressure :: forall event y.
(C event, Storable y, C y, C y) =>
Channel -> Int -> y -> y -> y -> Filter event (T y)
bendWheelPressure Channel
chan
     Int
pitchRange y
speed y
wheelDepth y
pressDepth =
   do T y
bend  <- forall event y.
(C event, Storable y, 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
      T y
fm    <- forall event y.
(C event, Storable y, C y) =>
Channel -> Controller -> (y, y) -> y -> Filter event (T y)
controllerLinear Channel
chan Controller
VoiceMsg.modulation (y
0,y
wheelDepth) y
0
      T y
press <- forall event y.
(C event, Storable y, C y) =>
Channel -> y -> y -> Filter event (T y)
channelPressure Channel
chan y
pressDepth y
0
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
         forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall b c a.
(Storable b, Storable c) =>
(a -> b -> c) -> T a -> T b -> T c
SigS.zipWithStorable forall a. C a => a -> a -> a
(*)) T y
bend forall a b. (a -> b) -> a -> b
$
         forall a b. (a -> b) -> T a -> T b
SigS.map (y
1forall a. C a => a -> a -> a
+) forall a b. (a -> b) -> a -> b
$
         forall a. C a => T a -> T a -> T a
FiltNRS.envelope
            (forall v. C v => T v -> T v -> T v
DispS.mix
               (forall a. Storable a => T a -> T a
SigS.fromStorableSignal T y
fm)
               (forall a. Storable a => T a -> T a
SigS.fromStorableSignal T y
press))
            (forall a b. C a => T a b -> T a -> a -> T b
OsciS.static forall a. C a => T a a
Wave.sine forall a. C a => a
zero y
speed)


type Instrument y yv = Gen.Instrument y (SigSt.T yv)
type Bank y yv = Gen.Bank y (SigSt.T yv)


{-# INLINE sequenceCore #-}
sequenceCore ::
   (Check.C event, Storable yv, Additive.C yv) =>
   SVL.ChunkSize ->
   Channel ->
   Program ->
   Gen.Modulator Note (SigSt.T yv) ->
   Filter event (SigSt.T yv)
sequenceCore :: forall event yv.
(C event, Storable yv, C yv) =>
ChunkSize
-> Channel
-> Program
-> Modulator Note (T yv)
-> Filter event (T yv)
sequenceCore ChunkSize
chunkSize Channel
chan Program
pgm Modulator Note (T yv)
modu =
   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall v. (Storable v, C v) => ChunkSize -> T (T Int) (T v) -> T v
CutSt.arrangeEquidist ChunkSize
chunkSize) forall a b. (a -> b) -> a -> b
$
   forall event signal.
(C event, Monoid signal) =>
Channel
-> Program -> Modulator Note signal -> FilterSequence event signal
Gen.sequenceCore Channel
chan Program
pgm Modulator Note (T yv)
modu


{-# INLINE sequence #-}
sequence ::
   (Check.C event, Storable yv, Additive.C yv, Trans.C y) =>
   SVL.ChunkSize ->
   Channel ->
   Instrument y yv ->
   Filter event (SigSt.T yv)
sequence :: forall event yv y.
(C event, Storable yv, C yv, C y) =>
ChunkSize -> Channel -> Instrument y yv -> Filter event (T yv)
sequence ChunkSize
chunkSize Channel
chan Instrument y yv
bank =
   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall v. (Storable v, C v) => ChunkSize -> T (T Int) (T v) -> T v
CutSt.arrangeEquidist ChunkSize
chunkSize) forall a b. (a -> b) -> a -> b
$
   forall event signal y.
(C event, Monoid signal, C y) =>
Channel -> Instrument y signal -> FilterSequence event signal
Gen.sequence Channel
chan Instrument y yv
bank


{-# INLINE sequenceModulated #-}
sequenceModulated ::
   (Check.C event, Storable c, Storable yv, Additive.C yv, Trans.C y) =>
   SVL.ChunkSize ->
   SigSt.T c ->
   Channel ->
   (SigSt.T c -> Instrument y yv) ->
   Filter event (SigSt.T yv)
sequenceModulated :: forall event c yv y.
(C event, Storable c, Storable yv, C yv, C y) =>
ChunkSize
-> T c
-> Channel
-> (T c -> Instrument y yv)
-> Filter event (T yv)
sequenceModulated ChunkSize
chunkSize T c
modu Channel
chan T c -> Instrument y yv
instr =
   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall v. (Storable v, C v) => ChunkSize -> T (T Int) (T v) -> T v
CutSt.arrangeEquidist ChunkSize
chunkSize) forall a b. (a -> b) -> a -> b
$
   forall event ctrl signal y.
(C event, Transform ctrl, NormalForm ctrl, Monoid signal, C y) =>
ctrl
-> Channel
-> (ctrl -> Instrument y signal)
-> FilterSequence event signal
Gen.sequenceModulated T c
modu Channel
chan T c -> Instrument y yv
instr


{-# INLINE sequenceMultiModulated #-}
sequenceMultiModulated ::
   (Check.C event, Storable yv, Additive.C yv, Trans.C y) =>
   SVL.ChunkSize ->
   Channel ->
   instrument ->
   Gen.Modulator (instrument, Note) (Instrument y yv, Note) ->
   Filter event (SigSt.T yv)
sequenceMultiModulated :: forall event yv y instrument.
(C event, Storable yv, C yv, C y) =>
ChunkSize
-> Channel
-> instrument
-> Modulator (instrument, Note) (Instrument y yv, Note)
-> Filter event (T yv)
sequenceMultiModulated ChunkSize
chunkSize Channel
chan instrument
instr Modulator (instrument, Note) (Instrument y yv, Note)
modu =
   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall v. (Storable v, C v) => ChunkSize -> T (T Int) (T v) -> T v
CutSt.arrangeEquidist ChunkSize
chunkSize) forall a b. (a -> b) -> a -> b
$
   forall event signal y instrument.
(C event, Monoid signal, C y) =>
Channel
-> instrument
-> Modulator (instrument, Note) (Instrument y signal, Note)
-> FilterSequence event signal
Gen.sequenceMultiModulated Channel
chan instrument
instr Modulator (instrument, Note) (Instrument y yv, Note)
modu


applyModulation ::
   (Storable c) =>
   SigSt.T c ->
   Gen.Modulator (SigSt.T c -> instr, note) (instr, note)
applyModulation :: forall c instr note.
Storable c =>
T c -> Modulator (T c -> instr, note) (instr, note)
applyModulation =
   forall signal instr note.
(Transform signal, NormalForm signal) =>
signal -> Modulator (signal -> instr, note) (instr, note)
Gen.applyModulation

advanceModulationLazy, advanceModulationStrict, advanceModulationChunky ::
   (Storable a) =>
   LazyTime -> State (SigSt.T a) LazyTime

{-
This one drops lazily,
such that the control signal will be cached until it is used.
That is, if for a long time no new note is played,
more and more memory will be allocated.
-}
advanceModulationLazy :: forall a. Storable a => LazyTime -> State (T a) LazyTime
advanceModulationLazy LazyTime
t =
   forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (forall a. Storable a => T ChunkSize -> Vector a -> Vector a
SigStV.drop (LazyTime -> T ChunkSize
chunkSizesFromLazyTime LazyTime
t)) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return LazyTime
t

{-
This one is too strict,
because the complete drop is forced
also if only the first chunk of the lazy time is requested.
-}
advanceModulationStrict :: forall a. Storable a => LazyTime -> State (T a) LazyTime
advanceModulationStrict LazyTime
t = forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state forall a b. (a -> b) -> a -> b
$ \Vector a
xs ->
   let ys :: Vector a
ys = forall a. Storable a => T ChunkSize -> Vector a -> Vector a
SigStV.drop (LazyTime -> T ChunkSize
chunkSizesFromLazyTime LazyTime
t) Vector a
xs
   in  (forall signal t. NormalForm signal => signal -> t -> t
Gen.evaluateVectorHead Vector a
ys LazyTime
t, Vector a
ys)

advanceModulationChunky :: forall a. Storable a => LazyTime -> State (T a) LazyTime
advanceModulationChunky =
   forall signal.
(Transform signal, NormalForm signal) =>
LazyTime -> State signal LazyTime
Gen.advanceModulation


{-# INLINE sequenceMultiProgram #-}
sequenceMultiProgram ::
   (Check.C event, Storable yv, Additive.C yv, Trans.C y) =>
   SVL.ChunkSize ->
   Channel ->
   Program ->
   [Instrument y yv] ->
   Filter event (SigSt.T yv)
sequenceMultiProgram :: forall event yv y.
(C event, Storable yv, C yv, C y) =>
ChunkSize
-> Channel -> Program -> [Instrument y yv] -> Filter event (T yv)
sequenceMultiProgram ChunkSize
chunkSize Channel
chan Program
pgm [Instrument y yv]
bank =
   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall v. (Storable v, C v) => ChunkSize -> T (T Int) (T v) -> T v
CutSt.arrangeEquidist ChunkSize
chunkSize) forall a b. (a -> b) -> a -> b
$
   forall event signal y.
(C event, Monoid signal, C y) =>
Channel
-> Program -> [Instrument y signal] -> FilterSequence event signal
Gen.sequenceMultiProgram Channel
chan Program
pgm [Instrument y yv]
bank