{- |
Treat a stream of MIDI events as parallel streams of MIDI controller events.
-}
{-# LANGUAGE NoImplicitPrelude #-}
module Synthesizer.MIDI.PiecewiseConstant.ControllerSet (
   T(Cons),
   mapStream,

   Controller(Controller,PitchBend,Pressure),
   fromChannel,
   maybeController,
   controllerLinear,
   controllerExponential,
   pitchBend,
   channelPressure,
   bendWheelPressure,
   checkBendWheelPressure,
   bendWheelPressureZip,

   -- * internal data needed in synthesizer-llvm
   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 Data.EventList.Relative.TimeBody  as EventListTB

import qualified Numeric.NonNegative.Class   as NonNeg98
-- import qualified Numeric.NonNegative.Wrapper as NonNegW
-- import qualified Numeric.NonNegative.Chunky as NonNegChunky
-- import Numeric.NonNegative.Class ((-|), )

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


{-
This data structure stores the initial values of all supported controllers
and an event list of all changes of individal controllers.
-}
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)

{- |
Prepend the initial values as events to the event-list.
-}
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

{- |
For reverse you must make sure,
that all controller events have an corresponding initial value.
Controllers that miss an initial value
their last constant piece will be undefined.
-}
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)

   -- cf. ChunkySize.dropMarginRem
   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)

   -- cf. StorableVector.Lazy.splitAt
   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)
{-
*Synthesizer.MIDI.PiecewiseConstant.ControllerSet Data.EventList.Relative.MixedTime> CutG.reverse $ Cons (Map.singleton 'a' GT) (2 /. [('a',EQ)] ./ 3 /. empty) :: T Char Ordering
-}



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)



{- |
@pitchBend channel range center@:
emits frequencies on an exponential scale from
@center/range@ to @center*range@.
-}
{-# 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))



-- adapted from getSlice
{-# 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))