{-# LANGUAGE ExistentialQuantification #-}
module Synthesizer.MIDI.CausalIO.Process (
Events,
slice,
controllerLinear,
controllerExponential,
pitchBend,
channelPressure,
bendWheelPressure,
constant,
Instrument,
Bank,
GateChunk,
noteEvents,
embedPrograms,
applyInstrument,
applyModulatedInstrument,
flattenControlSchedule,
applyModulation,
arrangeStorable,
sequenceCore,
sequenceModulated,
sequenceModulatedMultiProgram,
sequenceModulatedMultiProgramVelocityPitch,
sequenceStorable,
initWith,
mapMaybe,
) where
import qualified Synthesizer.CausalIO.Gate as Gate
import qualified Synthesizer.CausalIO.Process as PIO
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.MIDI.EventList as MIDIEv
import Synthesizer.MIDI.EventList (StrictTime, )
import qualified Synthesizer.PiecewiseConstant.Signal as PC
import qualified Synthesizer.Storable.Cut as CutSt
import qualified Synthesizer.Generic.Cut as CutG
import qualified Synthesizer.Zip as Zip
import qualified Sound.MIDI.Message.Class.Check as Check
import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg
import Control.DeepSeq (rnf, )
import qualified Data.EventList.Relative.TimeBody as EventList
import qualified Data.EventList.Relative.BodyTime as EventListBT
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.Absolute.TimeBody as AbsEventList
import qualified Numeric.NonNegative.Wrapper as NonNegW
import qualified Numeric.NonNegative.Class as NonNeg
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 Algebra.ToInteger as ToInteger
import qualified Data.StorableVector as SV
import qualified Data.StorableVector.ST.Strict as SVST
import Foreign.Storable (Storable, )
import qualified Control.Monad.Trans.Writer as MW
import qualified Control.Monad.Trans.State as MS
import qualified Control.Monad.Trans.Class as MT
import Control.Monad.IO.Class (liftIO, )
import qualified Data.Traversable as Trav
import Data.Traversable (Traversable, )
import Data.Foldable (traverse_, )
import Control.Arrow (Arrow, arr, (^<<), (<<^), )
import Control.Category ((.), )
import qualified Data.Map as Map
import qualified Data.List.HT as ListHT
import qualified Data.Maybe as Maybe
import Data.Monoid (Monoid, mempty, mappend, )
import Data.Semigroup (Semigroup, (<>), )
import Data.Maybe (maybeToList, )
import Data.Tuple.HT (mapFst, mapPair, )
import NumericPrelude.Numeric
import NumericPrelude.Base hiding ((.), sequence, )
import Prelude ()
type Events event = EventListTT.T StrictTime [event]
initWith ::
(y -> c) ->
c ->
PIO.T
(Events y)
(EventListBT.T PC.ShortStrictTime c)
initWith :: forall y c. (y -> c) -> c -> T (Events y) (T ShortStrictTime c)
initWith y -> c
f c
initial =
forall state a b. state -> (a -> State state b) -> T a b
PIO.traverse c
initial forall a b. (a -> b) -> a -> b
$
\Events y
evs0 -> do
c
y0 <- 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 y. T StrictTime y -> T ShortStrictTime y
PC.subdivideLongStrict forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall body time. body -> T time body -> T time body
EventListMT.consBody c
y0) forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
Trav.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 ()
MS.put forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat 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
MS.get) Events y
evs0
slice ::
(Check.C event) =>
(event -> Maybe Int) ->
(Int -> y) -> y ->
PIO.T
(Events event)
(EventListBT.T PC.ShortStrictTime y)
slice :: forall event y.
C event =>
(event -> Maybe Int)
-> (Int -> y) -> y -> T (Events event) (T ShortStrictTime y)
slice event -> Maybe Int
select Int -> y
f y
initial =
forall y c. (y -> c) -> c -> T (Events y) (T ShortStrictTime c)
initWith Int -> y
f y
initial 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])
mapMaybe event -> Maybe Int
select
mapMaybe ::
(Arrow arrow, Functor f) =>
(a -> Maybe b) ->
arrow (f [a]) (f [b])
mapMaybe :: forall (arrow :: * -> * -> *) (f :: * -> *) a b.
(Arrow arrow, Functor f) =>
(a -> Maybe b) -> arrow (f [a]) (f [b])
mapMaybe a -> Maybe b
f =
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe a -> Maybe b
f
catMaybes ::
(Arrow arrow, Functor f) =>
arrow (f [Maybe a]) (f [a])
catMaybes :: forall (arrow :: * -> * -> *) (f :: * -> *) a.
(Arrow arrow, Functor f) =>
arrow (f [Maybe a]) (f [a])
catMaybes =
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr 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
traverse ::
(Traversable f) =>
s -> (a -> MS.State s b) ->
PIO.T (f [a]) (f [b])
traverse :: forall (f :: * -> *) s a b.
Traversable f =>
s -> (a -> State s b) -> T (f [a]) (f [b])
traverse s
initial a -> State s b
f =
forall state a b. state -> (a -> State state b) -> T a b
PIO.traverse s
initial (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
Trav.traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
Trav.traverse a -> State s b
f))
controllerLinear ::
(Check.C event, Field.C y) =>
MIDIEv.Channel ->
MIDIEv.Controller ->
(y,y) -> y ->
PIO.T
(Events event)
(EventListBT.T PC.ShortStrictTime y)
controllerLinear :: forall event y.
(C event, C y) =>
Channel
-> Controller
-> (y, y)
-> y
-> T (Events event) (T ShortStrictTime y)
controllerLinear Channel
chan Controller
ctrl (y, y)
bnd y
initial =
forall event y.
C event =>
(event -> Maybe Int)
-> (Int -> y) -> y -> T (Events event) (T ShortStrictTime y)
slice (forall event.
C event =>
Channel -> Controller -> event -> Maybe Int
Check.controller Channel
chan Controller
ctrl)
(forall y. C y => (y, y) -> Int -> y
MV.controllerLinear (y, y)
bnd) y
initial
controllerExponential ::
(Check.C event, Trans.C y) =>
MIDIEv.Channel ->
MIDIEv.Controller ->
(y,y) -> y ->
PIO.T
(Events event)
(EventListBT.T PC.ShortStrictTime y)
controllerExponential :: forall event y.
(C event, C y) =>
Channel
-> Controller
-> (y, y)
-> y
-> T (Events event) (T ShortStrictTime y)
controllerExponential Channel
chan Controller
ctrl (y, y)
bnd y
initial =
forall event y.
C event =>
(event -> Maybe Int)
-> (Int -> y) -> y -> T (Events event) (T ShortStrictTime y)
slice (forall event.
C event =>
Channel -> Controller -> event -> Maybe Int
Check.controller Channel
chan Controller
ctrl)
(forall y. C y => (y, y) -> Int -> y
MV.controllerExponential (y, y)
bnd) y
initial
pitchBend ::
(Check.C event, Trans.C y) =>
MIDIEv.Channel ->
y -> y ->
PIO.T
(Events event)
(EventListBT.T PC.ShortStrictTime y)
pitchBend :: forall event y.
(C event, C y) =>
Channel -> y -> y -> T (Events event) (T ShortStrictTime y)
pitchBend Channel
chan y
range y
center =
forall event y.
C event =>
(event -> Maybe Int)
-> (Int -> y) -> y -> T (Events event) (T ShortStrictTime y)
slice (forall event. C event => Channel -> event -> Maybe Int
Check.pitchBend Channel
chan)
(forall y. C y => y -> y -> Int -> y
MV.pitchBend y
range y
center) y
center
channelPressure ::
(Check.C event, Trans.C y) =>
MIDIEv.Channel ->
y -> y ->
PIO.T
(Events event)
(EventListBT.T PC.ShortStrictTime y)
channelPressure :: forall event y.
(C event, C y) =>
Channel -> y -> y -> T (Events event) (T ShortStrictTime y)
channelPressure Channel
chan y
maxVal y
initial =
forall event y.
C event =>
(event -> Maybe Int)
-> (Int -> y) -> y -> T (Events event) (T ShortStrictTime y)
slice (forall event. C event => Channel -> event -> Maybe Int
Check.channelPressure Channel
chan)
(forall y. C y => (y, y) -> Int -> y
MV.controllerLinear (forall a. C a => a
zero,y
maxVal)) y
initial
bendWheelPressure ::
(Check.C event, RealRing.C y, Trans.C y) =>
MIDIEv.Channel ->
Int -> y -> y ->
PIO.T
(Events event)
(EventListBT.T PC.ShortStrictTime (BM.T y))
bendWheelPressure :: forall event y.
(C event, C y, C y) =>
Channel
-> Int -> y -> y -> T (Events event) (T ShortStrictTime (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 y c. (y -> c) -> c -> T (Events y) (T ShortStrictTime c)
initWith T -> T y
toBM (T -> T y
toBM T
BWP.deflt)
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.
(Arrow arrow, Functor f) =>
arrow (f [Maybe a]) (f [a])
catMaybes
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
forall (f :: * -> *) s a b.
Traversable f =>
s -> (a -> State s b) -> T (f [a]) (f [b])
traverse T
BWP.deflt (forall event. C event => Channel -> event -> State T (Maybe T)
BWP.check Channel
chan)
constant ::
(Arrow arrow) =>
y -> arrow (Events event) (EventListBT.T PC.ShortStrictTime y)
constant :: forall (arrow :: * -> * -> *) y event.
Arrow arrow =>
y -> arrow (Events event) (T ShortStrictTime y)
constant y
y = forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall a b. (a -> b) -> a -> b
$
forall body time. body -> time -> T time body
EventListBT.singleton y
y forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
forall a. (Ord a, Num a) => String -> a -> T a
NonNegW.fromNumberMsg String
"MIDI.CausalIO.constant" forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
forall a b. (C a, C b) => a -> b
fromIntegral forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
forall time body. C time => T time body -> time
EventListTT.duration
_constant ::
(Arrow arrow, CutG.Read input) =>
y -> arrow input (EventListBT.T PC.ShortStrictTime y)
_constant :: forall (arrow :: * -> * -> *) input y.
(Arrow arrow, Read input) =>
y -> arrow input (T ShortStrictTime y)
_constant y
y = forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall a b. (a -> b) -> a -> b
$
forall body time. body -> time -> T time body
EventListBT.singleton y
y forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
forall a. (Ord a, Num a) => String -> a -> T a
NonNegW.fromNumberMsg String
"MIDI.CausalIO.constant" forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
forall sig. Read sig => sig -> Int
CutG.length
noteEvents ::
(Check.C event, Arrow arrow) =>
MIDIEv.Channel ->
arrow
(Events event)
(Events (Either MIDIEv.Program (MIDIEv.NoteBoundary Bool)))
noteEvents :: forall event (arrow :: * -> * -> *).
(C event, Arrow arrow) =>
Channel
-> arrow
(Events event) (Events (Either Program (NoteBoundary Bool)))
noteEvents Channel
chan =
forall (arrow :: * -> * -> *) (f :: * -> *) a b.
(Arrow arrow, Functor f) =>
(a -> Maybe b) -> arrow (f [a]) (f [b])
mapMaybe forall a b. (a -> b) -> a -> b
$ forall event.
C event =>
Channel -> event -> Maybe (Either Program (NoteBoundary Bool))
MIDIEv.checkNoteEvent Channel
chan
embedPrograms ::
MIDIEv.Program ->
PIO.T
(Events (Either MIDIEv.Program (MIDIEv.NoteBoundary Bool)))
(Events (MIDIEv.NoteBoundary (Maybe MIDIEv.Program)))
embedPrograms :: Program
-> T (Events (Either Program (NoteBoundary Bool)))
(Events (NoteBoundary (Maybe Program)))
embedPrograms Program
initPgm =
forall (arrow :: * -> * -> *) (f :: * -> *) a.
(Arrow arrow, Functor f) =>
arrow (f [Maybe a]) (f [a])
catMaybes forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
forall (f :: * -> *) s a b.
Traversable f =>
s -> (a -> State s b) -> T (f [a]) (f [b])
traverse Program
initPgm Either Program (NoteBoundary Bool)
-> State Program (Maybe (NoteBoundary (Maybe Program)))
MIDIEv.embedProgramState
type GateChunk = Gate.Chunk MIDIEv.Velocity
type Instrument y chunk = y -> y -> PIO.T GateChunk chunk
type Bank y chunk = MIDIEv.Program -> Instrument y chunk
newtype NoteId = NoteId Integer
deriving (Int -> NoteId -> ShowS
[NoteId] -> ShowS
NoteId -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NoteId] -> ShowS
$cshowList :: [NoteId] -> ShowS
show :: NoteId -> String
$cshow :: NoteId -> String
showsPrec :: Int -> NoteId -> ShowS
$cshowsPrec :: Int -> NoteId -> ShowS
Show, NoteId -> NoteId -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NoteId -> NoteId -> Bool
$c/= :: NoteId -> NoteId -> Bool
== :: NoteId -> NoteId -> Bool
$c== :: NoteId -> NoteId -> Bool
Eq, Eq NoteId
NoteId -> NoteId -> Bool
NoteId -> NoteId -> Ordering
NoteId -> NoteId -> NoteId
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 :: NoteId -> NoteId -> NoteId
$cmin :: NoteId -> NoteId -> NoteId
max :: NoteId -> NoteId -> NoteId
$cmax :: NoteId -> NoteId -> NoteId
>= :: NoteId -> NoteId -> Bool
$c>= :: NoteId -> NoteId -> Bool
> :: NoteId -> NoteId -> Bool
$c> :: NoteId -> NoteId -> Bool
<= :: NoteId -> NoteId -> Bool
$c<= :: NoteId -> NoteId -> Bool
< :: NoteId -> NoteId -> Bool
$c< :: NoteId -> NoteId -> Bool
compare :: NoteId -> NoteId -> Ordering
$ccompare :: NoteId -> NoteId -> Ordering
Ord)
succNoteId :: NoteId -> NoteId
succNoteId :: NoteId -> NoteId
succNoteId (NoteId Integer
n) = Integer -> NoteId
NoteId (Integer
nforall a. C a => a -> a -> a
+Integer
1)
flattenNoteIdRange :: (NoteId,NoteId) -> [NoteId]
flattenNoteIdRange :: (NoteId, NoteId) -> [NoteId]
flattenNoteIdRange (NoteId
start,NoteId
afterEnd) =
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Ord a => a -> a -> Bool
<NoteId
afterEnd) forall a b. (a -> b) -> a -> b
$ forall a. (a -> a) -> a -> [a]
iterate NoteId -> NoteId
succNoteId NoteId
start
newtype NoteOffList =
NoteOffList {
NoteOffList -> Events (NoteBoundary NoteId)
unwrapNoteOffList :: Events (NoteBoundary NoteId)
}
instance CutG.Read NoteOffList where
null :: NoteOffList -> Bool
null (NoteOffList Events (NoteBoundary NoteId)
evs) =
forall time body. T time body -> Bool
EventListTT.isPause Events (NoteBoundary NoteId)
evs Bool -> Bool -> Bool
&& forall time body. C time => T time body -> time
EventListTT.duration Events (NoteBoundary NoteId)
evs forall a. Eq a => a -> a -> Bool
== StrictTime
0
length :: NoteOffList -> Int
length = forall a b. (C a, C b) => a -> b
fromIntegral forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall time body. C time => T time body -> time
EventListTT.duration forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. NoteOffList -> Events (NoteBoundary NoteId)
unwrapNoteOffList
instance CutG.NormalForm NoteOffList where
evaluateHead :: NoteOffList -> ()
evaluateHead =
forall time body a. (time -> T time body -> a) -> T time body -> a
EventListMT.switchTimeL (\StrictTime
t T StrictTime [NoteBoundary NoteId]
_ -> forall a. NFData a => a -> ()
rnf (forall a. T a -> a
NonNegW.toNumber StrictTime
t)) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
NoteOffList -> Events (NoteBoundary NoteId)
unwrapNoteOffList
instance Semigroup NoteOffList where
NoteOffList Events (NoteBoundary NoteId)
xs <> :: NoteOffList -> NoteOffList -> NoteOffList
<> NoteOffList Events (NoteBoundary NoteId)
ys = Events (NoteBoundary NoteId) -> NoteOffList
NoteOffList (Events (NoteBoundary NoteId)
xs forall a. Semigroup a => a -> a -> a
<> Events (NoteBoundary NoteId)
ys)
instance Monoid NoteOffList where
mempty :: NoteOffList
mempty = Events (NoteBoundary NoteId) -> NoteOffList
NoteOffList (forall time body. time -> T time body
EventListTT.pause forall a. Monoid a => a
mempty)
mappend :: NoteOffList -> NoteOffList -> NoteOffList
mappend = forall a. Semigroup a => a -> a -> a
(<>)
instance CutG.Transform NoteOffList where
take :: Int -> NoteOffList -> NoteOffList
take Int
n (NoteOffList Events (NoteBoundary NoteId)
xs) =
Events (NoteBoundary NoteId) -> NoteOffList
NoteOffList forall a b. (a -> b) -> a -> b
$
forall time body. C time => time -> T time body -> T time body
EventListTT.takeTime
(forall a. (Ord a, Num a) => String -> a -> T a
NonNegW.fromNumberMsg String
"NoteOffList.take" forall a b. (a -> b) -> a -> b
$ forall a b. (C a, C b) => a -> b
fromIntegral Int
n) Events (NoteBoundary NoteId)
xs
drop :: Int -> NoteOffList -> NoteOffList
drop Int
n (NoteOffList Events (NoteBoundary NoteId)
xs) =
Events (NoteBoundary NoteId) -> NoteOffList
NoteOffList forall a b. (a -> b) -> a -> b
$
forall time body. C time => time -> T time body -> T time body
EventListTT.dropTime
(forall a. (Ord a, Num a) => String -> a -> T a
NonNegW.fromNumberMsg String
"NoteOffList.drop" forall a b. (a -> b) -> a -> b
$ forall a b. (C a, C b) => a -> b
fromIntegral Int
n) Events (NoteBoundary NoteId)
xs
splitAt :: Int -> NoteOffList -> (NoteOffList, NoteOffList)
splitAt Int
n (NoteOffList Events (NoteBoundary NoteId)
xs) =
forall a c b d. (a -> c, b -> d) -> (a, b) -> (c, d)
mapPair (Events (NoteBoundary NoteId) -> NoteOffList
NoteOffList, Events (NoteBoundary NoteId) -> NoteOffList
NoteOffList) forall a b. (a -> b) -> a -> b
$
forall time body.
C time =>
time -> T time body -> (T time body, T time body)
EventListTT.splitAtTime
(forall a. (Ord a, Num a) => String -> a -> T a
NonNegW.fromNumberMsg String
"NoteOffList.splitAtTime" forall a b. (a -> b) -> a -> b
$ forall a b. (C a, C b) => a -> b
fromIntegral Int
n) Events (NoteBoundary NoteId)
xs
dropMarginRem :: Int -> Int -> NoteOffList -> (Int, NoteOffList)
dropMarginRem =
forall sig.
Transform sig =>
(sig -> [Int]) -> Int -> Int -> sig -> (Int, sig)
CutG.dropMarginRemChunky
(forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (C a, C b) => a -> b
fromIntegral forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall time body. T time body -> [time]
EventListTT.getTimes forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. NoteOffList -> Events (NoteBoundary NoteId)
unwrapNoteOffList)
reverse :: NoteOffList -> NoteOffList
reverse (NoteOffList Events (NoteBoundary NoteId)
xs) =
Events (NoteBoundary NoteId) -> NoteOffList
NoteOffList forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall time body. T time body -> T time body
EventListTT.reverse forall a b. (a -> b) -> a -> b
$ Events (NoteBoundary NoteId)
xs
findEvent ::
(a -> Bool) ->
Events a -> (Events a, Maybe a)
findEvent :: forall a. (a -> Bool) -> Events a -> (Events a, Maybe a)
findEvent a -> Bool
p =
forall time a b body.
(time -> a -> b) -> (body -> b -> a) -> a -> T time body -> b
EventListTT.foldr
(\StrictTime
t -> forall a c b. (a -> c) -> (a, b) -> (c, b)
mapFst (forall time body. time -> T time body -> T time body
EventListMT.consTime StrictTime
t))
(\[a]
evs (Events a, Maybe a)
rest ->
case forall a. (a -> Bool) -> [a] -> ([a], [a])
ListHT.break a -> Bool
p [a]
evs of
([a]
prefix, [a]
suffix) ->
forall a c b. (a -> c) -> (a, b) -> (c, b)
mapFst (forall body time. body -> T time body -> T time body
EventListMT.consBody [a]
prefix) forall a b. (a -> b) -> a -> b
$
case [a]
suffix of
[] -> (Events a, Maybe a)
rest
a
ev:[a]
_ -> (forall time body. time -> T time body
EventListTT.pause forall a. Monoid a => a
mempty, forall a. a -> Maybe a
Just a
ev))
(forall time body. T time body
EventListBT.empty, forall a. Maybe a
Nothing)
gateFromNoteOffs ::
(MIDIEv.Pitch, NoteId) ->
NoteOffList ->
GateChunk
gateFromNoteOffs :: (Pitch, NoteId) -> NoteOffList -> GateChunk
gateFromNoteOffs (Pitch, NoteId)
pitchNoteId (NoteOffList Events (NoteBoundary NoteId)
noteOffs) =
let dur :: StrictTime
dur = forall time body. C time => T time body -> time
EventListTT.duration Events (NoteBoundary NoteId)
noteOffs
(Events (NoteBoundary NoteId)
sustain, Maybe (NoteBoundary NoteId)
mEnd) =
forall a. (a -> Bool) -> Events a -> (Events a, Maybe a)
findEvent
(\NoteBoundary NoteId
bnd ->
case NoteBoundary NoteId
bnd of
NoteBoundary Pitch
endPitch Velocity
_ NoteId
noteId ->
(Pitch, NoteId)
pitchNoteId forall a. Eq a => a -> a -> Bool
== (Pitch
endPitch, NoteId
noteId))
Events (NoteBoundary NoteId)
noteOffs
in forall a. StrictTime -> Maybe (StrictTime, a) -> Chunk a
Gate.chunk StrictTime
dur forall a b. (a -> b) -> a -> b
$
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (NoteBoundary NoteId)
mEnd forall a b. (a -> b) -> a -> b
$ \NoteBoundary NoteId
end ->
(forall time body. C time => T time body -> time
EventListTT.duration Events (NoteBoundary NoteId)
sustain,
case NoteBoundary NoteId
end of
NoteBoundary Pitch
_ Velocity
endVel NoteId
_ -> Velocity
endVel
)
data NoteBoundary a =
NoteBoundary VoiceMsg.Pitch VoiceMsg.Velocity a
deriving (NoteBoundary a -> NoteBoundary a -> Bool
forall a. Eq a => NoteBoundary a -> NoteBoundary a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NoteBoundary a -> NoteBoundary a -> Bool
$c/= :: forall a. Eq a => NoteBoundary a -> NoteBoundary a -> Bool
== :: NoteBoundary a -> NoteBoundary a -> Bool
$c== :: forall a. Eq a => NoteBoundary a -> NoteBoundary a -> Bool
Eq, Int -> NoteBoundary a -> ShowS
forall a. Show a => Int -> NoteBoundary a -> ShowS
forall a. Show a => [NoteBoundary a] -> ShowS
forall a. Show a => NoteBoundary a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NoteBoundary a] -> ShowS
$cshowList :: forall a. Show a => [NoteBoundary a] -> ShowS
show :: NoteBoundary a -> String
$cshow :: forall a. Show a => NoteBoundary a -> String
showsPrec :: Int -> NoteBoundary a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> NoteBoundary a -> ShowS
Show)
assignNoteIds ::
(Traversable f) =>
PIO.T
(f [MIDIEv.NoteBoundary (Maybe MIDIEv.Program)])
(f [NoteBoundary (NoteId, Maybe MIDIEv.Program)])
assignNoteIds :: forall (f :: * -> *).
Traversable f =>
T (f [NoteBoundary (Maybe Program)])
(f [NoteBoundary (NoteId, Maybe Program)])
assignNoteIds =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
forall (a :: * -> * -> *) c d b.
Arrow a =>
(c -> d) -> a b c -> a b d
^<<
forall (f :: * -> *) s a b.
Traversable f =>
s -> (a -> State s b) -> T (f [a]) (f [b])
traverse forall k a. Map k a
Map.empty (\NoteBoundary (Maybe Program)
bnd ->
case NoteBoundary (Maybe Program)
bnd of
NoteBoundary (Maybe Program)
MIDIEv.AllNotesOff -> do
Map Pitch (NoteId, NoteId)
notes <- forall (m :: * -> *) s. Monad m => StateT s m s
MS.get
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
MS.put forall k a. Map k a
Map.empty
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Pitch
pitch, (NoteId, NoteId)
range) ->
forall a b. (a -> b) -> [a] -> [b]
map
(\NoteId
noteId ->
forall a. Pitch -> Velocity -> a -> NoteBoundary a
NoteBoundary Pitch
pitch Velocity
VoiceMsg.normalVelocity
(NoteId
noteId, forall a. Maybe a
Nothing))
((NoteId, NoteId) -> [NoteId]
flattenNoteIdRange (NoteId, NoteId)
range)) forall a b. (a -> b) -> a -> b
$
forall k a. Map k a -> [(k, a)]
Map.toList Map Pitch (NoteId, NoteId)
notes
MIDIEv.NoteBoundary Pitch
pitch Velocity
vel Maybe Program
mpgm ->
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\NoteId
noteId ->
forall a. Pitch -> Velocity -> a -> NoteBoundary a
NoteBoundary Pitch
pitch Velocity
vel (NoteId
noteId,Maybe Program
mpgm))) forall a b. (a -> b) -> a -> b
$
case Maybe Program
mpgm of
Maybe Program
Nothing -> do
Maybe (NoteId, NoteId)
mNoteId <- forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
MS.gets (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Pitch
pitch)
case Maybe (NoteId, NoteId)
mNoteId of
Maybe (NoteId, NoteId)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []
Just (NoteId
nextNoteOffId, NoteId
nextNoteOnId) ->
if NoteId
nextNoteOffId forall a. Ord a => a -> a -> Bool
>= NoteId
nextNoteOnId
then forall (m :: * -> *) a. Monad m => a -> m a
return []
else do
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
MS.modify (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Pitch
pitch (NoteId -> NoteId
succNoteId NoteId
nextNoteOffId, NoteId
nextNoteOnId))
forall (m :: * -> *) a. Monad m => a -> m a
return [NoteId
nextNoteOffId]
Just Program
_ -> do
Maybe (NoteId, NoteId)
mNoteId <- forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
MS.gets (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Pitch
pitch)
let (NoteId
nextNoteOffId, NoteId
nextNoteOnId) =
case Maybe (NoteId, NoteId)
mNoteId of
Maybe (NoteId, NoteId)
Nothing -> (Integer -> NoteId
NoteId Integer
0, Integer -> NoteId
NoteId Integer
0)
Just (NoteId, NoteId)
ids -> (NoteId, NoteId)
ids
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
MS.modify (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Pitch
pitch (NoteId
nextNoteOffId, NoteId -> NoteId
succNoteId NoteId
nextNoteOnId))
forall (m :: * -> *) a. Monad m => a -> m a
return [NoteId
nextNoteOnId])
{-# INLINE velFreqBank #-}
velFreqBank ::
(Trans.C y) =>
(MIDIEv.Program -> y -> y -> process) ->
(MIDIEv.Program -> MIDIEv.Velocity -> MIDIEv.Pitch -> process)
velFreqBank :: forall y process.
C y =>
(Program -> y -> y -> process)
-> Program -> Velocity -> Pitch -> process
velFreqBank Program -> y -> y -> process
bank Program
pgm Velocity
vel Pitch
pitch =
Program -> y -> y -> process
bank Program
pgm (forall y. C y => Velocity -> y
MV.velocity Velocity
vel) (forall y. C y => Pitch -> y
MV.frequencyFromPitch Pitch
pitch)
applyInstrumentCore ::
(Arrow arrow) =>
((MIDIEv.Pitch, NoteId) -> noteOffListCtrl -> gateCtrl) ->
(MIDIEv.Program -> MIDIEv.Velocity -> MIDIEv.Pitch ->
PIO.T gateCtrl chunk) ->
arrow
(Events (NoteBoundary (NoteId, Maybe MIDIEv.Program)))
(Zip.T
NoteOffList
(Events (PIO.T noteOffListCtrl chunk)))
applyInstrumentCore :: forall (arrow :: * -> * -> *) noteOffListCtrl gateCtrl chunk.
Arrow arrow =>
((Pitch, NoteId) -> noteOffListCtrl -> gateCtrl)
-> (Program -> Velocity -> Pitch -> T gateCtrl chunk)
-> arrow
(Events (NoteBoundary (NoteId, Maybe Program)))
(T NoteOffList (Events (T noteOffListCtrl chunk)))
applyInstrumentCore (Pitch, NoteId) -> noteOffListCtrl -> gateCtrl
makeGate Program -> Velocity -> Pitch -> T gateCtrl chunk
bank = forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall a b. (a -> b) -> a -> b
$
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b. a -> b -> T a b
Zip.Cons forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
forall a c b. (a -> c) -> (a, b) -> (c, b)
mapFst Events (NoteBoundary NoteId) -> NoteOffList
NoteOffList forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
forall time body0 body1.
T time (body0, body1) -> (T time body0, T time body1)
EventListTT.unzip forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat 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 {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\NoteBoundary (NoteId, Maybe Program)
ev ->
case NoteBoundary (NoteId, Maybe Program)
ev of
NoteBoundary Pitch
pitch Velocity
vel (NoteId
noteId, Maybe Program
mpgm) ->
case Maybe Program
mpgm of
Maybe Program
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. Pitch -> Velocity -> a -> NoteBoundary a
NoteBoundary Pitch
pitch Velocity
vel NoteId
noteId
Just Program
pgm ->
forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$
Program -> Velocity -> Pitch -> T gateCtrl chunk
bank Program
pgm Velocity
vel Pitch
pitch
forall (a :: * -> * -> *) c d b.
Arrow a =>
a c d -> (b -> c) -> a b d
<<^
(Pitch, NoteId) -> noteOffListCtrl -> gateCtrl
makeGate (Pitch
pitch, NoteId
noteId)))
applyInstrument ::
(Arrow arrow) =>
(MIDIEv.Program -> MIDIEv.Velocity -> MIDIEv.Pitch ->
PIO.T GateChunk chunk) ->
arrow
(Events (NoteBoundary (NoteId, Maybe MIDIEv.Program)))
(Zip.T
NoteOffList
(Events (PIO.T NoteOffList chunk)))
applyInstrument :: forall (arrow :: * -> * -> *) chunk.
Arrow arrow =>
(Program -> Velocity -> Pitch -> T GateChunk chunk)
-> arrow
(Events (NoteBoundary (NoteId, Maybe Program)))
(T NoteOffList (Events (T NoteOffList chunk)))
applyInstrument Program -> Velocity -> Pitch -> T GateChunk chunk
bank =
forall (arrow :: * -> * -> *) noteOffListCtrl gateCtrl chunk.
Arrow arrow =>
((Pitch, NoteId) -> noteOffListCtrl -> gateCtrl)
-> (Program -> Velocity -> Pitch -> T gateCtrl chunk)
-> arrow
(Events (NoteBoundary (NoteId, Maybe Program)))
(T NoteOffList (Events (T noteOffListCtrl chunk)))
applyInstrumentCore (Pitch, NoteId) -> NoteOffList -> GateChunk
gateFromNoteOffs Program -> Velocity -> Pitch -> T GateChunk chunk
bank
type ModulatedBank y ctrl chunk =
MIDIEv.Program -> y -> y ->
PIO.T (Zip.T GateChunk ctrl) chunk
applyModulatedInstrument ::
(Arrow arrow, CutG.Read ctrl) =>
(MIDIEv.Program -> MIDIEv.Velocity -> MIDIEv.Pitch ->
PIO.T (Zip.T GateChunk ctrl) chunk) ->
arrow
(Zip.T
(Events (NoteBoundary (NoteId, Maybe MIDIEv.Program)))
ctrl)
(Zip.T
(Zip.T NoteOffList ctrl)
(Events (PIO.T (Zip.T NoteOffList ctrl) chunk)))
applyModulatedInstrument :: forall (arrow :: * -> * -> *) ctrl chunk.
(Arrow arrow, Read ctrl) =>
(Program -> Velocity -> Pitch -> T (T GateChunk ctrl) chunk)
-> arrow
(T (Events (NoteBoundary (NoteId, Maybe Program))) ctrl)
(T (T NoteOffList ctrl) (Events (T (T NoteOffList ctrl) chunk)))
applyModulatedInstrument Program -> Velocity -> Pitch -> T (T GateChunk ctrl) chunk
bank =
(\(Zip.Cons (Zip.Cons NoteOffList
noteOffs Events (T (T NoteOffList ctrl) chunk)
events) ctrl
ctrl) ->
forall a b. a -> b -> T a b
Zip.Cons (forall a b. a -> b -> T a b
Zip.Cons NoteOffList
noteOffs ctrl
ctrl) Events (T (T NoteOffList ctrl) chunk)
events)
forall (a :: * -> * -> *) c d b.
Arrow a =>
(c -> d) -> a b c -> a b d
^<<
forall (arrow :: * -> * -> *) a b c.
Arrow arrow =>
arrow a b -> arrow (T a c) (T b c)
Zip.arrowFirst
(forall (arrow :: * -> * -> *) noteOffListCtrl gateCtrl chunk.
Arrow arrow =>
((Pitch, NoteId) -> noteOffListCtrl -> gateCtrl)
-> (Program -> Velocity -> Pitch -> T gateCtrl chunk)
-> arrow
(Events (NoteBoundary (NoteId, Maybe Program)))
(T NoteOffList (Events (T noteOffListCtrl chunk)))
applyInstrumentCore
(forall (arrow :: * -> * -> *) a b c.
Arrow arrow =>
arrow a b -> arrow (T a c) (T b c)
Zip.arrowFirst forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Pitch, NoteId) -> NoteOffList -> GateChunk
gateFromNoteOffs) Program -> Velocity -> Pitch -> T (T GateChunk ctrl) chunk
bank)
flatten ::
(NonNeg.C time) =>
a ->
EventListTT.T time [a] ->
EventListTT.T time a
flatten :: forall time a. C time => a -> T time [a] -> T time a
flatten a
empty =
forall time a b body.
(time -> a -> b) -> (body -> b -> a) -> a -> T time body -> b
EventListTT.foldr
forall time body. time -> T time body -> T time body
EventListMT.consTime
(\[a]
bt T time a
xs ->
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall body time. body -> T time body -> T time body
EventListMT.consBody forall a b. (a -> b) -> a -> b
$
case [a]
bt of
[] -> (a
empty, T time a
xs)
a
b:[a]
bs -> (a
b, forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a
c T time a
rest -> forall time body. time -> body -> T time body -> T time body
EventListTT.cons forall a. C a => a
NonNeg.zero a
c T time a
rest) T time a
xs [a]
bs))
forall time body. T time body
EventListBT.empty
flattenControlSchedule ::
(Monoid chunk, Arrow arrow) =>
arrow
(Zip.T ctrl
(EventListTT.T StrictTime [PIO.T ctrl chunk]))
(Zip.T ctrl
(EventListTT.T StrictTime (PIO.T ctrl chunk)))
flattenControlSchedule :: forall chunk (arrow :: * -> * -> *) ctrl.
(Monoid chunk, Arrow arrow) =>
arrow
(T ctrl (T StrictTime [T ctrl chunk]))
(T ctrl (T StrictTime (T ctrl chunk)))
flattenControlSchedule = forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall a b. (a -> b) -> a -> b
$
\(Zip.Cons ctrl
ctrl T StrictTime [T ctrl chunk]
evs) ->
forall a b. a -> b -> T a b
Zip.Cons ctrl
ctrl forall a b. (a -> b) -> a -> b
$
forall time a. C time => a -> T time [a] -> T time a
flatten (forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (forall a b. a -> b -> a
const forall a. Monoid a => a
mempty)) T StrictTime [T ctrl chunk]
evs
data CausalState a b =
forall state.
CausalState
(a -> state -> IO (b, state))
(state -> IO ())
state
_applyChunkSimple :: CausalState a b -> a -> IO (b, CausalState a b)
_applyChunkSimple :: forall a b. CausalState a b -> a -> IO (b, CausalState a b)
_applyChunkSimple (CausalState a -> state -> IO (b, state)
next state -> IO ()
delete state
state0) a
input = do
(b
output, state
state1) <- a -> state -> IO (b, state)
next a
input state
state0
forall (m :: * -> *) a. Monad m => a -> m a
return (b
output, forall a b state.
(a -> state -> IO (b, state))
-> (state -> IO ()) -> state -> CausalState a b
CausalState a -> state -> IO (b, state)
next state -> IO ()
delete state
state1)
applyChunk ::
(CutG.Read a, CutG.Read b) =>
CausalState a b -> a -> IO (b, Maybe (CausalState a b))
applyChunk :: forall a b.
(Read a, Read b) =>
CausalState a b -> a -> IO (b, Maybe (CausalState a b))
applyChunk (CausalState a -> state -> IO (b, state)
next state -> IO ()
delete state
state0) a
input = do
(b
output, state
state1) <- a -> state -> IO (b, state)
next a
input state
state0
Maybe (CausalState a b)
cs <-
if forall sig. Read sig => sig -> Int
CutG.length b
output forall a. Ord a => a -> a -> Bool
< forall sig. Read sig => sig -> Int
CutG.length a
input
then do
state -> IO ()
delete state
state1
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b state.
(a -> state -> IO (b, state))
-> (state -> IO ()) -> state -> CausalState a b
CausalState a -> state -> IO (b, state)
next state -> IO ()
delete state
state1
forall (m :: * -> *) a. Monad m => a -> m a
return (b
output, Maybe (CausalState a b)
cs)
applyModulation ::
(CutG.Transform ctrl, CutG.NormalForm ctrl,
CutG.Read chunk,
Monoid time, ToInteger.C time) =>
PIO.T
(Zip.T ctrl (EventListTT.T time (PIO.T ctrl chunk)))
(EventListTT.T time chunk)
applyModulation :: forall ctrl chunk time.
(Transform ctrl, NormalForm ctrl, Read chunk, Monoid time,
C time) =>
T (T ctrl (T time (T ctrl chunk))) (T time chunk)
applyModulation = forall a b state.
(a -> state -> IO (b, state))
-> IO state -> (state -> IO ()) -> T a b
PIO.Cons
(\(Zip.Cons ctrl
ctrl T time (T ctrl chunk)
evs) [CausalState ctrl chunk]
acc0 -> do
[(chunk, Maybe (CausalState ctrl chunk))]
acc1 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b.
(Read a, Read b) =>
CausalState a b -> a -> IO (b, Maybe (CausalState a b))
applyChunk ctrl
ctrl) [CausalState ctrl chunk]
acc0
let ([chunk]
accChunks, [Maybe (CausalState ctrl chunk)]
acc2) = forall a b. [(a, b)] -> ([a], [b])
unzip [(chunk, Maybe (CausalState ctrl chunk))]
acc1
(T time chunk
newChunks, [CausalState ctrl chunk]
newAcc) <-
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
MW.runWriterT forall a b. (a -> b) -> a -> b
$
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
MS.evalStateT ctrl
ctrl forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) time0 time1 body0 body1.
Monad m =>
(time0 -> m time1)
-> (body0 -> m body1) -> T time0 body0 -> m (T time1 body1)
EventListTT.mapM
(\time
time -> do
ctrl
ctrl_ <- forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
MS.gets (forall sig. Transform sig => Int -> sig -> sig
CutG.drop (forall a b. (C a, C b) => a -> b
fromIntegral time
time))
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
MS.put ctrl
ctrl_
forall (m :: * -> *) a. Monad m => a -> m a
return (case forall sig. NormalForm sig => sig -> ()
CutG.evaluateHead ctrl
ctrl_ of () -> time
time))
(\(PIO.Cons ctrl -> state -> IO (chunk, state)
next IO state
create state -> IO ()
delete) -> do
state
state0 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO state
create
(chunk
chunk, Maybe (CausalState ctrl chunk)
state1) <-
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b.
(Read a, Read b) =>
CausalState a b -> a -> IO (b, Maybe (CausalState a b))
applyChunk (forall a b state.
(a -> state -> IO (b, state))
-> (state -> IO ()) -> state -> CausalState a b
CausalState ctrl -> state -> IO (chunk, state)
next state -> IO ()
delete state
state0)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) s. Monad m => StateT s m s
MS.get
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
MT.lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
MW.tell forall a b. (a -> b) -> a -> b
$ forall a. Maybe a -> [a]
maybeToList Maybe (CausalState ctrl chunk)
state1
forall (m :: * -> *) a. Monad m => a -> m a
return chunk
chunk)
T time (T ctrl chunk)
evs
forall (m :: * -> *) a. Monad m => a -> m a
return
(forall time body. T time body -> T time body -> T time body
EventListTM.prependBodyEnd
(forall a b. [(a, b)] -> T a b
EventList.fromPairList forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map ((,) forall a. Monoid a => a
mempty) [chunk]
accChunks)
T time chunk
newChunks,
forall a. [Maybe a] -> [a]
Maybe.catMaybes [Maybe (CausalState ctrl chunk)]
acc2 forall a. [a] -> [a] -> [a]
++ [CausalState ctrl chunk]
newAcc))
(forall (m :: * -> *) a. Monad m => a -> m a
return [])
(forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(CausalState ctrl -> state -> IO (chunk, state)
_ state -> IO ()
close state
state) -> state -> IO ()
close state
state))
arrangeStorable ::
(Arrow arrow, Storable a, Additive.C a) =>
arrow
(EventListTT.T StrictTime (SV.Vector a))
(SV.Vector a)
arrangeStorable :: forall (arrow :: * -> * -> *) a.
(Arrow arrow, Storable a, C a) =>
arrow (T StrictTime (Vector a)) (Vector a)
arrangeStorable =
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall a b. (a -> b) -> a -> b
$ \T StrictTime (Vector a)
evs ->
forall e. Storable e => (forall s. ST s (Vector s e)) -> Vector e
SVST.runSTVector (do
Vector s a
v <- forall e s. Storable e => Int -> e -> ST s (Vector s e)
SVST.new (forall a b. (C a, C b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall time body. C time => T time body -> time
EventListTT.duration T StrictTime (Vector a)
evs) forall a. C a => a
zero
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b. (a -> b) -> a -> b
$ forall a s.
(Storable a, C a) =>
Vector s a -> Int -> Vector a -> ST s ()
CutSt.addChunkToBuffer Vector s a
v) forall a b. (a -> b) -> a -> b
$
forall a b. T a b -> [(a, b)]
AbsEventList.toPairList forall a b. (a -> b) -> a -> b
$
forall time0 time1 body.
(time0 -> time1) -> T time0 body -> T time1 body
AbsEventList.mapTime forall a b. (C a, C b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$
forall time body. Num time => time -> T time body -> T time body
EventList.toAbsoluteEventList StrictTime
0 forall a b. (a -> b) -> a -> b
$
forall time body a. (T time body -> time -> a) -> T time body -> a
EventListTM.switchTimeR forall a b. a -> b -> a
const T StrictTime (Vector a)
evs
forall (m :: * -> *) a. Monad m => a -> m a
return Vector s a
v)
sequenceCore ::
(Check.C event, Monoid chunk, CutG.Read chunk, Trans.C y) =>
MIDIEv.Channel ->
Bank y chunk ->
PIO.T (Events event) (EventListTT.T StrictTime chunk)
sequenceCore :: forall event chunk y.
(C event, Monoid chunk, Read chunk, C y) =>
Channel -> Bank y chunk -> T (Events event) (T StrictTime chunk)
sequenceCore Channel
channel Bank y chunk
bank =
forall ctrl chunk time.
(Transform ctrl, NormalForm ctrl, Read chunk, Monoid time,
C time) =>
T (T ctrl (T time (T ctrl chunk))) (T time chunk)
applyModulation
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
forall chunk (arrow :: * -> * -> *) ctrl.
(Monoid chunk, Arrow arrow) =>
arrow
(T ctrl (T StrictTime [T ctrl chunk]))
(T ctrl (T StrictTime (T ctrl chunk)))
flattenControlSchedule
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
forall (arrow :: * -> * -> *) chunk.
Arrow arrow =>
(Program -> Velocity -> Pitch -> T GateChunk chunk)
-> arrow
(Events (NoteBoundary (NoteId, Maybe Program)))
(T NoteOffList (Events (T NoteOffList chunk)))
applyInstrument (forall y process.
C y =>
(Program -> y -> y -> process)
-> Program -> Velocity -> Pitch -> process
velFreqBank Bank y chunk
bank)
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
forall (f :: * -> *).
Traversable f =>
T (f [NoteBoundary (Maybe Program)])
(f [NoteBoundary (NoteId, Maybe Program)])
assignNoteIds
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
Program
-> T (Events (Either Program (NoteBoundary Bool)))
(Events (NoteBoundary (Maybe Program)))
embedPrograms (Int -> Program
VoiceMsg.toProgram Int
0)
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
forall event (arrow :: * -> * -> *).
(C event, Arrow arrow) =>
Channel
-> arrow
(Events event) (Events (Either Program (NoteBoundary Bool)))
noteEvents Channel
channel
sequenceModulated ::
(Check.C event, Monoid chunk, CutG.Read chunk,
CutG.Transform ctrl, CutG.NormalForm ctrl, Trans.C y) =>
MIDIEv.Channel ->
ModulatedBank y ctrl chunk ->
PIO.T (Zip.T (Events event) ctrl) (EventListTT.T StrictTime chunk)
sequenceModulated :: forall event chunk ctrl y.
(C event, Monoid chunk, Read chunk, Transform ctrl,
NormalForm ctrl, C y) =>
Channel
-> ModulatedBank y ctrl chunk
-> T (T (Events event) ctrl) (T StrictTime chunk)
sequenceModulated Channel
channel ModulatedBank y ctrl chunk
bank =
forall ctrl chunk time.
(Transform ctrl, NormalForm ctrl, Read chunk, Monoid time,
C time) =>
T (T ctrl (T time (T ctrl chunk))) (T time chunk)
applyModulation
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
forall chunk (arrow :: * -> * -> *) ctrl.
(Monoid chunk, Arrow arrow) =>
arrow
(T ctrl (T StrictTime [T ctrl chunk]))
(T ctrl (T StrictTime (T ctrl chunk)))
flattenControlSchedule
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
forall (arrow :: * -> * -> *) ctrl chunk.
(Arrow arrow, Read ctrl) =>
(Program -> Velocity -> Pitch -> T (T GateChunk ctrl) chunk)
-> arrow
(T (Events (NoteBoundary (NoteId, Maybe Program))) ctrl)
(T (T NoteOffList ctrl) (Events (T (T NoteOffList ctrl) chunk)))
applyModulatedInstrument (forall y process.
C y =>
(Program -> y -> y -> process)
-> Program -> Velocity -> Pitch -> process
velFreqBank ModulatedBank y ctrl chunk
bank)
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
forall (arrow :: * -> * -> *) a b c.
Arrow arrow =>
arrow a b -> arrow (T a c) (T b c)
Zip.arrowFirst
(forall (f :: * -> *).
Traversable f =>
T (f [NoteBoundary (Maybe Program)])
(f [NoteBoundary (NoteId, Maybe Program)])
assignNoteIds
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
Program
-> T (Events (Either Program (NoteBoundary Bool)))
(Events (NoteBoundary (Maybe Program)))
embedPrograms (Int -> Program
VoiceMsg.toProgram Int
0)
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
forall event (arrow :: * -> * -> *).
(C event, Arrow arrow) =>
Channel
-> arrow
(Events event) (Events (Either Program (NoteBoundary Bool)))
noteEvents Channel
channel)
sequenceModulatedMultiProgram ::
(Check.C event, Monoid chunk, CutG.Read chunk,
CutG.Transform ctrl, CutG.NormalForm ctrl, Trans.C y) =>
MIDIEv.Channel ->
MIDIEv.Program ->
ModulatedBank y ctrl chunk ->
PIO.T (Zip.T (Events event) ctrl) (EventListTT.T StrictTime chunk)
sequenceModulatedMultiProgram :: forall event chunk ctrl y.
(C event, Monoid chunk, Read chunk, Transform ctrl,
NormalForm ctrl, C y) =>
Channel
-> Program
-> ModulatedBank y ctrl chunk
-> T (T (Events event) ctrl) (T StrictTime chunk)
sequenceModulatedMultiProgram Channel
channel Program
initPgm ModulatedBank y ctrl chunk
bank =
forall ctrl chunk time.
(Transform ctrl, NormalForm ctrl, Read chunk, Monoid time,
C time) =>
T (T ctrl (T time (T ctrl chunk))) (T time chunk)
applyModulation
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
forall chunk (arrow :: * -> * -> *) ctrl.
(Monoid chunk, Arrow arrow) =>
arrow
(T ctrl (T StrictTime [T ctrl chunk]))
(T ctrl (T StrictTime (T ctrl chunk)))
flattenControlSchedule
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
forall (arrow :: * -> * -> *) ctrl chunk.
(Arrow arrow, Read ctrl) =>
(Program -> Velocity -> Pitch -> T (T GateChunk ctrl) chunk)
-> arrow
(T (Events (NoteBoundary (NoteId, Maybe Program))) ctrl)
(T (T NoteOffList ctrl) (Events (T (T NoteOffList ctrl) chunk)))
applyModulatedInstrument (forall y process.
C y =>
(Program -> y -> y -> process)
-> Program -> Velocity -> Pitch -> process
velFreqBank ModulatedBank y ctrl chunk
bank)
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
forall (arrow :: * -> * -> *) a b c.
Arrow arrow =>
arrow a b -> arrow (T a c) (T b c)
Zip.arrowFirst
(forall (f :: * -> *).
Traversable f =>
T (f [NoteBoundary (Maybe Program)])
(f [NoteBoundary (NoteId, Maybe Program)])
assignNoteIds
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
Program
-> T (Events (Either Program (NoteBoundary Bool)))
(Events (NoteBoundary (Maybe Program)))
embedPrograms Program
initPgm
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
forall event (arrow :: * -> * -> *).
(C event, Arrow arrow) =>
Channel
-> arrow
(Events event) (Events (Either Program (NoteBoundary Bool)))
noteEvents Channel
channel)
sequenceModulatedMultiProgramVelocityPitch ::
(Check.C event, Monoid chunk, CutG.Read chunk,
CutG.Transform ctrl, CutG.NormalForm ctrl) =>
MIDIEv.Channel ->
MIDIEv.Program ->
(MIDIEv.Program -> MIDIEv.Velocity -> MIDIEv.Pitch ->
PIO.T (Zip.T GateChunk ctrl) chunk) ->
PIO.T (Zip.T (Events event) ctrl) (EventListTT.T StrictTime chunk)
sequenceModulatedMultiProgramVelocityPitch :: forall event chunk ctrl.
(C event, Monoid chunk, Read chunk, Transform ctrl,
NormalForm ctrl) =>
Channel
-> Program
-> (Program -> Velocity -> Pitch -> T (T GateChunk ctrl) chunk)
-> T (T (Events event) ctrl) (T StrictTime chunk)
sequenceModulatedMultiProgramVelocityPitch Channel
channel Program
initPgm Program -> Velocity -> Pitch -> T (T GateChunk ctrl) chunk
bank =
forall ctrl chunk time.
(Transform ctrl, NormalForm ctrl, Read chunk, Monoid time,
C time) =>
T (T ctrl (T time (T ctrl chunk))) (T time chunk)
applyModulation
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
forall chunk (arrow :: * -> * -> *) ctrl.
(Monoid chunk, Arrow arrow) =>
arrow
(T ctrl (T StrictTime [T ctrl chunk]))
(T ctrl (T StrictTime (T ctrl chunk)))
flattenControlSchedule
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
forall (arrow :: * -> * -> *) ctrl chunk.
(Arrow arrow, Read ctrl) =>
(Program -> Velocity -> Pitch -> T (T GateChunk ctrl) chunk)
-> arrow
(T (Events (NoteBoundary (NoteId, Maybe Program))) ctrl)
(T (T NoteOffList ctrl) (Events (T (T NoteOffList ctrl) chunk)))
applyModulatedInstrument Program -> Velocity -> Pitch -> T (T GateChunk ctrl) chunk
bank
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
forall (arrow :: * -> * -> *) a b c.
Arrow arrow =>
arrow a b -> arrow (T a c) (T b c)
Zip.arrowFirst
(forall (f :: * -> *).
Traversable f =>
T (f [NoteBoundary (Maybe Program)])
(f [NoteBoundary (NoteId, Maybe Program)])
assignNoteIds
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
Program
-> T (Events (Either Program (NoteBoundary Bool)))
(Events (NoteBoundary (Maybe Program)))
embedPrograms Program
initPgm
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
forall event (arrow :: * -> * -> *).
(C event, Arrow arrow) =>
Channel
-> arrow
(Events event) (Events (Either Program (NoteBoundary Bool)))
noteEvents Channel
channel)
sequenceStorable ::
(Check.C event, Storable a, Additive.C a, Trans.C y) =>
MIDIEv.Channel ->
Bank y (SV.Vector a) ->
PIO.T (Events event) (SV.Vector a)
sequenceStorable :: forall event a y.
(C event, Storable a, C a, C y) =>
Channel -> Bank y (Vector a) -> T (Events event) (Vector a)
sequenceStorable Channel
channel Bank y (Vector a)
bank =
forall (arrow :: * -> * -> *) a.
(Arrow arrow, Storable a, C a) =>
arrow (T StrictTime (Vector a)) (Vector a)
arrangeStorable
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
forall event chunk y.
(C event, Monoid chunk, Read chunk, C y) =>
Channel -> Bank y chunk -> T (Events event) (T StrictTime chunk)
sequenceCore Channel
channel Bank y (Vector a)
bank