-- Copyright 2013 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{-# LANGUAGE CPP #-}
{- | Main entry point for Perform.Midi.  Render Deriver output down to actual
    midi events.
-}
module Perform.Midi.Perform (
    default_velocity
    , State(..), initial_state
    , Config, config, addrs_config
    , perform
    -- * types
    , MidiEvents
#ifdef TESTING
    , module Perform.Midi.Perform
#endif
) where
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Text as Text

import qualified Util.CallStack as CallStack
import qualified Util.Lists as Lists
import qualified Util.Log as Log
import qualified Util.Maps as Maps
import qualified Util.Pretty as Pretty

import qualified Derive.LEvent as LEvent
import qualified Derive.ScoreT as ScoreT
import qualified Midi.Midi as Midi
import qualified Perform.Midi.Control as Control
import qualified Perform.Midi.MSignal as MSignal
import qualified Perform.Midi.Patch as Patch
import qualified Perform.Midi.Types as T
import qualified Perform.Pitch as Pitch
import qualified Perform.RealTime as RealTime
import           Perform.RealTime (RealTime)

import           Global


-- I tried using HashMap in here, but aside from one score with somewhat
-- better performance, the result seemed to be the same or slightly worse.
-- In any case, performance in here is not that important, since it happens
-- lazily on demand and is already way faster than realtime.

-- * constants

-- | Turn on debug logging.  This is hardcoded because debugging can generate
-- lots of logs and performance has to be efficient.
logging :: Bool
logging :: Bool
logging = Bool
False

-- | This winds up being 100, which is loud but not too loud and
-- distinctive-looking.
default_velocity :: MSignal.Y
default_velocity :: UnboxedY
default_velocity = UnboxedY
0.79

-- | A keyswitch gets this much lead time before the note it is meant to
-- apply to.  Some synthesizers (kontakt at least) will occasionally not notice
-- a keyswitch that comes too close to its note.
keyswitch_lead_time :: RealTime
keyswitch_lead_time :: RealTime
keyswitch_lead_time = Integer -> RealTime
RealTime.milliseconds Integer
10

-- | Most synths don't respond to control change and pitch bend instantly, but
-- smooth it out, so if you set pitch bend immediately before playing the note
-- you will get a little sproing.  Put pitch bends before their notes by this
-- amount.
control_lead_time :: RealTime
control_lead_time :: RealTime
control_lead_time = Integer -> RealTime
RealTime.milliseconds Integer
100

-- | 'control_lead_time' can be flattened out if there isn't time for it.  This
-- happens when there is another note on the same previous channel that would
-- overlap it.  To avoid an audible artifact on the tail of the previous note,
-- I omit the lead time in that case.  However, I still need a minimum amount
-- of lead time because some MIDI patches use the state of the controls at
-- NoteOn time to configure the whole note.  A tiny gap should be enough to
-- make sure the control changes arrive first, but short enough that it's not
-- audible on the previous note.
--
-- The root of the problem, like so many problems with MIDI, is that it's
-- highly stateful, nothing happens simultaneously, and channels are precious.
min_control_lead_time :: RealTime
min_control_lead_time :: RealTime
min_control_lead_time = Integer -> RealTime
RealTime.milliseconds Integer
4

-- | Subtract this much from every NoteOff.  Some synthesizers don't handle
-- simultaneous note on and note off of the same pitch well.  I actually only
-- need the gap for a NoteOff followed by NoteOn of the same pitch, but it's
-- simpler to just subtract it from all notes.
adjacent_note_gap :: RealTime
adjacent_note_gap :: RealTime
adjacent_note_gap = Integer -> RealTime
RealTime.milliseconds Integer
10

-- | Each note will have at least this duration.  The reason is that some
-- synthesizers (kontakt at least) will sometimes not notice a note which is
-- too short.  Usually these notes are percussion and come in with zero
-- duration.
--
-- Honestly nothing really surprises me about Kontakt anymore.
min_note_duration :: RealTime
min_note_duration :: RealTime
min_note_duration = Integer -> RealTime
RealTime.milliseconds Integer
20

-- * perform

type Events = [LEvent.LEvent T.Event]
type MidiEvents = [LEvent.LEvent Midi.WriteMessage]

-- | Performance state.  This is a snapshot of the state of the various
-- functions in the performance pipeline.  You should be able to resume
-- performance at any point given a RealTime and a State.
--
-- I don't do that anymore, and this is left over from when I cached the
-- performance.  I removed the cache but left the state visible.
data State = State {
    State -> ChannelizeState
state_channelize :: !ChannelizeState
    , State -> AllotState
state_allot :: !AllotState
    , State -> PerformState
state_perform :: !PerformState
    } deriving (State -> State -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: State -> State -> Bool
$c/= :: State -> State -> Bool
== :: State -> State -> Bool
$c== :: State -> State -> Bool
Eq, Voices -> State -> ShowS
[State] -> ShowS
State -> String
forall a.
(Voices -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [State] -> ShowS
$cshowList :: [State] -> ShowS
show :: State -> String
$cshow :: State -> String
showsPrec :: Voices -> State -> ShowS
$cshowsPrec :: Voices -> State -> ShowS
Show)

instance Pretty State where
    format :: State -> Doc
format (State ChannelizeState
channelize AllotState
allot PerformState
perform) = Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"State"
        [ (Text
"channelize", forall a. Pretty a => a -> Doc
Pretty.format ChannelizeState
channelize)
        , (Text
"allot", forall a. Pretty a => a -> Doc
Pretty.format AllotState
allot)
        , (Text
"perform", forall a. Pretty a => a -> Doc
Pretty.format PerformState
perform)
        ]

initial_state :: State
initial_state :: State
initial_state = ChannelizeState -> AllotState -> PerformState -> State
State [] AllotState
empty_allot_state PerformState
empty_perform_state

type Configs = Map ScoreT.Instrument Config
newtype Config = Config {
    Config -> [(Addr, Maybe Voices)]
_addrs :: [(Patch.Addr, Maybe Patch.Voices)]
    } deriving (Voices -> Config -> ShowS
[Config] -> ShowS
Config -> String
forall a.
(Voices -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Config] -> ShowS
$cshowList :: [Config] -> ShowS
show :: Config -> String
$cshow :: Config -> String
showsPrec :: Voices -> Config -> ShowS
$cshowsPrec :: Voices -> Config -> ShowS
Show, Config -> Config -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Config -> Config -> Bool
$c/= :: Config -> Config -> Bool
== :: Config -> Config -> Bool
$c== :: Config -> Config -> Bool
Eq)

empty_config :: Config
empty_config :: Config
empty_config = [(Addr, Maybe Voices)] -> Config
Config []

config :: Patch.Config -> Config
config :: Config -> Config
config Config
patch_config = Config
    { _addrs :: [(Addr, Maybe Voices)]
_addrs = Config -> [(Addr, Maybe Voices)]
Patch.config_allocation Config
patch_config
    }

addrs_config :: [(Patch.Addr, Maybe Patch.Voices)] -> Config
addrs_config :: [(Addr, Maybe Voices)] -> Config
addrs_config [(Addr, Maybe Voices)]
addrs = Config
empty_config { _addrs :: [(Addr, Maybe Voices)]
_addrs = [(Addr, Maybe Voices)]
addrs }

-- | Render instrument tracks down to midi messages, sorted in timestamp order.
-- This should be non-strict on the event list, so that it can start producing
-- MIDI output as soon as it starts processing Events.
perform :: State -> Configs -> Events -> (MidiEvents, State)
perform :: State -> Configs -> Events -> (MidiEvents, State)
perform State
state Configs
_ [] = ([], State
state)
perform State
state Configs
configs Events
events = (MidiEvents
final_msgs, State
final_state)
    where
    final_state :: State
final_state = ChannelizeState -> AllotState -> PerformState -> State
State ChannelizeState
channelize_state AllotState
allot_state PerformState
perform_state
    ([LEvent (Event, Integer)]
event_channels, ChannelizeState
channelize_state) =
        ChannelizeState
-> Configs
-> Events
-> ([LEvent (Event, Integer)], ChannelizeState)
channelize (State -> ChannelizeState
state_channelize State
state) Configs
configs Events
events
    ([LEvent (Event, Addr)]
event_allotted, AllotState
allot_state) =
        AllotState
-> Configs
-> [LEvent (Event, Integer)]
-> ([LEvent (Event, Addr)], AllotState)
allot (State -> AllotState
state_allot State
state) Configs
configs [LEvent (Event, Integer)]
event_channels
    (MidiEvents
msgs, PerformState
perform_state) = PerformState
-> [LEvent (Event, Addr)] -> (MidiEvents, PerformState)
perform_notes (State -> PerformState
state_perform State
state) [LEvent (Event, Addr)]
event_allotted
    (MidiEvents
final_msgs, PostprocState
_) = PostprocState -> MidiEvents -> (MidiEvents, PostprocState)
post_process forall a. Monoid a => a
mempty MidiEvents
msgs

-- * channelize

-- | This isn't directly the midi channel, since it goes higher than 15, but
-- will later be mapped to midi channels.
type Channel = Integer

-- | Overlapping events and the channels they were given.
type ChannelizeState = [(T.Event, Channel)]

-- | Assign channels.  Events will be merged into the the lowest channel they
-- can coexist with.
--
-- A less aggressive policy would be to distribute the instrument among all of
-- its addrs and only share when out of channels, but it seems like this would
-- quickly eat up all the channels, forcing a new note that can't share to snag
-- a used one.
channelize :: ChannelizeState -> Configs -> Events
    -> ([LEvent.LEvent (T.Event, Channel)], ChannelizeState)
channelize :: ChannelizeState
-> Configs
-> Events
-> ([LEvent (Event, Integer)], ChannelizeState)
channelize ChannelizeState
overlapping Configs
configs Events
events =
    forall a.
[(Event, a)]
-> ([(Event, a)] -> Event -> (a, [Msg]))
-> Events
-> ([LEvent (Event, a)], [(Event, a)])
overlap_map ChannelizeState
overlapping (Configs -> ChannelizeState -> Event -> (Integer, [Msg])
channelize_event Configs
configs) Events
events

-- | This doesn't pay any mind to instrument channel assignments, except as an
-- optimization for instruments with only a single channel.  Channels are
-- actually assigned later by 'allot'.
channelize_event :: Configs -> [(T.Event, Channel)] -> T.Event
    -> (Channel, [Log.Msg])
channelize_event :: Configs -> ChannelizeState -> Event -> (Integer, [Msg])
channelize_event Configs
configs ChannelizeState
overlapping Event
event =
    case Config -> [(Addr, Maybe Voices)]
_addrs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Instrument
inst_name Configs
configs of
        Just ((Addr, Maybe Voices)
_:(Addr, Maybe Voices)
_:[(Addr, Maybe Voices)]
_) -> (Integer
chan, [Msg
log])
        -- If the event has 0 or 1 addrs I can just give a constant channel.
        -- 'allot' will assign the correct addr, or drop the event if there
        -- are none.
        Maybe [(Addr, Maybe Voices)]
_ -> (Integer
0, [])
    where
    inst_name :: Instrument
inst_name = Patch -> Instrument
T.patch_name (Event -> Patch
T.event_patch Event
event)
    -- If there's no shareable channel, make up a channel one higher than the
    -- maximum channel in use.
    chan :: Integer
chan = forall a. a -> Maybe a -> a
fromMaybe (forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (-Integer
1 forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd ChannelizeState
overlapping) forall a. Num a => a -> a -> a
+ Integer
1) Maybe Integer
maybe_chan
    (Maybe Integer
maybe_chan, [(Integer, Text)]
reasons) = ChannelizeState -> Event -> (Maybe Integer, [(Integer, Text)])
shareable_chan ChannelizeState
overlapping Event
event
    log :: Msg
log = Stack => Priority -> Maybe Stack -> Text -> Msg
Log.msg Priority
Log.Warn (forall a. a -> Maybe a
Just (Event -> Stack
T.event_stack Event
event)) forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unlines forall a b. (a -> b) -> a -> b
$
        (Event -> Text
T.show_short Event
event forall a. Semigroup a => a -> a -> a
<> Text
": found chan " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Maybe Integer
maybe_chan
            forall a. Semigroup a => a -> a -> a
<> Text
", picked " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Integer
chan)
        forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Show a => (a, Text) -> Text
mkmsg [(Integer, Text)]
reasons
        forall a. [a] -> [a] -> [a]
++ [forall a. Show a => a -> Text
showt Integer
c forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Event -> Text
T.show_short Event
e | (Event
e, Integer
c) <- ChannelizeState
overlapping]
    mkmsg :: (a, Text) -> Text
mkmsg (a
chan, Text
reason) = Text
"can't share with " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt a
chan forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text
reason

-- | Find a channel from the list of overlapping (T.Event, Channel) all of whose
-- events can share with the given event.  Return the rest of the channels and
-- the reason why they can't be used.
shareable_chan :: [(T.Event, Channel)] -> T.Event
    -> (Maybe Channel, [(Channel, Text)])
shareable_chan :: ChannelizeState -> Event -> (Maybe Integer, [(Integer, Text)])
shareable_chan ChannelizeState
overlapping Event
event =
    ( forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Integer, [Text])]
unshareable_reasons
    , forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Text -> [Text] -> Text
Text.intercalate Text
"; ")) forall a b. (a -> b) -> a -> b
$
        forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Integer, [Text])]
unshareable_reasons
    )
    where
    unshareable_reasons :: [(Integer, [Text])]
unshareable_reasons = [(Integer
chan, [Event] -> [Text]
reasons [Event]
evts) | ([Event]
evts, Integer
chan) <- [([Event], Integer)]
by_chan]
    by_chan :: [([Event], Integer)]
by_chan = forall b a. Ord b => [(a, b)] -> [(NonNull a, b)]
Lists.groupSnd ChannelizeState
overlapping
    reasons :: [Event] -> [Text]
reasons = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a b c. (a -> b -> c) -> b -> a -> c
flip Event -> Event -> Maybe Text
can_share_chan Event
event)

-- | Can the two events coexist in the same channel without interfering?
-- The reason this is not commutative is so I can assume the start of @old@
-- is equal to or precedes the start of @new@ and save a little computation.
--
-- This is by far the most finicky function in the whole module, because
-- this is the core decision when multiplexing channels.
can_share_chan :: T.Event -> T.Event -> Maybe Text
can_share_chan :: Event -> Event -> Maybe Text
can_share_chan Event
old Event
new = case (Event -> Maybe (Key, PitchBendValue)
initial_pitch Event
old, Event -> Maybe (Key, PitchBendValue)
initial_pitch Event
new) of
    (Maybe (Key, PitchBendValue), Maybe (Key, PitchBendValue))
_ | RealTime
start forall a. Ord a => a -> a -> Bool
>= RealTime
end -> forall a. Maybe a
Nothing
    -- Previously I required that the whole Patch be equal, which caused
    -- notes with different keyswitches to not share channels.  However, they
    -- actually can share channels, though they still can't play
    -- simultaneously.  I need to be as aggressive as possible sharing
    -- channels, especially for instruments with long decays, because any
    -- channel stealing for pitch bends can be very audible.
    (Maybe (Key, PitchBendValue), Maybe (Key, PitchBendValue))
_ | Event -> Instrument
inst_of Event
old forall a. Eq a => a -> a -> Bool
/= Event -> Instrument
inst_of Event
new -> forall a. a -> Maybe a
Just Text
"instruments differ"
    (Just (Key
initial_old, PitchBendValue
_), Just (Key
initial_new, PitchBendValue
_))
        | Bool -> Bool
not (Bool
-> RealTime
-> RealTime
-> Key
-> Vector (Sample UnboxedY)
-> Key
-> Vector (Sample UnboxedY)
-> Bool
MSignal.pitches_share Bool
in_decay RealTime
start RealTime
end
            Key
initial_old (Event -> Vector (Sample UnboxedY)
T.event_pitch Event
old) Key
initial_new (Event -> Vector (Sample UnboxedY)
T.event_pitch Event
new)) ->
                forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text
"pitch signals incompatible: "
                    forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (Event -> Vector (Sample UnboxedY)
T.event_pitch Event
old) forall a. Semigroup a => a -> a -> a
<> Text
" /= "
                    forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (Event -> Vector (Sample UnboxedY)
T.event_pitch Event
new)
        | Bool -> Bool
not Bool
c_equal ->
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text
"controls differ: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (Event -> Map Control (Vector (Sample UnboxedY))
T.event_controls Event
old)
                forall a. Semigroup a => a -> a -> a
<> Text
" /= " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (Event -> Map Control (Vector (Sample UnboxedY))
T.event_controls Event
new)
        | Bool
otherwise -> forall a. Maybe a
Nothing
    (Maybe (Key, PitchBendValue), Maybe (Key, PitchBendValue))
_ -> forall a. Maybe a
Nothing
    where
    inst_of :: Event -> Instrument
inst_of = Patch -> Instrument
T.patch_name forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Patch
T.event_patch
    start :: RealTime
start = Event -> RealTime
T.event_start Event
new
    -- Note that I add the control_lead_time to the decay of the old note
    -- rather than subtracting it from the start of the new one.  Subtracting
    -- would cause 'MSignal.pitches_share' to check the pitch signal before
    -- the start of the note, which is going to be 0 and mess up sharing.
    end :: RealTime
end = forall a. Ord a => a -> a -> a
min (Event -> RealTime
note_end Event
new) (Event -> RealTime
note_end Event
old) forall a. Num a => a -> a -> a
+ RealTime
control_lead_time
    initial_pitch :: Event -> Maybe (Key, PitchBendValue)
initial_pitch Event
event = PbRange -> Event -> RealTime -> Maybe (Key, PitchBendValue)
event_pitch_at (Event -> PbRange
event_pb_range Event
event)
        Event
event (Event -> RealTime
T.event_start Event
event)
    -- If the overlap is in the decay of one or both notes, the rules are
    -- slightly different.
    in_decay :: Bool
in_decay = Event -> RealTime
T.event_end Event
new forall a. Ord a => a -> a -> Bool
<= Event -> RealTime
T.event_start Event
old
        Bool -> Bool -> Bool
|| Event -> RealTime
T.event_end Event
old forall a. Ord a => a -> a -> Bool
<= Event -> RealTime
T.event_start Event
new
    c_equal :: Bool
c_equal = RealTime
-> RealTime
-> Map Control (Vector (Sample UnboxedY))
-> Map Control (Vector (Sample UnboxedY))
-> Bool
controls_equal (Event -> RealTime
T.event_start Event
new) (Event -> RealTime
T.event_end Event
old)
        (Event -> Map Control (Vector (Sample UnboxedY))
T.event_controls Event
old) (Event -> Map Control (Vector (Sample UnboxedY))
T.event_controls Event
new)

{- | Are the controls equal in the given range?

    Notes with differing @c_aftertouch@ can always share, since they are
    addressed by MIDI key.  If the key is the same, they already can't share.

    Previously I insisted that the controls be identical, but now I check
    within the overlapping range only.  What's more, I only check where the
    events actually overlap, not including decay time.

    Each event is supposed to only include the controls within its range.  So
    given a series of notes with a changing control, each note includes a bit
    of control, which then becomes constant as soon as the next note begins,
    since the rest of the control belongs to the next note.  This means the two
    notes can't share, because one has a flat signal during its decay while the
    other has the moving signal.  But in practice this turns out to be
    inconvenient, because it means that a series of notes with a crescendo will
    be divided across multiple channels.  That's ok if there are enough
    channels, but if there aren't, then this can introduce lots of bad-sounding
    channel stealing.

    TODO However, not counting the decay means that very audible controls will
    be shared and cause artifacts.  I think the real difference is that
    controls like dyn and mod are not very audible during the decay, so it's ok
    to share them.  But another control, like a filter cutoff, might be very
    obvious.  So perhaps there should be a per-control configuration, but I'll
    worry about that only if it ever becomes a problem.
-}
controls_equal :: RealTime -> RealTime
    -> Map ScoreT.Control MSignal.Signal
    -> Map ScoreT.Control MSignal.Signal
    -> Bool
controls_equal :: RealTime
-> RealTime
-> Map Control (Vector (Sample UnboxedY))
-> Map Control (Vector (Sample UnboxedY))
-> Bool
controls_equal RealTime
start RealTime
end Map Control (Vector (Sample UnboxedY))
cs1 Map Control (Vector (Sample UnboxedY))
cs2 = RealTime
start forall a. Ord a => a -> a -> Bool
>= RealTime
end Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall {v :: * -> *} {y} {a}.
(Eq (v (Sample y)), Vector v (Sample y)) =>
(a, Paired (v (Sample y)) (v (Sample y))) -> Bool
eq [(Control,
  Paired (Vector (Sample UnboxedY)) (Vector (Sample UnboxedY)))]
pairs
    where
    -- Velocity and aftertouch are per-note addressable in midi, but the rest
    -- of the controls require their own channel.
    relevant :: Map Control a -> Map Control a
relevant = forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\Control
k a
_ -> Control -> Bool
Control.is_channel_control Control
k)
    pairs :: [(Control,
  Paired (Vector (Sample UnboxedY)) (Vector (Sample UnboxedY)))]
pairs = forall k v1 v2.
Ord k =>
Map k v1 -> Map k v2 -> [(k, Paired v1 v2)]
Maps.pairs (forall {a}. Map Control a -> Map Control a
relevant Map Control (Vector (Sample UnboxedY))
cs1) (forall {a}. Map Control a -> Map Control a
relevant Map Control (Vector (Sample UnboxedY))
cs2)
    eq :: (a, Paired (v (Sample y)) (v (Sample y))) -> Bool
eq (a
_, Lists.Both v (Sample y)
sig1 v (Sample y)
sig2) =
        forall (v :: * -> *) y.
Vector v (Sample y) =>
RealTime -> RealTime -> v (Sample y) -> v (Sample y)
MSignal.within RealTime
start RealTime
end v (Sample y)
sig1 forall a. Eq a => a -> a -> Bool
== forall (v :: * -> *) y.
Vector v (Sample y) =>
RealTime -> RealTime -> v (Sample y) -> v (Sample y)
MSignal.within RealTime
start RealTime
end v (Sample y)
sig2
    eq (a, Paired (v (Sample y)) (v (Sample y)))
_ = Bool
False


-- * allot channels

-- | 'channelize' will assign channels based on whether the notes can coexist
-- without interfering with each other.  'allot' reduces those channels down
-- to the real midi channels assigned to the instrument, stealing if necessary.
-- It steals from the longest-unused channel.
--
-- Events with instruments that have no address allocation in the config
-- will be dropped.
allot :: AllotState -> Configs -> [LEvent.LEvent (T.Event, Channel)]
    -> ([LEvent.LEvent (T.Event, Patch.Addr)], AllotState)
allot :: AllotState
-> Configs
-> [LEvent (Event, Integer)]
-> ([LEvent (Event, Addr)], AllotState)
allot AllotState
state Configs
configs [LEvent (Event, Integer)]
events = ([LEvent (Event, Addr)]
event_addrs, AllotState
final_state)
    where
    (AllotState
final_state, [LEvent (Event, Addr)]
event_addrs) = forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL AllotState
-> LEvent (Event, Integer) -> (AllotState, LEvent (Event, Addr))
allot1 AllotState
state [LEvent (Event, Integer)]
events
    allot1 :: AllotState
-> LEvent (Event, Integer) -> (AllotState, LEvent (Event, Addr))
allot1 AllotState
state (LEvent.Event (Event, Integer)
e) = Configs
-> AllotState
-> (Event, Integer)
-> (AllotState, LEvent (Event, Addr))
allot_event Configs
configs AllotState
state (Event, Integer)
e
    allot1 AllotState
state (LEvent.Log Msg
log) = (AllotState
state, forall a. Msg -> LEvent a
LEvent.Log Msg
log)

data AllotState = AllotState {
    -- | Allocated addresses, and when they were last used.
    -- This is used by the voice stealer to figure out which voice is ripest
    -- for plunder.  It also has the AllotKey so the previous allotment can be
    -- deleted.
    AllotState -> Map Addr (RealTime, AllotKey)
ast_available :: !(Map Patch.Addr (RealTime, AllotKey))
    -- | Map input channels to an instrument address in the allocated range.
    -- Once an (inst, chan) pair has been allotted to a particular Addr, it
    -- should keep going to that Addr, as long as voices remain.
    , AllotState -> Map AllotKey Allotted
ast_allotted :: !(Map AllotKey Allotted)
    } deriving (AllotState -> AllotState -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AllotState -> AllotState -> Bool
$c/= :: AllotState -> AllotState -> Bool
== :: AllotState -> AllotState -> Bool
$c== :: AllotState -> AllotState -> Bool
Eq, Voices -> AllotState -> ShowS
[AllotState] -> ShowS
AllotState -> String
forall a.
(Voices -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AllotState] -> ShowS
$cshowList :: [AllotState] -> ShowS
show :: AllotState -> String
$cshow :: AllotState -> String
showsPrec :: Voices -> AllotState -> ShowS
$cshowsPrec :: Voices -> AllotState -> ShowS
Show)

instance Pretty AllotState where
    format :: AllotState -> Doc
format (AllotState Map Addr (RealTime, AllotKey)
available Map AllotKey Allotted
allotted) = Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"AllotState"
        [ (Text
"available", forall a. Pretty a => a -> Doc
Pretty.format Map Addr (RealTime, AllotKey)
available)
        , (Text
"allotted", forall a. Pretty a => a -> Doc
Pretty.format Map AllotKey Allotted
allotted)
        ]

empty_allot_state :: AllotState
empty_allot_state :: AllotState
empty_allot_state = Map Addr (RealTime, AllotKey)
-> Map AllotKey Allotted -> AllotState
AllotState forall k a. Map k a
Map.empty forall k a. Map k a
Map.empty

-- | Channelize makes sure that a (inst, ichan) key identifies events that can
-- share channels.
type AllotKey = (ScoreT.Instrument, Channel)

data Allotted = Allotted {
    Allotted -> Addr
_allotted_addr :: !Patch.Addr
    -- | End time for each allocated voice.
    , Allotted -> [RealTime]
allotted_voices :: ![RealTime]
    -- | Maximum length for allotted_voices.
    , Allotted -> Voices
_allotted_voice_count :: !Patch.Voices
    } deriving (Allotted -> Allotted -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Allotted -> Allotted -> Bool
$c/= :: Allotted -> Allotted -> Bool
== :: Allotted -> Allotted -> Bool
$c== :: Allotted -> Allotted -> Bool
Eq, Voices -> Allotted -> ShowS
[Allotted] -> ShowS
Allotted -> String
forall a.
(Voices -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Allotted] -> ShowS
$cshowList :: [Allotted] -> ShowS
show :: Allotted -> String
$cshow :: Allotted -> String
showsPrec :: Voices -> Allotted -> ShowS
$cshowsPrec :: Voices -> Allotted -> ShowS
Show)

instance Pretty Allotted where
    format :: Allotted -> Doc
format (Allotted Addr
addr [RealTime]
voices Voices
voice_count) = Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"Allotted"
        [ (Text
"addr", forall a. Pretty a => a -> Doc
Pretty.format Addr
addr)
        , (Text
"voices", forall a. Pretty a => a -> Doc
Pretty.format [RealTime]
voices)
        , (Text
"voice_count", forall a. Pretty a => a -> Doc
Pretty.format Voices
voice_count)
        ]

-- | Try to find an Addr for the given Event.  If that's impossible, return
-- a log msg.
--
-- If channelize decided that two events have the same channel, then they can
-- go to the same addr, as long as it has voices left.  Otherwise, take over
-- another channel.
allot_event :: Configs -> AllotState -> (T.Event, Channel)
    -> (AllotState, LEvent.LEvent (T.Event, Patch.Addr))
allot_event :: Configs
-> AllotState
-> (Event, Integer)
-> (AllotState, LEvent (Event, Addr))
allot_event Configs
configs AllotState
state (Event
event, Integer
ichan) =
    case Allotted -> Allotted
expire_voices forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Instrument
inst, Integer
ichan) (AllotState -> Map AllotKey Allotted
ast_allotted AllotState
state) of
        -- If there is an already allotted addr with a free voice, add this
        -- event to it.
        Just (Allotted Addr
addr [RealTime]
voices Voices
voice_count) | forall (t :: * -> *) a. Foldable t => t a -> Voices
length [RealTime]
voices forall a. Ord a => a -> a -> Bool
< Voices
voice_count ->
            (Maybe (Voices, Maybe AllotKey)
-> Addr -> [RealTime] -> AllotState -> AllotState
update forall a. Maybe a
Nothing Addr
addr [RealTime]
voices AllotState
state, forall a. a -> LEvent a
LEvent.Event (Event
event, Addr
addr))
        -- Otherwise, steal the oldest already allotted voice.
        -- Delete the old (inst, chan) mapping.
        Maybe Allotted
_ -> case Configs
-> Instrument -> AllotState -> Maybe (Addr, Voices, Maybe AllotKey)
steal_addr Configs
configs Instrument
inst AllotState
state of
            Just (Addr
addr, Voices
voice_count, Maybe AllotKey
old_key) ->
                (Maybe (Voices, Maybe AllotKey)
-> Addr -> [RealTime] -> AllotState -> AllotState
update (forall a. a -> Maybe a
Just (Voices
voice_count, Maybe AllotKey
old_key)) Addr
addr [] AllotState
state,
                    forall a. a -> LEvent a
LEvent.Event (Event
event, Addr
addr))
            -- This will return lots of msgs if an inst has no allocation.
            -- A higher level should filter out the duplicates.
            Maybe (Addr, Voices, Maybe AllotKey)
Nothing -> (AllotState
state, forall a. Msg -> LEvent a
LEvent.Log Msg
no_alloc)
    where
    -- Remove voices that have ended.
    expire_voices :: Allotted -> Allotted
expire_voices Allotted
allotted = Allotted
allotted
        { allotted_voices :: [RealTime]
allotted_voices =
            forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Ord a => a -> a -> Bool
> Event -> RealTime
T.event_start Event
event) (Allotted -> [RealTime]
allotted_voices Allotted
allotted)
        }
    inst :: Instrument
inst = Patch -> Instrument
T.patch_name forall a b. (a -> b) -> a -> b
$ Event -> Patch
T.event_patch Event
event
    update :: Maybe (Voices, Maybe AllotKey)
-> Addr -> [RealTime] -> AllotState -> AllotState
update = AllotKey
-> RealTime
-> Maybe (Voices, Maybe AllotKey)
-> Addr
-> [RealTime]
-> AllotState
-> AllotState
update_allot_state (Instrument
inst, Integer
ichan) (Event -> RealTime
T.event_end Event
event)
    no_alloc :: Msg
no_alloc = Stack => Event -> Text -> Msg
event_warning Event
event (Text
"no allocation for " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Instrument
inst)

-- | Record this addr as now being allotted, and add its voice allocation.
update_allot_state :: (ScoreT.Instrument, Channel) -> RealTime
    -> Maybe (Patch.Voices, Maybe AllotKey) -> Patch.Addr
    -> [RealTime] -> AllotState -> AllotState
update_allot_state :: AllotKey
-> RealTime
-> Maybe (Voices, Maybe AllotKey)
-> Addr
-> [RealTime]
-> AllotState
-> AllotState
update_allot_state AllotKey
inst_chan RealTime
end Maybe (Voices, Maybe AllotKey)
maybe_new_allot Addr
addr [RealTime]
voices AllotState
state = AllotState
state
    { ast_available :: Map Addr (RealTime, AllotKey)
ast_available = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Addr
addr (RealTime
end, AllotKey
inst_chan) (AllotState -> Map Addr (RealTime, AllotKey)
ast_available AllotState
state)
    , ast_allotted :: Map AllotKey Allotted
ast_allotted = case Maybe (Voices, Maybe AllotKey)
maybe_new_allot of
        Just (Voices
voice_count, Maybe AllotKey
old_key) ->
            forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert AllotKey
inst_chan (Addr -> [RealTime] -> Voices -> Allotted
Allotted Addr
addr [RealTime
end] Voices
voice_count) forall a b. (a -> b) -> a -> b
$
                forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Maybe AllotKey
old_key (AllotState -> Map AllotKey Allotted
ast_allotted AllotState
state)
        Maybe (Voices, Maybe AllotKey)
Nothing -> forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust Allotted -> Allotted
adjust AllotKey
inst_chan (AllotState -> Map AllotKey Allotted
ast_allotted AllotState
state)
    }
    where adjust :: Allotted -> Allotted
adjust Allotted
allotted = Allotted
allotted { allotted_voices :: [RealTime]
allotted_voices = RealTime
end forall a. a -> [a] -> [a]
: [RealTime]
voices }

-- | Steal the least recently used address for the given instrument, and return
-- how many voices it supports.
--
-- Nothing voices means no limit, and in this case it'll pick a big number.
-- I initially feared keeping track of voice allocation would be wasteful for
-- addrs with no limitation, but profiling revealed no detectable difference.
-- So either it's not important or my profiles are broken.
steal_addr :: Configs -> ScoreT.Instrument -> AllotState
    -> Maybe (Patch.Addr, Patch.Voices, Maybe AllotKey)
steal_addr :: Configs
-> Instrument -> AllotState -> Maybe (Addr, Voices, Maybe AllotKey)
steal_addr Configs
configs Instrument
inst AllotState
state = case Config -> [(Addr, Maybe Voices)]
_addrs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Instrument
inst Configs
configs of
    Just [(Addr, Maybe Voices)]
addr_voices -> case forall k a. Ord k => (a -> k) -> [a] -> Maybe a
Lists.minimumOn (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [((Addr, Maybe Voices), (RealTime, Maybe AllotKey))]
avail of
        Just ((Addr
addr, Maybe Voices
voices), (RealTime
_, Maybe AllotKey
maybe_inst_chan)) ->
            forall a. a -> Maybe a
Just (Addr
addr, forall a. a -> Maybe a -> a
fromMaybe Voices
10000 Maybe Voices
voices, Maybe AllotKey
maybe_inst_chan)
        Maybe ((Addr, Maybe Voices), (RealTime, Maybe AllotKey))
Nothing -> forall a. Maybe a
Nothing
        where avail :: [((Addr, Maybe Voices), (RealTime, Maybe AllotKey))]
avail = forall a b. [a] -> [b] -> [(a, b)]
zip [(Addr, Maybe Voices)]
addr_voices (forall a b. (a -> b) -> [a] -> [b]
map (Addr -> (RealTime, Maybe AllotKey)
mlookup forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Addr, Maybe Voices)]
addr_voices)
    Maybe [(Addr, Maybe Voices)]
_ -> forall a. Maybe a
Nothing
    where
    mlookup :: Addr -> (RealTime, Maybe AllotKey)
mlookup Addr
addr = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Addr
addr (AllotState -> Map Addr (RealTime, AllotKey)
ast_available AllotState
state) of
        Maybe (RealTime, AllotKey)
Nothing -> (RealTime
0, forall a. Maybe a
Nothing)
        Just (RealTime
end, AllotKey
inst_chan) -> (RealTime
end, forall a. a -> Maybe a
Just AllotKey
inst_chan)


-- * perform notes

type PerformState = (AddrInst, NoteOffMap)

-- | As in 'Cmd.Cmd.WriteDeviceState', map an Addr to the Instrument active
-- at that address.
--
-- Used to emit keyswitches or program changes.
type AddrInst = Map Patch.Addr T.Patch

-- | Map from an address to the last time a note was playing on that address.
-- This includes the last note's decay time, so the channel should be reusable
-- after this time.
--
-- Used to give leading cc times a little breathing room.
--
-- It only needs to be 'min cc_lead (now - note_off)'
type NoteOffMap = Map Patch.Addr RealTime

-- | Pass an empty AddrInst because I can't make any assumptions about the
-- state of the synthesizer.  The one from the wdev state might be out of
-- date by the time this performance is played.
empty_perform_state :: PerformState
empty_perform_state :: PerformState
empty_perform_state = (forall k a. Map k a
Map.empty, forall k a. Map k a
Map.empty)

-- | Given an ordered list of note events, produce the appropriate midi msgs.
-- The input events are ordered, but may overlap.
perform_notes :: PerformState -> [LEvent.LEvent (T.Event, Patch.Addr)]
    -> (MidiEvents, PerformState)
perform_notes :: PerformState
-> [LEvent (Event, Addr)] -> (MidiEvents, PerformState)
perform_notes PerformState
state [LEvent (Event, Addr)]
events =
    (forall k a. Ord k => (a -> k) -> [[a]] -> [a]
Lists.mergeAscLists LEvent WriteMessage -> RealTime
merge_key [MidiEvents]
midi_msgs, PerformState
final_state)
    where
    (PerformState
final_state, [MidiEvents]
midi_msgs) = forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL PerformState
-> (LEvent (Event, Addr), [LEvent (Event, Addr)])
-> (PerformState, MidiEvents)
go PerformState
state
        (forall a b. [a] -> [b] -> [(a, b)]
zip [LEvent (Event, Addr)]
events (forall a. Voices -> [a] -> [a]
drop Voices
1 (forall a. [a] -> [[a]]
List.tails [LEvent (Event, Addr)]
events)))
    go :: PerformState
-> (LEvent (Event, Addr), [LEvent (Event, Addr)])
-> (PerformState, MidiEvents)
go PerformState
state (LEvent.Log Msg
log, [LEvent (Event, Addr)]
_) = (PerformState
state, [forall a. Msg -> LEvent a
LEvent.Log Msg
log])
    go PerformState
state (LEvent.Event event :: (Event, Addr)
event@(Event
_, Addr
addr), [LEvent (Event, Addr)]
future) =
        PerformState
-> Maybe RealTime -> (Event, Addr) -> (PerformState, MidiEvents)
perform_note_in_channel PerformState
state (forall {b}. Eq b => b -> [LEvent (Event, b)] -> Maybe RealTime
find_addr Addr
addr [LEvent (Event, Addr)]
future) (Event, Addr)
event
    find_addr :: b -> [LEvent (Event, b)] -> Maybe RealTime
find_addr b
addr =
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Event -> RealTime
T.event_start forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [LEvent a] -> Maybe a
LEvent.find_event ((forall a. Eq a => a -> a -> Bool
==b
addr) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)

-- | Emit msgs to set the channel state, and msgs for a single note.
perform_note_in_channel :: PerformState
    -> Maybe RealTime -- ^ next note with the same addr
    -> (T.Event, Patch.Addr) -> (PerformState, MidiEvents)
perform_note_in_channel :: PerformState
-> Maybe RealTime -> (Event, Addr) -> (PerformState, MidiEvents)
perform_note_in_channel (Map Addr Patch
addr_inst, Map Addr RealTime
note_off_map) Maybe RealTime
next_note_on (Event
event, Addr
addr) =
    ((Map Addr Patch
addr_inst2, forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Addr
addr RealTime
note_off Map Addr RealTime
note_off_map), MidiEvents
msgs)
    where
    (MidiEvents
note_msgs, RealTime
note_off) = RealTime
-> Maybe RealTime -> Event -> Addr -> (MidiEvents, RealTime)
perform_note
        (forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault RealTime
0 Addr
addr Map Addr RealTime
note_off_map) Maybe RealTime
next_note_on Event
event Addr
addr
    (MidiEvents
chan_state_msgs, Map Addr Patch
addr_inst2) = Map Addr Patch -> Addr -> Event -> (MidiEvents, Map Addr Patch)
adjust_chan_state Map Addr Patch
addr_inst Addr
addr Event
event
    msgs :: MidiEvents
msgs = MidiEvents -> MidiEvents -> MidiEvents
merge_events MidiEvents
chan_state_msgs MidiEvents
note_msgs

{- | Figure out of any msgs need to be emitted to convert the channel state to
    the given event on the given addr.  This means keyswitches and program
    changes.

    If there's no chan state always emit msgs, since in general there's no way
    to know what state the synth is in.  If I do know (e.g. playback will
    pass the current addr_inst) I can filter out expensive messages like
    program change.
    TODO implement playback with addr_inst when I implement pchange

    Another strategy would be to always emit msgs and rely on playback filter,
    but that would triple the number of msgs, which seems excessive.
-}
adjust_chan_state :: AddrInst -> Patch.Addr -> T.Event -> (MidiEvents, AddrInst)
adjust_chan_state :: Map Addr Patch -> Addr -> Event -> (MidiEvents, Map Addr Patch)
adjust_chan_state Map Addr Patch
addr_inst Addr
addr Event
event = case Event -> Maybe Key
event_midi_key Event
event of
    Maybe Key
Nothing -> ([], Map Addr Patch
new_addr_inst)
    Just Key
midi_key ->
        case Key
-> Addr
-> RealTime
-> Maybe Patch
-> Patch
-> Either Text [WriteMessage]
chan_state_msgs Key
midi_key Addr
addr (Event -> RealTime
T.event_start Event
event) Maybe Patch
old Patch
inst of
            Left Text
err -> ([forall a. Msg -> LEvent a
LEvent.Log forall a b. (a -> b) -> a -> b
$ Stack => Event -> Text -> Msg
event_warning Event
event Text
err], Map Addr Patch
new_addr_inst)
            Right [WriteMessage]
msgs -> (forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> LEvent a
LEvent.Event [WriteMessage]
msgs, Map Addr Patch
new_addr_inst)
    where
    new_addr_inst :: Map Addr Patch
new_addr_inst = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Addr
addr Patch
inst Map Addr Patch
addr_inst
    inst :: Patch
inst = Event -> Patch
T.event_patch Event
event
    old :: Maybe Patch
old = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Addr
addr Map Addr Patch
addr_inst

-- | TODO support program change, I'll have to get ahold of patch_initialize.
chan_state_msgs :: Midi.Key -> Patch.Addr -> RealTime
    -> Maybe T.Patch -> T.Patch
    -> Either Text [Midi.WriteMessage]
chan_state_msgs :: Key
-> Addr
-> RealTime
-> Maybe Patch
-> Patch
-> Either Text [WriteMessage]
chan_state_msgs Key
midi_key addr :: Addr
addr@(WriteDevice
wdev, ControlValue
chan) RealTime
start Maybe Patch
maybe_old_inst Patch
new_inst
    | Bool -> Bool
not Bool
same_inst = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"program change not supported yet on "
        forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Addr
addr forall a. Semigroup a => a -> a -> a
<> Text
": "
            forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (Patch -> Instrument
T.patch_name forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Patch
maybe_old_inst)
            forall a. Semigroup a => a -> a -> a
<> Text
" -> " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (Patch -> Instrument
T.patch_name Patch
new_inst)
    | Bool -> Bool
not (Maybe Patch -> Patch -> Bool
same_keyswitches Maybe Patch
maybe_old_inst Patch
new_inst) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$
        Key
-> Maybe Patch
-> Patch
-> WriteDevice
-> ControlValue
-> RealTime
-> [WriteMessage]
keyswitch_messages Key
midi_key Maybe Patch
maybe_old_inst Patch
new_inst WriteDevice
wdev ControlValue
chan RealTime
start
    | Bool
otherwise = forall a b. b -> Either a b
Right []
    where
    same_inst :: Bool
same_inst = case Maybe Patch
maybe_old_inst of
        Maybe Patch
Nothing -> Bool
True -- when pchange is supported I can assume false
        Just Patch
o -> Patch -> Instrument
T.patch_name Patch
o forall a. Eq a => a -> a -> Bool
== Patch -> Instrument
T.patch_name Patch
new_inst

same_keyswitches :: Maybe T.Patch -> T.Patch -> Bool
same_keyswitches :: Maybe Patch -> Patch -> Bool
same_keyswitches Maybe Patch
maybe_old Patch
new =
    [Keyswitch] -> [Keyswitch] -> Bool
go (forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Patch -> [Keyswitch]
T.patch_keyswitches Maybe Patch
maybe_old) (Patch -> [Keyswitch]
T.patch_keyswitches Patch
new)
    where
    go :: [Keyswitch] -> [Keyswitch] -> Bool
go [] [] = Bool
True
    -- To actually get this right I'd have to either change the Instrument
    -- Keyswitch to have the MIDI key, or keep a map of the aftertouch state
    -- by key.  Both sound like a hassle, so I'll just emit possibly redundant
    -- msgs.
    go (Patch.Aftertouch ControlValue
_ : [Keyswitch]
_) (Patch.Aftertouch ControlValue
_ : [Keyswitch]
_) = Bool
False
    go (Keyswitch
x : [Keyswitch]
xs) (Keyswitch
y : [Keyswitch]
ys) = Keyswitch
x forall a. Eq a => a -> a -> Bool
== Keyswitch
y Bool -> Bool -> Bool
&& [Keyswitch] -> [Keyswitch] -> Bool
go [Keyswitch]
xs [Keyswitch]
ys
    go [Keyswitch]
_ [Keyswitch]
_ = Bool
False

{- | Emit keyswitch msgs to adjust the channel to the new instrument.

    TODO if the last note was a hold keyswitch, this will leave the keyswitch
    down.  Technically I should clean that up, but it's a hassle because I'd
    need to keep the keyswitch down state in the PerformState so
    'perform_notes' can clean them all up, or let 'adjust_chan_state' look into
    the future so it knows if there will be another note.  But in practice, all
    notes get turned off after playing so the keyswitch should be cleaned up by
    that.
-}
keyswitch_messages :: Midi.Key -> Maybe T.Patch
    -> T.Patch -> Midi.WriteDevice -> Midi.Channel -> RealTime
    -> [Midi.WriteMessage]
keyswitch_messages :: Key
-> Maybe Patch
-> Patch
-> WriteDevice
-> ControlValue
-> RealTime
-> [WriteMessage]
keyswitch_messages Key
midi_key Maybe Patch
maybe_old_inst Patch
new_inst WriteDevice
wdev ControlValue
chan RealTime
start =
    [WriteMessage]
prev_ks_off forall a. [a] -> [a] -> [a]
++ [WriteMessage]
new_ks_on
    where
    -- Hold keyswitches have to stay down for the for the duration they are in
    -- effect.  So they just emit a NoteOn.  If I am switching keyswitches
    -- and the previous one was a hold-keyswitch, then it must be down, and
    -- I have to emit a NoteOff for it.
    prev_ks_off :: [WriteMessage]
prev_ks_off = forall a. a -> Maybe a -> a
Maybe.fromMaybe [] forall a b. (a -> b) -> a -> b
$ do
        Patch
old <- Maybe Patch
maybe_old_inst
        forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Patch -> Bool
T.patch_hold_keyswitches Patch
old)
        -- I apply the adjacent_note_gap to the ks note off too.  It's probably
        -- unnecessary, but this way the note and the ks go off at the same
        -- time.
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (RealTime -> Keyswitch -> Maybe WriteMessage
ks_off (RealTime
startforall a. Num a => a -> a -> a
-RealTime
adjacent_note_gap))
            (Patch -> [Keyswitch]
T.patch_keyswitches Patch
old)

    new_ks :: [Keyswitch]
new_ks = Patch -> [Keyswitch]
T.patch_keyswitches Patch
new_inst
    is_hold :: Bool
is_hold = Patch -> Bool
T.patch_hold_keyswitches Patch
new_inst
    ks_start :: RealTime
ks_start = RealTime
start forall a. Num a => a -> a -> a
- RealTime
keyswitch_lead_time

    new_ks_on :: [WriteMessage]
new_ks_on
        | Bool
is_hold = forall a b. (a -> b) -> [a] -> [b]
map (RealTime -> Keyswitch -> WriteMessage
ks_on RealTime
ks_start) [Keyswitch]
new_ks
        | Bool
otherwise = forall a b. (a -> b) -> [a] -> [b]
map (RealTime -> Keyswitch -> WriteMessage
ks_on RealTime
ks_start) [Keyswitch]
new_ks
            forall a. [a] -> [a] -> [a]
++ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (RealTime -> Keyswitch -> Maybe WriteMessage
ks_off (RealTime
ks_startforall a. Num a => a -> a -> a
+RealTime
min_note_duration)) [Keyswitch]
new_ks
    ks_on :: RealTime -> Keyswitch -> WriteMessage
ks_on RealTime
ts = RealTime -> ChannelMessage -> WriteMessage
mkmsg RealTime
ts forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Keyswitch -> ChannelMessage
Patch.keyswitch_on Key
midi_key
    ks_off :: RealTime -> Keyswitch -> Maybe WriteMessage
ks_off RealTime
ts = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RealTime -> ChannelMessage -> WriteMessage
mkmsg RealTime
ts) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Keyswitch -> Maybe ChannelMessage
Patch.keyswitch_off
    mkmsg :: RealTime -> ChannelMessage -> WriteMessage
mkmsg RealTime
ts ChannelMessage
msg = WriteDevice -> RealTime -> Message -> WriteMessage
Midi.WriteMessage WriteDevice
wdev RealTime
ts (ControlValue -> ChannelMessage -> Message
Midi.ChannelMessage ControlValue
chan ChannelMessage
msg)

-- ** perform note

-- | Emit MIDI for a single event.
perform_note :: RealTime -> Maybe RealTime -- ^ next note with the same addr
    -> T.Event -> Patch.Addr -> (MidiEvents, RealTime) -- ^ (msgs, note_off)
perform_note :: RealTime
-> Maybe RealTime -> Event -> Addr -> (MidiEvents, RealTime)
perform_note RealTime
prev_note_off Maybe RealTime
next_note_on Event
event Addr
addr =
    case Event -> Maybe Key
event_midi_key Event
event of
        Maybe Key
Nothing ->
            ( [forall a. Msg -> LEvent a
LEvent.Log forall a b. (a -> b) -> a -> b
$ Stack => Event -> Text -> Msg
event_warning Event
event Text
"event has no valid pitches"]
            , RealTime
prev_note_off
            )
        Just Key
midi_key -> (MidiEvents -> MidiEvents -> MidiEvents
merge_events MidiEvents
control_msgs MidiEvents
note_msgs, RealTime
note_off)
            where
            (MidiEvents
note_msgs, RealTime
note_off) = Key -> (MidiEvents, RealTime)
_note_msgs Key
midi_key
            control_msgs :: MidiEvents
control_msgs = RealTime -> Key -> MidiEvents
_control_msgs RealTime
note_off Key
midi_key
    where
    -- 'perform_note_msgs' and 'perform_control_msgs' are really part of one
    -- big function.  Splitting it apart led to a bit of duplicated work but
    -- hopefully it's easier to understand this way.
    _note_msgs :: Key -> (MidiEvents, RealTime)
_note_msgs = Event -> Addr -> Key -> (MidiEvents, RealTime)
perform_note_msgs Event
event Addr
addr
    _control_msgs :: RealTime -> Key -> MidiEvents
_control_msgs = RealTime
-> Maybe RealTime -> Event -> Addr -> RealTime -> Key -> MidiEvents
perform_control_msgs RealTime
prev_note_off Maybe RealTime
next_note_on Event
event Addr
addr

-- | Perform the note on and note off.
perform_note_msgs :: T.Event -> Patch.Addr -> Midi.Key -> (MidiEvents, RealTime)
perform_note_msgs :: Event -> Addr -> Key -> (MidiEvents, RealTime)
perform_note_msgs Event
event (WriteDevice
dev, ControlValue
chan) Key
midi_nn = (MidiEvents
events, RealTime
note_off)
    where
    events :: MidiEvents
events =
        [ forall a. a -> LEvent a
LEvent.Event forall a b. (a -> b) -> a -> b
$ RealTime -> ChannelMessage -> WriteMessage
chan_msg RealTime
note_on forall a b. (a -> b) -> a -> b
$ Key -> ControlValue -> ChannelMessage
Midi.NoteOn Key
midi_nn forall a b. (a -> b) -> a -> b
$
            -- NoteOn with 0 velocity is interpreted as NoteOff.  This messes
            -- up notes that are supposed to start from 0, e.g. via breath
            -- control.
            forall a. Ord a => a -> a -> a
max ControlValue
1 (UnboxedY -> ControlValue
Control.val_to_cval (Event -> UnboxedY
T.event_start_velocity Event
event))
        , forall a. a -> LEvent a
LEvent.Event forall a b. (a -> b) -> a -> b
$ RealTime -> ChannelMessage -> WriteMessage
chan_msg RealTime
note_off forall a b. (a -> b) -> a -> b
$ Key -> ControlValue -> ChannelMessage
Midi.NoteOff Key
midi_nn forall a b. (a -> b) -> a -> b
$
            UnboxedY -> ControlValue
Control.val_to_cval (Event -> UnboxedY
T.event_end_velocity Event
event)
        ]
    note_on :: RealTime
note_on = Event -> RealTime
T.event_start Event
event
    -- Subtract the adjacent_note_gap, but still have at least
    -- min_note_duration.
    note_off :: RealTime
note_off = forall a. Ord a => a -> a -> a
max (RealTime
note_on forall a. Num a => a -> a -> a
+ RealTime
min_note_duration)
        (Event -> RealTime
T.event_end Event
event forall a. Num a => a -> a -> a
- RealTime
adjacent_note_gap)
    chan_msg :: RealTime -> ChannelMessage -> WriteMessage
chan_msg RealTime
pos ChannelMessage
msg = WriteDevice -> RealTime -> Message -> WriteMessage
Midi.WriteMessage WriteDevice
dev RealTime
pos (ControlValue -> ChannelMessage -> Message
Midi.ChannelMessage ControlValue
chan ChannelMessage
msg)

-- | Perform control change messages.
perform_control_msgs :: RealTime -> Maybe RealTime -> T.Event -> Patch.Addr
    -> RealTime -> Midi.Key -> MidiEvents
perform_control_msgs :: RealTime
-> Maybe RealTime -> Event -> Addr -> RealTime -> Key -> MidiEvents
perform_control_msgs RealTime
prev_note_off Maybe RealTime
next_note_on Event
event (WriteDevice
dev, ControlValue
chan) RealTime
note_off
        Key
midi_key =
    forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> LEvent a
LEvent.Event [WriteMessage]
control_msgs forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a. Msg -> LEvent a
LEvent.Log [Msg]
warns
    where
    control_msgs :: [WriteMessage]
control_msgs = [[WriteMessage]] -> [WriteMessage]
merge_messages forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map (RealTime, ChannelMessage) -> WriteMessage
chan_msg) ([(RealTime, ChannelMessage)]
pitch_pos_msgs forall a. a -> [a] -> [a]
: [[(RealTime, ChannelMessage)]]
control_pos_msgs)
    control_sigs :: [(Control, Vector (Sample UnboxedY))]
control_sigs = forall k a. Map k a -> [(k, a)]
Map.toList (Event -> Map Control (Vector (Sample UnboxedY))
T.event_controls Event
event)
    cmap :: ControlMap
cmap = Patch -> ControlMap
T.patch_control_map (Event -> Patch
T.event_patch Event
event)
    -- |===---
    --      -|===---
    -- Drop controls that would overlap with the next note on.
    -- The controls after the note off are clipped to make room for the next
    -- note's leading controls.  Lead time will get pushed forward if the
    -- note really is adjacent, but if it's supposedly off then it's lower
    -- priority and I can clip off its controls.  Otherwise, the lead-time
    -- controls get messed up by controls from the last note.
    control_end :: Maybe RealTime
control_end = case Maybe RealTime
next_note_on of
        Maybe RealTime
Nothing -> forall a. Maybe a
Nothing
        Just RealTime
next -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
max RealTime
note_off (RealTime
next forall a. Num a => a -> a -> a
- RealTime
control_lead_time)

    ([[(RealTime, ChannelMessage)]]
control_pos_msgs, [[ClipRange]]
clip_warns) = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map (ControlMap
-> RealTime
-> RealTime
-> Maybe RealTime
-> Key
-> (Control, Vector (Sample UnboxedY))
-> ([(RealTime, ChannelMessage)], [ClipRange])
perform_control ControlMap
cmap RealTime
prev_note_off RealTime
note_on Maybe RealTime
control_end Key
midi_key)
            [(Control, Vector (Sample UnboxedY))]
control_sigs
    pitch_pos_msgs :: [(RealTime, ChannelMessage)]
pitch_pos_msgs = PbRange
-> Key
-> RealTime
-> RealTime
-> Maybe RealTime
-> Vector (Sample UnboxedY)
-> [(RealTime, ChannelMessage)]
perform_pitch (Event -> PbRange
event_pb_range Event
event)
        Key
midi_key RealTime
prev_note_off RealTime
note_on Maybe RealTime
control_end (Event -> Vector (Sample UnboxedY)
T.event_pitch Event
event)
    note_on :: RealTime
note_on = Event -> RealTime
T.event_start Event
event

    warns :: [Msg]
warns = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Event -> (Control, [ClipRange]) -> [Msg]
make_clip_warnings Event
event)
        (forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Control, Vector (Sample UnboxedY))]
control_sigs) [[ClipRange]]
clip_warns)
    chan_msg :: (RealTime, ChannelMessage) -> WriteMessage
chan_msg (RealTime
pos, ChannelMessage
msg) =
        WriteDevice -> RealTime -> Message -> WriteMessage
Midi.WriteMessage WriteDevice
dev RealTime
pos (ControlValue -> ChannelMessage -> Message
Midi.ChannelMessage ControlValue
chan ChannelMessage
msg)

event_pb_range :: T.Event -> Control.PbRange
event_pb_range :: Event -> PbRange
event_pb_range = Patch -> PbRange
T.patch_pitch_bend_range forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Patch
T.event_patch

-- | Get pitch at the given point of the signal.
--
-- The pitch bend always tunes upwards from the tempered note.  It would be
-- slicker to use a negative offset if the note is eventually going above
-- unity, but that's too much work.
event_pitch_at :: Control.PbRange -> T.Event -> RealTime
    -> Maybe (Midi.Key, Midi.PitchBendValue)
event_pitch_at :: PbRange -> Event -> RealTime -> Maybe (Key, PitchBendValue)
event_pitch_at PbRange
pb_range Event
event RealTime
pos =
    PbRange -> NoteNumber -> Maybe (Key, PitchBendValue)
Control.pitch_to_midi PbRange
pb_range forall a b. (a -> b) -> a -> b
$
        UnboxedY -> NoteNumber
Pitch.NoteNumber forall a b. (a -> b) -> a -> b
$ RealTime -> Vector (Sample UnboxedY) -> UnboxedY
MSignal.at RealTime
pos (Event -> Vector (Sample UnboxedY)
T.event_pitch Event
event)

-- | Get the Midi.Key that will be used for the event, without pitch bend.
event_midi_key :: T.Event -> Maybe Midi.Key
event_midi_key :: Event -> Maybe Key
event_midi_key Event
event =
    forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PbRange -> Event -> RealTime -> Maybe (Key, PitchBendValue)
event_pitch_at (Event -> PbRange
event_pb_range Event
event) Event
event (Event -> RealTime
T.event_start Event
event)

type ClipRange = (RealTime, RealTime)

make_clip_warnings :: T.Event -> (ScoreT.Control, [ClipRange]) -> [Log.Msg]
make_clip_warnings :: Event -> (Control, [ClipRange]) -> [Msg]
make_clip_warnings Event
event (Control
control, [ClipRange]
clip_warns) =
    [ Stack => Event -> Text -> Msg
event_warning Event
event forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Text
pretty Control
control forall a. Semigroup a => a -> a -> a
<> Text
" clipped: "
        forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty RealTime
s forall a. Semigroup a => a -> a -> a
<> Text
"--" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty RealTime
e
    | (RealTime
s, RealTime
e) <- [ClipRange]
clip_warns
    ]

perform_pitch :: Control.PbRange -> Midi.Key -> RealTime -> RealTime
    -> Maybe RealTime -> MSignal.Signal -> [(RealTime, Midi.ChannelMessage)]
perform_pitch :: PbRange
-> Key
-> RealTime
-> RealTime
-> Maybe RealTime
-> Vector (Sample UnboxedY)
-> [(RealTime, ChannelMessage)]
perform_pitch PbRange
pb_range Key
nn RealTime
prev_note_off RealTime
start Maybe RealTime
end Vector (Sample UnboxedY)
sig =
    [ (RealTime
x, PitchBendValue -> ChannelMessage
Midi.PitchBend (PbRange -> Key -> NoteNumber -> PitchBendValue
Control.pb_from_nn PbRange
pb_range Key
nn (UnboxedY -> NoteNumber
Pitch.NoteNumber UnboxedY
y)))
    | (RealTime
x, UnboxedY
y) <- [(RealTime, UnboxedY)]
pos_vals
    ]
    where pos_vals :: [(RealTime, UnboxedY)]
pos_vals = RealTime
-> RealTime
-> Maybe RealTime
-> Vector (Sample UnboxedY)
-> [(RealTime, UnboxedY)]
perform_signal RealTime
prev_note_off RealTime
start Maybe RealTime
end Vector (Sample UnboxedY)
sig

-- | Return the (pos, msg) pairs, and whether the signal value went out of the
-- allowed control range, 0--1.
perform_control :: Control.ControlMap -> RealTime -> RealTime -> Maybe RealTime
    -> Midi.Key -> (ScoreT.Control, MSignal.Signal)
    -> ([(RealTime, Midi.ChannelMessage)], [ClipRange])
perform_control :: ControlMap
-> RealTime
-> RealTime
-> Maybe RealTime
-> Key
-> (Control, Vector (Sample UnboxedY))
-> ([(RealTime, ChannelMessage)], [ClipRange])
perform_control ControlMap
cmap RealTime
prev_note_off RealTime
start Maybe RealTime
end Key
midi_key (Control
control, Vector (Sample UnboxedY)
sig) =
    case ControlMap -> Control -> Key -> Maybe (UnboxedY -> ChannelMessage)
Control.control_constructor ControlMap
cmap Control
control Key
midi_key of
        Maybe (UnboxedY -> ChannelMessage)
Nothing -> ([], [])
        Just UnboxedY -> ChannelMessage
ctor -> ([(RealTime
x, UnboxedY -> ChannelMessage
ctor UnboxedY
y) | (RealTime
x, UnboxedY
y) <- [(RealTime, UnboxedY)]
pos_vals], [ClipRange]
clip_warns)
    where
    -- The signal should already be trimmed to the event range, except that,
    -- as per the behaviour of MSignal.drop_before, it may have a leading
    -- sample.  I can drop that since it's handled specially by
    -- 'perform_signal'.
    pos_vals :: [(RealTime, UnboxedY)]
pos_vals = RealTime
-> RealTime
-> Maybe RealTime
-> Vector (Sample UnboxedY)
-> [(RealTime, UnboxedY)]
perform_signal RealTime
prev_note_off RealTime
start Maybe RealTime
end Vector (Sample UnboxedY)
clipped
    (Vector (Sample UnboxedY)
clipped, [ClipRange]
out_of_bounds) = UnboxedY
-> UnboxedY
-> Vector (Sample UnboxedY)
-> (Vector (Sample UnboxedY), [ClipRange])
MSignal.clip_bounds UnboxedY
0 UnboxedY
1 Vector (Sample UnboxedY)
sig
    clip_warns :: [ClipRange]
clip_warns = [(RealTime
s, RealTime
e) | (RealTime
s, RealTime
e) <- [ClipRange]
out_of_bounds]

-- | Trim a signal to the proper time range and emit (X, Y) pairs.  The proper
-- time range is complicated since there are two levels of priority.  Controls
-- within the note's start to end+decay are always emitted.  The end+decay is
-- put into the 'NoteOffMap' so the next note will yield 'control_lead_time' if
-- necessary.  Samples after end+decay are also emitted, but trimmed so they
-- won't overlap the next note's start - control_lead_time.
--
-- 'channelize' respects 'control_lead_time', so I expect msgs to be
-- scheduled on their own channels if possible.
--
-- If the signal has consecutive samples with the same value, this will emit
-- unnecessary CCs, but they will be eliminated by postprocessing.
perform_signal :: RealTime -> RealTime -> Maybe RealTime -> MSignal.Signal
    -> [(RealTime, MSignal.Y)]
perform_signal :: RealTime
-> RealTime
-> Maybe RealTime
-> Vector (Sample UnboxedY)
-> [(RealTime, UnboxedY)]
perform_signal RealTime
prev_note_off RealTime
start Maybe RealTime
end Vector (Sample UnboxedY)
sig = (RealTime, UnboxedY)
initial forall a. a -> [a] -> [a]
: [(RealTime, UnboxedY)]
pairs
    where
    -- The signal should already be trimmed to the event start, except that
    -- it may have a leading sample, due to 'MSignal.drop_before'.
    pairs :: [(RealTime, UnboxedY)]
pairs = forall k a. Eq k => (a -> k) -> [a] -> [a]
Lists.dropInitialDups forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$
        forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((forall a. Ord a => a -> a -> Bool
<=RealTime
start) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ Vector (Sample UnboxedY) -> [(RealTime, UnboxedY)]
MSignal.to_pairs forall a b. (a -> b) -> a -> b
$
        forall (v :: * -> *) y.
Vector v (Sample y) =>
RealTime -> v (Sample y) -> v (Sample y)
MSignal.drop_before RealTime
start forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall (v :: * -> *) y.
Vector v (Sample y) =>
RealTime -> v (Sample y) -> v (Sample y)
MSignal.drop_at_after Maybe RealTime
end Vector (Sample UnboxedY)
sig
    -- Don't go before the previous note, but don't go after the start of this
    -- note, in case the previous note ends after this one begins.
    tweaked_start :: RealTime
tweaked_start = forall a. Ord a => a -> a -> a
min (RealTime
start forall a. Num a => a -> a -> a
- RealTime
min_control_lead_time) forall a b. (a -> b) -> a -> b
$
        forall a. Ord a => a -> a -> a
max (forall a. Ord a => a -> a -> a
min RealTime
prev_note_off RealTime
start) (RealTime
start forall a. Num a => a -> a -> a
- RealTime
control_lead_time)
    initial :: (RealTime, UnboxedY)
initial = (RealTime
tweaked_start, RealTime -> Vector (Sample UnboxedY) -> UnboxedY
MSignal.at RealTime
start Vector (Sample UnboxedY)
sig)

-- * post process

type PostprocState = Map Patch.Addr AddrState

-- | Keep a running state for each channel and drop duplicate msgs.
type AddrState = (Maybe Midi.PitchBendValue, Map Midi.Control Midi.ControlValue)

-- | Some context free post-processing on the midi stream.
post_process :: PostprocState -> MidiEvents -> (MidiEvents, PostprocState)
post_process :: PostprocState -> MidiEvents -> (MidiEvents, PostprocState)
post_process PostprocState
state = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first MidiEvents -> MidiEvents
avoid_overlaps forall b c a. (b -> c) -> (a -> b) -> a -> c
. PostprocState -> MidiEvents -> (MidiEvents, PostprocState)
drop_dup_controls PostprocState
state forall b c a. (b -> c) -> (a -> b) -> a -> c
. MidiEvents -> MidiEvents
resort

{- |
    Overlapping notes with the same key number are undefined in MIDI.
    I have two strategies for them.  One is that an overlapping NoteOn will
    cause a NoteOff, and then the next NoteOff will be suppressed, which is
    effectively moving the overlapping note's NoteOff to right before the
    NoteOn.  So where + is NoteOn and | is NoteOff:

    > 0   1   2   3   5   6   7   8
    > +---+---|---|
    > +--|+-------|

    The other is Patch.UseFinalNoteOff, which accumulates the NoteOffs to the
    end:

    > 0   1   2   3   5   6   7   8
    > +---+---|---|
    > +---+-------||

    This was originally for kontakt, which doesn't count NoteOns and turns the
    note off on the first NoteOff, but I think the first method makes this
    obsolete, so it's disabled.
-}
avoid_overlaps :: MidiEvents -> MidiEvents
avoid_overlaps :: MidiEvents -> MidiEvents
avoid_overlaps MidiEvents
events = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall state a b.
(state -> a -> [a] -> (state, [b]))
-> state -> [LEvent a] -> (state, [[LEvent b]])
LEvent.map_accum forall {p}.
Map (WriteDevice, ControlValue, Key) NoteOnState
-> WriteMessage
-> p
-> (Map (WriteDevice, ControlValue, Key) NoteOnState,
    [WriteMessage])
move Map (WriteDevice, ControlValue, Key) NoteOnState
initial MidiEvents
events
    where
    initial :: Map (Midi.WriteDevice, Midi.Channel, Midi.Key) NoteOnState
    initial :: Map (WriteDevice, ControlValue, Key) NoteOnState
initial = forall k a. Map k a
Map.empty

    move :: Map (WriteDevice, ControlValue, Key) NoteOnState
-> WriteMessage
-> p
-> (Map (WriteDevice, ControlValue, Key) NoteOnState,
    [WriteMessage])
move Map (WriteDevice, ControlValue, Key) NoteOnState
state WriteMessage
wmsg p
_ = case WriteMessage
-> Maybe ((WriteDevice, ControlValue, Key), ChannelMessage)
msg_key WriteMessage
wmsg of
        Just (skey :: (WriteDevice, ControlValue, Key)
skey@(WriteDevice
_, ControlValue
chan, Key
key), ChannelMessage
msg) -> case ChannelMessage
msg of
            Midi.NoteOff {} ->
                (Map (WriteDevice, ControlValue, Key) NoteOnState
state2, forall a b. (a -> b) -> [a] -> [b]
map (WriteMessage -> Message -> WriteMessage
make_msg WriteMessage
wmsg forall b c a. (b -> c) -> (a -> b) -> a -> c
. ControlValue -> ChannelMessage -> Message
Midi.ChannelMessage ControlValue
chan) [ChannelMessage]
offs)
                where (Map (WriteDevice, ControlValue, Key) NoteOnState
state2, [ChannelMessage]
offs) = forall {k} {a}.
Ord k =>
k -> a -> Map k NoteOnState -> (Map k NoteOnState, [a])
note_off (WriteDevice, ControlValue, Key)
skey ChannelMessage
msg Map (WriteDevice, ControlValue, Key) NoteOnState
state
            Midi.NoteOn {} -> (Map (WriteDevice, ControlValue, Key) NoteOnState
state2, forall a. Bool -> a -> [a] -> [a]
cons_if Bool
emit_off WriteMessage
off [WriteMessage
wmsg])
                where
                off :: WriteMessage
off = WriteMessage -> Message -> WriteMessage
make_msg WriteMessage
wmsg forall a b. (a -> b) -> a -> b
$
                    ControlValue -> ChannelMessage -> Message
Midi.ChannelMessage ControlValue
chan forall a b. (a -> b) -> a -> b
$ Key -> ControlValue -> ChannelMessage
Midi.NoteOff Key
key ControlValue
100
                (Map (WriteDevice, ControlValue, Key) NoteOnState
state2, Bool
emit_off) = forall {k}.
Ord k =>
k -> Map k NoteOnState -> (Map k NoteOnState, Bool)
note_on (WriteDevice, ControlValue, Key)
skey Map (WriteDevice, ControlValue, Key) NoteOnState
state
            ChannelMessage
_ -> (Map (WriteDevice, ControlValue, Key) NoteOnState
state, [WriteMessage
wmsg])
        Maybe ((WriteDevice, ControlValue, Key), ChannelMessage)
Nothing -> (Map (WriteDevice, ControlValue, Key) NoteOnState
state, [WriteMessage
wmsg])
    -- Overlapping notes with the same (dev, chan, key) are affected.
    msg_key :: WriteMessage
-> Maybe ((WriteDevice, ControlValue, Key), ChannelMessage)
msg_key WriteMessage
wmsg = case WriteMessage -> Message
Midi.wmsg_msg WriteMessage
wmsg of
        Midi.ChannelMessage ControlValue
chan msg :: ChannelMessage
msg@(Midi.NoteOn Key
key ControlValue
_) ->
            forall a. a -> Maybe a
Just ((WriteDevice
dev, ControlValue
chan, Key
key), ChannelMessage
msg)
        Midi.ChannelMessage ControlValue
chan msg :: ChannelMessage
msg@(Midi.NoteOff Key
key ControlValue
_) ->
            forall a. a -> Maybe a
Just ((WriteDevice
dev, ControlValue
chan, Key
key), ChannelMessage
msg)
        Message
_ -> forall a. Maybe a
Nothing
        where dev :: WriteDevice
dev = WriteMessage -> WriteDevice
Midi.wmsg_dev WriteMessage
wmsg

    -- When I see NoteOn, emit NoteOff if a note with that key is already on.
    note_on :: k -> Map k NoteOnState -> (Map k NoteOnState, Bool)
note_on k
skey Map k NoteOnState
state = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
skey Map k NoteOnState
state of
        Just NoteOnState
Playing -> (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
skey NoteOnState
SuppressNoteOff Map k NoteOnState
state, Bool
True)
        Maybe NoteOnState
_ -> (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
skey NoteOnState
Playing Map k NoteOnState
state, Bool
False)

    -- When I see a NoteOff, drop it if SuppressNoteOff or there's nothing
    -- playing, otherwise emit it normally and update the state.
    note_off :: k -> a -> Map k NoteOnState -> (Map k NoteOnState, [a])
note_off k
skey a
msg Map k NoteOnState
state = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
skey Map k NoteOnState
state of
        Just NoteOnState
SuppressNoteOff -> (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
skey NoteOnState
Playing Map k NoteOnState
state, [])
        Just NoteOnState
NotPlaying -> (Map k NoteOnState
state, [])
        Just NoteOnState
Playing -> (forall k a. Ord k => k -> Map k a -> Map k a
Map.delete k
skey Map k NoteOnState
state, [a
msg])
        Maybe NoteOnState
Nothing -> (Map k NoteOnState
state, [])

    make_msg :: WriteMessage -> Message -> WriteMessage
make_msg WriteMessage
wmsg = WriteDevice -> RealTime -> Message -> WriteMessage
Midi.WriteMessage (WriteMessage -> WriteDevice
Midi.wmsg_dev WriteMessage
wmsg) (WriteMessage -> RealTime
Midi.wmsg_ts WriteMessage
wmsg)

data NoteOnState = Playing | NotPlaying
    -- | This means the next NoteOff will get skipped, but the one after that
    -- emitted.
    | SuppressNoteOff
    deriving (Voices -> NoteOnState -> ShowS
[NoteOnState] -> ShowS
NoteOnState -> String
forall a.
(Voices -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NoteOnState] -> ShowS
$cshowList :: [NoteOnState] -> ShowS
show :: NoteOnState -> String
$cshow :: NoteOnState -> String
showsPrec :: Voices -> NoteOnState -> ShowS
$cshowsPrec :: Voices -> NoteOnState -> ShowS
Show)

cons_if :: Bool -> a -> [a] -> [a]
cons_if :: forall a. Bool -> a -> [a] -> [a]
cons_if Bool
True a
x = (a
x:)
cons_if Bool
False a
_ = forall a. a -> a
id

-- | Having to deal with Log is ugly... can't I get that out with fmap?
drop_dup_controls :: PostprocState -> MidiEvents -> (MidiEvents, PostprocState)
drop_dup_controls :: PostprocState -> MidiEvents -> (MidiEvents, PostprocState)
drop_dup_controls PostprocState
state [] = ([], PostprocState
state)
drop_dup_controls PostprocState
state (log :: LEvent WriteMessage
log@(LEvent.Log Msg
_) : MidiEvents
events) =
    let (MidiEvents
rest, PostprocState
final_state) = PostprocState -> MidiEvents -> (MidiEvents, PostprocState)
drop_dup_controls PostprocState
state MidiEvents
events
    in (LEvent WriteMessage
log forall a. a -> [a] -> [a]
: MidiEvents
rest, PostprocState
final_state)
drop_dup_controls PostprocState
state (event :: LEvent WriteMessage
event@(LEvent.Event WriteMessage
wmsg) : MidiEvents
wmsgs) = case WriteMessage
wmsg of
    Midi.WriteMessage WriteDevice
dev RealTime
_ (Midi.ChannelMessage ControlValue
chan ChannelMessage
cmsg) ->
        let addr :: Addr
addr = (WriteDevice
dev, ControlValue
chan)
            addr_state :: Maybe AddrState
addr_state = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Addr
addr PostprocState
state
            (Bool
keep, Maybe AddrState
addr_state2) = Maybe AddrState -> ChannelMessage -> (Bool, Maybe AddrState)
analyze_msg Maybe AddrState
addr_state ChannelMessage
cmsg
            state2 :: PostprocState
state2 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe PostprocState
state (\AddrState
s -> forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Addr
addr AddrState
s PostprocState
state) Maybe AddrState
addr_state2
            (MidiEvents
rest, PostprocState
final_state) = PostprocState -> MidiEvents -> (MidiEvents, PostprocState)
drop_dup_controls PostprocState
state2 MidiEvents
wmsgs
        in (if Bool
keep then LEvent WriteMessage
event forall a. a -> [a] -> [a]
: MidiEvents
rest else MidiEvents
rest, PostprocState
final_state)
    WriteMessage
_ -> PostprocState -> MidiEvents -> (MidiEvents, PostprocState)
drop_dup_controls PostprocState
state MidiEvents
wmsgs

analyze_msg :: Maybe AddrState -> Midi.ChannelMessage -> (Bool, Maybe AddrState)
analyze_msg :: Maybe AddrState -> ChannelMessage -> (Bool, Maybe AddrState)
analyze_msg Maybe AddrState
Nothing ChannelMessage
msg = case ChannelMessage
msg of
    Midi.PitchBend PitchBendValue
v -> (Bool
True, forall a. a -> Maybe a
Just (forall a. a -> Maybe a
Just PitchBendValue
v, forall k a. Map k a
Map.empty))
    Midi.ControlChange ControlValue
c ControlValue
v -> (Bool
True, forall a. a -> Maybe a
Just (forall a. Maybe a
Nothing, forall k a. k -> a -> Map k a
Map.singleton ControlValue
c ControlValue
v))
    ChannelMessage
_ -> (Bool
True, forall a. Maybe a
Nothing)
analyze_msg (Just (Maybe PitchBendValue
pb_val, Map ControlValue ControlValue
cmap)) ChannelMessage
msg = case ChannelMessage
msg of
    Midi.PitchBend PitchBendValue
v
        | forall a. a -> Maybe a
Just PitchBendValue
v forall a. Eq a => a -> a -> Bool
== Maybe PitchBendValue
pb_val -> (Bool
False, forall a. Maybe a
Nothing)
        | Bool
otherwise -> (Bool
True, forall a. a -> Maybe a
Just (forall a. a -> Maybe a
Just PitchBendValue
v, Map ControlValue ControlValue
cmap))
    Midi.ControlChange ControlValue
c ControlValue
v
        | forall a. a -> Maybe a
Just ControlValue
v forall a. Eq a => a -> a -> Bool
== forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ControlValue
c Map ControlValue ControlValue
cmap -> (Bool
False, forall a. Maybe a
Nothing)
        | Bool
otherwise -> (Bool
True, forall a. a -> Maybe a
Just (Maybe PitchBendValue
pb_val, forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ControlValue
c ControlValue
v Map ControlValue ControlValue
cmap))
    ChannelMessage
_ -> (Bool
True, forall a. Maybe a
Nothing)

-- | Sort almost-sorted MidiEvents.  Events may be out of order by
-- as much as control_lead_time.  This happens because 'perform_signal' adds
-- events between 0--control_lead_time before the note, which can violate the
-- precondition of 'Lists.mergeAscLists'.
--
-- I tried to come up with a way for the events to come out sorted even with
-- 'perform_signal', but creativity failed me, so I resorted to this hammer.
resort :: MidiEvents -> MidiEvents
resort :: MidiEvents -> MidiEvents
resort = [WriteMessage] -> MidiEvents -> MidiEvents
go forall a. Monoid a => a
mempty
    where
    go :: [WriteMessage] -> MidiEvents -> MidiEvents
go [WriteMessage]
collect [] = forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> LEvent a
LEvent.Event [WriteMessage]
collect
    go [WriteMessage]
collect (LEvent.Log Msg
log : MidiEvents
events) = forall a. Msg -> LEvent a
LEvent.Log Msg
log forall a. a -> [a] -> [a]
: [WriteMessage] -> MidiEvents -> MidiEvents
go [WriteMessage]
collect MidiEvents
events
    go [WriteMessage]
collect (LEvent.Event WriteMessage
event : MidiEvents
events) =
        forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> LEvent a
LEvent.Event [WriteMessage]
pre forall a. [a] -> [a] -> [a]
++ [WriteMessage] -> MidiEvents -> MidiEvents
go [WriteMessage]
post MidiEvents
events
        where
        -- In the common sorted case, this means copying 'collect' every single
        -- time.  Presumably I could go find a priority queue on hackage, but
        -- lists are pretty fast...
        ([WriteMessage]
pre, [WriteMessage]
post) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break ((forall a. Ord a => a -> a -> Bool
> WriteMessage -> RealTime
Midi.wmsg_ts WriteMessage
event forall a. Num a => a -> a -> a
- RealTime
interval) forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriteMessage -> RealTime
Midi.wmsg_ts)
            (forall k a. Ord k => (a -> k) -> a -> [a] -> [a]
Lists.insertOn WriteMessage -> RealTime
Midi.wmsg_ts WriteMessage
event [WriteMessage]
collect)
    interval :: RealTime
interval = RealTime
control_lead_time


-- * event

note_begin :: T.Event -> RealTime
note_begin :: Event -> RealTime
note_begin Event
event = Event -> RealTime
T.event_start Event
event forall a. Num a => a -> a -> a
- RealTime
control_lead_time

-- | The end of an event after taking decay into account.  The note shouldn't
-- be sounding past this time.
note_end :: T.Event -> RealTime
note_end :: Event -> RealTime
note_end Event
event = Event -> RealTime
T.event_end Event
event
    forall a. Num a => a -> a -> a
+ forall a. a -> Maybe a -> a
fromMaybe RealTime
T.default_decay (Patch -> Maybe RealTime
T.patch_decay (Event -> Patch
T.event_patch Event
event))

-- * util

-- | Merge an unsorted list of sorted lists of midi messages.
merge_messages :: [[Midi.WriteMessage]] -> [Midi.WriteMessage]
merge_messages :: [[WriteMessage]] -> [WriteMessage]
merge_messages = forall k a. Ord k => (a -> k) -> [[a]] -> [a]
Lists.mergeLists WriteMessage -> RealTime
Midi.wmsg_ts

merge_events :: MidiEvents -> MidiEvents -> MidiEvents
merge_events :: MidiEvents -> MidiEvents -> MidiEvents
merge_events = forall k a. Ord k => (a -> k) -> [a] -> [a] -> [a]
Lists.mergeOn LEvent WriteMessage -> RealTime
merge_key

merge_key :: LEvent.LEvent Midi.WriteMessage -> RealTime
merge_key :: LEvent WriteMessage -> RealTime
merge_key (LEvent.Log Msg
_) = RealTime
0
merge_key (LEvent.Event WriteMessage
msg) = WriteMessage -> RealTime
Midi.wmsg_ts WriteMessage
msg


-- | Map the given function across the events, passing it previous events it
-- overlaps with.  The previous events passed to the function are paired with
-- its previous return values on those events.  The overlapping events are
-- passed in reverse order, so the most recently overlapping is first.
overlap_map :: [(T.Event, a)] -> ([(T.Event, a)] -> T.Event
    -> (a, [Log.Msg])) -> Events
    -> ([LEvent.LEvent (T.Event, a)], [(T.Event, a)])
    -- ^ (output for each event, final overlapping state)
overlap_map :: forall a.
[(Event, a)]
-> ([(Event, a)] -> Event -> (a, [Msg]))
-> Events
-> ([LEvent (Event, a)], [(Event, a)])
overlap_map [(Event, a)]
initial = forall a.
[(Event, a)]
-> ([(Event, a)] -> Event -> (a, [Msg]))
-> Events
-> ([LEvent (Event, a)], [(Event, a)])
go [(Event, a)]
initial
    where
    go :: [(Event, b)]
-> ([(Event, b)] -> Event -> (b, [Msg]))
-> Events
-> ([LEvent (Event, b)], [(Event, b)])
go [(Event, b)]
prev [(Event, b)] -> Event -> (b, [Msg])
_ [] = ([], [(Event, b)]
prev)
    go [(Event, b)]
prev [(Event, b)] -> Event -> (b, [Msg])
f (LEvent.Log Msg
log : Events
events) = (forall a. Msg -> LEvent a
LEvent.Log Msg
log forall a. a -> [a] -> [a]
: [LEvent (Event, b)]
rest, [(Event, b)]
final_state)
        where ([LEvent (Event, b)]
rest, [(Event, b)]
final_state) = [(Event, b)]
-> ([(Event, b)] -> Event -> (b, [Msg]))
-> Events
-> ([LEvent (Event, b)], [(Event, b)])
go [(Event, b)]
prev [(Event, b)] -> Event -> (b, [Msg])
f Events
events
    go [(Event, b)]
prev [(Event, b)] -> Event -> (b, [Msg])
f (LEvent.Event Event
e : Events
events) =
        (forall a. a -> LEvent a
LEvent.Event (Event
e, b
val) forall a. a -> [a] -> [a]
: forall {a}. [LEvent a]
log_events forall a. [a] -> [a] -> [a]
++ [LEvent (Event, b)]
vals, [(Event, b)]
final_state)
        where
        start :: RealTime
start = Event -> RealTime
note_begin Event
e
        overlapping :: [(Event, b)]
overlapping = forall a. (a -> Bool) -> [a] -> [a]
takeWhile ((forall a. Ord a => a -> a -> Bool
> RealTime
start) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> RealTime
note_end forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Event, b)]
prev
        (b
val, [Msg]
logs) = [(Event, b)] -> Event -> (b, [Msg])
f [(Event, b)]
overlapping Event
e
        log_events :: [LEvent a]
log_events = if Bool
logging then forall a b. (a -> b) -> [a] -> [b]
map forall a. Msg -> LEvent a
LEvent.Log [Msg]
logs else []
        ([LEvent (Event, b)]
vals, [(Event, b)]
final_state) = [(Event, b)]
-> ([(Event, b)] -> Event -> (b, [Msg]))
-> Events
-> ([LEvent (Event, b)], [(Event, b)])
go ((Event
e, b
val) forall a. a -> [a] -> [a]
: [(Event, b)]
overlapping) [(Event, b)] -> Event -> (b, [Msg])
f Events
events

event_warning :: CallStack.Stack => T.Event -> Text -> Log.Msg
event_warning :: Stack => Event -> Text -> Msg
event_warning Event
event = Stack => Priority -> Maybe Stack -> Text -> Msg
Log.msg Priority
Log.Warn (forall a. a -> Maybe a
Just (Event -> Stack
T.event_stack Event
event))