-- 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 #-}
{- | Implement midi thru by mapping InputNotes to MIDI messages.

    This is effectively a recreation of the deriver and MIDI performer, but
    geared to producing a single note immediately rather than deriving and
    performing an entire score.  But since derivation and performance are both
    very complicated, it's doomed to be complicated and inaccurate.

    The rationale is that the performer is oriented around a stream of events
    when their durations are known, while this must derive a single key, and in
    real time.  However, it's also due to history (derivation used to be much
    simpler), and concerns about efficiency, so in the future I'll probably
    move towards reusing as much of the deriver and performer as possible.

    Note that actually much of the deriver is already reused, courtesy of
    'Perf.derive_at'.  Also, 'Scale.scale_input_to_nn' may have a shortcut
    implementation, but for complicated scales falls back on derivation.

    An implementation that fully reuses deriver and performer is in
    "Cmd.Instrument.CUtil".insert_expr.

    This is a very complicated thru and might be too slow.  It has to deal
    with:

    - Remap input pitch according to scale and control pitch bend range
    (done by NoteEntry) and instrument pb range.  This means keeping track of
    previous note id and pb val.

    - Remap addr based on addrs assign to instrument, assigning round-robin.
    This means keeping track of note ids assigned to addrs and serial numbers
    for each addr.

    It's different from the usual simple thru in that it attempts to assign
    control messages to a single note.  So if the instrument is multiplexed,
    control changes (including pitch bend) will go only to the last sounding
    key.  This also means that controls will not go through at all unless
    there is a note sounding.

    It should be possible to reduce latency by bypassing the responder loop and
    running this in its own thread.  It does mean the InputNote work is
    duplicated and synchronization of state, such as current instrument info,
    gets more complicated because it has to go through an mvar or something.

    I should find out what makes the responder so slow.  Profile it!

    - The sync afterwards: Some mechanism to find out if no Ui.State changes
    have happened and skip sync.

    - Marshalling the cmd list: cache the expensive parts.  The only changing
    bit is the focus cmds, so keep those until focus changes.

    - Duplicate NoteInput conversions.

    - Instrument is looked up on every msg just for pb_range, so cache that.
    Effectively, the short-circuit thread is another way to cache this.
-}
module Cmd.MidiThru (
    cmd_midi_thru, for_instrument
    , convert_input
    -- * util
    , channel_messages
#ifdef TESTING
    , module Cmd.MidiThru
#endif
) where
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Vivid.OSC as OSC

import qualified Util.Log as Log
import qualified Util.Lists as Lists
import qualified Cmd.Cmd as Cmd
import qualified Cmd.EditUtil as EditUtil
import qualified Cmd.InputNote as InputNote
import           Cmd.InputNote (NoteId)
import qualified Cmd.Msg as Msg
import qualified Cmd.Perf as Perf
import qualified Cmd.Selection as Selection

import qualified Derive.Attrs as Attrs
import qualified Derive.Controls as Controls
import qualified Derive.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Scale as Scale
import qualified Derive.ScoreT as ScoreT

import qualified Instrument.Common as Common
import qualified Instrument.Inst as Inst
import qualified Midi.Midi as Midi
import qualified Perform.Midi.Control as Control
import qualified Perform.Midi.Patch as Patch
import           Perform.Midi.Patch (Addr)
import qualified Perform.Pitch as Pitch
import qualified Perform.Sc.Patch as Sc.Patch
import qualified Perform.Sc.Play as Sc.Play

import qualified Ui.Ui as Ui
import qualified Ui.UiConfig as UiConfig

import           Global


-- | Send midi thru, addressing it to the given Instrument.
--
-- Actually, this handles 'Cmd.ImThru' as well, since it relies on the
-- instrument itself providing the thru function in 'Cmd.inst_thru'.
cmd_midi_thru :: Msg.Msg -> Cmd.CmdId Cmd.Status
cmd_midi_thru :: Msg -> CmdId Status
cmd_midi_thru Msg
msg = do
    Input
input <- case Msg
msg of
        Msg.InputNote Input
input -> forall (m :: * -> *) a. Monad m => a -> m a
return Input
input
        Msg
_ -> forall (m :: * -> *) a. M m => m a
Cmd.abort
    Instrument
score_inst <- forall (m :: * -> *) a. M m => Maybe a -> m a
Cmd.abort_unless forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m (Maybe Instrument)
EditUtil.lookup_instrument
    Attributes
attrs <- forall (m :: * -> *). M m => Instrument -> m Attributes
Cmd.get_instrument_attributes Instrument
score_inst
    Scale
scale <- forall (m :: * -> *). M m => Track -> m Scale
Perf.get_scale forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m Track
Selection.track
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). M m => Thru -> m ()
Cmd.write_thru forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Instrument -> ThruFunction
for_instrument Instrument
score_inst Scale
scale Attributes
attrs Input
input
    forall (m :: * -> *) a. Monad m => a -> m a
return Status
Cmd.Continue

for_instrument :: ScoreT.Instrument -> Cmd.ThruFunction
for_instrument :: Instrument -> ThruFunction
for_instrument Instrument
score_inst Scale
scale Attributes
attrs Input
input = do
    ResolvedInstrument
resolved <- forall (m :: * -> *).
(Stack, M m) =>
Instrument -> m ResolvedInstrument
Cmd.get_instrument Instrument
score_inst
    let code_of :: ResolvedInstrument -> InstrumentCode
code_of = forall code. Common code -> code
Common.common_code forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall code. Inst code -> Common code
Inst.inst_common forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolvedInstrument -> Inst
Cmd.inst_instrument
    let flags :: Set Flag
flags = forall code. Common code -> Set Flag
Common.common_flags forall a b. (a -> b) -> a -> b
$ ResolvedInstrument -> Common InstrumentCode
Cmd.inst_common ResolvedInstrument
resolved
    case InstrumentCode -> Maybe ThruFunction
Cmd.inst_thru (ResolvedInstrument -> InstrumentCode
code_of ResolvedInstrument
resolved) of
        Maybe ThruFunction
Nothing
            | Just (Patch
patch, Config
config) <- ResolvedInstrument -> Maybe (Patch, Config)
Cmd.midi_patch ResolvedInstrument
resolved ->
                Patch -> Config -> Instrument -> ThruFunction
midi_thru Patch
patch Config
config Instrument
score_inst Scale
scale Attributes
attrs Input
input
            | Just Patch
patch <- ResolvedInstrument -> Maybe Patch
Cmd.sc_patch ResolvedInstrument
resolved ->
                Patch -> Set Flag -> Instrument -> ThruFunction
osc_thru Patch
patch Set Flag
flags Instrument
score_inst Scale
scale Attributes
attrs Input
input
            | Bool
otherwise -> forall (m :: * -> *) a. M m => m a
Cmd.abort
        Just ThruFunction
thru -> ThruFunction
thru Scale
scale Attributes
attrs Input
input

-- | This doesn't really fit with the name of the module, but OSC thru for
-- supercollider is so much simpler than MIDI I can just throw it in here.
osc_thru :: Sc.Patch.Patch -> Set Common.Flag -> ScoreT.Instrument
    -> Cmd.ThruFunction
osc_thru :: Patch -> Set Flag -> Instrument -> ThruFunction
osc_thru Patch
patch Set Flag
flags Instrument
score_inst Scale
scale Attributes
_attrs Input
input = do
    -- attrs is used for keyswitches in MIDI, but sc doesn't support attrs yet.
    -- If I do, it'll probably be via string-valued controls.
    InputNn
input <- forall (m :: * -> *).
M m =>
Instrument -> Scale -> Input -> m InputNn
convert_input Instrument
score_inst Scale
scale Input
input
    (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [OSC] -> Thru
Cmd.OscThru forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
M m =>
Patch -> Set Flag -> InputNn -> m [OSC]
input_to_osc Patch
patch Set Flag
flags InputNn
input

input_to_osc :: Cmd.M m => Sc.Patch.Patch -> Set Common.Flag
    -> InputNote.InputNn -> m [OSC.OSC]
input_to_osc :: forall (m :: * -> *).
M m =>
Patch -> Set Flag -> InputNn -> m [OSC]
input_to_osc Patch
patch Set Flag
flags = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
    InputNote.NoteOn NoteId
note_id NoteNumber
nn Y
vel ->
        Patch -> Bool -> Serial -> NoteNumber -> Y -> [OSC]
Sc.Play.note_on Patch
patch Bool
triggered (NoteId -> Serial
unid NoteId
note_id) NoteNumber
nn Y
vel
    InputNote.NoteOff NoteId
note_id Y
_ ->
        Bool -> Serial -> [OSC]
Sc.Play.note_off Bool
triggered (NoteId -> Serial
unid NoteId
note_id)
    InputNote.Control NoteId
note_id Control
control Y
val ->
        Patch -> Serial -> Control -> Y -> [OSC]
Sc.Play.set_control Patch
patch (NoteId -> Serial
unid NoteId
note_id) Control
control Y
val
    InputNote.PitchChange NoteId
note_id NoteNumber
nn ->
        Patch -> Serial -> NoteNumber -> [OSC]
Sc.Play.pitch_change Patch
patch (NoteId -> Serial
unid NoteId
note_id) NoteNumber
nn
    where
    triggered :: Bool
triggered = Flag
Common.Triggered forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Flag
flags
    unid :: NoteId -> Serial
unid (InputNote.NoteId Serial
id) = Serial
id

-- | I used to keep track of the previous PitchBend to avoid sending extra ones.
-- But it turns out I don't actually know the state of the MIDI channel, so
-- now I always send PitchBend.  I'm not sure why I ever thought it could work.
-- I could still do this by tracking channel state at the Midi.Interface level.
-- I actually already do that a bit of tracking with note_tracker, but it's
-- simpler to just always send PitchBend, unless it becomes a problem.
midi_thru :: Patch.Patch -> Patch.Config -> ScoreT.Instrument
    -> Cmd.ThruFunction
midi_thru :: Patch -> Config -> Instrument -> ThruFunction
midi_thru Patch
patch Config
config Instrument
score_inst Scale
scale Attributes
attrs Input
input = do
    InputNn
input <- forall (m :: * -> *).
M m =>
Instrument -> Scale -> Input -> m InputNn
convert_input Instrument
score_inst Scale
scale Input
input
    let addrs :: [Addr]
addrs = Config -> [Addr]
Patch.config_addrs Config
config
    if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Addr]
addrs then forall (m :: * -> *) a. Monad m => a -> m a
return [] else do
        (InputNn
input_nn, [Keyswitch]
ks) <- forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
Cmd.require
            (forall a. Pretty a => a -> Text
pretty (Scale -> ScaleId
Scale.scale_id Scale
scale) forall a. Semigroup a => a -> a -> a
<> Text
" doesn't have " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty InputNn
input)
            forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
M m =>
Instrument
-> AttributeMap
-> Maybe Scale
-> Attributes
-> InputNn
-> m (Maybe (InputNn, [Keyswitch]))
input_to_nn Instrument
score_inst (Patch -> AttributeMap
Patch.patch_attribute_map Patch
patch)
                (Config :-> Settings
Patch.settingsforall a b c. Lens a b -> Lens b c -> Lens a c
#Settings :-> Maybe Scale
Patch.scale forall f a. Lens f a -> f -> a
#$ Config
config) Attributes
attrs InputNn
input
        WriteDeviceState
wdev_state <- forall (m :: * -> *). M m => m WriteDeviceState
Cmd.get_wdev_state
        PbRange
pb_range <- forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
Cmd.require Text
"no pb range" forall a b. (a -> b) -> a -> b
$
            Config :-> Settings
Patch.settingsforall a b c. Lens a b -> Lens b c -> Lens a c
#Settings :-> Maybe PbRange
Patch.pitch_bend_range forall f a. Lens f a -> f -> a
#$ Config
config
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return []) (forall {m :: * -> *} {t :: * -> *}.
(M m, Foldable t) =>
t Keyswitch
-> ([(WriteDevice, Message)], WriteDeviceState) -> m [Thru]
to_msgs [Keyswitch]
ks) forall a b. (a -> b) -> a -> b
$
            PbRange
-> WriteDeviceState
-> [Addr]
-> InputNn
-> Maybe ([(WriteDevice, Message)], WriteDeviceState)
input_to_midi PbRange
pb_range WriteDeviceState
wdev_state [Addr]
addrs InputNn
input_nn
    where
    to_msgs :: t Keyswitch
-> ([(WriteDevice, Message)], WriteDeviceState) -> m [Thru]
to_msgs t Keyswitch
ks ([(WriteDevice, Message)]
thru_msgs, WriteDeviceState
wdev_state) = do
        forall (m :: * -> *).
M m =>
(WriteDeviceState -> WriteDeviceState) -> m ()
Cmd.modify_wdev_state (forall a b. a -> b -> a
const WriteDeviceState
wdev_state)
        let ks_msgs :: [(WriteDevice, Message)]
ks_msgs = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([(WriteDevice, Message)] -> Keyswitch -> [(WriteDevice, Message)]
keyswitch_to_midi [(WriteDevice, Message)]
thru_msgs) t Keyswitch
ks
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry WriteDevice -> Message -> Thru
Cmd.midi_thru) forall a b. (a -> b) -> a -> b
$ [(WriteDevice, Message)]
ks_msgs forall a. [a] -> [a] -> [a]
++ [(WriteDevice, Message)]
thru_msgs

-- | The keyswitch winds up being simultaneous with the note on.  Especially
-- stupid VSTs like kontakt will sometimes miss a keyswitch if it doesn't have
-- enough lead time.  There's not much I can do about that, but to avoid making
-- the keyswitch too short I hold it down along with the note.
keyswitch_to_midi :: [(Midi.WriteDevice, Midi.Message)] -> Patch.Keyswitch
    -> [(Midi.WriteDevice, Midi.Message)]
keyswitch_to_midi :: [(WriteDevice, Message)] -> Keyswitch -> [(WriteDevice, Message)]
keyswitch_to_midi [(WriteDevice, Message)]
msgs Keyswitch
ks = case forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum (forall a b. (a -> b) -> [a] -> [b]
map forall {a}. (a, Message) -> Maybe ((a, Word8), Key, Bool)
note_msg [(WriteDevice, Message)]
msgs) of
    Maybe (Addr, Key, Bool)
Nothing -> []
    Just (Addr
addr, Key
key, Bool
is_note_on) -> forall a b. (a -> b) -> [a] -> [b]
map (Addr -> ChannelMessage -> (WriteDevice, Message)
with_addr Addr
addr) forall a b. (a -> b) -> a -> b
$
        if Bool
is_note_on then [Key -> Keyswitch -> ChannelMessage
Patch.keyswitch_on Key
key Keyswitch
ks]
            else forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall a. a -> [a] -> [a]
:[]) (Keyswitch -> Maybe ChannelMessage
Patch.keyswitch_off Keyswitch
ks)
    where
    note_msg :: (a, Message) -> Maybe ((a, Word8), Key, Bool)
note_msg (a
dev, Midi.ChannelMessage Word8
chan ChannelMessage
msg) = case ChannelMessage
msg of
        Midi.NoteOn Key
key Word8
_ -> forall a. a -> Maybe a
Just ((a
dev, Word8
chan), Key
key, Bool
True)
        Midi.NoteOff Key
key Word8
_ -> forall a. a -> Maybe a
Just ((a
dev, Word8
chan), Key
key, Bool
False)
        ChannelMessage
_ -> forall a. Maybe a
Nothing
    note_msg (a, Message)
_ = forall a. Maybe a
Nothing

-- | Realize the Input as a pitch in the given scale.
input_to_nn :: Cmd.M m => ScoreT.Instrument -> Patch.AttributeMap
    -> Maybe Patch.Scale -> Attrs.Attributes -> InputNote.InputNn
    -> m (Maybe (InputNote.InputNn, [Patch.Keyswitch]))
input_to_nn :: forall (m :: * -> *).
M m =>
Instrument
-> AttributeMap
-> Maybe Scale
-> Attributes
-> InputNn
-> m (Maybe (InputNn, [Keyswitch]))
input_to_nn Instrument
inst AttributeMap
attr_map Maybe Scale
patch_scale Attributes
attrs = \case
    InputNote.NoteOn NoteId
note_id NoteNumber
nn Y
vel -> forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm (forall {m :: * -> *}.
LogMonad m =>
NoteNumber -> m (Maybe (NoteNumber, [Keyswitch]))
convert NoteNumber
nn) forall a b. (a -> b) -> a -> b
$ \(NoteNumber
nn, [Keyswitch]
ks) ->
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (forall pitch. NoteId -> pitch -> Y -> GenericInput pitch
InputNote.NoteOn NoteId
note_id NoteNumber
nn Y
vel, [Keyswitch]
ks)
    InputNote.PitchChange NoteId
note_id NoteNumber
input -> forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)
justm (forall {m :: * -> *}.
LogMonad m =>
NoteNumber -> m (Maybe (NoteNumber, [Keyswitch]))
convert NoteNumber
input) forall a b. (a -> b) -> a -> b
$ \(NoteNumber
nn, [Keyswitch]
_) ->
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (forall pitch. NoteId -> pitch -> GenericInput pitch
InputNote.PitchChange NoteId
note_id NoteNumber
nn, [])
    input :: InputNn
input@(InputNote.NoteOff {}) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (InputNn
input, [Keyswitch]
ks)
        where
        ks :: [Keyswitch]
ks = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ forall a. Attributes -> AttributeMap a -> Maybe (Attributes, a)
Common.lookup_attributes Attributes
attrs AttributeMap
attr_map
    input :: InputNn
input@(InputNote.Control {}) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (InputNn
input, [])
    where
    convert :: NoteNumber -> m (Maybe (NoteNumber, [Keyswitch]))
convert NoteNumber
nn = do
        let (Maybe (NoteNumber, [Keyswitch])
result, Bool
not_found) = AttributeMap
-> Maybe Scale
-> Attributes
-> NoteNumber
-> (Maybe (NoteNumber, [Keyswitch]), Bool)
convert_pitch AttributeMap
attr_map Maybe Scale
patch_scale Attributes
attrs NoteNumber
nn
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
not_found forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ Text
"inst " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Instrument
inst forall a. Semigroup a => a -> a -> a
<> Text
" doesn't have attrs "
                forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Attributes
attrs forall a. Semigroup a => a -> a -> a
<> Text
", understood attrs are: "
                forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (forall a. AttributeMap a -> [Attributes]
Common.mapped_attributes AttributeMap
attr_map)
        forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (NoteNumber, [Keyswitch])
result

-- | Convert a keyboard input into the NoteNumber desired by the scale.
convert_input :: Cmd.M m => ScoreT.Instrument -> Scale.Scale -> InputNote.Input
    -> m InputNote.InputNn
convert_input :: forall (m :: * -> *).
M m =>
Instrument -> Scale -> Input -> m InputNn
convert_input Instrument
inst Scale
scale = \case
    InputNote.NoteOn NoteId
note_id Input
input Y
vel -> do
        NoteNumber
nn <- Input -> m NoteNumber
convert Input
input
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall pitch. NoteId -> pitch -> Y -> GenericInput pitch
InputNote.NoteOn NoteId
note_id NoteNumber
nn Y
vel
    InputNote.PitchChange NoteId
note_id Input
input ->
        forall pitch. NoteId -> pitch -> GenericInput pitch
InputNote.PitchChange NoteId
note_id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Input -> m NoteNumber
convert Input
input
    InputNote.NoteOff NoteId
note_id Y
vel -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall pitch. NoteId -> Y -> GenericInput pitch
InputNote.NoteOff NoteId
note_id Y
vel
    InputNote.Control NoteId
note_id Control
control Y
val ->
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall pitch. NoteId -> Control -> Y -> GenericInput pitch
InputNote.Control NoteId
note_id Control
control Y
val
    where
    convert :: Input -> m NoteNumber
convert = forall (m :: * -> *).
M m =>
Instrument -> Scale -> Input -> m NoteNumber
convert_input_pitch Instrument
inst Scale
scale

convert_input_pitch :: Cmd.M m => ScoreT.Instrument -> Scale.Scale
    -> Pitch.Input -> m Pitch.NoteNumber
convert_input_pitch :: forall (m :: * -> *).
M m =>
Instrument -> Scale -> Input -> m NoteNumber
convert_input_pitch Instrument
inst Scale
scale Input
input = do
    (BlockId
block_id, Serial
_, TrackId
track_id, TrackTime
pos) <- forall (m :: * -> *).
M m =>
m (BlockId, Serial, TrackId, TrackTime)
Selection.get_insert
    -- I ignore _logs, any interesting errors should be in 'result'.
    (Either Error (Either PitchError NoteNumber)
result, [Msg]
_logs) <- forall (m :: * -> *) a.
M m =>
BlockId -> TrackId -> Deriver a -> m (Either Error a, [Msg])
Perf.derive_at_exc BlockId
block_id TrackId
track_id forall a b. (a -> b) -> a -> b
$
        forall d. Instrument -> Deriver d -> Deriver d
Derive.with_instrument Instrument
inst forall a b. (a -> b) -> a -> b
$
        forall a. Scale -> Deriver a -> Deriver a
filter_transposers Scale
scale forall a b. (a -> b) -> a -> b
$
        Scale
-> TrackTime -> Input -> Deriver (Either PitchError NoteNumber)
Scale.scale_input_to_nn Scale
scale TrackTime
pos Input
input
    case Either Error (Either PitchError NoteNumber)
result of
        Left (Derive.Error CallStack
_ Stack
_ ErrorVal
err) -> forall {a}. Text -> m a
throw forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Text
pretty ErrorVal
err
        -- This just means the key isn't in the scale, it happens a lot so
        -- no need to shout about it.
        Right (Left PitchError
DeriveT.InvalidInput) -> forall (m :: * -> *) a. M m => m a
Cmd.abort
        Right (Left PitchError
err) -> forall {a}. Text -> m a
throw forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Text
pretty PitchError
err
        Right (Right NoteNumber
nn) -> forall (m :: * -> *) a. Monad m => a -> m a
return NoteNumber
nn
    where
    throw :: Text -> m a
throw = forall (m :: * -> *) a. (Stack, M m) => Text -> m a
Cmd.throw forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text
"scale_input_to_nn for " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Input
input forall a. Semigroup a => a -> a -> a
<> Text
": ") <>)

-- | Remove transposers because otherwise the thru pitch doesn't match the
-- entered pitch and it's very confusing.  However, I retain 'Controls.octave'
-- and 'Controls.hz' because those are used to configure a scale, e.g. via
-- 'Patch.config_controls', and the pitch is nominally the same.
filter_transposers :: Scale.Scale -> Derive.Deriver a
    -> Derive.Deriver a
filter_transposers :: forall a. Scale -> Deriver a -> Deriver a
filter_transposers Scale
scale = forall a. [(Control, Typed Control)] -> Deriver a -> Deriver a
Derive.with_controls [(Control, Typed Control)]
transposers
    where
    transposers :: [(Control, Typed Control)]
transposers = forall a b. [a] -> [b] -> [(a, b)]
zip
        (forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Control
Controls.octave, Control
Controls.hz])
            (forall a. Set a -> [a]
Set.toList (Scale -> Set Control
Scale.scale_transposers Scale
scale)))
        (forall a. a -> [a]
repeat (forall a. a -> Typed a
ScoreT.untyped forall a. Monoid a => a
mempty))

-- | This is a midi thru version of 'Perform.Midi.Convert.convert_midi_pitch'.
-- It's different because it works with a scalar NoteNumber instead of
-- a Score.Event with a pitch signal, which makes it hard to share code.
convert_pitch :: Patch.AttributeMap -> Maybe Patch.Scale -> Attrs.Attributes
    -> Pitch.NoteNumber -> (Maybe (Pitch.NoteNumber, [Patch.Keyswitch]), Bool)
    -- ^ The Bool is True if the attrs were non-empty but not found.
convert_pitch :: AttributeMap
-> Maybe Scale
-> Attributes
-> NoteNumber
-> (Maybe (NoteNumber, [Keyswitch]), Bool)
convert_pitch AttributeMap
attr_map Maybe Scale
patch_scale Attributes
attrs NoteNumber
nn =
    case forall a. Attributes -> AttributeMap a -> Maybe (Attributes, a)
Common.lookup_attributes Attributes
attrs AttributeMap
attr_map of
        Maybe (Attributes, ([Keyswitch], Maybe Keymap))
Nothing -> ((, []) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe NoteNumber
maybe_pitch, Attributes
attrs forall a. Eq a => a -> a -> Bool
/= forall a. Monoid a => a
mempty)
        Just (Attributes
_, ([Keyswitch]
keyswitches, Maybe Keymap
maybe_keymap)) ->
            ( (, [Keyswitch]
keyswitches) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe NoteNumber
maybe_pitch Keymap -> Maybe NoteNumber
set_keymap Maybe Keymap
maybe_keymap
            , Bool
False
            )
    where
    maybe_pitch :: Maybe NoteNumber
maybe_pitch = NoteNumber -> Maybe NoteNumber
apply_patch_scale NoteNumber
nn
    apply_patch_scale :: NoteNumber -> Maybe NoteNumber
apply_patch_scale = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> Maybe a
Just Scale -> NoteNumber -> Maybe NoteNumber
Patch.convert_scale Maybe Scale
patch_scale
    set_keymap :: Keymap -> Maybe NoteNumber
set_keymap (Patch.UnpitchedKeymap Key
key) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Num a => Key -> a
Midi.from_key Key
key
    set_keymap (Patch.PitchedKeymap Key
low Key
_ Key
low_pitch) =
        (forall a. Num a => a -> a -> a
+ forall a. Num a => Key -> a
Midi.from_key (Key
low forall a. Num a => a -> a -> a
- Key
low_pitch)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe NoteNumber
maybe_pitch

input_to_midi :: Control.PbRange -> Cmd.WriteDeviceState
    -> [Addr] -> InputNote.InputNn
    -> Maybe ([(Midi.WriteDevice, Midi.Message)], Cmd.WriteDeviceState)
input_to_midi :: PbRange
-> WriteDeviceState
-> [Addr]
-> InputNn
-> Maybe ([(WriteDevice, Message)], WriteDeviceState)
input_to_midi PbRange
pb_range WriteDeviceState
wdev_state [Addr]
addrs InputNn
input_nn = case [Addr]
-> InputNn
-> (Maybe Addr, Maybe (Map NoteId Addr, Map Addr Serial))
alloc [Addr]
addrs InputNn
input_nn of
    (Maybe Addr
Nothing, Maybe (Map NoteId Addr, Map Addr Serial)
_) -> forall a. Maybe a
Nothing
    (Just Addr
addr, Maybe (Map NoteId Addr, Map Addr Serial)
new_state) -> forall a. a -> Maybe a
Just (forall a b. (a -> b) -> [a] -> [b]
map (Addr -> ChannelMessage -> (WriteDevice, Message)
with_addr Addr
addr) [ChannelMessage]
msgs, WriteDeviceState
state)
        where
        ([ChannelMessage]
msgs, Map NoteId Key
note_key) = PbRange
-> Map NoteId Key -> InputNn -> ([ChannelMessage], Map NoteId Key)
InputNote.to_midi PbRange
pb_range
            (WriteDeviceState -> Map NoteId Key
Cmd.wdev_note_key WriteDeviceState
wdev_state) InputNn
input_nn
        state :: WriteDeviceState
state = Maybe (Map NoteId Addr, Map Addr Serial)
-> WriteDeviceState -> WriteDeviceState
merge_state Maybe (Map NoteId Addr, Map Addr Serial)
new_state
            (WriteDeviceState
wdev_state { wdev_note_key :: Map NoteId Key
Cmd.wdev_note_key = Map NoteId Key
note_key })
    where
    alloc :: [Addr]
-> InputNn
-> (Maybe Addr, Maybe (Map NoteId Addr, Map Addr Serial))
alloc = Map NoteId Addr
-> Map Addr Serial
-> Serial
-> [Addr]
-> InputNn
-> (Maybe Addr, Maybe (Map NoteId Addr, Map Addr Serial))
alloc_addr (WriteDeviceState -> Map NoteId Addr
Cmd.wdev_note_addr WriteDeviceState
wdev_state)
        (WriteDeviceState -> Map Addr Serial
Cmd.wdev_addr_serial WriteDeviceState
wdev_state) (WriteDeviceState -> Serial
Cmd.wdev_serial WriteDeviceState
wdev_state)

merge_state :: Maybe (Map NoteId Addr, Map Addr Cmd.Serial)
    -> Cmd.WriteDeviceState -> Cmd.WriteDeviceState
merge_state :: Maybe (Map NoteId Addr, Map Addr Serial)
-> WriteDeviceState -> WriteDeviceState
merge_state Maybe (Map NoteId Addr, Map Addr Serial)
new_state WriteDeviceState
old = case Maybe (Map NoteId Addr, Map Addr Serial)
new_state of
    Maybe (Map NoteId Addr, Map Addr Serial)
Nothing -> WriteDeviceState
old
    Just (Map NoteId Addr
note_addr, Map Addr Serial
addr_serial) -> WriteDeviceState
old
        { wdev_note_addr :: Map NoteId Addr
Cmd.wdev_note_addr = Map NoteId Addr
note_addr
        , wdev_addr_serial :: Map Addr Serial
Cmd.wdev_addr_serial = Map Addr Serial
addr_serial
        , wdev_serial :: Serial
Cmd.wdev_serial = WriteDeviceState -> Serial
Cmd.wdev_serial WriteDeviceState
old forall a. Num a => a -> a -> a
+ Serial
1
        }

-- | If the note_id is already playing in an addr, return that one.  Otherwise,
-- if it's not NoteOn or NoteOff, abort.  If it is, pick a free addr, and if
-- there is no free one, pick the oldest one.  Update the wdev state and assign
-- the note id to the addr.
alloc_addr :: Map NoteId Addr -> Map Addr Cmd.Serial -> Cmd.Serial
    -> [Addr] -- ^ Addrs allocated to this instrument.
    -> InputNote.InputNn
    -> (Maybe Addr, Maybe (Map NoteId Addr, Map Addr Cmd.Serial))
alloc_addr :: Map NoteId Addr
-> Map Addr Serial
-> Serial
-> [Addr]
-> InputNn
-> (Maybe Addr, Maybe (Map NoteId Addr, Map Addr Serial))
alloc_addr Map NoteId Addr
note_addr Map Addr Serial
addr_serial Serial
serial [Addr]
addrs InputNn
input
    | Just Addr
addr <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NoteId
note_id Map NoteId Addr
note_addr, Addr
addr forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Addr]
addrs =
        case InputNn
input of
            InputNote.NoteOff NoteId
_ Y
_ -> (forall a. a -> Maybe a
Just Addr
addr, Addr -> Maybe (Map NoteId Addr, Map Addr Serial)
unassign Addr
addr)
            InputNn
_ -> (forall a. a -> Maybe a
Just Addr
addr, forall a. Maybe a
Nothing)
    | Bool -> Bool
not (forall {pitch}. GenericInput pitch -> Bool
new_note InputNn
input) = (forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
    | Just Addr
addr <- Maybe Addr
oldest = (forall a. a -> Maybe a
Just Addr
addr, Addr -> Maybe (Map NoteId Addr, Map Addr Serial)
assign Addr
addr)
    | Bool
otherwise = (forall a. Maybe a
Nothing, forall a. Maybe a
Nothing) -- addrs must be null
    where
    note_id :: NoteId
note_id = forall x. GenericInput x -> NoteId
InputNote.input_id InputNn
input
    new_note :: GenericInput pitch -> Bool
new_note (InputNote.NoteOn {}) = Bool
True
    new_note (InputNote.NoteOff {}) = Bool
True
    new_note GenericInput pitch
_ = Bool
False
    assign :: Addr -> Maybe (Map NoteId Addr, Map Addr Serial)
assign Addr
addr = forall a. a -> Maybe a
Just
        (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert NoteId
note_id Addr
addr Map NoteId Addr
note_addr, forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Addr
addr Serial
serial Map Addr Serial
addr_serial)
    unassign :: Addr -> Maybe (Map NoteId Addr, Map Addr Serial)
unassign Addr
addr = forall a. a -> Maybe a
Just
        (forall k a. Ord k => k -> Map k a -> Map k a
Map.delete NoteId
note_id Map NoteId Addr
note_addr, forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Addr
addr Serial
serial Map Addr Serial
addr_serial)
    -- Always pick the channel with the oldest note, whether or not it's
    -- allocated.  Previously I would try to pick a free one, but reusing
    -- a free channel led to audible artifacts with long-ringing instruments.
    oldest :: Maybe Addr
oldest = forall k a. Ord k => (a -> k) -> [a] -> Maybe a
Lists.minimumOn (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Map Addr Serial
addr_serial) [Addr]
addrs

with_addr :: Addr -> Midi.ChannelMessage -> (Midi.WriteDevice, Midi.Message)
with_addr :: Addr -> ChannelMessage -> (WriteDevice, Message)
with_addr (WriteDevice
wdev, Word8
chan) ChannelMessage
msg = (WriteDevice
wdev, Word8 -> ChannelMessage -> Message
Midi.ChannelMessage Word8
chan ChannelMessage
msg)


-- * util

-- | Send ChannelMessages to the addrs (or just the lowest addr) of the current
-- instrument.  This bypasses all of the WriteDeviceState stuff so it won't
-- cooperate with addr allocation, but hopefully this won't cause problems for
-- simple uses like keymapped instruments.
channel_messages :: Cmd.M m => Maybe ScoreT.Instrument -- ^ use this inst, or
    -- the one on the selected track if Nothing.
    -> Bool -> [Midi.ChannelMessage] -> m ()
channel_messages :: forall (m :: * -> *).
M m =>
Maybe Instrument -> Bool -> [ChannelMessage] -> m ()
channel_messages Maybe Instrument
maybe_inst Bool
first_addr [ChannelMessage]
msgs = do
    [Addr]
addrs <- forall (m :: * -> *). M m => Maybe Instrument -> m [Addr]
get_addrs Maybe Instrument
maybe_inst
    let addrs2 :: [Addr]
addrs2 = if Bool
first_addr then forall a. Serial -> [a] -> [a]
take Serial
1 [Addr]
addrs else [Addr]
addrs
    forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
        [ forall (m :: * -> *). M m => WriteDevice -> Message -> m ()
Cmd.midi WriteDevice
wdev (Word8 -> ChannelMessage -> Message
Midi.ChannelMessage Word8
chan ChannelMessage
msg)
        | (WriteDevice
wdev, Word8
chan) <- [Addr]
addrs2, ChannelMessage
msg <- [ChannelMessage]
msgs
        ]

get_addrs :: Cmd.M m => Maybe ScoreT.Instrument -> m [Addr]
get_addrs :: forall (m :: * -> *). M m => Maybe Instrument -> m [Addr]
get_addrs Maybe Instrument
maybe_inst = do
    Instrument
inst <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. M m => Maybe a -> m a
Cmd.abort_unless forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m (Maybe Instrument)
EditUtil.lookup_instrument)
        forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Instrument
maybe_inst
    Maybe Allocation
alloc <- Instrument -> Lens State (Maybe Allocation)
Ui.allocation Instrument
inst forall (f :: * -> *) a b. Functor f => Lens a b -> f a -> f b
<#> forall (m :: * -> *). M m => m State
Ui.get
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Allocation -> Backend
UiConfig.alloc_backend forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Allocation
alloc of
        Just (UiConfig.Midi Config
config) -> Config -> [Addr]
Patch.config_addrs Config
config
        Maybe Backend
_ -> []