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

-- | Functions for instrument cmds.  This is called CUtil because there is also
-- "Derive.Instrument.DUtil" and they are usually imported together.
--
-- I need a better name than \"Util\" for everything.
module Cmd.Instrument.CUtil where
import qualified Data.Either as Either
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe

import qualified Util.Lists as Lists
import qualified App.Config as Config
import qualified Cmd.Cmd as Cmd
import qualified Cmd.EditUtil as EditUtil
import qualified Cmd.Instrument.Drums as Drums
import qualified Cmd.Instrument.ImInst as ImInst
import qualified Cmd.Instrument.MidiInst as MidiInst
import qualified Cmd.MidiThru as MidiThru
import qualified Cmd.Msg as Msg
import qualified Cmd.Perf as Perf
import qualified Cmd.PhysicalKey as PhysicalKey
import qualified Cmd.Selection as Selection

import qualified Derive.Args as Args
import qualified Derive.Attrs as Attrs
import qualified Derive.C.Prelude.Note as Note
import qualified Derive.Call as Call
import qualified Derive.Call.Module as Module
import qualified Derive.Call.Sub as Sub
import qualified Derive.Call.Tags as Tags
import qualified Derive.Controls as Controls
import qualified Derive.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Expr as Expr
import qualified Derive.LEvent as LEvent
import qualified Derive.PSignal as PSignal
import qualified Derive.Score as Score
import qualified Derive.ScoreT as ScoreT
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Sig as Sig

import qualified Instrument.Common as Common
import qualified Midi.Midi as Midi
import qualified Perform.Midi.Patch as Patch
import qualified Perform.NN as NN
import qualified Perform.Pitch as Pitch
import qualified Perform.Signal as Signal

import qualified Synth.Shared.Control as Control
import qualified Synth.Shared.Thru as Thru
import qualified Ui.KeycapsT as KeycapsT
import qualified Ui.UiMsg as UiMsg

import           Global
import           Types


-- * eval call

insert_call :: Cmd.M m => Thru -> [(Char, Expr.Symbol)] -> Cmd.Handler m
insert_call :: forall (m :: * -> *). M m => Thru -> [(Char, Symbol)] -> Handler m
insert_call Thru
thru [(Char, Symbol)]
char_syms = forall (m :: * -> *). M m => Thru -> NoteEntryMap Expr -> Handler m
insert_expr Thru
thru (forall a. Map Char a -> NoteEntryMap a
Cmd.WithoutOctave forall {val}. Map Char (Expr val)
char_to_expr)
    where
    to_expr :: Symbol -> Expr val
to_expr Symbol
call = forall val. Symbol -> Expr val
Expr.generator0 Symbol
call
    char_to_expr :: Map Char (Expr val)
char_to_expr = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Stack => Char -> Char
PhysicalKey.physical_key forall val. Symbol -> Expr val
to_expr) [(Char, Symbol)]
char_syms

strokes_to_calls :: [Drums.Stroke] -> [(Char, Expr.Symbol)]
strokes_to_calls :: [Stroke] -> [(Char, Symbol)]
strokes_to_calls [Stroke]
strokes =
    [(Stroke -> Char
Drums._char Stroke
s, Stroke -> Symbol
Drums._name Stroke
s) | Stroke
s <- [Stroke]
strokes, Stroke -> Char
Drums._char Stroke
s forall a. Eq a => a -> a -> Bool
/= Char
' ']
    -- As advertised in 'Drums.Stroke', don't bind to ' '.

-- | Select the flavor of thru to use when inserting an expression.  This
-- selects either 'expr_midi_thru' or 'expr_im_thru'.
--
-- Choosing manually is silly because the valid kind of thru depends on the
-- patch type.  It's just that due to history and wanting to avoid duplicated
-- code, the Cmd and Derive code in here doesn't care about MIDI vs. im...
-- except for thru.
data Thru = MidiThru | ImThru !Thru.ThruFunction | NoThru
    -- WRT ImThru, I can't just delegate to MidiThru.cmd_midi_thru because it
    -- doesn't know about the attrs, since it uses
    -- Cmd.get_instrument_attributes.

-- | Create a custom kbd entry cmd that inserts tracklang expressions at
-- the insertion point.  Since this shadows the default note entry cmd, it
-- has to handle thru on its own.
insert_expr :: Cmd.M m => Thru -- ^ Evaluate the expression and emit MIDI thru.
    -> Cmd.NoteEntryMap DeriveT.Expr
    -> Cmd.Handler m
insert_expr :: forall (m :: * -> *). M m => Thru -> NoteEntryMap Expr -> Handler m
insert_expr Thru
thru NoteEntryMap Expr
note_entry_map = forall {m :: * -> *}. (Msg -> m Status) -> Handler m
handler forall a b. (a -> b) -> a -> b
$ \Msg
msg -> do
    forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM forall (m :: * -> *). M m => m Bool
Cmd.is_kbd_entry forall (m :: * -> *) a. M m => m a
Cmd.abort
    forall (m :: * -> *). M m => Fallthrough -> Msg -> m ()
EditUtil.fallthrough Fallthrough
EditUtil.NoBackspace Msg
msg
    (KbdState
kstate, Char
char) <- forall (m :: * -> *) a. M m => Maybe a -> m a
Cmd.abort_unless forall a b. (a -> b) -> a -> b
$ Msg -> Maybe (KbdState, Char)
Msg.char Msg
msg
    Octave
octave <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets forall a b. (a -> b) -> a -> b
$ EditState -> Octave
Cmd.state_kbd_entry_octave forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> EditState
Cmd.state_edit
    case forall a. Octave -> Char -> NoteEntryMap a -> Maybe a
Cmd.note_entry_lookup Octave
octave Char
char NoteEntryMap Expr
note_entry_map of
        Maybe Expr
Nothing
            -- Eat keys that normally would be eaten by kbd entry.  Otherwise
            -- it'll fall through to normal kbd entry and try to enter a
            -- pitched note.
            --
            -- TODO another possibly cleaner way to accomplish this would be to
            -- put the NoteEntry stuff in as a default instrument cmd, so I
            -- could just replace it entirely.  But I still want to mask out
            -- those PhysicalKey.pitch_map keys because it seems to confusing
            -- to fall through to an editing key.
            | forall k a. Ord k => k -> Map k a -> Bool
Map.member Char
char Map Char Pitch
PhysicalKey.pitch_map -> forall (m :: * -> *) a. Monad m => a -> m a
return Status
Cmd.Done
            | Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return Status
Cmd.Continue
        Just Expr
expr -> do
            case Thru
thru of
                Thru
NoThru -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Thru
MidiThru -> forall (m :: * -> *). M m => KbdState -> Expr -> m ()
expr_midi_thru KbdState
kstate Expr
expr
                ImThru ThruFunction
thru_f -> case KbdState
kstate of
                    KbdState
UiMsg.KeyDown ->
                        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
=<< forall (m :: * -> *). M m => ThruFunction -> Expr -> m [Thru]
expr_im_thru ThruFunction
thru_f Expr
expr
                    KbdState
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            case KbdState
kstate of
                KbdState
UiMsg.KeyDown -> forall {m :: * -> *} {a}. (M m, ShowVal a) => a -> m ()
keydown Expr
expr
                KbdState
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            forall (m :: * -> *) a. Monad m => a -> m a
return Status
Cmd.Done
    where
    handler :: (Msg -> m Status) -> Handler m
handler = forall (m :: * -> *).
Maybe (NoteEntryMap KeyDoc) -> NamedCmd m -> Handler m
Cmd.Handler
        (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> NoteEntryMap a -> NoteEntryMap a
merge_kbd_entry KeyDoc
"" forall a b. (a -> b) -> a -> b
$ Expr -> KeyDoc
to_keycap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NoteEntryMap Expr
note_entry_map)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). KeyDoc -> (Msg -> m Status) -> NamedCmd m
Cmd.NamedCmd KeyDoc
"insert_expr"
    keydown :: a -> m ()
keydown a
expr = do
        forall (m :: * -> *).
M m =>
(Octave, KeyDoc) -> Maybe KeyDoc -> m ()
Cmd.set_status (Octave, KeyDoc)
Config.status_note forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. ShowVal a => a -> KeyDoc
ShowVal.show_val a
expr
        forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM forall (m :: * -> *). M m => m Bool
Cmd.is_val_edit forall a b. (a -> b) -> a -> b
$ forall {a}. m a -> m a
suppressed forall a b. (a -> b) -> a -> b
$ do
            Pos
pos <- forall (m :: * -> *). M m => m Pos
EditUtil.get_pos
            forall (m :: * -> *). M m => Pos -> Bool -> Bool -> Modify -> m ()
EditUtil.modify_event_at_trigger Pos
pos Bool
False Bool
True forall a b. (a -> b) -> a -> b
$
                forall a b. a -> b -> a
const (forall a. a -> Maybe a
Just (forall a. ShowVal a => a -> KeyDoc
ShowVal.show_val a
expr), Bool
True)
        where
        suppressed :: m a -> m a
suppressed = forall (m :: * -> *) a. M m => EditMode -> KeyDoc -> m a -> m a
Cmd.suppress_history EditMode
Cmd.ValEdit
            (KeyDoc
"keymap: " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> KeyDoc
ShowVal.show_val a
expr)

to_keycap :: DeriveT.Expr -> KeycapsT.KeyDoc
to_keycap :: Expr -> KeyDoc
to_keycap = forall val. ShowVal (Call val) => Expr val -> KeyDoc
Expr.show_val_expr

merge_kbd_entry :: a -> Cmd.NoteEntryMap a -> Cmd.NoteEntryMap a
merge_kbd_entry :: forall a. a -> NoteEntryMap a -> NoteEntryMap a
merge_kbd_entry a
val = \case
    Cmd.WithOctave Map Octave (Map Char a)
m -> forall a. Map Octave (Map Char a) -> NoteEntryMap a
Cmd.WithOctave forall a b. (a -> b) -> a -> b
$ (forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map Char a
empty) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Octave (Map Char a)
m
    Cmd.WithoutOctave Map Char a
m -> forall a. Map Char a -> NoteEntryMap a
Cmd.WithoutOctave forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map Char a
m Map Char a
empty
    where empty :: Map Char a
empty = forall a b. a -> b -> a
const a
val forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Char Pitch
PhysicalKey.pitch_map

expr_im_thru :: Cmd.M m => Thru.ThruFunction -> DeriveT.Expr -> m [Cmd.Thru]
expr_im_thru :: forall (m :: * -> *). M m => ThruFunction -> Expr -> m [Thru]
expr_im_thru ThruFunction
thru_f Expr
expr = do
    [Note]
notes <- forall (m :: * -> *). M m => Expr -> m [Note]
eval_thru_notes Expr
expr
    Message
msg <- forall (m :: * -> *) err a.
(Stack, M m) =>
(err -> KeyDoc) -> Either err a -> m a
Cmd.require_right (KeyDoc
"thru_f: "<>) forall a b. (a -> b) -> a -> b
$ ThruFunction
thru_f [Note]
notes
    forall (m :: * -> *) a. Monad m => a -> m a
return [Message -> Thru
Cmd.ImThru Message
msg]

eval_thru_notes :: Cmd.M m => DeriveT.Expr -> m [Thru.Note]
eval_thru_notes :: forall (m :: * -> *). M m => Expr -> m [Note]
eval_thru_notes Expr
expr = do
    (BlockId
block_id, Octave
_, TrackId
track_id, TrackTime
pos) <- forall (m :: * -> *).
M m =>
m (BlockId, Octave, TrackId, TrackTime)
Selection.get_insert
    Either KeyDoc [Note]
result <- forall (m :: * -> *) a. LogMonad m => KeyDoc -> (a, [Msg]) -> m a
LEvent.write_snd_prefix KeyDoc
"CUtil.expr_attributes"
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) d.
(M m, CallableExpr d) =>
BlockId
-> TrackId -> TrackTime -> Expr -> m (Either KeyDoc [d], [Msg])
Perf.derive_expr BlockId
block_id TrackId
track_id TrackTime
pos Expr
expr
    [Note]
events <- forall (m :: * -> *) err a.
(Stack, M m) =>
(err -> KeyDoc) -> Either err a -> m a
Cmd.require_right (KeyDoc
"CUtil.expr_attributes: "<>) Either KeyDoc [Note]
result
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Note]
events) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. (Stack, M m) => KeyDoc -> m a
Cmd.throw forall a b. (a -> b) -> a -> b
$ KeyDoc
"expected events when evaluating: "
        forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> KeyDoc
ShowVal.show_val Expr
expr
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Note -> Note
make [Note]
events
    where
    make :: Note -> Note
make Note
event = Thru.Note
        { _pitch :: NoteNumber
_pitch = forall a. a -> Maybe a -> a
fromMaybe NoteNumber
0 (Note -> Maybe NoteNumber
Score.initial_nn Note
event)
        , _velocity :: Y
_velocity = Note -> Y
Score.initial_dynamic Note
event
        , _attributes :: Attributes
_attributes = Note -> Attributes
Score.event_attributes Note
event
        , _startOffset :: Octave
_startOffset = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Octave
0 (forall a b. (RealFrac a, Integral b) => a -> b
floor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Typed a -> a
ScoreT.val_of) forall a b. (a -> b) -> a -> b
$
            RealTime -> Control -> Note -> Maybe (Typed Y)
Score.control_at (Note -> RealTime
Score.event_start Note
event)
                (Control -> Control
Controls.from_shared Control
Control.sampleStartOffset) Note
event
        }

{- | Emit MIDI thru for an arbitrary expresison.

    This is more accurate and principled than what the usual kbd entry cmds do,
    since it reuses the deriver and performer directly, while they recreate the
    performer in an ad-hoc way, e.g. in "Cmd.MidiThru".  However, this allows
    them to play chords and is thus more suitable for pitched instruments.
    Actually, what MidiThru recreates is the channel allocation part of the
    performer, ultimately becasue the performer's allocator doesn't work in
    real time.  Still, perhaps it would be possible to integrate them better
    than I have.
-}
expr_midi_thru :: Cmd.M m => UiMsg.KbdState -> DeriveT.Expr -> m ()
expr_midi_thru :: forall (m :: * -> *). M m => KbdState -> Expr -> m ()
expr_midi_thru KbdState
kstate Expr
expr = case KbdState
kstate of
    KbdState
UiMsg.KeyRepeat -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    KbdState
UiMsg.KeyDown -> do
        (BlockId
block_id, Octave
_, TrackId
track_id, TrackTime
pos) <- forall (m :: * -> *).
M m =>
m (BlockId, Octave, TrackId, TrackTime)
Selection.get_insert
        [WriteMessage]
msgs <- forall (m :: * -> *).
M m =>
BlockId -> TrackId -> TrackTime -> Expr -> m [WriteMessage]
expr_to_midi BlockId
block_id TrackId
track_id TrackTime
pos Expr
expr
        let note_ons :: [(WriteDevice, Message)]
note_ons =
                [ (WriteMessage -> WriteDevice
Midi.wmsg_dev WriteMessage
wmsg, WriteMessage -> Message
Midi.wmsg_msg WriteMessage
wmsg)
                | WriteMessage
wmsg <- [WriteMessage]
msgs
                , Message -> Bool
Midi.is_note_on (WriteMessage -> Message
Midi.wmsg_msg WriteMessage
wmsg)
                ]
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall (m :: * -> *). M m => WriteDevice -> Message -> m ()
Cmd.midi) [(WriteDevice, Message)]
note_ons
    KbdState
UiMsg.KeyUp -> do
        -- This runs relies on 'expr_to_midi' producing exactly the same thing
        -- as the call above, so the NoteOffs will cancel out the NoteOns.  If
        -- this seems too unreliable, I could keep a Map from exprs to the note
        -- offs.  Keeping state around is also a bit unreliable, but maybe less
        -- so.
        (BlockId
block_id, Octave
_, TrackId
track_id, TrackTime
pos) <- forall (m :: * -> *).
M m =>
m (BlockId, Octave, TrackId, TrackTime)
Selection.get_insert
        [WriteMessage]
msgs <- forall (m :: * -> *).
M m =>
BlockId -> TrackId -> TrackTime -> Expr -> m [WriteMessage]
expr_to_midi BlockId
block_id TrackId
track_id TrackTime
pos Expr
expr
        let note_offs :: [(WriteDevice, Message)]
note_offs =
                [ (WriteDevice
dev, Message
msg)
                | Midi.WriteMessage WriteDevice
dev RealTime
_
                    msg :: Message
msg@(Midi.ChannelMessage Channel
_ (Midi.NoteOff Key
_ Channel
_)) <- [WriteMessage]
msgs
                ]
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall (m :: * -> *). M m => WriteDevice -> Message -> m ()
Cmd.midi) [(WriteDevice, Message)]
note_offs

-- | Call a note call and return the MIDI msgs it produces.
expr_to_midi :: Cmd.M m => BlockId -> TrackId -> TrackTime -> DeriveT.Expr
    -> m [Midi.WriteMessage]
expr_to_midi :: forall (m :: * -> *).
M m =>
BlockId -> TrackId -> TrackTime -> Expr -> m [WriteMessage]
expr_to_midi BlockId
block_id TrackId
track_id TrackTime
pos Expr
expr = do
    Either KeyDoc [Note]
result <- forall (m :: * -> *) a. LogMonad m => KeyDoc -> (a, [Msg]) -> m a
LEvent.write_snd_prefix KeyDoc
"CUtil.expr_to_midi"
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) d.
(M m, CallableExpr d) =>
BlockId
-> TrackId -> TrackTime -> Expr -> m (Either KeyDoc [d], [Msg])
Perf.derive_expr BlockId
block_id TrackId
track_id TrackTime
pos Expr
expr
    [Note]
events <- forall (m :: * -> *) err a.
(Stack, M m) =>
(err -> KeyDoc) -> Either err a -> m a
Cmd.require_right (KeyDoc
"CUtil.expr_to_midi: "<>) Either KeyDoc [Note]
result
    forall (m :: * -> *) a. LogMonad m => (a, [Msg]) -> m a
LEvent.write_snd forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => [Note] -> m ([WriteMessage], [Msg])
Perf.perform [Note]
events

-- * keyswitch

{- | Create a Cmd to set keyswitches.

    This simply sets the note text for subsequent notes, and also configures
    the instrument to play in the given keyswitch.

    TODO this just emits keyswitches for every addr and emits them redundantly.
    This is simpler but it would be more correct to use WriteDeviceState to
    emit them only when needed.  However, it's more complicated because then
    I need a current attrs (Map Instrument Attrs) along with current note text,
    so MidiThru can use the attrs to find the keyswitch.

    TODO if I can pull the current or previous note out of the derive then
    I could use that to play an example note.  Wait until I have a "play
    current line" framework up for that.
-}
keyswitches :: Cmd.M m => [(Char, Expr.Symbol, Midi.Key)] -> Cmd.Handler m
keyswitches :: forall (m :: * -> *). M m => [(Char, Symbol, Key)] -> Handler m
keyswitches [(Char, Symbol, Key)]
inputs = forall {m :: * -> *}. (Msg -> m Status) -> Handler m
handler forall a b. (a -> b) -> a -> b
$ \Msg
msg -> do
    forall (m :: * -> *). M m => Fallthrough -> Msg -> m ()
EditUtil.fallthrough Fallthrough
EditUtil.NoBackspace Msg
msg
    Char
char <- forall (m :: * -> *) a. M m => Maybe a -> m a
Cmd.abort_unless forall a b. (a -> b) -> a -> b
$ Msg -> Maybe Char
Msg.char_down Msg
msg
    (Symbol
call, Key
key) <- forall (m :: * -> *) a. M m => Maybe a -> m a
Cmd.abort_unless forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Char
char Map Char (Symbol, Key)
to_call
    forall (m :: * -> *).
M m =>
Maybe Instrument -> Bool -> [ChannelMessage] -> m ()
MidiThru.channel_messages forall a. Maybe a
Nothing Bool
False
        [Key -> Channel -> ChannelMessage
Midi.NoteOn Key
key Channel
64, Key -> Channel -> ChannelMessage
Midi.NoteOff Key
key Channel
64]
    forall (m :: * -> *). M m => KeyDoc -> m ()
Cmd.set_note_text (Symbol -> KeyDoc
Expr.unsym Symbol
call)
    forall (m :: * -> *) a. Monad m => a -> m a
return Status
Cmd.Done
    where
    handler :: (Msg -> m Status) -> Handler m
handler = forall (m :: * -> *).
Maybe (NoteEntryMap KeyDoc) -> NamedCmd m -> Handler m
Cmd.Handler (forall a. a -> Maybe a
Just NoteEntryMap KeyDoc
note_entry_map) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). KeyDoc -> (Msg -> m Status) -> NamedCmd m
Cmd.NamedCmd KeyDoc
"keyswitches"
    note_entry_map :: NoteEntryMap KeyDoc
note_entry_map = forall a. Map Char a -> NoteEntryMap a
Cmd.WithoutOctave forall a b. (a -> b) -> a -> b
$ Symbol -> KeyDoc
Expr.unsym forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Char (Symbol, Key)
to_call
    to_call :: Map Char (Symbol, Key)
to_call = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Char
char, (Symbol
call, Key
key)) | (Char
char, Symbol
call, Key
key) <- [(Char, Symbol, Key)]
inputs]


-- * drums

-- | Create an unpitched drum instrument.  This is an instrument with an
-- enumeration of symbols and no pitch or duration.  Each key maps to its
-- own symbol.
simple_drum :: Thru -> Maybe ScoreT.Control -> [(Drums.Stroke, Midi.Key)]
    -> MidiInst.Patch -> MidiInst.Patch
simple_drum :: Thru -> Maybe Control -> [(Stroke, Key)] -> Patch -> Patch
simple_drum Thru
thru Maybe Control
tuning_control [(Stroke, Key)]
stroke_keys Patch
patch =
    Lens Patch Code
MidiInst.code forall f a. Lens f a -> a -> f -> f
#= Code
code forall a b. (a -> b) -> a -> b
$ [(Stroke, Key)] -> Patch -> Patch
drum_patch [(Stroke, Key)]
stroke_keys Patch
patch
    where
    code :: Code
code = Thru -> [(Stroke, CallConfig)] -> Code
drum_code Thru
thru (forall a b. (a -> b) -> [a] -> [b]
map ((,CallConfig
config) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Stroke, Key)]
stroke_keys)
    config :: CallConfig
config = CallConfig
call_config { _tuning_control :: Maybe Control
_tuning_control = Maybe Control
tuning_control }

-- ** code

-- | Construct code from drum strokes.  This is both the deriver calls to
-- interpret the stroke names, and the cmds to enter them.
drum_code :: Thru -> [(Drums.Stroke, CallConfig)] -> MidiInst.Code
drum_code :: Thru -> [(Stroke, CallConfig)] -> Code
drum_code = [(Char, Symbol)] -> Thru -> [(Stroke, CallConfig)] -> Code
drum_code_cmd []

-- | 'drum_code', but with the opportunity to insert extra keys for
-- 'insert_call'.  This is because 'insert_expr' can't be stacked, since it
-- consumes kbd entry keys it doesn't map, since it's confusing if it doesn't.
drum_code_cmd :: [(Char, Expr.Symbol)] -> Thru -> [(Drums.Stroke, CallConfig)]
    -> MidiInst.Code
drum_code_cmd :: [(Char, Symbol)] -> Thru -> [(Stroke, CallConfig)] -> Code
drum_code_cmd [(Char, Symbol)]
extra_cmds Thru
thru [(Stroke, CallConfig)]
stroke_configs =
    [(Symbol, Generator Note)] -> Code
MidiInst.note_generators ([(Stroke, CallConfig)] -> [(Symbol, Generator Note)]
drum_calls [(Stroke, CallConfig)]
stroke_configs)
    forall a. Semigroup a => a -> a -> a
<> HandlerId -> Code
MidiInst.cmd (forall (m :: * -> *).
M m =>
[(Char, Symbol)] -> Thru -> [Stroke] -> Handler m
drum_cmd [(Char, Symbol)]
extra_cmds Thru
thru (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Stroke, CallConfig)]
stroke_configs))

drum_code_ :: Thru -> [Drums.Stroke] -> MidiInst.Code
drum_code_ :: Thru -> [Stroke] -> Code
drum_code_ Thru
thru = Thru -> [(Stroke, CallConfig)] -> Code
drum_code Thru
thru forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (,CallConfig
call_config)

drum_cmd :: Cmd.M m => [(Char, Expr.Symbol)] -> Thru -> [Drums.Stroke]
    -> Cmd.Handler m
drum_cmd :: forall (m :: * -> *).
M m =>
[(Char, Symbol)] -> Thru -> [Stroke] -> Handler m
drum_cmd [(Char, Symbol)]
extras Thru
thru = forall (m :: * -> *). M m => Thru -> [(Char, Symbol)] -> Handler m
insert_call Thru
thru forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Char, Symbol)]
extras++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Stroke] -> [(Char, Symbol)]
strokes_to_calls

-- ** patch

-- | Create a MIDI patch for the traditional kind of drum instrument where
-- each different stroke is mapped to a single MIDI keys.  'pitched_drum_patch'
-- is the variant where each stroke has a range of keys.
drum_patch :: [(Drums.Stroke, Midi.Key)] -> MidiInst.Patch -> MidiInst.Patch
drum_patch :: [(Stroke, Key)] -> Patch -> Patch
drum_patch [(Stroke, Key)]
stroke_keys =
    Patch -> Patch
MidiInst.triggered
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Patch :-> Common Code
MidiInst.commonforall a b c. Lens a b -> Lens b c -> Lens a c
#forall {code}. Common code :-> CallMap
Common.call_map forall f a. Lens f a -> a -> f -> f
#= [Stroke] -> CallMap
make_call_map (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Stroke, Key)]
stroke_keys))
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Patch :-> Patch
MidiInst.patchforall a b c. Lens a b -> Lens b c -> Lens a c
#Patch :-> AttributeMap
Patch.attribute_map forall f a. Lens f a -> a -> f -> f
#= AttributeMap
keymap)
    where
    keymap :: AttributeMap
keymap = [(Attributes, Key)] -> AttributeMap
Patch.unpitched_keymap
        [(Stroke -> Attributes
Drums._attributes Stroke
stroke, Key
key) | (Stroke
stroke, Key
key) <- [(Stroke, Key)]
stroke_keys]

-- | im is much simpler than MIDI and doesn't need all the keymap garbage.
-- However, like 'drum_patch', this just sets patch config, the cmd and deriver
-- code has to be added separately, see 'drum_code' or 'drum_calls' for that.
im_drum_patch :: [Drums.Stroke] -> ImInst.Patch -> ImInst.Patch
im_drum_patch :: [Stroke] -> Patch -> Patch
im_drum_patch [Stroke]
strokes =
    Patch -> Patch
ImInst.triggered forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Patch :-> Common Code
ImInst.commonforall a b c. Lens a b -> Lens b c -> Lens a c
#forall {code}. Common code :-> CallMap
Common.call_map forall f a. Lens f a -> a -> f -> f
#= [Stroke] -> CallMap
make_call_map [Stroke]
strokes)

-- | Used with 'pitched_attribute_map' for MIDI instruments that do the
-- strategy of assigning pitch ranges to each drum stroke.
type PitchedStrokes = [(Drums.Stroke, KeyswitchRange)]

-- | (keyswitch, low, high, root_pitch).  The root pitch is the pitch at the
-- bottom of the key range, and winds up in 'Patch.PitchedKeymap'.
type KeyswitchRange = ([Patch.Keyswitch], Midi.Key, Midi.Key, Midi.Key)

-- | Make a KeyswitchRange for each grouped Attributes set.  Attributes in the
-- same group get the same range and are differentiated by keyswitch.
make_keymap :: Maybe Midi.Key -- ^ Keyswitches start here.  If not given,
    -- this patch doesn't use keyswitches.
    -> Midi.Key -- ^ notes start here
    -> Midi.Key -- ^ each sound is mapped over this range
    -> Midi.Key -- ^ the pitch of the bottom note of each range
    -> [[Attrs.Attributes]] -> Map Attrs.Attributes KeyswitchRange
make_keymap :: Maybe Key
-> Key
-> Key
-> Key
-> [[Attributes]]
-> Map Attributes KeyswitchRange
make_keymap Maybe Key
base_keyswitch Key
base_key Key
range Key
root_pitch [[Attributes]]
groups = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ do
    ([Attributes]
group, Key
low) <- forall a b. [a] -> [b] -> [(a, b)]
zip [[Attributes]]
groups [Key
base_key, Key
base_keyforall a. Num a => a -> a -> a
+Key
range ..]
    (Attributes
attrs, [Keyswitch]
ks) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Attributes]
group forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. a -> [a]
repeat [])
        (\Key
base -> forall a b. (a -> b) -> [a] -> [b]
map ((forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Keyswitch
Patch.Keyswitch) [Key
base..]) Maybe Key
base_keyswitch
    forall (m :: * -> *) a. Monad m => a -> m a
return (Attributes
attrs, ([Keyswitch]
ks, Key
low, Key
low forall a. Num a => a -> a -> a
+ (Key
rangeforall a. Num a => a -> a -> a
-Key
1), Key
root_pitch))

-- | This is like 'make_keymap', except with the arguments rearranged to more
-- closely match the sample utils I use.
make_keymap2 :: Maybe Midi.Key -> Midi.Key -> Midi.Key -> Midi.Key
    -> Midi.Key -> [[Attrs.Attributes]]
    -> Map Attrs.Attributes KeyswitchRange
make_keymap2 :: Maybe Key
-> Key
-> Key
-> Key
-> Key
-> [[Attributes]]
-> Map Attributes KeyswitchRange
make_keymap2 Maybe Key
base_keyswitch Key
base_key Key
natural_key Key
range Key
natural_nn =
    Maybe Key
-> Key
-> Key
-> Key
-> [[Attributes]]
-> Map Attributes KeyswitchRange
make_keymap Maybe Key
base_keyswitch Key
base_key Key
range
        (Key
natural_nn forall a. Num a => a -> a -> a
- forall a. Num a => Key -> a
Midi.from_key Key
natural_key)

-- | This is like 'make_keymap', except that attributes are differentiated by
-- a 'Patch.ControlSwitch'.  CCs start at 102, and only groups of size >1
-- get a CC.  Since each group is controlled by its own CC number, you can then
-- select each variation independently.  This means any set of variations can
-- be played simultaneously, which is not true for keyswitches.
make_cc_keymap :: Midi.Key -- ^ notes start here
    -> Midi.Key -- ^ each sound is mapped over this range
    -> Midi.Key -- ^ the pitch of the bottom note of each range
    -> [[Attrs.Attributes]] -> Map Attrs.Attributes KeyswitchRange
make_cc_keymap :: Key
-> Key -> Key -> [[Attributes]] -> Map Attributes KeyswitchRange
make_cc_keymap Key
base_key Key
range Key
root_pitch =
    forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Channel -> [(Key, [a])] -> [(a, KeyswitchRange)]
go Channel
base_cc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [Key
base_key, Key
base_key forall a. Num a => a -> a -> a
+ Key
range ..]
    where
    go :: Channel -> [(Key, [a])] -> [(a, KeyswitchRange)]
go Channel
_ [] = []
    go Channel
cc ((Key
low, [a]
group) : [(Key, [a])]
groups) = case [a]
group of
        [] -> Channel -> [(Key, [a])] -> [(a, KeyswitchRange)]
go Channel
cc [(Key, [a])]
groups
        [a
attrs] -> (a
attrs, ([], Key
low, Key
low forall a. Num a => a -> a -> a
+ (Key
rangeforall a. Num a => a -> a -> a
-Key
1), Key
root_pitch))
            forall a. a -> [a] -> [a]
: Channel -> [(Key, [a])] -> [(a, KeyswitchRange)]
go Channel
cc [(Key, [a])]
groups
        [a]
_ ->
            [ (a
attrs, ([Channel -> Channel -> Keyswitch
Patch.ControlSwitch Channel
cc Channel
cc_val],
                Key
low, Key
low forall a. Num a => a -> a -> a
+ (Key
rangeforall a. Num a => a -> a -> a
-Key
1), Key
root_pitch))
            | (a
attrs, Channel
cc_val) <- forall a b. [a] -> [b] -> [(a, b)]
zip [a]
group [Channel
0 ..]
            ] forall a. [a] -> [a] -> [a]
++ Channel -> [(Key, [a])] -> [(a, KeyswitchRange)]
go (Channel
ccforall a. Num a => a -> a -> a
+Channel
1) [(Key, [a])]
groups
    -- There is an unallocated block [102 .. 119], which should be enough.
    base_cc :: Channel
base_cc = Channel
102

-- | Annotate a Patch with an 'Patch.AttributeMap' from the given
-- PitchedStrokes.
pitched_drum_patch :: PitchedStrokes -> MidiInst.Patch -> MidiInst.Patch
pitched_drum_patch :: PitchedStrokes -> Patch -> Patch
pitched_drum_patch PitchedStrokes
strokes =
    Patch -> Patch
MidiInst.triggered
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Patch :-> Common Code
MidiInst.commonforall a b c. Lens a b -> Lens b c -> Lens a c
#forall {code}. Common code :-> CallMap
Common.call_map forall f a. Lens f a -> a -> f -> f
#= [Stroke] -> CallMap
make_call_map (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst PitchedStrokes
strokes))
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Patch :-> Patch
MidiInst.patchforall a b c. Lens a b -> Lens b c -> Lens a c
#Patch :-> AttributeMap
Patch.attribute_map forall f a. Lens f a -> a -> f -> f
#= PitchedStrokes -> AttributeMap
pitched_attribute_map PitchedStrokes
strokes)

make_call_map :: [Drums.Stroke] -> Common.CallMap
make_call_map :: [Stroke] -> CallMap
make_call_map = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\Stroke
n -> (Stroke -> Attributes
Drums._attributes Stroke
n, Stroke -> Symbol
Drums._name Stroke
n))

pitched_attribute_map :: PitchedStrokes -> Patch.AttributeMap
pitched_attribute_map :: PitchedStrokes -> AttributeMap
pitched_attribute_map PitchedStrokes
strokes = forall a. [(Attributes, a)] -> AttributeMap a
Common.attribute_map forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
Lists.unique
    -- It's ok to have Notes with the same (attr, keyswitch), for instance if
    -- there are loud and soft versions, but pitched_attribute_map will see them
    -- as overlapping attrs, so filter out duplicates.
    [ (Stroke -> Attributes
Drums._attributes Stroke
stroke, ([Keyswitch]
ks, forall a. a -> Maybe a
Just (Key -> Key -> Key -> Keymap
Patch.PitchedKeymap Key
low Key
high Key
root)))
    | (Stroke
stroke, ([Keyswitch]
ks, Key
low, Key
high, Key
root)) <- PitchedStrokes
strokes
    ]

-- | Make PitchedStrokes by pairing each 'Drums.Stroke' with its
-- 'KeyswitchRange'.
drum_pitched_strokes :: [Drums.Stroke] -> Map Attrs.Attributes KeyswitchRange
    -> (PitchedStrokes, ([Drums.Stroke], [Attrs.Attributes]))
    -- ^ Also return the strokes with no mapping (so they can't be played), and
    -- keymap ranges with no corresponding strokes (so there is no call to
    -- play them).
drum_pitched_strokes :: [Stroke]
-> Map Attributes KeyswitchRange
-> (PitchedStrokes, ([Stroke], [Attributes]))
drum_pitched_strokes [Stroke]
strokes Map Attributes KeyswitchRange
keymap = (PitchedStrokes
found, ([Stroke]
not_found, [Attributes]
unused))
    where
    unused :: [Attributes]
unused = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Attributes]
stroke_attrs) (forall k a. Map k a -> [k]
Map.keys Map Attributes KeyswitchRange
keymap)
    stroke_attrs :: [Attributes]
stroke_attrs = forall a b. (a -> b) -> [a] -> [b]
map Stroke -> Attributes
Drums._attributes [Stroke]
strokes
    ([Stroke]
not_found, PitchedStrokes
found) = forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Stroke -> Either Stroke (Stroke, KeyswitchRange)
find [Stroke]
strokes
    find :: Stroke -> Either Stroke (Stroke, KeyswitchRange)
find Stroke
n = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left Stroke
n) (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) Stroke
n)
        (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Stroke -> Attributes
Drums._attributes Stroke
n) Map Attributes KeyswitchRange
keymap)

-- | Create a 'drum_call' for each Drums.Stroke.
--
-- This should probably go in DUtil, but that would make it depend on
-- "Cmd.Instrument.Drums".
drum_calls :: [(Drums.Stroke, CallConfig)]
    -> [(Expr.Symbol, Derive.Generator Derive.Note)]
drum_calls :: [(Stroke, CallConfig)] -> [(Symbol, Generator Note)]
drum_calls = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a -> b) -> a -> b
$ \(Stroke
stroke, CallConfig
config) ->
    ( Stroke -> Symbol
Drums._name Stroke
stroke
    , CallConfig -> Symbol -> Attributes -> Generator Note
drum_call
        (CallConfig
config { _stroke_dyn :: Y
_stroke_dyn = Stroke -> Y
Drums._dynamic Stroke
stroke forall a. Num a => a -> a -> a
* CallConfig -> Y
_stroke_dyn CallConfig
config })
        (Stroke -> Symbol
Drums._name Stroke
stroke) (Stroke -> Attributes
Drums._attributes Stroke
stroke)
    )

-- | For 'drum_calls'.  If Just, only strokes which are a superset of one of
-- these move with the pitch, otherwise the stay at the given NoteNumber.  If
-- Nothing, all strokes move with the pitch.
pitched_strokes :: [Attrs.Attributes] -> Pitch.NoteNumber
    -> Attrs.Attributes -> CallConfig
pitched_strokes :: [Attributes] -> NoteNumber -> Attributes -> CallConfig
pitched_strokes [Attributes]
pitched NoteNumber
natural_nn Attributes
attrs
    | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Attributes -> Attributes -> Bool
Attrs.contain Attributes
attrs) [Attributes]
pitched = CallConfig
call_config
    | Bool
otherwise = CallConfig
call_config
        { _transform :: NoteDeriver -> NoteDeriver
_transform = forall a. Pitch -> Deriver a -> Deriver a
Derive.with_constant_pitch (NoteNumber -> Pitch
PSignal.nn_pitch NoteNumber
natural_nn)
        }

data CallConfig = CallConfig {
    -- | If set, look at this control for relative pitch adjustment.  For
    -- unpitched drums which nonetheless can use some tweaking.
    CallConfig -> Maybe Control
_tuning_control :: Maybe ScoreT.Control
    -- | If set, take pitch from a $name-pitch arg, otherwise use the given
    -- pitch.
    , CallConfig -> Maybe NoteNumber
_natural_nn :: Maybe Pitch.NoteNumber
    -- | Multiply dyn signal by this.
    , CallConfig -> Y
_stroke_dyn :: Signal.Y
    , CallConfig -> NoteDeriver -> NoteDeriver
_transform :: Derive.NoteDeriver -> Derive.NoteDeriver
    }

call_config :: CallConfig
call_config :: CallConfig
call_config = CallConfig
    { _tuning_control :: Maybe Control
_tuning_control = forall a. Maybe a
Nothing
    , _natural_nn :: Maybe NoteNumber
_natural_nn = forall a. Maybe a
Nothing
    , _stroke_dyn :: Y
_stroke_dyn = Y
1
    , _transform :: NoteDeriver -> NoteDeriver
_transform = forall a. a -> a
id
    }

-- | This is the common deriver call that all drums and drum-like instruments
-- use at the bottom.
drum_call :: CallConfig -> Expr.Symbol -> Attrs.Attributes
    -> Derive.Generator Derive.Note
drum_call :: CallConfig -> Symbol -> Attributes -> Generator Note
drum_call (CallConfig Maybe Control
tuning_control Maybe NoteNumber
mb_natural_nn Y
stroke_dyn NoteDeriver -> NoteDeriver
transform)
        (Expr.Symbol KeyDoc
name) Attributes
attrs =
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
Module.instrument (KeyDoc -> CallName
Derive.CallName KeyDoc
name) Tags
Tags.attr Doc
doc forall a b. (a -> b) -> a -> b
$
    forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,)
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"dyn" (Y
1 :: Double) Doc
"Dyn multiplier."
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (if forall a. Maybe a -> Bool
Maybe.isNothing Maybe NoteNumber
mb_natural_nn then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
            else forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.environ ArgName
"pitch" EnvironDefault
Derive.Prefixed
                (forall a. Maybe a
Nothing :: Maybe Sig.Dummy) Doc
"doc")
    ) forall a b. (a -> b) -> a -> b
$ \(Y
dyn, Maybe Pitch
mb_pitch) -> forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
args ->
        forall a. Y -> Deriver a -> Deriver a
Call.multiply_dynamic (Y
stroke_dyn forall a. Num a => a -> a -> a
* Y
dyn) forall a b. (a -> b) -> a -> b
$ forall d. Attributes -> Deriver d -> Deriver d
Call.add_attributes Attributes
attrs forall a b. (a -> b) -> a -> b
$
            forall {a}. PassedArgs Note -> Deriver a -> Deriver a
with_tuning PassedArgs Note
args forall a b. (a -> b) -> a -> b
$ NoteDeriver -> NoteDeriver
transform forall a b. (a -> b) -> a -> b
$ forall {a}. Maybe Pitch -> Deriver a -> Deriver a
set_pitch Maybe Pitch
mb_pitch forall a b. (a -> b) -> a -> b
$
            KeyDoc -> Config -> Generator Note (Stream Note)
Note.default_note_integrate KeyDoc
name Config
Note.no_duration_attributes PassedArgs Note
args
    where
    with_tuning :: PassedArgs Note -> Deriver a -> Deriver a
with_tuning PassedArgs Note
args = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (forall a. PassedArgs Note -> Control -> Deriver a -> Deriver a
apply_tuning_control PassedArgs Note
args) Maybe Control
tuning_control
    set_pitch :: Maybe Pitch -> Deriver a -> Deriver a
set_pitch Maybe Pitch
mb_pitch = case Maybe NoteNumber
mb_natural_nn of
        Maybe NoteNumber
Nothing -> forall a. a -> a
id
        Just NoteNumber
natural_nn -> forall a. Pitch -> Deriver a -> Deriver a
Derive.with_constant_pitch
            (forall a. a -> Maybe a -> a
fromMaybe (NoteNumber -> Pitch
PSignal.nn_pitch NoteNumber
natural_nn) Maybe Pitch
mb_pitch)
    doc :: Doc
doc = case Maybe Control
tuning_control of
        Maybe Control
Nothing -> Doc
""
        Just Control
control -> Doc
"This instrument is unpitched, but its tuning can be\
            \ adjusted with " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Control
control forall a. Semigroup a => a -> a -> a
<> Doc
", in semitones\
            \ from the natural pitch."

apply_tuning_control :: Derive.NoteArgs -> ScoreT.Control -> Derive.Deriver a
    -> Derive.Deriver a
apply_tuning_control :: forall a. PassedArgs Note -> Control -> Deriver a -> Deriver a
apply_tuning_control PassedArgs Note
args Control
control Deriver a
deriver = do
    Y
tuning <- forall a. a -> Maybe a -> a
fromMaybe Y
0 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        (Control -> RealTime -> Deriver State Error (Maybe Y)
Derive.untyped_control_at Control
control forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Note
args)
    let nn :: NoteNumber
nn = NoteNumber
NN.middle_c forall a. Num a => a -> a -> a
+ forall a. Real a => a -> NoteNumber
Pitch.nn Y
tuning
    forall a. Pitch -> Deriver a -> Deriver a
Derive.with_constant_pitch (NoteNumber -> Pitch
PSignal.nn_pitch NoteNumber
nn) Deriver a
deriver

-- * util

-- | Given a map describing how Attributes are mapped to the MIDI key range,
-- take a key binding to a 'PitchedStrokes'.  The reason these are separate is
-- that the map describes how a particular patch maps attributes, while the
-- key binding describes the capabilities of the instrument itself.
--
-- If a mapping has 'Attrs.soft', it's looked up without the soft, but gets
-- the given dynamic.
resolve_strokes :: Signal.Y -> Map Attrs.Attributes KeyswitchRange
    -> [(Char, Expr.Symbol, Attrs.Attributes, Drums.Group)]
    -- ^ (key_binding, emits_text, call_attributes, stop_group)
    -> (PitchedStrokes, [Text]) -- ^ also return errors
resolve_strokes :: Y
-> Map Attributes KeyswitchRange
-> [(Char, Symbol, Attributes, KeyDoc)]
-> (PitchedStrokes, [KeyDoc])
resolve_strokes Y
soft_dyn Map Attributes KeyswitchRange
keymap =
    forall {b}. ([KeyDoc], [(Stroke, b)]) -> ([(Stroke, b)], [KeyDoc])
check_dups forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Char, Symbol, Attributes, KeyDoc)
-> Either KeyDoc (Stroke, KeyswitchRange)
resolve
    where
    resolve :: (Char, Symbol, Attributes, KeyDoc)
-> Either KeyDoc (Stroke, KeyswitchRange)
resolve (Char
char, Symbol
call, Attributes
attrs, KeyDoc
group) =
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ KeyDoc
"unmapped: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> KeyDoc
pretty Attributes
attrs) (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Stroke
stroke,)) forall a b. (a -> b) -> a -> b
$
            forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Attributes -> Attributes -> Attributes
Attrs.remove Attributes
Attrs.soft Attributes
attrs) Map Attributes KeyswitchRange
keymap
        where
        stroke :: Stroke
stroke = (Char -> Symbol -> Attributes -> Y -> Stroke
Drums.stroke_dyn Char
char Symbol
call Attributes
attrs Y
dyn) { _group :: KeyDoc
Drums._group = KeyDoc
group }
        dyn :: Y
dyn = if Attributes -> Attributes -> Bool
Attrs.contain Attributes
attrs Attributes
Attrs.soft then Y
soft_dyn else Y
1
    check_dups :: ([KeyDoc], [(Stroke, b)]) -> ([(Stroke, b)], [KeyDoc])
check_dups ([KeyDoc]
msgs, [(Stroke, b)]
strokes) = ([(Stroke, b)]
strokes3, [KeyDoc]
dup_msgs forall a. [a] -> [a] -> [a]
++ [KeyDoc]
msgs)
        where
        dup_msgs :: [KeyDoc]
dup_msgs = forall a b. (a -> b) -> [a] -> [b]
map ((KeyDoc
">1 call with same name: "<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {b}. ((Stroke, b), [(Stroke, b)]) -> KeyDoc
extract) [((Stroke, b), [(Stroke, b)])]
by_name
            forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map ((KeyDoc
">1 call mapped to same key: "<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {b}. ((Stroke, b), [(Stroke, b)]) -> KeyDoc
extract) [((Stroke, b), [(Stroke, b)])]
by_key
        extract :: ((Stroke, b), [(Stroke, b)]) -> KeyDoc
extract = forall a. Pretty a => a -> KeyDoc
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\((Stroke, b)
x, [(Stroke, b)]
xs) -> (Stroke, b)
x forall a. a -> [a] -> [a]
: [(Stroke, b)]
xs)
        ([(Stroke, b)]
strokes2, [((Stroke, b), [(Stroke, b)])]
by_name) = forall k a. Ord k => (a -> k) -> [a] -> ([a], [(a, [a])])
Lists.partitionDups (Stroke -> Symbol
Drums._name forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Stroke, b)]
strokes
        ([(Stroke, b)]
strokes3, [((Stroke, b), [(Stroke, b)])]
by_key) = forall k a. Ord k => (a -> k) -> [a] -> ([a], [(a, [a])])
Lists.partitionDups (Stroke -> Char
Drums._char forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Stroke, b)]
strokes2