{-# 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,

   -- auxiliary function
   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)


-- might be moved to synthesizer-core
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



{-
for distinction of notes with the same pitch

We must use Integer instead of Int, in order to avoid an overflow
that would invalidate the check for unmatched NoteOffs
that is based on comparison of the NoteIds.
We cannot re-use NoteIds easily,
since the events at one time point are handled out of order.
-}
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
(<>)

{- |
The function defined here are based on the interpretation
of event lists as piecewise constant signals.
They do not fit to the interpretation of atomic events.
Because e.g. it makes no sense to split an atomic event into two instances by splitAt,
and it is also not clear, whether dropping the first chunk
shall leave a chunk of length zero
or remove that chunk completely.
-}
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

   -- cf. ChunkySize.dropMarginRem
   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
                   -- AllNotesOff -> True
                   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
           {-
           AllNotesOff -> VoiceMsg.normalVelocity -} )


data NoteBoundary a =
     NoteBoundary VoiceMsg.Pitch VoiceMsg.Velocity a
--   | AllSoundOff
   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)

{- |
We count NoteIds per pitch,
such that the pair (pitch,noteId) identifies a note.
We treat nested notes in a first-in-first-out order (FIFO).
E.g.

> On, On, On, Off, Off, Off

is interpreted as

> On 0, On 1, On 2, Off 0, Off 1, Off 2

NoteOffs without previous NoteOns are thrown away.
-}
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
--         MIDIEv.AllNotesOff -> Left MIDIEv.AllNotesOff
         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)


{- |
Turn an event list with bundles of elements
into an event list with single events.
ToDo: Move to event-list package?
-}
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) ->
      -- Zip.consChecked "flattenControlSchedule" ctrl $
      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)

-- could be moved to synthesizer-core
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))

-- move synthesizer-core:CausalIO
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)


-- | may replace the other functions
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