{-# 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
{-# 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)
{-# 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
{-# 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)
{-# 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)
{-# 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
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
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