-- 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)]) 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 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))