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