{-# LANGUAGE CPP #-}
module Perform.Midi.Perform (
default_velocity
, State(..), initial_state
, Config, config, addrs_config
, perform
, 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.Log as Log
import qualified Util.Maps as Maps
import qualified Util.Pretty as Pretty
import qualified Util.Seq as Seq
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
logging :: Bool
logging :: Bool
logging = Bool
False
default_velocity :: MSignal.Y
default_velocity :: UnboxedY
default_velocity = UnboxedY
0.79
keyswitch_lead_time :: RealTime
keyswitch_lead_time :: RealTime
keyswitch_lead_time = Integer -> RealTime
RealTime.milliseconds Integer
10
control_lead_time :: RealTime
control_lead_time :: RealTime
control_lead_time = Integer -> RealTime
RealTime.milliseconds Integer
100
min_control_lead_time :: RealTime
min_control_lead_time :: RealTime
min_control_lead_time = Integer -> RealTime
RealTime.milliseconds Integer
4
adjacent_note_gap :: RealTime
adjacent_note_gap :: RealTime
adjacent_note_gap = Integer -> RealTime
RealTime.milliseconds Integer
10
min_note_duration :: RealTime
min_note_duration :: RealTime
min_note_duration = Integer -> RealTime
RealTime.milliseconds Integer
20
type Events = [LEvent.LEvent T.Event]
type MidiEvents = [LEvent.LEvent Midi.WriteMessage]
data State = State {
State -> ChannelizeState
state_channelize :: !ChannelizeState
, State -> AllotState
state_allot :: !AllotState
, State -> PerformState
state_perform :: !PerformState
} deriving (State -> State -> Bool
(State -> State -> Bool) -> (State -> State -> Bool) -> Eq State
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
(Voices -> State -> ShowS)
-> (State -> String) -> ([State] -> ShowS) -> Show State
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", ChannelizeState -> Doc
forall a. Pretty a => a -> Doc
Pretty.format ChannelizeState
channelize)
, (Text
"allot", AllotState -> Doc
forall a. Pretty a => a -> Doc
Pretty.format AllotState
allot)
, (Text
"perform", PerformState -> Doc
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
(Voices -> Config -> ShowS)
-> (Config -> String) -> ([Config] -> ShowS) -> Show Config
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
(Config -> Config -> Bool)
-> (Config -> Config -> Bool) -> Eq Config
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 }
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 PostprocState
forall a. Monoid a => a
mempty MidiEvents
msgs
type Channel = Integer
type ChannelizeState = [(T.Event, Channel)]
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 =
ChannelizeState
-> (ChannelizeState -> Event -> (Integer, [Msg]))
-> Events
-> ([LEvent (Event, Integer)], ChannelizeState)
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
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 (Config -> [(Addr, Maybe Voices)])
-> Maybe Config -> Maybe [(Addr, Maybe Voices)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Instrument -> Configs -> Maybe Config
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])
Maybe [(Addr, Maybe Voices)]
_ -> (Integer
0, [])
where
inst_name :: Instrument
inst_name = Patch -> Instrument
T.patch_name (Event -> Patch
T.event_patch Event
event)
chan :: Integer
chan = Integer -> Maybe Integer -> Integer
forall a. a -> Maybe a -> a
fromMaybe ([Integer] -> Integer
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (-Integer
1 Integer -> [Integer] -> [Integer]
forall a. a -> [a] -> [a]
: ((Event, Integer) -> Integer) -> ChannelizeState -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map (Event, Integer) -> Integer
forall a b. (a, b) -> b
snd ChannelizeState
overlapping) Integer -> Integer -> Integer
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
Priority -> Maybe Stack -> Text -> Msg
Log.msg Priority
Log.Warn (Stack -> Maybe Stack
forall a. a -> Maybe a
Just (Event -> Stack
T.event_stack Event
event)) (Text -> Msg) -> Text -> Msg
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
(Event -> Text
T.show_short Event
event Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": found chan " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe Integer -> Text
forall a. Show a => a -> Text
showt Maybe Integer
maybe_chan
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", picked " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Integer -> Text
forall a. Show a => a -> Text
showt Integer
chan)
Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: ((Integer, Text) -> Text) -> [(Integer, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Integer, Text) -> Text
forall {a}. Show a => (a, Text) -> Text
mkmsg [(Integer, Text)]
reasons
[Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Integer -> Text
forall a. Show a => a -> Text
showt Integer
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> 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 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. Show a => a -> Text
showt a
chan Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
reason
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 =
( (Integer, [Text]) -> Integer
forall a b. (a, b) -> a
fst ((Integer, [Text]) -> Integer)
-> Maybe (Integer, [Text]) -> Maybe Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Integer, [Text]) -> Bool)
-> [(Integer, [Text])] -> Maybe (Integer, [Text])
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ([Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Text] -> Bool)
-> ((Integer, [Text]) -> [Text]) -> (Integer, [Text]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer, [Text]) -> [Text]
forall a b. (a, b) -> b
snd) [(Integer, [Text])]
unshareable_reasons
, ((Integer, [Text]) -> (Integer, Text))
-> [(Integer, [Text])] -> [(Integer, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (([Text] -> Text) -> (Integer, [Text]) -> (Integer, Text)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Text -> [Text] -> Text
Text.intercalate Text
"; ")) ([(Integer, [Text])] -> [(Integer, Text)])
-> [(Integer, [Text])] -> [(Integer, Text)]
forall a b. (a -> b) -> a -> b
$
((Integer, [Text]) -> Bool)
-> [(Integer, [Text])] -> [(Integer, [Text])]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((Integer, [Text]) -> Bool) -> (Integer, [Text]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Text] -> Bool)
-> ((Integer, [Text]) -> [Text]) -> (Integer, [Text]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer, [Text]) -> [Text]
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 = ChannelizeState -> [([Event], Integer)]
forall b a. Ord b => [(a, b)] -> [(NonNull a, b)]
Seq.group_snd ChannelizeState
overlapping
reasons :: [Event] -> [Text]
reasons = (Event -> Maybe Text) -> [Event] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((Event -> Event -> Maybe Text) -> Event -> Event -> Maybe Text
forall a b c. (a -> b -> c) -> b -> a -> c
flip Event -> Event -> Maybe Text
can_share_chan Event
event)
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 RealTime -> RealTime -> Bool
forall a. Ord a => a -> a -> Bool
>= RealTime
end -> Maybe Text
forall a. Maybe a
Nothing
(Maybe (Key, PitchBendValue), Maybe (Key, PitchBendValue))
_ | Event -> Instrument
inst_of Event
old Instrument -> Instrument -> Bool
forall a. Eq a => a -> a -> Bool
/= Event -> Instrument
inst_of Event
new -> Text -> Maybe Text
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)) ->
Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
"pitch signals incompatible: "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Vector (Sample UnboxedY) -> Text
forall a. Pretty a => a -> Text
pretty (Event -> Vector (Sample UnboxedY)
T.event_pitch Event
old) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" /= "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Vector (Sample UnboxedY) -> Text
forall a. Pretty a => a -> Text
pretty (Event -> Vector (Sample UnboxedY)
T.event_pitch Event
new)
| Bool -> Bool
not Bool
c_equal ->
Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
"controls differ: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Map Control (Vector (Sample UnboxedY)) -> Text
forall a. Pretty a => a -> Text
pretty (Event -> Map Control (Vector (Sample UnboxedY))
T.event_controls Event
old)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" /= " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Map Control (Vector (Sample UnboxedY)) -> Text
forall a. Pretty a => a -> Text
pretty (Event -> Map Control (Vector (Sample UnboxedY))
T.event_controls Event
new)
| Bool
otherwise -> Maybe Text
forall a. Maybe a
Nothing
(Maybe (Key, PitchBendValue), Maybe (Key, PitchBendValue))
_ -> Maybe Text
forall a. Maybe a
Nothing
where
inst_of :: Event -> Instrument
inst_of = Patch -> Instrument
T.patch_name (Patch -> Instrument) -> (Event -> Patch) -> Event -> Instrument
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
end :: RealTime
end = RealTime -> RealTime -> RealTime
forall a. Ord a => a -> a -> a
min (Event -> RealTime
note_end Event
new) (Event -> RealTime
note_end Event
old) RealTime -> RealTime -> RealTime
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)
in_decay :: Bool
in_decay = Event -> RealTime
T.event_end Event
new RealTime -> RealTime -> Bool
forall a. Ord a => a -> a -> Bool
<= Event -> RealTime
T.event_start Event
old
Bool -> Bool -> Bool
|| Event -> RealTime
T.event_end Event
old RealTime -> RealTime -> Bool
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)
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 RealTime -> RealTime -> Bool
forall a. Ord a => a -> a -> Bool
>= RealTime
end Bool -> Bool -> Bool
|| ((Control,
Paired (Vector (Sample UnboxedY)) (Vector (Sample UnboxedY)))
-> Bool)
-> [(Control,
Paired (Vector (Sample UnboxedY)) (Vector (Sample UnboxedY)))]
-> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Control,
Paired (Vector (Sample UnboxedY)) (Vector (Sample UnboxedY)))
-> Bool
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
relevant :: Map Control a -> Map Control a
relevant = (Control -> a -> Bool) -> Map Control a -> Map Control a
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 = Map Control (Vector (Sample UnboxedY))
-> Map Control (Vector (Sample UnboxedY))
-> [(Control,
Paired (Vector (Sample UnboxedY)) (Vector (Sample UnboxedY)))]
forall k v1 v2.
Ord k =>
Map k v1 -> Map k v2 -> [(k, Paired v1 v2)]
Maps.pairs (Map Control (Vector (Sample UnboxedY))
-> Map Control (Vector (Sample UnboxedY))
forall {a}. Map Control a -> Map Control a
relevant Map Control (Vector (Sample UnboxedY))
cs1) (Map Control (Vector (Sample UnboxedY))
-> Map Control (Vector (Sample UnboxedY))
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
_, Seq.Both v (Sample y)
sig1 v (Sample y)
sig2) =
RealTime -> RealTime -> v (Sample y) -> v (Sample y)
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 v (Sample y) -> v (Sample y) -> Bool
forall a. Eq a => a -> a -> Bool
== RealTime -> RealTime -> v (Sample y) -> v (Sample y)
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 :: 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) = (AllotState
-> LEvent (Event, Integer) -> (AllotState, LEvent (Event, Addr)))
-> AllotState
-> [LEvent (Event, Integer)]
-> (AllotState, [LEvent (Event, Addr)])
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, Msg -> LEvent (Event, Addr)
forall a. Msg -> LEvent a
LEvent.Log Msg
log)
data AllotState = AllotState {
AllotState -> Map Addr (RealTime, AllotKey)
ast_available :: !(Map Patch.Addr (RealTime, AllotKey))
, AllotState -> Map AllotKey Allotted
ast_allotted :: !(Map AllotKey Allotted)
} deriving (AllotState -> AllotState -> Bool
(AllotState -> AllotState -> Bool)
-> (AllotState -> AllotState -> Bool) -> Eq AllotState
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
(Voices -> AllotState -> ShowS)
-> (AllotState -> String)
-> ([AllotState] -> ShowS)
-> Show AllotState
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", Map Addr (RealTime, AllotKey) -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Map Addr (RealTime, AllotKey)
available)
, (Text
"allotted", Map AllotKey Allotted -> Doc
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 Map Addr (RealTime, AllotKey)
forall k a. Map k a
Map.empty Map AllotKey Allotted
forall k a. Map k a
Map.empty
type AllotKey = (ScoreT.Instrument, Channel)
data Allotted = Allotted {
Allotted -> Addr
_allotted_addr :: !Patch.Addr
, Allotted -> [RealTime]
allotted_voices :: ![RealTime]
, Allotted -> Voices
_allotted_voice_count :: !Patch.Voices
} deriving (Allotted -> Allotted -> Bool
(Allotted -> Allotted -> Bool)
-> (Allotted -> Allotted -> Bool) -> Eq Allotted
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
(Voices -> Allotted -> ShowS)
-> (Allotted -> String) -> ([Allotted] -> ShowS) -> Show Allotted
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", Addr -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Addr
addr)
, (Text
"voices", [RealTime] -> Doc
forall a. Pretty a => a -> Doc
Pretty.format [RealTime]
voices)
, (Text
"voice_count", Voices -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Voices
voice_count)
]
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 (Allotted -> Allotted) -> Maybe Allotted -> Maybe Allotted
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AllotKey -> Map AllotKey Allotted -> Maybe Allotted
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
Just (Allotted Addr
addr [RealTime]
voices Voices
voice_count) | [RealTime] -> Voices
forall (t :: * -> *) a. Foldable t => t a -> Voices
length [RealTime]
voices Voices -> Voices -> Bool
forall a. Ord a => a -> a -> Bool
< Voices
voice_count ->
(Maybe (Voices, Maybe AllotKey)
-> Addr -> [RealTime] -> AllotState -> AllotState
update Maybe (Voices, Maybe AllotKey)
forall a. Maybe a
Nothing Addr
addr [RealTime]
voices AllotState
state, (Event, Addr) -> LEvent (Event, Addr)
forall a. a -> LEvent a
LEvent.Event (Event
event, Addr
addr))
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 ((Voices, Maybe AllotKey) -> Maybe (Voices, Maybe AllotKey)
forall a. a -> Maybe a
Just (Voices
voice_count, Maybe AllotKey
old_key)) Addr
addr [] AllotState
state,
(Event, Addr) -> LEvent (Event, Addr)
forall a. a -> LEvent a
LEvent.Event (Event
event, Addr
addr))
Maybe (Addr, Voices, Maybe AllotKey)
Nothing -> (AllotState
state, Msg -> LEvent (Event, Addr)
forall a. Msg -> LEvent a
LEvent.Log Msg
no_alloc)
where
expire_voices :: Allotted -> Allotted
expire_voices Allotted
allotted = Allotted
allotted
{ allotted_voices :: [RealTime]
allotted_voices =
(RealTime -> Bool) -> [RealTime] -> [RealTime]
forall a. (a -> Bool) -> [a] -> [a]
filter (RealTime -> RealTime -> Bool
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 (Patch -> Instrument) -> Patch -> Instrument
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 -> Text -> Msg
event_warning Event
event (Text
"no allocation for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Instrument -> Text
forall a. Pretty a => a -> Text
pretty Instrument
inst)
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 = Addr
-> (RealTime, AllotKey)
-> Map Addr (RealTime, AllotKey)
-> Map Addr (RealTime, AllotKey)
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) ->
AllotKey
-> Allotted -> Map AllotKey Allotted -> Map AllotKey Allotted
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) (Map AllotKey Allotted -> Map AllotKey Allotted)
-> Map AllotKey Allotted -> Map AllotKey Allotted
forall a b. (a -> b) -> a -> b
$
(Map AllotKey Allotted -> Map AllotKey Allotted)
-> (AllotKey -> Map AllotKey Allotted -> Map AllotKey Allotted)
-> Maybe AllotKey
-> Map AllotKey Allotted
-> Map AllotKey Allotted
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map AllotKey Allotted -> Map AllotKey Allotted
forall a. a -> a
id AllotKey -> Map AllotKey Allotted -> Map AllotKey Allotted
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 -> (Allotted -> Allotted)
-> AllotKey -> Map AllotKey Allotted -> Map AllotKey Allotted
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 RealTime -> [RealTime] -> [RealTime]
forall a. a -> [a] -> [a]
: [RealTime]
voices }
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 (Config -> [(Addr, Maybe Voices)])
-> Maybe Config -> Maybe [(Addr, Maybe Voices)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Instrument -> Configs -> Maybe Config
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 (((Addr, Maybe Voices), (RealTime, Maybe AllotKey)) -> RealTime)
-> [((Addr, Maybe Voices), (RealTime, Maybe AllotKey))]
-> Maybe ((Addr, Maybe Voices), (RealTime, Maybe AllotKey))
forall k a. Ord k => (a -> k) -> [a] -> Maybe a
Seq.minimum_on ((RealTime, Maybe AllotKey) -> RealTime
forall a b. (a, b) -> a
fst ((RealTime, Maybe AllotKey) -> RealTime)
-> (((Addr, Maybe Voices), (RealTime, Maybe AllotKey))
-> (RealTime, Maybe AllotKey))
-> ((Addr, Maybe Voices), (RealTime, Maybe AllotKey))
-> RealTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Addr, Maybe Voices), (RealTime, Maybe AllotKey))
-> (RealTime, Maybe AllotKey)
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)) ->
(Addr, Voices, Maybe AllotKey)
-> Maybe (Addr, Voices, Maybe AllotKey)
forall a. a -> Maybe a
Just (Addr
addr, Voices -> Maybe Voices -> Voices
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 -> Maybe (Addr, Voices, Maybe AllotKey)
forall a. Maybe a
Nothing
where avail :: [((Addr, Maybe Voices), (RealTime, Maybe AllotKey))]
avail = [(Addr, Maybe Voices)]
-> [(RealTime, Maybe AllotKey)]
-> [((Addr, Maybe Voices), (RealTime, Maybe AllotKey))]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Addr, Maybe Voices)]
addr_voices (((Addr, Maybe Voices) -> (RealTime, Maybe AllotKey))
-> [(Addr, Maybe Voices)] -> [(RealTime, Maybe AllotKey)]
forall a b. (a -> b) -> [a] -> [b]
map (Addr -> (RealTime, Maybe AllotKey)
mlookup (Addr -> (RealTime, Maybe AllotKey))
-> ((Addr, Maybe Voices) -> Addr)
-> (Addr, Maybe Voices)
-> (RealTime, Maybe AllotKey)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Addr, Maybe Voices) -> Addr
forall a b. (a, b) -> a
fst) [(Addr, Maybe Voices)]
addr_voices)
Maybe [(Addr, Maybe Voices)]
_ -> Maybe (Addr, Voices, Maybe AllotKey)
forall a. Maybe a
Nothing
where
mlookup :: Addr -> (RealTime, Maybe AllotKey)
mlookup Addr
addr = case Addr -> Map Addr (RealTime, AllotKey) -> Maybe (RealTime, AllotKey)
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, Maybe AllotKey
forall a. Maybe a
Nothing)
Just (RealTime
end, AllotKey
inst_chan) -> (RealTime
end, AllotKey -> Maybe AllotKey
forall a. a -> Maybe a
Just AllotKey
inst_chan)
type PerformState = (AddrInst, NoteOffMap)
type AddrInst = Map Patch.Addr T.Patch
type NoteOffMap = Map Patch.Addr RealTime
empty_perform_state :: PerformState
empty_perform_state :: PerformState
empty_perform_state = (Map Addr Patch
forall k a. Map k a
Map.empty, Map Addr RealTime
forall k a. Map k a
Map.empty)
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 =
((LEvent WriteMessage -> RealTime) -> [MidiEvents] -> MidiEvents
forall k a. Ord k => (a -> k) -> [[a]] -> [a]
Seq.merge_asc_lists LEvent WriteMessage -> RealTime
merge_key [MidiEvents]
midi_msgs, PerformState
final_state)
where
(PerformState
final_state, [MidiEvents]
midi_msgs) = (PerformState
-> (LEvent (Event, Addr), [LEvent (Event, Addr)])
-> (PerformState, MidiEvents))
-> PerformState
-> [(LEvent (Event, Addr), [LEvent (Event, Addr)])]
-> (PerformState, [MidiEvents])
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
([LEvent (Event, Addr)]
-> [[LEvent (Event, Addr)]]
-> [(LEvent (Event, Addr), [LEvent (Event, Addr)])]
forall a b. [a] -> [b] -> [(a, b)]
zip [LEvent (Event, Addr)]
events (Voices -> [[LEvent (Event, Addr)]] -> [[LEvent (Event, Addr)]]
forall a. Voices -> [a] -> [a]
drop Voices
1 ([LEvent (Event, Addr)] -> [[LEvent (Event, Addr)]]
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, [Msg -> LEvent WriteMessage
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 (Addr -> [LEvent (Event, Addr)] -> Maybe RealTime
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 =
((Event, b) -> RealTime) -> Maybe (Event, b) -> Maybe RealTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Event -> RealTime
T.event_start (Event -> RealTime)
-> ((Event, b) -> Event) -> (Event, b) -> RealTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Event, b) -> Event
forall a b. (a, b) -> a
fst) (Maybe (Event, b) -> Maybe RealTime)
-> ([LEvent (Event, b)] -> Maybe (Event, b))
-> [LEvent (Event, b)]
-> Maybe RealTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Event, b) -> Bool) -> [LEvent (Event, b)] -> Maybe (Event, b)
forall a. (a -> Bool) -> [LEvent a] -> Maybe a
LEvent.find_event ((b -> b -> Bool
forall a. Eq a => a -> a -> Bool
==b
addr) (b -> Bool) -> ((Event, b) -> b) -> (Event, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Event, b) -> b
forall a b. (a, b) -> b
snd)
perform_note_in_channel :: PerformState
-> Maybe RealTime
-> (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, Addr -> RealTime -> Map Addr RealTime -> Map Addr RealTime
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
(RealTime -> Addr -> Map Addr RealTime -> RealTime
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
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 -> ([Msg -> LEvent WriteMessage
forall a. Msg -> LEvent a
LEvent.Log (Msg -> LEvent WriteMessage) -> Msg -> LEvent WriteMessage
forall a b. (a -> b) -> a -> b
$ Stack => Event -> Text -> Msg
Event -> Text -> Msg
event_warning Event
event Text
err], Map Addr Patch
new_addr_inst)
Right [WriteMessage]
msgs -> ((WriteMessage -> LEvent WriteMessage)
-> [WriteMessage] -> MidiEvents
forall a b. (a -> b) -> [a] -> [b]
map WriteMessage -> LEvent WriteMessage
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 = Addr -> Patch -> Map Addr Patch -> Map Addr Patch
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 = Addr -> Map Addr Patch -> Maybe Patch
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Addr
addr Map Addr Patch
addr_inst
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 = Text -> Either Text [WriteMessage]
forall a b. a -> Either a b
Left (Text -> Either Text [WriteMessage])
-> Text -> Either Text [WriteMessage]
forall a b. (a -> b) -> a -> b
$ Text
"program change not supported yet on "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Addr -> Text
forall a. Pretty a => a -> Text
pretty Addr
addr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe Instrument -> Text
forall a. Pretty a => a -> Text
pretty (Patch -> Instrument
T.patch_name (Patch -> Instrument) -> Maybe Patch -> Maybe Instrument
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Patch
maybe_old_inst)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" -> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Instrument -> Text
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) = [WriteMessage] -> Either Text [WriteMessage]
forall a b. b -> Either a b
Right ([WriteMessage] -> Either Text [WriteMessage])
-> [WriteMessage] -> Either Text [WriteMessage]
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 = [WriteMessage] -> Either Text [WriteMessage]
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
Just Patch
o -> Patch -> Instrument
T.patch_name Patch
o Instrument -> Instrument -> Bool
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 ([Keyswitch] -> (Patch -> [Keyswitch]) -> Maybe Patch -> [Keyswitch]
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
go (Patch.Aftertouch ControlValue
_ : [Keyswitch]
_) (Patch.Aftertouch ControlValue
_ : [Keyswitch]
_) = Bool
False
go (Keyswitch
x : [Keyswitch]
xs) (Keyswitch
y : [Keyswitch]
ys) = Keyswitch
x Keyswitch -> Keyswitch -> Bool
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
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 [WriteMessage] -> [WriteMessage] -> [WriteMessage]
forall a. [a] -> [a] -> [a]
++ [WriteMessage]
new_ks_on
where
prev_ks_off :: [WriteMessage]
prev_ks_off = [WriteMessage] -> Maybe [WriteMessage] -> [WriteMessage]
forall a. a -> Maybe a -> a
Maybe.fromMaybe [] (Maybe [WriteMessage] -> [WriteMessage])
-> Maybe [WriteMessage] -> [WriteMessage]
forall a b. (a -> b) -> a -> b
$ do
Patch
old <- Maybe Patch
maybe_old_inst
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Patch -> Bool
T.patch_hold_keyswitches Patch
old)
[WriteMessage] -> Maybe [WriteMessage]
forall (m :: * -> *) a. Monad m => a -> m a
return ([WriteMessage] -> Maybe [WriteMessage])
-> [WriteMessage] -> Maybe [WriteMessage]
forall a b. (a -> b) -> a -> b
$ (Keyswitch -> Maybe WriteMessage) -> [Keyswitch] -> [WriteMessage]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (RealTime -> Keyswitch -> Maybe WriteMessage
ks_off (RealTime
startRealTime -> RealTime -> RealTime
forall 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 RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
- RealTime
keyswitch_lead_time
new_ks_on :: [WriteMessage]
new_ks_on
| Bool
is_hold = (Keyswitch -> WriteMessage) -> [Keyswitch] -> [WriteMessage]
forall a b. (a -> b) -> [a] -> [b]
map (RealTime -> Keyswitch -> WriteMessage
ks_on RealTime
ks_start) [Keyswitch]
new_ks
| Bool
otherwise = (Keyswitch -> WriteMessage) -> [Keyswitch] -> [WriteMessage]
forall a b. (a -> b) -> [a] -> [b]
map (RealTime -> Keyswitch -> WriteMessage
ks_on RealTime
ks_start) [Keyswitch]
new_ks
[WriteMessage] -> [WriteMessage] -> [WriteMessage]
forall a. [a] -> [a] -> [a]
++ (Keyswitch -> Maybe WriteMessage) -> [Keyswitch] -> [WriteMessage]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (RealTime -> Keyswitch -> Maybe WriteMessage
ks_off (RealTime
ks_startRealTime -> RealTime -> RealTime
forall 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 (ChannelMessage -> WriteMessage)
-> (Keyswitch -> ChannelMessage) -> Keyswitch -> WriteMessage
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 = (ChannelMessage -> WriteMessage)
-> Maybe ChannelMessage -> Maybe WriteMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RealTime -> ChannelMessage -> WriteMessage
mkmsg RealTime
ts) (Maybe ChannelMessage -> Maybe WriteMessage)
-> (Keyswitch -> Maybe ChannelMessage)
-> Keyswitch
-> Maybe WriteMessage
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 :: RealTime -> Maybe RealTime
-> T.Event -> Patch.Addr -> (MidiEvents, RealTime)
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 ->
( [Msg -> LEvent WriteMessage
forall a. Msg -> LEvent a
LEvent.Log (Msg -> LEvent WriteMessage) -> Msg -> LEvent WriteMessage
forall a b. (a -> b) -> a -> b
$ Stack => Event -> Text -> Msg
Event -> Text -> Msg
event_warning Event
event Text
"no pitch signal"]
, 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
_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_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 =
[ WriteMessage -> LEvent WriteMessage
forall a. a -> LEvent a
LEvent.Event (WriteMessage -> LEvent WriteMessage)
-> WriteMessage -> LEvent WriteMessage
forall a b. (a -> b) -> a -> b
$ RealTime -> ChannelMessage -> WriteMessage
chan_msg RealTime
note_on (ChannelMessage -> WriteMessage) -> ChannelMessage -> WriteMessage
forall a b. (a -> b) -> a -> b
$ Key -> ControlValue -> ChannelMessage
Midi.NoteOn Key
midi_nn (ControlValue -> ChannelMessage) -> ControlValue -> ChannelMessage
forall a b. (a -> b) -> a -> b
$
ControlValue -> ControlValue -> ControlValue
forall a. Ord a => a -> a -> a
max ControlValue
1 (UnboxedY -> ControlValue
Control.val_to_cval (Event -> UnboxedY
T.event_start_velocity Event
event))
, WriteMessage -> LEvent WriteMessage
forall a. a -> LEvent a
LEvent.Event (WriteMessage -> LEvent WriteMessage)
-> WriteMessage -> LEvent WriteMessage
forall a b. (a -> b) -> a -> b
$ RealTime -> ChannelMessage -> WriteMessage
chan_msg RealTime
note_off (ChannelMessage -> WriteMessage) -> ChannelMessage -> WriteMessage
forall a b. (a -> b) -> a -> b
$ Key -> ControlValue -> ChannelMessage
Midi.NoteOff Key
midi_nn (ControlValue -> ChannelMessage) -> ControlValue -> ChannelMessage
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
note_off :: RealTime
note_off = RealTime -> RealTime -> RealTime
forall a. Ord a => a -> a -> a
max (RealTime
note_on RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
+ RealTime
min_note_duration)
(Event -> RealTime
T.event_end Event
event RealTime -> RealTime -> RealTime
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_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 =
(WriteMessage -> LEvent WriteMessage)
-> [WriteMessage] -> MidiEvents
forall a b. (a -> b) -> [a] -> [b]
map WriteMessage -> LEvent WriteMessage
forall a. a -> LEvent a
LEvent.Event [WriteMessage]
control_msgs MidiEvents -> MidiEvents -> MidiEvents
forall a. [a] -> [a] -> [a]
++ (Msg -> LEvent WriteMessage) -> [Msg] -> MidiEvents
forall a b. (a -> b) -> [a] -> [b]
map Msg -> LEvent WriteMessage
forall a. Msg -> LEvent a
LEvent.Log [Msg]
warns
where
control_msgs :: [WriteMessage]
control_msgs = [[WriteMessage]] -> [WriteMessage]
merge_messages ([[WriteMessage]] -> [WriteMessage])
-> [[WriteMessage]] -> [WriteMessage]
forall a b. (a -> b) -> a -> b
$
([(RealTime, ChannelMessage)] -> [WriteMessage])
-> [[(RealTime, ChannelMessage)]] -> [[WriteMessage]]
forall a b. (a -> b) -> [a] -> [b]
map (((RealTime, ChannelMessage) -> WriteMessage)
-> [(RealTime, ChannelMessage)] -> [WriteMessage]
forall a b. (a -> b) -> [a] -> [b]
map (RealTime, ChannelMessage) -> WriteMessage
chan_msg) ([(RealTime, ChannelMessage)]
pitch_pos_msgs [(RealTime, ChannelMessage)]
-> [[(RealTime, ChannelMessage)]] -> [[(RealTime, ChannelMessage)]]
forall a. a -> [a] -> [a]
: [[(RealTime, ChannelMessage)]]
control_pos_msgs)
control_sigs :: [(Control, Vector (Sample UnboxedY))]
control_sigs = Map Control (Vector (Sample UnboxedY))
-> [(Control, Vector (Sample UnboxedY))]
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)
control_end :: Maybe RealTime
control_end = case Maybe RealTime
next_note_on of
Maybe RealTime
Nothing -> Maybe RealTime
forall a. Maybe a
Nothing
Just RealTime
next -> RealTime -> Maybe RealTime
forall a. a -> Maybe a
Just (RealTime -> Maybe RealTime) -> RealTime -> Maybe RealTime
forall a b. (a -> b) -> a -> b
$ RealTime -> RealTime -> RealTime
forall a. Ord a => a -> a -> a
max RealTime
note_off (RealTime
next RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
- RealTime
control_lead_time)
([[(RealTime, ChannelMessage)]]
control_pos_msgs, [[ClipRange]]
clip_warns) = [([(RealTime, ChannelMessage)], [ClipRange])]
-> ([[(RealTime, ChannelMessage)]], [[ClipRange]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([(RealTime, ChannelMessage)], [ClipRange])]
-> ([[(RealTime, ChannelMessage)]], [[ClipRange]]))
-> [([(RealTime, ChannelMessage)], [ClipRange])]
-> ([[(RealTime, ChannelMessage)]], [[ClipRange]])
forall a b. (a -> b) -> a -> b
$
((Control, Vector (Sample UnboxedY))
-> ([(RealTime, ChannelMessage)], [ClipRange]))
-> [(Control, Vector (Sample UnboxedY))]
-> [([(RealTime, ChannelMessage)], [ClipRange])]
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 = ((Control, [ClipRange]) -> [Msg])
-> [(Control, [ClipRange])] -> [Msg]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Event -> (Control, [ClipRange]) -> [Msg]
make_clip_warnings Event
event)
([Control] -> [[ClipRange]] -> [(Control, [ClipRange])]
forall a b. [a] -> [b] -> [(a, b)]
zip (((Control, Vector (Sample UnboxedY)) -> Control)
-> [(Control, Vector (Sample UnboxedY))] -> [Control]
forall a b. (a -> b) -> [a] -> [b]
map (Control, Vector (Sample UnboxedY)) -> Control
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 (Patch -> PbRange) -> (Event -> Patch) -> Event -> PbRange
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Patch
T.event_patch
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 (NoteNumber -> Maybe (Key, PitchBendValue))
-> NoteNumber -> Maybe (Key, PitchBendValue)
forall a b. (a -> b) -> a -> b
$
UnboxedY -> NoteNumber
Pitch.NoteNumber (UnboxedY -> NoteNumber) -> UnboxedY -> 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)
event_midi_key :: T.Event -> Maybe Midi.Key
event_midi_key :: Event -> Maybe Key
event_midi_key Event
event =
(Key, PitchBendValue) -> Key
forall a b. (a, b) -> a
fst ((Key, PitchBendValue) -> Key)
-> Maybe (Key, PitchBendValue) -> Maybe Key
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 -> Text -> Msg
event_warning Event
event (Text -> Msg) -> Text -> Msg
forall a b. (a -> b) -> a -> b
$ Control -> Text
forall a. Pretty a => a -> Text
pretty Control
control Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" clipped: "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RealTime -> Text
forall a. Pretty a => a -> Text
pretty RealTime
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"--" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RealTime -> Text
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
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
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]
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 (RealTime, UnboxedY)
-> [(RealTime, UnboxedY)] -> [(RealTime, UnboxedY)]
forall a. a -> [a] -> [a]
: [(RealTime, UnboxedY)]
pairs
where
pairs :: [(RealTime, UnboxedY)]
pairs = ((RealTime, UnboxedY) -> RealTime)
-> [(RealTime, UnboxedY)] -> [(RealTime, UnboxedY)]
forall k a. Eq k => (a -> k) -> [a] -> [a]
Seq.drop_initial_dups (RealTime, UnboxedY) -> RealTime
forall a b. (a, b) -> a
fst ([(RealTime, UnboxedY)] -> [(RealTime, UnboxedY)])
-> [(RealTime, UnboxedY)] -> [(RealTime, UnboxedY)]
forall a b. (a -> b) -> a -> b
$
((RealTime, UnboxedY) -> Bool)
-> [(RealTime, UnboxedY)] -> [(RealTime, UnboxedY)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((RealTime -> RealTime -> Bool
forall a. Ord a => a -> a -> Bool
<=RealTime
start) (RealTime -> Bool)
-> ((RealTime, UnboxedY) -> RealTime)
-> (RealTime, UnboxedY)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RealTime, UnboxedY) -> RealTime
forall a b. (a, b) -> a
fst) ([(RealTime, UnboxedY)] -> [(RealTime, UnboxedY)])
-> [(RealTime, UnboxedY)] -> [(RealTime, UnboxedY)]
forall a b. (a -> b) -> a -> b
$ Vector (Sample UnboxedY) -> [(RealTime, UnboxedY)]
MSignal.to_pairs (Vector (Sample UnboxedY) -> [(RealTime, UnboxedY)])
-> Vector (Sample UnboxedY) -> [(RealTime, UnboxedY)]
forall a b. (a -> b) -> a -> b
$
RealTime -> Vector (Sample UnboxedY) -> Vector (Sample UnboxedY)
forall (v :: * -> *) y.
Vector v (Sample y) =>
RealTime -> v (Sample y) -> v (Sample y)
MSignal.drop_before RealTime
start (Vector (Sample UnboxedY) -> Vector (Sample UnboxedY))
-> Vector (Sample UnboxedY) -> Vector (Sample UnboxedY)
forall a b. (a -> b) -> a -> b
$ (Vector (Sample UnboxedY) -> Vector (Sample UnboxedY))
-> (RealTime
-> Vector (Sample UnboxedY) -> Vector (Sample UnboxedY))
-> Maybe RealTime
-> Vector (Sample UnboxedY)
-> Vector (Sample UnboxedY)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Vector (Sample UnboxedY) -> Vector (Sample UnboxedY)
forall a. a -> a
id RealTime -> Vector (Sample UnboxedY) -> Vector (Sample UnboxedY)
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
tweaked_start :: RealTime
tweaked_start = RealTime -> RealTime -> RealTime
forall a. Ord a => a -> a -> a
min (RealTime
start RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
- RealTime
min_control_lead_time) (RealTime -> RealTime) -> RealTime -> RealTime
forall a b. (a -> b) -> a -> b
$
RealTime -> RealTime -> RealTime
forall a. Ord a => a -> a -> a
max (RealTime -> RealTime -> RealTime
forall a. Ord a => a -> a -> a
min RealTime
prev_note_off RealTime
start) (RealTime
start RealTime -> RealTime -> RealTime
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)
type PostprocState = Map Patch.Addr AddrState
type AddrState = (Maybe Midi.PitchBendValue, Map Midi.Control Midi.ControlValue)
post_process :: PostprocState -> MidiEvents -> (MidiEvents, PostprocState)
post_process :: PostprocState -> MidiEvents -> (MidiEvents, PostprocState)
post_process PostprocState
state = (MidiEvents -> MidiEvents)
-> (MidiEvents, PostprocState) -> (MidiEvents, PostprocState)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first MidiEvents -> MidiEvents
avoid_overlaps ((MidiEvents, PostprocState) -> (MidiEvents, PostprocState))
-> (MidiEvents -> (MidiEvents, PostprocState))
-> MidiEvents
-> (MidiEvents, PostprocState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PostprocState -> MidiEvents -> (MidiEvents, PostprocState)
drop_dup_controls PostprocState
state (MidiEvents -> (MidiEvents, PostprocState))
-> (MidiEvents -> MidiEvents)
-> MidiEvents
-> (MidiEvents, PostprocState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MidiEvents -> MidiEvents
resort
avoid_overlaps :: MidiEvents -> MidiEvents
avoid_overlaps :: MidiEvents -> MidiEvents
avoid_overlaps MidiEvents
events = [MidiEvents] -> MidiEvents
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([MidiEvents] -> MidiEvents) -> [MidiEvents] -> MidiEvents
forall a b. (a -> b) -> a -> b
$ (Map (WriteDevice, ControlValue, Key) NoteOnState, [MidiEvents])
-> [MidiEvents]
forall a b. (a, b) -> b
snd ((Map (WriteDevice, ControlValue, Key) NoteOnState, [MidiEvents])
-> [MidiEvents])
-> (Map (WriteDevice, ControlValue, Key) NoteOnState, [MidiEvents])
-> [MidiEvents]
forall a b. (a -> b) -> a -> b
$ (Map (WriteDevice, ControlValue, Key) NoteOnState
-> WriteMessage
-> [WriteMessage]
-> (Map (WriteDevice, ControlValue, Key) NoteOnState,
[WriteMessage]))
-> Map (WriteDevice, ControlValue, Key) NoteOnState
-> MidiEvents
-> (Map (WriteDevice, ControlValue, Key) NoteOnState, [MidiEvents])
forall state a b.
(state -> a -> [a] -> (state, [b]))
-> state -> [LEvent a] -> (state, [[LEvent b]])
LEvent.map_accum Map (WriteDevice, ControlValue, Key) NoteOnState
-> WriteMessage
-> [WriteMessage]
-> (Map (WriteDevice, ControlValue, Key) NoteOnState,
[WriteMessage])
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 = Map (WriteDevice, ControlValue, Key) NoteOnState
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, (ChannelMessage -> WriteMessage)
-> [ChannelMessage] -> [WriteMessage]
forall a b. (a -> b) -> [a] -> [b]
map (WriteMessage -> Message -> WriteMessage
make_msg WriteMessage
wmsg (Message -> WriteMessage)
-> (ChannelMessage -> Message) -> ChannelMessage -> WriteMessage
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) = (WriteDevice, ControlValue, Key)
-> ChannelMessage
-> Map (WriteDevice, ControlValue, Key) NoteOnState
-> (Map (WriteDevice, ControlValue, Key) NoteOnState,
[ChannelMessage])
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, Bool -> WriteMessage -> [WriteMessage] -> [WriteMessage]
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 (Message -> WriteMessage) -> Message -> WriteMessage
forall a b. (a -> b) -> a -> b
$
ControlValue -> ChannelMessage -> Message
Midi.ChannelMessage ControlValue
chan (ChannelMessage -> Message) -> ChannelMessage -> Message
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) = (WriteDevice, ControlValue, Key)
-> Map (WriteDevice, ControlValue, Key) NoteOnState
-> (Map (WriteDevice, ControlValue, Key) NoteOnState, Bool)
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])
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
_) ->
((WriteDevice, ControlValue, Key), ChannelMessage)
-> Maybe ((WriteDevice, ControlValue, Key), ChannelMessage)
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
_) ->
((WriteDevice, ControlValue, Key), ChannelMessage)
-> Maybe ((WriteDevice, ControlValue, Key), ChannelMessage)
forall a. a -> Maybe a
Just ((WriteDevice
dev, ControlValue
chan, Key
key), ChannelMessage
msg)
Message
_ -> Maybe ((WriteDevice, ControlValue, Key), ChannelMessage)
forall a. Maybe a
Nothing
where dev :: WriteDevice
dev = WriteMessage -> WriteDevice
Midi.wmsg_dev WriteMessage
wmsg
note_on :: k -> Map k NoteOnState -> (Map k NoteOnState, Bool)
note_on k
skey Map k NoteOnState
state = case k -> Map k NoteOnState -> Maybe NoteOnState
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
skey Map k NoteOnState
state of
Just NoteOnState
Playing -> (k -> NoteOnState -> Map k NoteOnState -> Map k NoteOnState
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
_ -> (k -> NoteOnState -> Map k NoteOnState -> Map k 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)
note_off :: k -> a -> Map k NoteOnState -> (Map k NoteOnState, [a])
note_off k
skey a
msg Map k NoteOnState
state = case k -> Map k NoteOnState -> Maybe NoteOnState
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
skey Map k NoteOnState
state of
Just NoteOnState
SuppressNoteOff -> (k -> NoteOnState -> Map k NoteOnState -> Map k NoteOnState
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 -> (k -> Map k NoteOnState -> Map k NoteOnState
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
| SuppressNoteOff
deriving (Voices -> NoteOnState -> ShowS
[NoteOnState] -> ShowS
NoteOnState -> String
(Voices -> NoteOnState -> ShowS)
-> (NoteOnState -> String)
-> ([NoteOnState] -> ShowS)
-> Show NoteOnState
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
_ = [a] -> [a]
forall a. a -> a
id
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 LEvent WriteMessage -> MidiEvents -> MidiEvents
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 = Addr -> PostprocState -> Maybe AddrState
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 = PostprocState
-> (AddrState -> PostprocState) -> Maybe AddrState -> PostprocState
forall b a. b -> (a -> b) -> Maybe a -> b
maybe PostprocState
state (\AddrState
s -> Addr -> AddrState -> PostprocState -> PostprocState
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 LEvent WriteMessage -> MidiEvents -> MidiEvents
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, AddrState -> Maybe AddrState
forall a. a -> Maybe a
Just (PitchBendValue -> Maybe PitchBendValue
forall a. a -> Maybe a
Just PitchBendValue
v, Map ControlValue ControlValue
forall k a. Map k a
Map.empty))
Midi.ControlChange ControlValue
c ControlValue
v -> (Bool
True, AddrState -> Maybe AddrState
forall a. a -> Maybe a
Just (Maybe PitchBendValue
forall a. Maybe a
Nothing, ControlValue -> ControlValue -> Map ControlValue ControlValue
forall k a. k -> a -> Map k a
Map.singleton ControlValue
c ControlValue
v))
ChannelMessage
_ -> (Bool
True, Maybe AddrState
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
| PitchBendValue -> Maybe PitchBendValue
forall a. a -> Maybe a
Just PitchBendValue
v Maybe PitchBendValue -> Maybe PitchBendValue -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe PitchBendValue
pb_val -> (Bool
False, Maybe AddrState
forall a. Maybe a
Nothing)
| Bool
otherwise -> (Bool
True, AddrState -> Maybe AddrState
forall a. a -> Maybe a
Just (PitchBendValue -> Maybe PitchBendValue
forall a. a -> Maybe a
Just PitchBendValue
v, Map ControlValue ControlValue
cmap))
Midi.ControlChange ControlValue
c ControlValue
v
| ControlValue -> Maybe ControlValue
forall a. a -> Maybe a
Just ControlValue
v Maybe ControlValue -> Maybe ControlValue -> Bool
forall a. Eq a => a -> a -> Bool
== ControlValue -> Map ControlValue ControlValue -> Maybe ControlValue
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ControlValue
c Map ControlValue ControlValue
cmap -> (Bool
False, Maybe AddrState
forall a. Maybe a
Nothing)
| Bool
otherwise -> (Bool
True, AddrState -> Maybe AddrState
forall a. a -> Maybe a
Just (Maybe PitchBendValue
pb_val, ControlValue
-> ControlValue
-> Map ControlValue ControlValue
-> Map ControlValue ControlValue
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, Maybe AddrState
forall a. Maybe a
Nothing)
resort :: MidiEvents -> MidiEvents
resort :: MidiEvents -> MidiEvents
resort = [WriteMessage] -> MidiEvents -> MidiEvents
go [WriteMessage]
forall a. Monoid a => a
mempty
where
go :: [WriteMessage] -> MidiEvents -> MidiEvents
go [WriteMessage]
collect [] = (WriteMessage -> LEvent WriteMessage)
-> [WriteMessage] -> MidiEvents
forall a b. (a -> b) -> [a] -> [b]
map WriteMessage -> LEvent WriteMessage
forall a. a -> LEvent a
LEvent.Event [WriteMessage]
collect
go [WriteMessage]
collect (LEvent.Log Msg
log : MidiEvents
events) = Msg -> LEvent WriteMessage
forall a. Msg -> LEvent a
LEvent.Log Msg
log LEvent WriteMessage -> MidiEvents -> MidiEvents
forall a. a -> [a] -> [a]
: [WriteMessage] -> MidiEvents -> MidiEvents
go [WriteMessage]
collect MidiEvents
events
go [WriteMessage]
collect (LEvent.Event WriteMessage
event : MidiEvents
events) =
(WriteMessage -> LEvent WriteMessage)
-> [WriteMessage] -> MidiEvents
forall a b. (a -> b) -> [a] -> [b]
map WriteMessage -> LEvent WriteMessage
forall a. a -> LEvent a
LEvent.Event [WriteMessage]
pre MidiEvents -> MidiEvents -> MidiEvents
forall a. [a] -> [a] -> [a]
++ [WriteMessage] -> MidiEvents -> MidiEvents
go [WriteMessage]
post MidiEvents
events
where
([WriteMessage]
pre, [WriteMessage]
post) = (WriteMessage -> Bool)
-> [WriteMessage] -> ([WriteMessage], [WriteMessage])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break ((RealTime -> RealTime -> Bool
forall a. Ord a => a -> a -> Bool
> WriteMessage -> RealTime
Midi.wmsg_ts WriteMessage
event RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
- RealTime
interval) (RealTime -> Bool)
-> (WriteMessage -> RealTime) -> WriteMessage -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriteMessage -> RealTime
Midi.wmsg_ts)
((WriteMessage -> RealTime)
-> WriteMessage -> [WriteMessage] -> [WriteMessage]
forall k a. Ord k => (a -> k) -> a -> [a] -> [a]
Seq.insert_on WriteMessage -> RealTime
Midi.wmsg_ts WriteMessage
event [WriteMessage]
collect)
interval :: RealTime
interval = RealTime
control_lead_time
note_begin :: T.Event -> RealTime
note_begin :: Event -> RealTime
note_begin Event
event = Event -> RealTime
T.event_start Event
event RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
- RealTime
control_lead_time
note_end :: T.Event -> RealTime
note_end :: Event -> RealTime
note_end Event
event = Event -> RealTime
T.event_end Event
event
RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
+ RealTime -> Maybe RealTime -> RealTime
forall a. a -> Maybe a -> a
fromMaybe RealTime
T.default_decay (Patch -> Maybe RealTime
T.patch_decay (Event -> Patch
T.event_patch Event
event))
merge_messages :: [[Midi.WriteMessage]] -> [Midi.WriteMessage]
merge_messages :: [[WriteMessage]] -> [WriteMessage]
merge_messages = (WriteMessage -> RealTime) -> [[WriteMessage]] -> [WriteMessage]
forall k a. Ord k => (a -> k) -> [[a]] -> [a]
Seq.merge_lists WriteMessage -> RealTime
Midi.wmsg_ts
merge_events :: MidiEvents -> MidiEvents -> MidiEvents
merge_events :: MidiEvents -> MidiEvents -> MidiEvents
merge_events = (LEvent WriteMessage -> RealTime)
-> MidiEvents -> MidiEvents -> MidiEvents
forall k a. Ord k => (a -> k) -> [a] -> [a] -> [a]
Seq.merge_on 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
overlap_map :: [(T.Event, a)] -> ([(T.Event, a)] -> T.Event
-> (a, [Log.Msg])) -> Events
-> ([LEvent.LEvent (T.Event, a)], [(T.Event, a)])
overlap_map :: forall a.
[(Event, a)]
-> ([(Event, a)] -> Event -> (a, [Msg]))
-> Events
-> ([LEvent (Event, a)], [(Event, a)])
overlap_map [(Event, a)]
initial = [(Event, a)]
-> ([(Event, a)] -> Event -> (a, [Msg]))
-> Events
-> ([LEvent (Event, a)], [(Event, a)])
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) = (Msg -> LEvent (Event, b)
forall a. Msg -> LEvent a
LEvent.Log Msg
log LEvent (Event, b) -> [LEvent (Event, b)] -> [LEvent (Event, b)]
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) =
((Event, b) -> LEvent (Event, b)
forall a. a -> LEvent a
LEvent.Event (Event
e, b
val) LEvent (Event, b) -> [LEvent (Event, b)] -> [LEvent (Event, b)]
forall a. a -> [a] -> [a]
: [LEvent (Event, b)]
forall {a}. [LEvent a]
log_events [LEvent (Event, b)] -> [LEvent (Event, b)] -> [LEvent (Event, b)]
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 = ((Event, b) -> Bool) -> [(Event, b)] -> [(Event, b)]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile ((RealTime -> RealTime -> Bool
forall a. Ord a => a -> a -> Bool
> RealTime
start) (RealTime -> Bool)
-> ((Event, b) -> RealTime) -> (Event, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> RealTime
note_end (Event -> RealTime)
-> ((Event, b) -> Event) -> (Event, b) -> RealTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Event, b) -> Event
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 (Msg -> LEvent a) -> [Msg] -> [LEvent a]
forall a b. (a -> b) -> [a] -> [b]
map Msg -> LEvent a
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) (Event, b) -> [(Event, b)] -> [(Event, b)]
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
Priority -> Maybe Stack -> Text -> Msg
Log.msg Priority
Log.Warn (Stack -> Maybe Stack
forall a. a -> Maybe a
Just (Event -> Stack
T.event_stack Event
event))