{-# LANGUAGE NoImplicitPrelude #-}
module Synthesizer.MIDI.PiecewiseConstant.ControllerSet (
T(Cons),
mapStream,
Controller(Controller,PitchBend,Pressure),
fromChannel,
maybeController,
controllerLinear,
controllerExponential,
pitchBend,
channelPressure,
bendWheelPressure,
checkBendWheelPressure,
bendWheelPressureZip,
initial, stream,
) where
import qualified Synthesizer.PiecewiseConstant.Signal as PC
import qualified Synthesizer.MIDI.EventList as Ev
import Synthesizer.MIDI.EventList (StrictTime, 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.Generic.Cut as CutG
import Control.DeepSeq (NFData, rnf, )
import qualified Data.EventList.Relative.TimeTime as EventListTT
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 Numeric.NonNegative.Class as NonNeg98
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 qualified Data.Map as Map
import Data.Map (Map, )
import qualified Data.Accessor.Monad.Trans.State as AccState
import qualified Data.Accessor.Basic as Acc
import Control.Monad.Trans.State (State, evalState, state, get, put, )
import Control.Monad (liftM2, msum, )
import Data.Traversable (traverse, )
import Data.Foldable (traverse_, )
import Data.Monoid (Monoid, mempty, mappend, )
import Data.Semigroup (Semigroup, (<>), )
import Data.Maybe.HT (toMaybe, )
import Data.Tuple.HT (mapFst, mapPair, )
import qualified Data.List.HT as ListHT
import qualified Data.List as List
import NumericPrelude.Numeric
import NumericPrelude.Base
import qualified Prelude as P
data T key a =
Cons {
forall key a. T key a -> Map key a
initial :: Map key a,
forall key a. T key a -> T StrictTime [(key, a)]
stream :: EventListTT.T StrictTime [(key, a)]
}
deriving Int -> T key a -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall key a. (Show key, Show a) => Int -> T key a -> ShowS
forall key a. (Show key, Show a) => [T key a] -> ShowS
forall key a. (Show key, Show a) => T key a -> String
showList :: [T key a] -> ShowS
$cshowList :: forall key a. (Show key, Show a) => [T key a] -> ShowS
show :: T key a -> String
$cshow :: forall key a. (Show key, Show a) => T key a -> String
showsPrec :: Int -> T key a -> ShowS
$cshowsPrec :: forall key a. (Show key, Show a) => Int -> T key a -> ShowS
Show
mapStream ::
(EventListTT.T StrictTime [(key, a)] ->
EventListTT.T StrictTime [(key, a)]) ->
T key a -> T key a
mapStream :: forall key a.
(T StrictTime [(key, a)] -> T StrictTime [(key, a)])
-> T key a -> T key a
mapStream T StrictTime [(key, a)] -> T StrictTime [(key, a)]
f T key a
s = forall key a. Map key a -> T StrictTime [(key, a)] -> T key a
Cons (forall key a. T key a -> Map key a
initial T key a
s) (T StrictTime [(key, a)] -> T StrictTime [(key, a)]
f (forall key a. T key a -> T StrictTime [(key, a)]
stream T key a
s))
data Controller =
Controller VoiceMsg.Controller
| PitchBend
| Pressure
deriving (Int -> Controller -> ShowS
[Controller] -> ShowS
Controller -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Controller] -> ShowS
$cshowList :: [Controller] -> ShowS
show :: Controller -> String
$cshow :: Controller -> String
showsPrec :: Int -> Controller -> ShowS
$cshowsPrec :: Int -> Controller -> ShowS
Show, Controller -> Controller -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Controller -> Controller -> Bool
$c/= :: Controller -> Controller -> Bool
== :: Controller -> Controller -> Bool
$c== :: Controller -> Controller -> Bool
Eq, Eq Controller
Controller -> Controller -> Bool
Controller -> Controller -> Ordering
Controller -> Controller -> Controller
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Controller -> Controller -> Controller
$cmin :: Controller -> Controller -> Controller
max :: Controller -> Controller -> Controller
$cmax :: Controller -> Controller -> Controller
>= :: Controller -> Controller -> Bool
$c>= :: Controller -> Controller -> Bool
> :: Controller -> Controller -> Bool
$c> :: Controller -> Controller -> Bool
<= :: Controller -> Controller -> Bool
$c<= :: Controller -> Controller -> Bool
< :: Controller -> Controller -> Bool
$c< :: Controller -> Controller -> Bool
compare :: Controller -> Controller -> Ordering
$ccompare :: Controller -> Controller -> Ordering
Ord)
instance NFData Controller where
rnf :: Controller -> ()
rnf (Controller Controller
c) =
forall a. NFData a => a -> ()
rnf (Controller -> Int
VoiceMsg.fromController Controller
c)
rnf Controller
_ = ()
fromChannel ::
(Check.C event) =>
Channel ->
Ev.Filter event (T Controller Int)
fromChannel :: forall event. C event => Channel -> Filter event (T Controller Int)
fromChannel Channel
chan =
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
Cons forall k a. Map k a
Map.empty) forall a b. (a -> b) -> a -> b
$
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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
NonNeg98.zero) forall a b. (a -> b) -> a -> b
$
forall event a.
(event -> Maybe a) -> Filter event (T StrictTime [a])
Ev.getSlice (forall event.
C event =>
Channel -> event -> Maybe (Controller, Int)
maybeController Channel
chan)
maybeController ::
(Check.C event) =>
Channel -> event -> Maybe (Controller, Int)
maybeController :: forall event.
C event =>
Channel -> event -> Maybe (Controller, Int)
maybeController Channel
chan event
e = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum forall a b. (a -> b) -> a -> b
$
(forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a c b. (a -> c) -> (a, b) -> (c, b)
mapFst Controller -> Controller
Controller) forall a b. (a -> b) -> a -> b
$ forall event.
C event =>
Channel -> event -> Maybe (Controller, Int)
Check.anyController Channel
chan event
e) forall a. a -> [a] -> [a]
:
(forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((,) Controller
PitchBend) forall a b. (a -> b) -> a -> b
$ forall event. C event => Channel -> event -> Maybe Int
Check.pitchBend Channel
chan event
e) forall a. a -> [a] -> [a]
:
(forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((,) Controller
Pressure) forall a b. (a -> b) -> a -> b
$ forall event. C event => Channel -> event -> Maybe Int
Check.channelPressure Channel
chan event
e) forall a. a -> [a] -> [a]
:
[]
instance CutG.Read (T key a) where
null :: T key a -> Bool
null =
forall (t :: * -> *) a. Foldable t => t a -> Bool
List.null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
List.filter (forall a. Ord a => a -> a -> Bool
> forall a. Num a => Integer -> a
P.fromInteger Integer
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall time body. T time body -> [time]
EventListTT.getTimes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key a. T key a -> T StrictTime [(key, a)]
stream
length :: T key a -> Int
length =
forall a b. (C a, C b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Integral a => a -> Integer
P.toInteger forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
P.sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall time body. T time body -> [time]
EventListTT.getTimes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key a. T key a -> T StrictTime [(key, a)]
stream
instance Semigroup (T key y) where
T key y
x <> :: T key y -> T key y -> T key y
<> T key y
y =
forall key a. Map key a -> T StrictTime [(key, a)] -> T key a
Cons
(forall key a. T key a -> Map key a
initial T key y
x)
(forall time body.
C time =>
T time body -> T time body -> T time body
EventListTT.append (forall key a. T key a -> T StrictTime [(key, a)]
stream T key y
x) (forall key a. T key a -> T StrictTime [(key, a)]
flatten T key y
y))
instance Monoid (T key y) where
mempty :: T key y
mempty = forall key a. Map key a -> T StrictTime [(key, a)] -> T key a
Cons forall k a. Map k a
Map.empty (forall time body. time -> T time body
EventListTT.pause forall a. Monoid a => a
mempty)
mappend :: T key y -> T key y -> T key y
mappend = forall a. Semigroup a => a -> a -> a
(<>)
instance (NFData key, NFData a) => CutG.NormalForm (T key a) where
evaluateHead :: T key a -> ()
evaluateHead T key a
xs = forall a. NFData a => a -> ()
rnf (forall key a. T key a -> Map key a
initial T key a
xs)
flatten ::
T key a -> EventListTT.T StrictTime [(key, a)]
flatten :: forall key a. T key a -> T StrictTime [(key, a)]
flatten T key a
xs =
forall time body. time -> body -> T time body -> T time body
EventListTT.cons
forall a. Monoid a => a
mempty (forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$ forall key a. T key a -> Map key a
initial T key a
xs)
(forall key a. T key a -> T StrictTime [(key, a)]
stream T key a
xs)
mapInsertMany ::
(Ord key) =>
[(key,a)] -> Map key a -> 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
reverseList ::
(Ord key) =>
(Map key a, [(key,a)]) ->
(Map key a, [(key,a)])
reverseList :: forall key a.
Ord key =>
(Map key a, [(key, a)]) -> (Map key a, [(key, a)])
reverseList (Map key a
inits,[(key, a)]
xs) =
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
(\(Map key a
inits0,[(key, a)]
ys) (key
key,a
a) ->
let (Maybe a
ma,Map key a
inits1) =
forall k a.
Ord k =>
(k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a, Map k a)
Map.insertLookupWithKey
(\ key
_k a
new a
_old -> a
new) key
key a
a Map key a
inits0
in (Map key a
inits1,
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(forall a. HasCallStack => String -> a
error String
"MIDIControllerSet.reverse: uninitialized controller")
((,) key
key) Maybe a
ma
forall a. a -> [a] -> [a]
: [(key, a)]
ys))
(Map key a
inits, [])
[(key, a)]
xs
instance (Ord key) => CutG.Transform (T key y) where
take :: Int -> T key y -> T key y
take Int
n =
forall key a.
(T StrictTime [(key, a)] -> T StrictTime [(key, a)])
-> T key a -> T key a
mapStream (forall time body. C time => time -> T time body -> T time body
EventListTT.takeTime (forall a b. (Integral a, Num b) => a -> b
P.fromIntegral Int
n))
drop :: Int -> T key y -> T key y
drop Int
n0 T key y
xs =
let recourse :: StrictTime -> Map key a -> T StrictTime [(key, a)] -> T key a
recourse StrictTime
n Map key a
inits =
forall time body a. (time -> T time body -> a) -> T time body -> a
EventListMT.switchTimeL forall a b. (a -> b) -> a -> b
$ \StrictTime
t T StrictTime [(key, a)]
xs1 ->
let (Bool
b,StrictTime
d) = forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a. C a => a -> a -> (a, (Bool, a))
NonNeg98.split StrictTime
t StrictTime
n
in forall key a.
(T StrictTime [(key, a)] -> T StrictTime [(key, a)])
-> T key a -> T key a
mapStream (forall time body. C time => T time body -> T time body
EventListTT.forceTimeHead) forall a b. (a -> b) -> a -> b
$
if Bool -> Bool
not Bool
b
then forall key a. Map key a -> T StrictTime [(key, a)] -> T key a
Cons Map key a
inits (forall time body. time -> T time body -> T time body
EventListMT.consTime StrictTime
d T StrictTime [(key, a)]
xs1)
else
forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a body time.
a -> (body -> T time body -> a) -> T time body -> a
EventListMT.switchBodyL
(forall key a. Map key a -> T StrictTime [(key, a)] -> T key a
Cons Map key a
inits (forall time body. time -> T time body
EventListTT.pause forall a. Monoid a => a
mempty))) T StrictTime [(key, a)]
xs1 forall a b. (a -> b) -> a -> b
$ \[(key, a)]
assignments T StrictTime [(key, a)]
xs2 ->
StrictTime -> Map key a -> T StrictTime [(key, a)] -> T key a
recourse StrictTime
d (forall key a. Ord key => [(key, a)] -> Map key a -> Map key a
mapInsertMany [(key, a)]
assignments Map key a
inits) T StrictTime [(key, a)]
xs2
in forall {key} {a}.
Ord key =>
StrictTime -> Map key a -> T StrictTime [(key, a)] -> T key a
recourse (forall a b. (Integral a, Num b) => a -> b
P.fromIntegral Int
n0) (forall key a. T key a -> Map key a
initial T key y
xs) (forall key a. T key a -> T StrictTime [(key, a)]
stream T key y
xs)
dropMarginRem :: Int -> Int -> T key y -> (Int, T key y)
dropMarginRem Int
n Int
m T key y
xs =
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl'
(\(Int
mi,T key y
xsi) Int
k -> (Int
miforall a. C a => a -> a -> a
-Int
k, forall sig. Transform sig => Int -> sig -> sig
CutG.drop Int
k T key y
xsi))
(Int
m, T key y
xs)
(forall a b. (a -> b) -> [a] -> [b]
List.map forall a b. (Integral a, Num b) => a -> b
P.fromIntegral forall a b. (a -> b) -> a -> b
$ forall time body. T time body -> [time]
EventListTT.getTimes forall a b. (a -> b) -> a -> b
$
forall time body. C time => time -> T time body -> T time body
EventListTT.takeTime (forall a b. (Integral a, Num b) => a -> b
P.fromIntegral Int
m) forall a b. (a -> b) -> a -> b
$
forall time body. C time => time -> T time body -> T time body
EventListTT.dropTime (forall a b. (Integral a, Num b) => a -> b
P.fromIntegral Int
n) forall a b. (a -> b) -> a -> b
$
forall key a. T key a -> T StrictTime [(key, a)]
stream T key y
xs)
splitAt :: Int -> T key y -> (T key y, T key y)
splitAt Int
n0 T key y
xs =
let recourse :: StrictTime
-> Map key a
-> T StrictTime [(key, a)]
-> (T StrictTime [(key, a)], T key a)
recourse StrictTime
n Map key a
inits =
forall time body a. (time -> T time body -> a) -> T time body -> a
EventListMT.switchTimeL forall a b. (a -> b) -> a -> b
$ \StrictTime
t T StrictTime [(key, a)]
xs1 ->
let (StrictTime
m, ~(Bool
b,StrictTime
d)) = forall a. C a => a -> a -> (a, (Bool, a))
NonNeg98.split StrictTime
t StrictTime
n
in forall a c b d. (a -> c, b -> d) -> (a, b) -> (c, d)
mapPair
(forall time body. time -> T time body -> T time body
EventListMT.consTime StrictTime
m,
forall key a.
(T StrictTime [(key, a)] -> T StrictTime [(key, a)])
-> T key a -> T key a
mapStream (forall time body. C time => T time body -> T time body
EventListTT.forceTimeHead)) forall a b. (a -> b) -> a -> b
$
if Bool -> Bool
not Bool
b
then
(forall time body. T time body
EventListBT.empty,
forall key a. Map key a -> T StrictTime [(key, a)] -> T key a
Cons Map key a
inits (forall time body. time -> T time body -> T time body
EventListMT.consTime StrictTime
d T StrictTime [(key, a)]
xs1))
else
forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a body time.
a -> (body -> T time body -> a) -> T time body -> a
EventListMT.switchBodyL
(forall time body. T time body
EventListBT.empty,
forall key a. Map key a -> T StrictTime [(key, a)] -> T key a
Cons Map key a
inits (forall time body. time -> T time body
EventListTT.pause forall a. Monoid a => a
mempty))) T StrictTime [(key, a)]
xs1 forall a b. (a -> b) -> a -> b
$ \[(key, a)]
keyAs T StrictTime [(key, a)]
xs2 ->
forall a c b. (a -> c) -> (a, b) -> (c, b)
mapFst (forall body time. body -> T time body -> T time body
EventListMT.consBody [(key, a)]
keyAs) forall a b. (a -> b) -> a -> b
$
StrictTime
-> Map key a
-> T StrictTime [(key, a)]
-> (T StrictTime [(key, a)], T key a)
recourse StrictTime
d (forall key a. Ord key => [(key, a)] -> Map key a -> Map key a
mapInsertMany [(key, a)]
keyAs Map key a
inits) T StrictTime [(key, a)]
xs2
in forall a c b. (a -> c) -> (a, b) -> (c, b)
mapFst (forall key a. Map key a -> T StrictTime [(key, a)] -> T key a
Cons (forall key a. T key a -> Map key a
initial T key y
xs)) forall a b. (a -> b) -> a -> b
$
forall {key} {a}.
Ord key =>
StrictTime
-> Map key a
-> T StrictTime [(key, a)]
-> (T StrictTime [(key, a)], T key a)
recourse (forall a b. (Integral a, Num b) => a -> b
P.fromIntegral Int
n0) (forall key a. T key a -> Map key a
initial T key y
xs) (forall key a. T key a -> T StrictTime [(key, a)]
stream T key y
xs)
reverse :: T key y -> T key y
reverse T key y
xs =
forall a time b body.
(a -> time -> b) -> (b -> body -> a) -> a -> T time body -> b
EventListTT.foldl
(\(Map key y
inits,T StrictTime [(key, y)]
ys) StrictTime
t -> forall key a. Map key a -> T StrictTime [(key, a)] -> T key a
Cons Map key y
inits forall a b. (a -> b) -> a -> b
$ forall time body. time -> T time body -> T time body
EventListMT.consTime StrictTime
t T StrictTime [(key, y)]
ys)
(\(Cons Map key y
inits0 T StrictTime [(key, y)]
ys) [(key, y)]
evs0 ->
let (Map key y
inits1, [(key, y)]
evs1) = forall key a.
Ord key =>
(Map key a, [(key, a)]) -> (Map key a, [(key, a)])
reverseList (Map key y
inits0, [(key, y)]
evs0)
in (Map key y
inits1, forall body time. body -> T time body -> T time body
EventListMT.consBody [(key, y)]
evs1 T StrictTime [(key, y)]
ys))
(forall key a. T key a -> Map key a
initial T key y
xs, forall time body. T time body
EventListBT.empty)
(forall key a. T key a -> T StrictTime [(key, a)]
stream T key y
xs)
type Filter = State (T Controller Int)
_errorUninitialized :: Controller -> Int
_errorUninitialized :: Controller -> Int
_errorUninitialized Controller
c =
forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$
String
"getSlice: uninitialized controller " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Controller
c
{-# INLINE getSlice #-}
getSlice ::
Controller ->
(Int -> a) ->
a -> Filter (PC.T a)
getSlice :: forall a. Controller -> (Int -> a) -> a -> Filter (T a)
getSlice Controller
c Int -> a
f a
deflt =
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state forall a b. (a -> b) -> a -> b
$ \T Controller Int
xs ->
let (T StrictTime [Int]
ys,T StrictTime [(Controller, Int)]
zs) =
forall time body0 body1.
T time (body0, body1) -> (T time body0, T time body1)
EventListTT.unzip 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], [a])
ListHT.partitionMaybe
(\(Controller
ci,Int
a) -> forall a. Bool -> a -> Maybe a
toMaybe (Controller
cforall a. Eq a => a -> a -> Bool
==Controller
ci) Int
a))
(forall key a. T key a -> T StrictTime [(key, a)]
stream T Controller Int
xs)
(Maybe Int
yin0,Map Controller Int
zis) =
forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey
(\ Controller
_k Int
_a -> forall a. Maybe a
Nothing) Controller
c
(forall key a. T key a -> Map key a
initial T Controller Int
xs)
yin1 :: a
yin1 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe a
deflt Int -> a
f Maybe Int
yin0
fill :: T StrictTime [Int] -> T StrictTime a
fill =
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> a
evalState a
yin1 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
(\[Int]
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 ()
put forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a
f) [Int]
ys0 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) s. Monad m => StateT s m s
get)
in (forall body time. body -> T time body -> T time body
EventListMT.consBody a
yin1 (T StrictTime [Int] -> T StrictTime a
fill T StrictTime [Int]
ys),
forall key a. Map key a -> T StrictTime [(key, a)] -> T key a
Cons Map Controller Int
zis T StrictTime [(Controller, Int)]
zs)
{-# INLINE controllerLinear #-}
controllerLinear ::
(Field.C y) =>
Ev.Controller -> (y,y) -> y -> Filter (PC.T y)
controllerLinear :: forall y. C y => Controller -> (y, y) -> y -> Filter (T y)
controllerLinear Controller
ctrl (y, y)
bnd =
forall a. Controller -> (Int -> a) -> a -> Filter (T a)
getSlice (Controller -> Controller
Controller Controller
ctrl) (forall y. C y => (y, y) -> Int -> y
MV.controllerLinear (y, y)
bnd)
{-# INLINE controllerExponential #-}
controllerExponential ::
(Trans.C y) =>
Ev.Controller -> (y,y) -> y -> Filter (PC.T y)
controllerExponential :: forall y. C y => Controller -> (y, y) -> y -> Filter (T y)
controllerExponential Controller
ctrl (y, y)
bnd =
forall a. Controller -> (Int -> a) -> a -> Filter (T a)
getSlice (Controller -> Controller
Controller Controller
ctrl) (forall y. C y => (y, y) -> Int -> y
MV.controllerExponential (y, y)
bnd)
{-# INLINE pitchBend #-}
pitchBend ::
(Trans.C y) =>
y -> y ->
Filter (PC.T y)
pitchBend :: forall y. C y => y -> y -> Filter (T y)
pitchBend y
range y
center =
forall a. Controller -> (Int -> a) -> a -> Filter (T a)
getSlice Controller
PitchBend (forall y. C y => y -> y -> Int -> y
MV.pitchBend y
range y
center) y
center
{-# INLINE channelPressure #-}
channelPressure ::
(Trans.C y) =>
y -> y ->
Filter (PC.T y)
channelPressure :: forall y. C y => y -> y -> Filter (T y)
channelPressure y
maxVal =
forall a. Controller -> (Int -> a) -> a -> Filter (T a)
getSlice Controller
Pressure (forall y. C y => (y, y) -> Int -> y
MV.controllerLinear (forall a. C a => a
Additive.zero,y
maxVal))
{-# INLINE bendWheelPressure #-}
bendWheelPressure ::
(RealRing.C y, Trans.C y) =>
Int -> y -> y ->
Filter (PC.T (BM.T y))
bendWheelPressure :: forall y. (C y, C y) => Int -> y -> y -> Filter (T (T y))
bendWheelPressure Int
pitchRange y
wheelDepth y
pressDepth =
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state forall a b. (a -> b) -> a -> b
$ \T Controller Int
xs ->
let (T StrictTime [T]
ys,T StrictTime [(Controller, Int)]
zs) =
forall time body0 body1.
T time (body0, body1) -> (T time body0, T time body1)
EventListTT.unzip forall a b. (a -> b) -> a -> b
$
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. [Either a b] -> ([a], [b])
ListHT.unzipEithers 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
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 (Either T (Controller, Int))
separateBWP) (forall key a. T key a -> T StrictTime [(key, a)]
stream T Controller Int
xs)
move :: k -> T c a -> (c, Map k a) -> (c, Map k a)
move k
key T c a
field (c
bwp,Map k a
mp) =
forall a c b. (a -> c) -> (a, b) -> (c, b)
mapFst (forall b a. b -> (a -> b) -> Maybe a -> b
maybe c
bwp (\a
y -> forall r a. T r a -> a -> r -> r
Acc.set T c a
field a
y c
bwp)) forall a b. (a -> b) -> a -> b
$
forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey
(\ k
_k a
_a -> forall a. Maybe a
Nothing) k
key Map k a
mp
(T
yin,Map Controller Int
zis) =
forall {k} {c} {a}.
Ord k =>
k -> T c a -> (c, Map k a) -> (c, Map k a)
move Controller
PitchBend T T Int
BWP.bend forall a b. (a -> b) -> a -> b
$
forall {k} {c} {a}.
Ord k =>
k -> T c a -> (c, Map k a) -> (c, Map k a)
move (Controller -> Controller
Controller Controller
VoiceMsg.modulation) T T Int
BWP.wheel forall a b. (a -> b) -> a -> b
$
forall {k} {c} {a}.
Ord k =>
k -> T c a -> (c, Map k a) -> (c, Map k a)
move Controller
Pressure T T Int
BWP.pressure forall a b. (a -> b) -> a -> b
$
(T
BWP.deflt, forall key a. T key a -> Map key a
initial T Controller Int
xs)
fill :: T StrictTime [T] -> T StrictTime T
fill =
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> a
evalState T
yin 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
(\[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 ()
put [T]
ys0 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) s. Monad m => StateT s m s
get)
in (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 (T StrictTime [T] -> T StrictTime T
fill T StrictTime [T]
ys),
forall key a. Map key a -> T StrictTime [(key, a)] -> T key a
Cons Map Controller Int
zis T StrictTime [(Controller, Int)]
zs)
separateBWP ::
(Controller, Int) -> State BWP.T (Either BWP.T (Controller, Int))
separateBWP :: (Controller, Int) -> State T (Either T (Controller, Int))
separateBWP (Controller, Int)
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 (Controller, Int)
ev) forall a b. a -> Either a b
Left) forall a b. (a -> b) -> a -> b
$
(Controller, Int) -> State T (Maybe T)
checkBendWheelPressure (Controller, Int)
ev
checkBendWheelPressure ::
(Controller, Int) -> State BWP.T (Maybe BWP.T)
checkBendWheelPressure :: (Controller, Int) -> State T (Maybe T)
checkBendWheelPressure (Controller
ctrl,Int
val) =
let update :: T a Int -> StateT a m (Maybe a)
update T a Int
field = forall (m :: * -> *) r a. Monad m => T r a -> a -> StateT r m ()
AccState.set T a Int
field Int
val forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall (m :: * -> *) s. Monad m => StateT s m s
get
in case Controller
ctrl of
Controller
PitchBend -> forall {m :: * -> *} {a}.
Monad m =>
T a Int -> StateT a m (Maybe a)
update T T Int
BWP.bend
Controller
Pressure -> forall {m :: * -> *} {a}.
Monad m =>
T a Int -> StateT a m (Maybe a)
update T T Int
BWP.pressure
Controller Controller
cc ->
if Controller
cc forall a. Eq a => a -> a -> Bool
== Controller
VoiceMsg.modulation
then forall {m :: * -> *} {a}.
Monad m =>
T a Int -> StateT a m (Maybe a)
update T T Int
BWP.wheel
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Maybe a
Nothing
{-# INLINE bendWheelPressureZip #-}
bendWheelPressureZip ::
(RealRing.C y, Trans.C y) =>
Int -> y -> y ->
Filter (PC.T (BM.T y))
bendWheelPressureZip :: forall y. (C y, C y) => Int -> y -> y -> Filter (T (T y))
bendWheelPressureZip 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 y. C y => y -> y -> Filter (T y)
pitchBend (y
2 forall a. C a => a -> a -> a
^? (forall a b. (C a, C b) => a -> b
fromIntegral Int
pitchRange forall 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 y. C y => Controller -> (y, y) -> y -> Filter (T y)
controllerLinear Controller
VoiceMsg.modulation (y
0,y
wheelDepth) y
0)
(forall y. C y => y -> y -> Filter (T y)
channelPressure y
pressDepth y
0))