module Synthesizer.MIDI.CausalIO.ControllerSet (
T,
fromChannel,
slice, PCS.Controller(..),
controllerLinear,
controllerExponential,
pitchBend,
channelPressure,
bendWheelPressure,
) where
import qualified Synthesizer.CausalIO.Process as PIO
import qualified Synthesizer.MIDI.CausalIO.Process as MIO
import qualified Synthesizer.MIDI.PiecewiseConstant.ControllerSet as PCS
import qualified Synthesizer.MIDI.EventList as MIDIEv
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 Sound.MIDI.Message.Channel.Voice as VoiceMsg
import qualified Sound.MIDI.Message.Class.Check as Check
import qualified Data.EventList.Relative.TimeTime as EventListTT
import qualified Data.EventList.Relative.BodyTime as EventListBT
import qualified Data.EventList.Relative.MixedTime as EventListMT
import qualified Algebra.Transcendental as Trans
import qualified Algebra.Field as Field
import qualified Algebra.RealRing as RealRing
import qualified Control.Monad.Trans.State as MS
import qualified Data.Accessor.Basic as Acc
import qualified Data.Map as Map
import Data.Traversable (traverse, )
import Data.Foldable (traverse_, )
import Control.Arrow (Arrow, arr, )
import Control.Category ((.), )
import qualified Data.Maybe as Maybe
import Data.Maybe.HT (toMaybe, )
import NumericPrelude.Numeric
import NumericPrelude.Base hiding ((.), )
import Prelude ()
mapInsertMany ::
(Ord key) =>
[(key,a)] -> Map.Map key a -> Map.Map key a
mapInsertMany :: forall key a. Ord key => [(key, a)] -> Map key a -> Map key a
mapInsertMany [(key, a)]
assignments Map key a
inits =
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert)) Map key a
inits [(key, a)]
assignments
fromChannel ::
(Check.C event) =>
MIDIEv.Channel ->
PIO.T
(EventListTT.T MIDIEv.StrictTime [event])
(PCS.T PCS.Controller Int)
fromChannel :: forall event.
C event =>
Channel -> T (T StrictTime [event]) (T Controller Int)
fromChannel Channel
chan =
(forall state a b. state -> (a -> State state b) -> T a b
PIO.traverse forall k a. Map k a
Map.empty forall a b. (a -> b) -> a -> b
$ \T StrictTime [(Controller, Int)]
evs0 -> do
Map Controller Int
initial <- forall (m :: * -> *) s. Monad m => StateT s m s
MS.get
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall key a. Map key a -> T StrictTime [(key, a)] -> T key a
PCS.Cons Map Controller Int
initial) forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\[(Controller, Int)]
ys -> forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
MS.modify (forall key a. Ord key => [(key, a)] -> Map key a -> Map key a
mapInsertMany [(Controller, Int)]
ys) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return [(Controller, Int)]
ys) T StrictTime [(Controller, Int)]
evs0)
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
forall (arrow :: * -> * -> *) (f :: * -> *) a b.
(Arrow arrow, Functor f) =>
(a -> Maybe b) -> arrow (f [a]) (f [b])
MIO.mapMaybe (forall event.
C event =>
Channel -> event -> Maybe (Controller, Int)
PCS.maybeController Channel
chan)
type T arrow y =
arrow
(PCS.T PCS.Controller Int)
(EventListBT.T PC.ShortStrictTime y)
slice ::
(Arrow arrow) =>
PCS.Controller ->
(Int -> y) ->
y ->
T arrow y
slice :: forall (arrow :: * -> * -> *) y.
Arrow arrow =>
Controller -> (Int -> y) -> y -> T arrow y
slice Controller
c Int -> y
f y
deflt =
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall a b. (a -> b) -> a -> b
$ \(PCS.Cons Map Controller Int
initial T StrictTime [(Controller, Int)]
stream) ->
let yin :: y
yin = forall b a. b -> (a -> b) -> Maybe a -> b
maybe y
deflt Int -> y
f forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Controller
c Map Controller Int
initial
in forall y. T StrictTime y -> T ShortStrictTime y
PC.subdivideLongStrict forall a b. (a -> b) -> a -> b
$
forall body time. body -> T time body -> T time body
EventListMT.consBody y
yin forall a b. (a -> b) -> a -> b
$
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> a
MS.evalState y
yin forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
(\[Int]
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 ()
MS.put forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int -> y
f) [Int]
ys forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) s. Monad m => StateT s m s
MS.get) forall a b. (a -> b) -> a -> b
$
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
(forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe
(\(Controller
ci,Int
a) -> forall a. Bool -> a -> Maybe a
toMaybe (Controller
cforall a. Eq a => a -> a -> Bool
==Controller
ci) Int
a))
T StrictTime [(Controller, Int)]
stream
controllerLinear ::
(Field.C y, Arrow arrow) =>
MIDIEv.Controller ->
(y,y) -> y ->
T arrow y
controllerLinear :: forall y (arrow :: * -> * -> *).
(C y, Arrow arrow) =>
Controller -> (y, y) -> y -> T arrow y
controllerLinear Controller
ctrl (y, y)
bnd y
initial =
forall (arrow :: * -> * -> *) y.
Arrow arrow =>
Controller -> (Int -> y) -> y -> T arrow y
slice (Controller -> Controller
PCS.Controller Controller
ctrl) (forall y. C y => (y, y) -> Int -> y
MV.controllerLinear (y, y)
bnd) y
initial
controllerExponential ::
(Trans.C y, Arrow arrow) =>
MIDIEv.Controller ->
(y,y) -> y ->
T arrow y
controllerExponential :: forall y (arrow :: * -> * -> *).
(C y, Arrow arrow) =>
Controller -> (y, y) -> y -> T arrow y
controllerExponential Controller
ctrl (y, y)
bnd y
initial =
forall (arrow :: * -> * -> *) y.
Arrow arrow =>
Controller -> (Int -> y) -> y -> T arrow y
slice (Controller -> Controller
PCS.Controller Controller
ctrl) (forall y. C y => (y, y) -> Int -> y
MV.controllerExponential (y, y)
bnd) y
initial
pitchBend ::
(Trans.C y, Arrow arrow) =>
y -> y ->
T arrow y
pitchBend :: forall y (arrow :: * -> * -> *).
(C y, Arrow arrow) =>
y -> y -> T arrow y
pitchBend y
range y
center =
forall (arrow :: * -> * -> *) y.
Arrow arrow =>
Controller -> (Int -> y) -> y -> T arrow y
slice Controller
PCS.PitchBend (forall y. C y => y -> y -> Int -> y
MV.pitchBend y
range y
center) y
center
channelPressure ::
(Trans.C y, Arrow arrow) =>
y -> y ->
T arrow y
channelPressure :: forall y (arrow :: * -> * -> *).
(C y, Arrow arrow) =>
y -> y -> T arrow y
channelPressure y
maxVal y
initial =
forall (arrow :: * -> * -> *) y.
Arrow arrow =>
Controller -> (Int -> y) -> y -> T arrow y
slice Controller
PCS.Pressure (forall y. C y => (y, y) -> Int -> y
MV.controllerLinear (forall a. C a => a
zero,y
maxVal)) y
initial
bendWheelPressure ::
(RealRing.C y, Trans.C y, Arrow arrow) =>
Int -> y -> y ->
T arrow (BM.T y)
bendWheelPressure :: forall y (arrow :: * -> * -> *).
(C y, C y, Arrow arrow) =>
Int -> y -> y -> T arrow (T y)
bendWheelPressure Int
pitchRange y
wheelDepth y
pressDepth =
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall a b. (a -> b) -> a -> b
$ \(PCS.Cons Map Controller Int
initial T StrictTime [(Controller, Int)]
stream) ->
let set :: Controller -> T a Int -> a -> a
set Controller
key T a Int
field =
forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (forall r a. T r a -> a -> r -> r
Acc.set T a Int
field) forall a b. (a -> b) -> a -> b
$
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Controller
key Map Controller Int
initial
yin :: T
yin =
forall {a}. Controller -> T a Int -> a -> a
set Controller
PCS.PitchBend T T Int
BWP.bend forall a b. (a -> b) -> a -> b
$
forall {a}. Controller -> T a Int -> a -> a
set (Controller -> Controller
PCS.Controller Controller
VoiceMsg.modulation) T T Int
BWP.wheel forall a b. (a -> b) -> a -> b
$
forall {a}. Controller -> T a Int -> a -> a
set Controller
PCS.Pressure T T Int
BWP.pressure forall a b. (a -> b) -> a -> b
$
T
BWP.deflt
in forall y. T StrictTime y -> T ShortStrictTime y
PC.subdivideLongStrict forall a b. (a -> b) -> a -> b
$
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. (C a, C a) => Int -> a -> a -> T -> T a
BM.fromBendWheelPressure Int
pitchRange y
wheelDepth y
pressDepth) forall a b. (a -> b) -> a -> b
$
forall body time. body -> T time body -> T time body
EventListMT.consBody T
yin forall a b. (a -> b) -> a -> b
$
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> a
MS.evalState T
yin forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\[T]
ys0 -> 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 ()
MS.put [T]
ys0 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) s. Monad m => StateT s m s
MS.get) forall a b. (a -> b) -> a -> b
$
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [Maybe a] -> [a]
Maybe.catMaybes forall a b. (a -> b) -> a -> b
$
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> a
MS.evalState T
BWP.deflt forall a b. (a -> b) -> a -> b
$
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 (Controller, Int) -> State T (Maybe T)
PCS.checkBendWheelPressure) T StrictTime [(Controller, Int)]
stream