-- 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 #-}
{- | Description of a midi-specific instrument, as well as the runtime midi
    device and channel mapping.
-}
module Perform.Midi.Patch (
    -- * Config
    Config(..), config_addrs
    , merge_defaults
    , allocation, control_defaults, initialization, settings
    , config
    , Initialization(..), Addr, Voices
    , has_flag
    -- Re-exported so instrument definitions don't have to have
    -- Midi.Control.PbRange.
    , Control.PbRange
    -- ** Settings
    , Settings(..)
    , pitch_bend_range, decay, scale, flags

    -- * Patch
    , Patch(..), name, control_map
    , initialize, attribute_map, mode_map, defaults
    , patch
    , default_name
    -- ** Scale
    , Scale(..) -- should just be Scale(scale_name), but Cmd.Serialize
    , make_scale
    , convert_scale, nn_at
    , scale_nns, scale_offsets, scale_tuning
    -- ** Flag
    , Flag(..)
    , add_flag, remove_flag
    -- ** InitializePatch
    , InitializePatch(..)
    , initialize_midi
    -- ** AttributeMap
    , AttributeMap, Keymap(..), Keyswitch(..)
    , keyswitches, single_keyswitches, cc_keyswitches, cc_keyswitches_permute
    , keymap, unpitched_keymap
    , keyswitch_on, keyswitch_off
    -- ** ModeMap
    , ModeMap(..)
    , make_mode_map, cc_mode_map
#ifdef TESTING
    , module Perform.Midi.Patch
#endif
) where
import qualified Control.DeepSeq as DeepSeq
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Vector.Unboxed as Unboxed

import qualified GHC.Generics as Generics

import qualified Util.Lens as Lens
import qualified Util.Num as Num
import qualified Util.Pretty as Pretty
import qualified Util.Seq as Seq
import qualified Util.Vector

import qualified Derive.Attrs as Attrs
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Expr as Expr
import qualified Derive.ScoreT as ScoreT

import qualified Instrument.Common as Common
import qualified Instrument.InstT as InstT
import qualified Midi.Midi as Midi
import qualified Perform.Midi.Control as Control
import qualified Perform.Pitch as Pitch
import qualified Perform.Signal as Signal

import           Global
import           Types


-- * Config

-- | Configuration for one MIDI instrument allocation.
data Config = Config {
    -- | An instrument may have multiple addresses assigned to it, which means
    -- that it can be multiplexed across multiple channels.  In addition,
    -- multiple instruments can be allocated to overlapping addresses, which is
    -- how keyswitches work; each one is considered a separate instrument.  An
    -- instrument wishing to use an address will emit an appropriate message to
    -- configure it (probably a keyswitch, possibly a program change).
    --
    -- Each Addr has a count of how many simultaneous voices the addr can
    -- handle.  Nothing means there's no limit.
    Config -> [(Addr, Maybe Int)]
config_allocation :: ![(Addr, Maybe Voices)]
    , Config -> Maybe Initialization
config_initialization :: !(Maybe Initialization)
    , Config -> Settings
config_settings :: !Settings
    } deriving (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, Int -> Config -> ShowS
[Config] -> ShowS
Config -> String
(Int -> Config -> ShowS)
-> (Config -> String) -> ([Config] -> ShowS) -> Show Config
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Config] -> ShowS
$cshowList :: [Config] -> ShowS
show :: Config -> String
$cshow :: Config -> String
showsPrec :: Int -> Config -> ShowS
$cshowsPrec :: Int -> Config -> ShowS
Show, (forall x. Config -> Rep Config x)
-> (forall x. Rep Config x -> Config) -> Generic Config
forall x. Rep Config x -> Config
forall x. Config -> Rep Config x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Config x -> Config
$cfrom :: forall x. Config -> Rep Config x
Generics.Generic)

allocation :: Config :-> [(Addr, Maybe Int)]
allocation = (Config -> [(Addr, Maybe Int)])
-> (([(Addr, Maybe Int)] -> [(Addr, Maybe Int)])
    -> Config -> Config)
-> Config :-> [(Addr, Maybe Int)]
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Config -> [(Addr, Maybe Int)]
config_allocation
    (\[(Addr, Maybe Int)] -> [(Addr, Maybe Int)]
f Config
r -> Config
r { config_allocation :: [(Addr, Maybe Int)]
config_allocation = [(Addr, Maybe Int)] -> [(Addr, Maybe Int)]
f (Config -> [(Addr, Maybe Int)]
config_allocation Config
r) })
initialization :: Config :-> Maybe Initialization
initialization = (Config -> Maybe Initialization)
-> ((Maybe Initialization -> Maybe Initialization)
    -> Config -> Config)
-> Config :-> Maybe Initialization
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Config -> Maybe Initialization
config_initialization
    (\Maybe Initialization -> Maybe Initialization
f Config
r -> Config
r { config_initialization :: Maybe Initialization
config_initialization = Maybe Initialization -> Maybe Initialization
f (Config -> Maybe Initialization
config_initialization Config
r) })
settings :: Config :-> Settings
settings = (Config -> Settings)
-> ((Settings -> Settings) -> Config -> Config)
-> Config :-> Settings
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Config -> Settings
config_settings
    (\Settings -> Settings
f Config
r -> Config
r { config_settings :: Settings
config_settings = Settings -> Settings
f (Config -> Settings
config_settings Config
r) })

config_addrs :: Config -> [Addr]
config_addrs :: Config -> [Addr]
config_addrs = ((Addr, Maybe Int) -> Addr) -> [(Addr, Maybe Int)] -> [Addr]
forall a b. (a -> b) -> [a] -> [b]
map (Addr, Maybe Int) -> Addr
forall a b. (a, b) -> a
fst ([(Addr, Maybe Int)] -> [Addr])
-> (Config -> [(Addr, Maybe Int)]) -> Config -> [Addr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> [(Addr, Maybe Int)]
config_allocation

config :: [(Addr, Maybe Voices)] -> Config
config :: [(Addr, Maybe Int)] -> Config
config [(Addr, Maybe Int)]
alloc = Config
    { config_allocation :: [(Addr, Maybe Int)]
config_allocation = [(Addr, Maybe Int)]
alloc
    , config_initialization :: Maybe Initialization
config_initialization = Maybe Initialization
forall a. Maybe a
Nothing
    , config_settings :: Settings
config_settings = Settings
forall a. Monoid a => a
mempty
    }

merge_defaults :: Patch -> Config -> Config
merge_defaults :: Patch -> Config -> Config
merge_defaults Patch
patch = Config :-> Settings
settings (Config :-> Settings) -> (Settings -> Settings) -> Config -> Config
forall f a. Lens f a -> (a -> a) -> f -> f
%= (Settings -> Settings -> Settings
forall a. Semigroup a => a -> a -> a
<> Patch -> Settings
patch_defaults Patch
patch)

instance Pretty Config where format :: Config -> Doc
format = Config -> Doc
forall a. (PrettyG (Rep a), Generic a) => a -> Doc
Pretty.formatG_

-- | Document what kinds of initialization this instrument needs.  Each
-- instrument is initialized once when the score is loaded.
data Initialization =
    Tuning -- ^ Configure tuning with 'Midi.realtime_tuning'.
    | NrpnTuning -- ^ Configure tuning with 'Midi.nrpn_tuning'.
    deriving (Int -> Initialization -> ShowS
[Initialization] -> ShowS
Initialization -> String
(Int -> Initialization -> ShowS)
-> (Initialization -> String)
-> ([Initialization] -> ShowS)
-> Show Initialization
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Initialization] -> ShowS
$cshowList :: [Initialization] -> ShowS
show :: Initialization -> String
$cshow :: Initialization -> String
showsPrec :: Int -> Initialization -> ShowS
$cshowsPrec :: Int -> Initialization -> ShowS
Show, Eq Initialization
Eq Initialization
-> (Initialization -> Initialization -> Ordering)
-> (Initialization -> Initialization -> Bool)
-> (Initialization -> Initialization -> Bool)
-> (Initialization -> Initialization -> Bool)
-> (Initialization -> Initialization -> Bool)
-> (Initialization -> Initialization -> Initialization)
-> (Initialization -> Initialization -> Initialization)
-> Ord Initialization
Initialization -> Initialization -> Bool
Initialization -> Initialization -> Ordering
Initialization -> Initialization -> Initialization
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Initialization -> Initialization -> Initialization
$cmin :: Initialization -> Initialization -> Initialization
max :: Initialization -> Initialization -> Initialization
$cmax :: Initialization -> Initialization -> Initialization
>= :: Initialization -> Initialization -> Bool
$c>= :: Initialization -> Initialization -> Bool
> :: Initialization -> Initialization -> Bool
$c> :: Initialization -> Initialization -> Bool
<= :: Initialization -> Initialization -> Bool
$c<= :: Initialization -> Initialization -> Bool
< :: Initialization -> Initialization -> Bool
$c< :: Initialization -> Initialization -> Bool
compare :: Initialization -> Initialization -> Ordering
$ccompare :: Initialization -> Initialization -> Ordering
Ord, Initialization -> Initialization -> Bool
(Initialization -> Initialization -> Bool)
-> (Initialization -> Initialization -> Bool) -> Eq Initialization
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Initialization -> Initialization -> Bool
$c/= :: Initialization -> Initialization -> Bool
== :: Initialization -> Initialization -> Bool
$c== :: Initialization -> Initialization -> Bool
Eq)
instance Pretty Initialization where pretty :: Initialization -> Key
pretty = Initialization -> Key
forall a. Show a => a -> Key
showt

-- | MIDI instruments are addressed by a (device, channel) pair, allocated in
-- 'Config'.
type Addr = (Midi.WriteDevice, Midi.Channel)
-- | Number of simultaneous voices a certain Addr supports, aka polyphony.
type Voices = Int

has_flag :: Config -> Flag -> Bool
has_flag :: Config -> Flag -> Bool
has_flag Config
config Flag
flag = Bool -> (Set Flag -> Bool) -> Maybe (Set Flag) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Flag -> Set Flag -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Flag
flag) (Config :-> Settings
settings(Config :-> Settings)
-> Lens Settings (Maybe (Set Flag))
-> Lens Config (Maybe (Set Flag))
forall a b c. Lens a b -> Lens b c -> Lens a c
#Lens Settings (Maybe (Set Flag))
flags Lens Config (Maybe (Set Flag)) -> Config -> Maybe (Set Flag)
forall f a. Lens f a -> f -> a
#$ Config
config)

-- ** Settings

-- | This has instrument configuration which has built-in defaults but can also
-- be modified per score.  When the instrument is looked up
-- (Cmd.resolve_instrument), 'patch_defaults' is merged with 'config_settings'
-- via 'merge_defaults'.
data Settings = Settings {
    Settings -> Maybe (Set Flag)
config_flags :: !(Maybe (Set Flag))
    , Settings -> Maybe Scale
config_scale :: !(Maybe Scale)
    -- | Time from NoteOff to inaudible, in seconds.  This can be used to
    -- figure out how long to generate control messages, or possibly determine
    -- overlap for channel allocation, though I use LRU so it shouldn't matter.
    , Settings -> Maybe RealTime
config_decay :: !(Maybe RealTime)
    , Settings -> Maybe PbRange
config_pitch_bend_range :: !(Maybe Control.PbRange)
    -- | Default controls for this instrument, will always be set unless
    -- explicitly replaced.  This hopefully avoids the problem where
    -- a synthesizer starts in an undefined state.  This is different from
    -- 'Common.config_controls' in that these are meant to provide a default
    -- for synthesizer state, so these are only applied during conversion, and
    -- thus should only contain controls the MIDI instrument understands.
    , Settings -> Maybe ControlValMap
config_control_defaults :: !(Maybe ScoreT.ControlValMap)
    } deriving (Settings -> Settings -> Bool
(Settings -> Settings -> Bool)
-> (Settings -> Settings -> Bool) -> Eq Settings
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Settings -> Settings -> Bool
$c/= :: Settings -> Settings -> Bool
== :: Settings -> Settings -> Bool
$c== :: Settings -> Settings -> Bool
Eq, Int -> Settings -> ShowS
[Settings] -> ShowS
Settings -> String
(Int -> Settings -> ShowS)
-> (Settings -> String) -> ([Settings] -> ShowS) -> Show Settings
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Settings] -> ShowS
$cshowList :: [Settings] -> ShowS
show :: Settings -> String
$cshow :: Settings -> String
showsPrec :: Int -> Settings -> ShowS
$cshowsPrec :: Int -> Settings -> ShowS
Show, (forall x. Settings -> Rep Settings x)
-> (forall x. Rep Settings x -> Settings) -> Generic Settings
forall x. Rep Settings x -> Settings
forall x. Settings -> Rep Settings x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Settings x -> Settings
$cfrom :: forall x. Settings -> Rep Settings x
Generics.Generic)

instance Pretty Settings where format :: Settings -> Doc
format = Settings -> Doc
forall a. (PrettyG (Rep a), Generic a) => a -> Doc
Pretty.formatG_

instance Semigroup Settings where
    <> :: Settings -> Settings -> Settings
(<>)    (Settings Maybe (Set Flag)
flags1 Maybe Scale
scale1 Maybe RealTime
decay1 Maybe PbRange
pb_range1 Maybe ControlValMap
cdefaults1)
            (Settings Maybe (Set Flag)
flags2 Maybe Scale
scale2 Maybe RealTime
decay2 Maybe PbRange
pb_range2 Maybe ControlValMap
cdefaults2) =
        Maybe (Set Flag)
-> Maybe Scale
-> Maybe RealTime
-> Maybe PbRange
-> Maybe ControlValMap
-> Settings
Settings (Maybe (Set Flag)
flags1 Maybe (Set Flag) -> Maybe (Set Flag) -> Maybe (Set Flag)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (Set Flag)
flags2) (Maybe Scale
scale1 Maybe Scale -> Maybe Scale -> Maybe Scale
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Scale
scale2) (Maybe RealTime
decay1 Maybe RealTime -> Maybe RealTime -> Maybe RealTime
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe RealTime
decay2)
            (Maybe PbRange
pb_range1 Maybe PbRange -> Maybe PbRange -> Maybe PbRange
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe PbRange
pb_range2) (Maybe ControlValMap
cdefaults1 Maybe ControlValMap -> Maybe ControlValMap -> Maybe ControlValMap
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe ControlValMap
cdefaults2)
instance Monoid Settings where
    mempty :: Settings
mempty = Settings
        { config_flags :: Maybe (Set Flag)
config_flags = Maybe (Set Flag)
forall a. Maybe a
Nothing
        , config_scale :: Maybe Scale
config_scale = Maybe Scale
forall a. Maybe a
Nothing
        , config_decay :: Maybe RealTime
config_decay = Maybe RealTime
forall a. Maybe a
Nothing
        , config_pitch_bend_range :: Maybe PbRange
config_pitch_bend_range = Maybe PbRange
forall a. Maybe a
Nothing
        , config_control_defaults :: Maybe ControlValMap
config_control_defaults = Maybe ControlValMap
forall a. Maybe a
Nothing
        }
    mappend :: Settings -> Settings -> Settings
mappend = Settings -> Settings -> Settings
forall a. Semigroup a => a -> a -> a
(<>)

pitch_bend_range :: Settings :-> Maybe PbRange
pitch_bend_range = (Settings -> Maybe PbRange)
-> ((Maybe PbRange -> Maybe PbRange) -> Settings -> Settings)
-> Settings :-> Maybe PbRange
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Settings -> Maybe PbRange
config_pitch_bend_range
    (\Maybe PbRange -> Maybe PbRange
f Settings
r -> Settings
r { config_pitch_bend_range :: Maybe PbRange
config_pitch_bend_range = Maybe PbRange -> Maybe PbRange
f (Settings -> Maybe PbRange
config_pitch_bend_range Settings
r) })
decay :: Settings :-> Maybe RealTime
decay = (Settings -> Maybe RealTime)
-> ((Maybe RealTime -> Maybe RealTime) -> Settings -> Settings)
-> Settings :-> Maybe RealTime
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Settings -> Maybe RealTime
config_decay
    (\Maybe RealTime -> Maybe RealTime
f Settings
r -> Settings
r { config_decay :: Maybe RealTime
config_decay = Maybe RealTime -> Maybe RealTime
f (Settings -> Maybe RealTime
config_decay Settings
r) })
scale :: Settings :-> Maybe Scale
scale = (Settings -> Maybe Scale)
-> ((Maybe Scale -> Maybe Scale) -> Settings -> Settings)
-> Settings :-> Maybe Scale
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Settings -> Maybe Scale
config_scale
    (\Maybe Scale -> Maybe Scale
f Settings
r -> Settings
r { config_scale :: Maybe Scale
config_scale = Maybe Scale -> Maybe Scale
f (Settings -> Maybe Scale
config_scale Settings
r) })
flags :: Lens Settings (Maybe (Set Flag))
flags = (Settings -> Maybe (Set Flag))
-> ((Maybe (Set Flag) -> Maybe (Set Flag)) -> Settings -> Settings)
-> Lens Settings (Maybe (Set Flag))
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Settings -> Maybe (Set Flag)
config_flags
    (\Maybe (Set Flag) -> Maybe (Set Flag)
f Settings
r -> Settings
r { config_flags :: Maybe (Set Flag)
config_flags = Maybe (Set Flag) -> Maybe (Set Flag)
f (Settings -> Maybe (Set Flag)
config_flags Settings
r) })
control_defaults :: Settings :-> Maybe ControlValMap
control_defaults = (Settings -> Maybe ControlValMap)
-> ((Maybe ControlValMap -> Maybe ControlValMap)
    -> Settings -> Settings)
-> Settings :-> Maybe ControlValMap
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Settings -> Maybe ControlValMap
config_control_defaults
    (\Maybe ControlValMap -> Maybe ControlValMap
f Settings
r -> Settings
r { config_control_defaults :: Maybe ControlValMap
config_control_defaults = Maybe ControlValMap -> Maybe ControlValMap
f (Settings -> Maybe ControlValMap
config_control_defaults Settings
r) })

-- * Patch

-- | A Patch has information about one specific instrument.  The performance
-- 'Instrument' and MIDI config are derived from it, via its
-- 'Instrument.Inst.Synth'.
data Patch = Patch {
    -- | This is the name of the instrument on the synthesizer, and likely has
    -- all sorts of wacky characters in it, and may not be unique, even on
    -- a single synth.  This is just for documentation, and is not actually
    -- used by anyone, though the unique name may be derived from this one.
    --
    -- The patch's unique name, as used by 'InstT.Qualified' to look up
    -- the patch, is in 'Instrument.Inst.synth_insts'.
    Patch -> Key
patch_name :: !Text
    , Patch -> ControlMap
patch_control_map :: !Control.ControlMap
    , Patch -> InitializePatch
patch_initialize :: !InitializePatch
    , Patch -> AttributeMap
patch_attribute_map :: !AttributeMap
    , Patch -> ModeMap
patch_mode_map :: !ModeMap
    , Patch -> Settings
patch_defaults :: !Settings
    } deriving (Patch -> Patch -> Bool
(Patch -> Patch -> Bool) -> (Patch -> Patch -> Bool) -> Eq Patch
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Patch -> Patch -> Bool
$c/= :: Patch -> Patch -> Bool
== :: Patch -> Patch -> Bool
$c== :: Patch -> Patch -> Bool
Eq, Int -> Patch -> ShowS
[Patch] -> ShowS
Patch -> String
(Int -> Patch -> ShowS)
-> (Patch -> String) -> ([Patch] -> ShowS) -> Show Patch
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Patch] -> ShowS
$cshowList :: [Patch] -> ShowS
show :: Patch -> String
$cshow :: Patch -> String
showsPrec :: Int -> Patch -> ShowS
$cshowsPrec :: Int -> Patch -> ShowS
Show)

instance Pretty Patch where
    format :: Patch -> Doc
format (Patch Key
name ControlMap
cmap InitializePatch
init AttributeMap
attr_map ModeMap
mode_map Settings
defaults) =
        Doc -> [(Key, Doc)] -> Doc
Pretty.record Doc
"Patch"
            [ (Key
"name", Key -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Key
name)
            , (Key
"control_map", ControlMap -> Doc
forall a. Pretty a => a -> Doc
Pretty.format ControlMap
cmap)
            , (Key
"initialize", InitializePatch -> Doc
forall a. Pretty a => a -> Doc
Pretty.format InitializePatch
init)
            , (Key
"attribute_map", AttributeMap -> Doc
forall a. Pretty a => a -> Doc
Pretty.format AttributeMap
attr_map)
            , (Key
"mode_map", ModeMap -> Doc
forall a. Pretty a => a -> Doc
Pretty.format ModeMap
mode_map)
            , (Key
"defaults", Settings -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Settings
defaults)
            ]

name :: Patch :-> Key
name = (Patch -> Key) -> ((Key -> Key) -> Patch -> Patch) -> Patch :-> Key
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Patch -> Key
patch_name (\Key -> Key
f Patch
r -> Patch
r { patch_name :: Key
patch_name = Key -> Key
f (Patch -> Key
patch_name Patch
r) })
control_map :: Patch :-> ControlMap
control_map = (Patch -> ControlMap)
-> ((ControlMap -> ControlMap) -> Patch -> Patch)
-> Patch :-> ControlMap
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Patch -> ControlMap
patch_control_map
    (\ControlMap -> ControlMap
f Patch
r -> Patch
r { patch_control_map :: ControlMap
patch_control_map = ControlMap -> ControlMap
f (Patch -> ControlMap
patch_control_map Patch
r) })
initialize :: Patch :-> InitializePatch
initialize = (Patch -> InitializePatch)
-> ((InitializePatch -> InitializePatch) -> Patch -> Patch)
-> Patch :-> InitializePatch
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Patch -> InitializePatch
patch_initialize
    (\InitializePatch -> InitializePatch
f Patch
r -> Patch
r { patch_initialize :: InitializePatch
patch_initialize = InitializePatch -> InitializePatch
f (Patch -> InitializePatch
patch_initialize Patch
r) })
attribute_map :: Patch :-> AttributeMap
attribute_map = (Patch -> AttributeMap)
-> ((AttributeMap -> AttributeMap) -> Patch -> Patch)
-> Patch :-> AttributeMap
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Patch -> AttributeMap
patch_attribute_map
    (\AttributeMap -> AttributeMap
f Patch
r -> Patch
r { patch_attribute_map :: AttributeMap
patch_attribute_map = AttributeMap -> AttributeMap
f (Patch -> AttributeMap
patch_attribute_map Patch
r) })
mode_map :: Patch :-> ModeMap
mode_map = (Patch -> ModeMap)
-> ((ModeMap -> ModeMap) -> Patch -> Patch) -> Patch :-> ModeMap
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Patch -> ModeMap
patch_mode_map
    (\ModeMap -> ModeMap
f Patch
r -> Patch
r { patch_mode_map :: ModeMap
patch_mode_map = ModeMap -> ModeMap
f (Patch -> ModeMap
patch_mode_map Patch
r) })
defaults :: Patch :-> Settings
defaults = (Patch -> Settings)
-> ((Settings -> Settings) -> Patch -> Patch) -> Patch :-> Settings
forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Patch -> Settings
patch_defaults
    (\Settings -> Settings
f Patch
r -> Patch
r { patch_defaults :: Settings
patch_defaults = Settings -> Settings
f (Patch -> Settings
patch_defaults Patch
r) })

-- | Create a Patch with empty vals, to set them as needed.
patch :: Control.PbRange -> InstT.Name -> Patch
patch :: PbRange -> Key -> Patch
patch PbRange
pb_range Key
name = Patch
    { patch_name :: Key
patch_name = Key
name
    , patch_control_map :: ControlMap
patch_control_map = ControlMap
forall a. Monoid a => a
mempty
    , patch_initialize :: InitializePatch
patch_initialize = InitializePatch
NoInitialization
    , patch_attribute_map :: AttributeMap
patch_attribute_map = [(Attributes, ([Keyswitch], Maybe Keymap))] -> AttributeMap
forall a. [(Attributes, a)] -> AttributeMap a
Common.AttributeMap []
    , patch_mode_map :: ModeMap
patch_mode_map = Map Key ((Control, Double), Map MiniVal (Control, Double))
-> ModeMap
ModeMap Map Key ((Control, Double), Map MiniVal (Control, Double))
forall a. Monoid a => a
mempty
    , patch_defaults :: Settings
patch_defaults = Settings
forall a. Monoid a => a
mempty { config_pitch_bend_range :: Maybe PbRange
config_pitch_bend_range = PbRange -> Maybe PbRange
forall a. a -> Maybe a
Just PbRange
pb_range }
    }

-- | This is a convention for the default instrument of a synth.  This is
-- useful for softsynths whose patches all generally have the same config.
default_name :: InstT.Name
default_name :: Key
default_name = Key
""

-- ** Scale

{- | Describe the tuning of a MIDI patch.

    This is used both to describe a patch tuned to something other than 12TET,
    and to retune a 12TET patch.

    The Scale is used during performance to warp played pitches to the patch's
    tuning.  The idea is that they will warp to integral 'Midi.Key's that won't
    need any tuning and can thus all go on a single MIDI channel.
-}
data Scale = Scale {
    Scale -> Key
scale_name :: !Text
    -- | If a patch is tuned to something other than 12TET, this vector maps
    -- MIDI key numbers to their NNs, or 'no_pitch' if the patch doesn't
    -- support that key.
    , Scale -> Vector Double
scale_key_to_nn :: !(Unboxed.Vector Double)
    } deriving (Scale -> Scale -> Bool
(Scale -> Scale -> Bool) -> (Scale -> Scale -> Bool) -> Eq Scale
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Scale -> Scale -> Bool
$c/= :: Scale -> Scale -> Bool
== :: Scale -> Scale -> Bool
$c== :: Scale -> Scale -> Bool
Eq, Int -> Scale -> ShowS
[Scale] -> ShowS
Scale -> String
(Int -> Scale -> ShowS)
-> (Scale -> String) -> ([Scale] -> ShowS) -> Show Scale
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Scale] -> ShowS
$cshowList :: [Scale] -> ShowS
show :: Scale -> String
$cshow :: Scale -> String
showsPrec :: Int -> Scale -> ShowS
$cshowsPrec :: Int -> Scale -> ShowS
Show)

instance Pretty Scale where
    format :: Scale -> Doc
format (Scale Key
name Vector Double
_) = Key -> [Doc] -> Doc
Pretty.constructor Key
"Patch.Scale" [Key -> Doc
Pretty.text Key
name]
    -- format (Scale name key_to_nn) = Pretty.record "Patch.Scale"
    --     [ ("name", Pretty.format name)
    --     , ("key_to_nn", Pretty.format $
    --         List.dropWhileEnd (== -1) $ dropWhile (== -1) $
    --         Unboxed.toList key_to_nn)
    --     ]
    --     stripped xs =
    --         where ys = List.dropWhileEnd (== -1) $ dropWhile (== -1) xs

no_pitch :: Double
no_pitch :: Double
no_pitch = -Double
1

-- | Fill in non-adjacent MIDI keys by interpolating the neighboring
-- NoteNumbers.  This is because a 0 between two notes will prevent pitch
-- slides.  Another problem is that the MIDI performer has no notion of
-- instruments that don't support certain key numbers.  That could be added
-- but it's simpler to just not have patches like that.
make_scale :: Text -> [(Midi.Key, Pitch.NoteNumber)] -> Scale
make_scale :: Key -> [(Key, NoteNumber)] -> Scale
make_scale Key
name [(Key, NoteNumber)]
keys = Scale
    { scale_name :: Key
scale_name = Key
name
    , scale_key_to_nn :: Vector Double
scale_key_to_nn = Vector Double
empty Vector Double -> [(Int, Double)] -> Vector Double
forall a. Unbox a => Vector a -> [(Int, a)] -> Vector a
Unboxed.// ((Key, NoteNumber) -> (Int, Double))
-> [(Key, NoteNumber)] -> [(Int, Double)]
forall a b. (a -> b) -> [a] -> [b]
map (Key, NoteNumber) -> (Int, Double)
forall {a}. Num a => (Key, NoteNumber) -> (a, Double)
convert ([(Key, NoteNumber)] -> [(Key, NoteNumber)]
interpolate_gaps [(Key, NoteNumber)]
keys)
    }
    where
    convert :: (Key, NoteNumber) -> (a, Double)
convert (Key
k, Pitch.NoteNumber Double
nn) = (Key -> a
forall a. Num a => Key -> a
Midi.from_key Key
k, Double
nn)
    empty :: Vector Double
empty = [Double] -> Vector Double
forall a. Unbox a => [a] -> Vector a
Unboxed.fromList ([Double] -> Vector Double) -> [Double] -> Vector Double
forall a b. (a -> b) -> a -> b
$ Int -> Double -> [Double]
forall a. Int -> a -> [a]
replicate Int
128 Double
no_pitch

interpolate_gaps :: [(Midi.Key, Pitch.NoteNumber)]
    -> [(Midi.Key, Pitch.NoteNumber)]
interpolate_gaps :: [(Key, NoteNumber)] -> [(Key, NoteNumber)]
interpolate_gaps ((Key
k1, NoteNumber
nn1) : rest :: [(Key, NoteNumber)]
rest@((Key
k2, NoteNumber
nn2) : [(Key, NoteNumber)]
_))
    | Key
k1 Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1 Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
k2 = (Key
k1, NoteNumber
nn1) (Key, NoteNumber) -> [(Key, NoteNumber)] -> [(Key, NoteNumber)]
forall a. a -> [a] -> [a]
: [(Key, NoteNumber)] -> [(Key, NoteNumber)]
interpolate_gaps [(Key, NoteNumber)]
rest
    | Bool
otherwise = (Key
k1, NoteNumber
nn1) (Key, NoteNumber) -> [(Key, NoteNumber)] -> [(Key, NoteNumber)]
forall a. a -> [a] -> [a]
: (Key -> (Key, NoteNumber)) -> [Key] -> [(Key, NoteNumber)]
forall a b. (a -> b) -> [a] -> [b]
map Key -> (Key, NoteNumber)
mk (Key -> Key -> Key -> [Key]
forall a. (Num a, Ord a) => a -> a -> a -> [a]
Seq.range' (Key
k1Key -> Key -> Key
forall a. Num a => a -> a -> a
+Key
1) Key
k2 Key
1)
        [(Key, NoteNumber)] -> [(Key, NoteNumber)] -> [(Key, NoteNumber)]
forall a. [a] -> [a] -> [a]
++ [(Key, NoteNumber)] -> [(Key, NoteNumber)]
interpolate_gaps [(Key, NoteNumber)]
rest
    where
    mk :: Key -> (Key, NoteNumber)
mk Key
k = (Key
k, NoteNumber
nn)
        where
        nn :: NoteNumber
nn = NoteNumber -> NoteNumber -> NoteNumber -> NoteNumber
forall a. (Eq a, Num a) => a -> a -> a -> a
Num.scale NoteNumber
nn1 NoteNumber
nn2 (NoteNumber -> NoteNumber) -> NoteNumber -> NoteNumber
forall a b. (a -> b) -> a -> b
$ NoteNumber -> NoteNumber -> NoteNumber -> NoteNumber
forall a. (Eq a, Fractional a) => a -> a -> a -> a
Num.normalize
            (Key -> NoteNumber
forall a. Num a => Key -> a
Midi.from_key Key
k1) (Key -> NoteNumber
forall a. Num a => Key -> a
Midi.from_key Key
k2) (Key -> NoteNumber
forall a. Num a => Key -> a
Midi.from_key Key
k)
interpolate_gaps [(Key, NoteNumber)]
xs = [(Key, NoteNumber)]
xs

convert_scale :: Scale -> Pitch.NoteNumber -- ^ if you want this pitch
    -> Maybe Pitch.NoteNumber -- ^ play this key
convert_scale :: Scale -> NoteNumber -> Maybe NoteNumber
convert_scale (Scale Key
_ Vector Double
scale) (Pitch.NoteNumber Double
nn) =
    case Vector Double -> Double -> Maybe (Int, Double, Double)
Util.Vector.bracket Vector Double
scale Double
nn of
        Just (Int
i, Double
low, Double
high) | Double
low Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double
no_pitch ->
            NoteNumber -> Maybe NoteNumber
forall a. a -> Maybe a
Just (NoteNumber -> Maybe NoteNumber) -> NoteNumber -> Maybe NoteNumber
forall a b. (a -> b) -> a -> b
$ Double -> NoteNumber
Pitch.NoteNumber (Double -> NoteNumber) -> Double -> NoteNumber
forall a b. (a -> b) -> a -> b
$ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double -> Double -> Double -> Double
forall a. (Eq a, Fractional a) => a -> a -> a -> a
Num.normalize Double
low Double
high Double
nn
        Maybe (Int, Double, Double)
_ -> Maybe NoteNumber
forall a. Maybe a
Nothing

-- *** tuning

-- | Absolute NoteNumber for each 'Midi.Key' to tune 12TET to this scale.
scale_nns :: Maybe AttributeMap -> Scale -> [(Midi.Key, Pitch.NoteNumber)]
scale_nns :: Maybe AttributeMap -> Scale -> [(Key, NoteNumber)]
scale_nns Maybe AttributeMap
attr_map Scale
scale =
    [(Key
key, NoteNumber
nn) | (Key
key, Just (Key
_, NoteNumber
nn)) <- [Key]
-> [Maybe (Key, NoteNumber)] -> [(Key, Maybe (Key, NoteNumber))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Key
0..] (Maybe AttributeMap -> Scale -> [Maybe (Key, NoteNumber)]
scale_tuning Maybe AttributeMap
attr_map Scale
scale)]

-- | Relative NoteNumber offset for each 'Midi.Key' to tune 12TET to this scale.
scale_offsets :: Maybe AttributeMap -> Scale -> [Maybe Pitch.NoteNumber]
scale_offsets :: Maybe AttributeMap -> Scale -> [Maybe NoteNumber]
scale_offsets Maybe AttributeMap
attr_map = (Maybe (Key, NoteNumber) -> Maybe NoteNumber)
-> [Maybe (Key, NoteNumber)] -> [Maybe NoteNumber]
forall a b. (a -> b) -> [a] -> [b]
map (((Key, NoteNumber) -> NoteNumber)
-> Maybe (Key, NoteNumber) -> Maybe NoteNumber
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Key, NoteNumber) -> NoteNumber
forall {a}. Num a => (Key, a) -> a
to_offset) ([Maybe (Key, NoteNumber)] -> [Maybe NoteNumber])
-> (Scale -> [Maybe (Key, NoteNumber)])
-> Scale
-> [Maybe NoteNumber]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe AttributeMap -> Scale -> [Maybe (Key, NoteNumber)]
scale_tuning Maybe AttributeMap
attr_map
    where to_offset :: (Key, a) -> a
to_offset (Key
base, a
nn) = a
nn a -> a -> a
forall a. Num a => a -> a -> a
- Key -> a
forall a. Num a => Key -> a
Midi.from_key Key
base

-- | Map the mapped keys through the scale.
scale_tuning :: Maybe AttributeMap -> Scale
    -> [Maybe (Midi.Key, Pitch.NoteNumber)]
scale_tuning :: Maybe AttributeMap -> Scale -> [Maybe (Key, NoteNumber)]
scale_tuning Maybe AttributeMap
attr_map Scale
scale = (Key -> Maybe (Key, NoteNumber))
-> [Key] -> [Maybe (Key, NoteNumber)]
forall a b. (a -> b) -> [a] -> [b]
map Key -> Maybe (Key, NoteNumber)
tuning [Key
0..Key
127]
    where
    tuning :: Key -> Maybe (Key, NoteNumber)
tuning Key
key
        | [(Key, Key, Key)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Key, Key, Key)]
ranges = (Key
key,) (NoteNumber -> (Key, NoteNumber))
-> Maybe NoteNumber -> Maybe (Key, NoteNumber)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Scale -> Key -> Maybe NoteNumber
nn_at Scale
scale Key
key
        | Bool
otherwise = case ((Key, Key, Key) -> Bool)
-> [(Key, Key, Key)] -> Maybe (Key, Key, Key)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (Key -> (Key, Key, Key) -> Bool
forall {a} {c}. Ord a => a -> (a, a, c) -> Bool
in_range Key
key) [(Key, Key, Key)]
ranges of
            Maybe (Key, Key, Key)
Nothing -> Maybe (Key, NoteNumber)
forall a. Maybe a
Nothing
            Just (Key
low, Key
_, Key
base_nn) -> (Key
abs_key,) (NoteNumber -> (Key, NoteNumber))
-> Maybe NoteNumber -> Maybe (Key, NoteNumber)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Scale -> Key -> Maybe NoteNumber
nn_at Scale
scale Key
abs_key
                where abs_key :: Key
abs_key = Key
base_nn Key -> Key -> Key
forall a. Num a => a -> a -> a
+ (Key
key Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
low)
    in_range :: a -> (a, a, c) -> Bool
in_range a
key (a
low, a
high, c
_) = a
low a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
key Bool -> Bool -> Bool
&& a
key a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
high
    ranges :: [(Key, Key, Key)]
ranges =
        [ (Key
low, Key
high, Key
nn)
        | ([Keyswitch]
_, Just (PitchedKeymap Key
low Key
high Key
nn))
            <- [([Keyswitch], Maybe Keymap)]
-> (AttributeMap -> [([Keyswitch], Maybe Keymap)])
-> Maybe AttributeMap
-> [([Keyswitch], Maybe Keymap)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] AttributeMap -> [([Keyswitch], Maybe Keymap)]
forall a. AttributeMap a -> [a]
Common.attribute_vals Maybe AttributeMap
attr_map
        ]

nn_at :: Scale -> Midi.Key -> Maybe Pitch.NoteNumber
nn_at :: Scale -> Key -> Maybe NoteNumber
nn_at Scale
scale Key
key
    | Key
key Key -> Key -> Bool
forall a. Ord a => a -> a -> Bool
>= Key
0 Bool -> Bool -> Bool
&& Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Vector Double -> Int
forall a. Unbox a => Vector a -> Int
Unboxed.length (Scale -> Vector Double
scale_key_to_nn Scale
scale) =
        if Double
nn Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
no_pitch then Maybe NoteNumber
forall a. Maybe a
Nothing else NoteNumber -> Maybe NoteNumber
forall a. a -> Maybe a
Just (Double -> NoteNumber
forall a. Real a => a -> NoteNumber
Pitch.nn Double
nn)
    | Bool
otherwise = Maybe NoteNumber
forall a. Maybe a
Nothing
    where
    k :: Int
k = Key -> Int
forall a. Num a => Key -> a
Midi.from_key Key
key
    nn :: Double
nn = Scale -> Vector Double
scale_key_to_nn Scale
scale Vector Double -> Int -> Double
forall a. Unbox a => Vector a -> Int -> a
Unboxed.! Int
k

-- ** Flag

-- | Various instrument flags.  Add new ones at the bottom to avoid messing up
-- serialization.
data Flag =
    -- | Patch uses continuous pressure control, assigned to CC 2 (breath),
    -- instead of trigger velocity.  This is used to support the @dyn@ control.
    -- Percussive instruments like pianos map it to MIDI velocity, and
    -- continuous instruments like winds always have maximum velocity and map
    -- @dyn@ to breath.
    Pressure
    -- | If set, a keysitch has to be held while its note is playing.
    -- Otherwise, it will just be tapped before the note starts.
    | HoldKeyswitch
    -- | When playing from mid-score, scan backwards for the first overlapping
    -- notes with this instrument set and resume that note.  This way you can
    -- play long notes like tambura from the middle.
    | ResumePlay
    -- | If there are overlapping notes with the same MIDI key, delay all
    -- NoteOffs until the final one.  This is for synthesizers which turn the
    -- note off on the first one, such as Kontakt.
    --
    -- TODO: this is disabled, remove it entirely if I really don't seem to
    -- need it.  'Perform.Midi.Perform.avoid_overlaps'.
    | UseFinalNoteOff
    -- | Obsolete, don't use.
    | Old_Triggered
    deriving (Flag -> Flag -> Bool
(Flag -> Flag -> Bool) -> (Flag -> Flag -> Bool) -> Eq Flag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Flag -> Flag -> Bool
$c/= :: Flag -> Flag -> Bool
== :: Flag -> Flag -> Bool
$c== :: Flag -> Flag -> Bool
Eq, Eq Flag
Eq Flag
-> (Flag -> Flag -> Ordering)
-> (Flag -> Flag -> Bool)
-> (Flag -> Flag -> Bool)
-> (Flag -> Flag -> Bool)
-> (Flag -> Flag -> Bool)
-> (Flag -> Flag -> Flag)
-> (Flag -> Flag -> Flag)
-> Ord Flag
Flag -> Flag -> Bool
Flag -> Flag -> Ordering
Flag -> Flag -> Flag
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Flag -> Flag -> Flag
$cmin :: Flag -> Flag -> Flag
max :: Flag -> Flag -> Flag
$cmax :: Flag -> Flag -> Flag
>= :: Flag -> Flag -> Bool
$c>= :: Flag -> Flag -> Bool
> :: Flag -> Flag -> Bool
$c> :: Flag -> Flag -> Bool
<= :: Flag -> Flag -> Bool
$c<= :: Flag -> Flag -> Bool
< :: Flag -> Flag -> Bool
$c< :: Flag -> Flag -> Bool
compare :: Flag -> Flag -> Ordering
$ccompare :: Flag -> Flag -> Ordering
Ord, Int -> Flag -> ShowS
[Flag] -> ShowS
Flag -> String
(Int -> Flag -> ShowS)
-> (Flag -> String) -> ([Flag] -> ShowS) -> Show Flag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Flag] -> ShowS
$cshowList :: [Flag] -> ShowS
show :: Flag -> String
$cshow :: Flag -> String
showsPrec :: Int -> Flag -> ShowS
$cshowsPrec :: Int -> Flag -> ShowS
Show, Flag
Flag -> Flag -> Bounded Flag
forall a. a -> a -> Bounded a
maxBound :: Flag
$cmaxBound :: Flag
minBound :: Flag
$cminBound :: Flag
Bounded, Int -> Flag
Flag -> Int
Flag -> [Flag]
Flag -> Flag
Flag -> Flag -> [Flag]
Flag -> Flag -> Flag -> [Flag]
(Flag -> Flag)
-> (Flag -> Flag)
-> (Int -> Flag)
-> (Flag -> Int)
-> (Flag -> [Flag])
-> (Flag -> Flag -> [Flag])
-> (Flag -> Flag -> [Flag])
-> (Flag -> Flag -> Flag -> [Flag])
-> Enum Flag
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Flag -> Flag -> Flag -> [Flag]
$cenumFromThenTo :: Flag -> Flag -> Flag -> [Flag]
enumFromTo :: Flag -> Flag -> [Flag]
$cenumFromTo :: Flag -> Flag -> [Flag]
enumFromThen :: Flag -> Flag -> [Flag]
$cenumFromThen :: Flag -> Flag -> [Flag]
enumFrom :: Flag -> [Flag]
$cenumFrom :: Flag -> [Flag]
fromEnum :: Flag -> Int
$cfromEnum :: Flag -> Int
toEnum :: Int -> Flag
$ctoEnum :: Int -> Flag
pred :: Flag -> Flag
$cpred :: Flag -> Flag
succ :: Flag -> Flag
$csucc :: Flag -> Flag
Enum)

instance Pretty Flag where pretty :: Flag -> Key
pretty = Flag -> Key
forall a. Show a => a -> Key
showt

add_flag :: Flag -> Set Flag -> Set Flag
add_flag :: Flag -> Set Flag -> Set Flag
add_flag = Flag -> Set Flag -> Set Flag
forall a. Ord a => a -> Set a -> Set a
Set.insert

remove_flag :: Flag -> Set Flag -> Set Flag
remove_flag :: Flag -> Set Flag -> Set Flag
remove_flag = Flag -> Set Flag -> Set Flag
forall a. Ord a => a -> Set a -> Set a
Set.delete

-- ** InitializePatch

-- | Describe how an instrument should be initialized before it can be played.
data InitializePatch =
    -- | Send these msgs to initialize the patch.  It should be a patch
    -- change or a sysex.  Channel is ignored.
    InitializeMidi ![Midi.Message]
    -- | Display this msg to the user and hope they do what it says.
    | InitializeMessage !Text
    | NoInitialization
    deriving (InitializePatch -> InitializePatch -> Bool
(InitializePatch -> InitializePatch -> Bool)
-> (InitializePatch -> InitializePatch -> Bool)
-> Eq InitializePatch
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InitializePatch -> InitializePatch -> Bool
$c/= :: InitializePatch -> InitializePatch -> Bool
== :: InitializePatch -> InitializePatch -> Bool
$c== :: InitializePatch -> InitializePatch -> Bool
Eq, Eq InitializePatch
Eq InitializePatch
-> (InitializePatch -> InitializePatch -> Ordering)
-> (InitializePatch -> InitializePatch -> Bool)
-> (InitializePatch -> InitializePatch -> Bool)
-> (InitializePatch -> InitializePatch -> Bool)
-> (InitializePatch -> InitializePatch -> Bool)
-> (InitializePatch -> InitializePatch -> InitializePatch)
-> (InitializePatch -> InitializePatch -> InitializePatch)
-> Ord InitializePatch
InitializePatch -> InitializePatch -> Bool
InitializePatch -> InitializePatch -> Ordering
InitializePatch -> InitializePatch -> InitializePatch
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: InitializePatch -> InitializePatch -> InitializePatch
$cmin :: InitializePatch -> InitializePatch -> InitializePatch
max :: InitializePatch -> InitializePatch -> InitializePatch
$cmax :: InitializePatch -> InitializePatch -> InitializePatch
>= :: InitializePatch -> InitializePatch -> Bool
$c>= :: InitializePatch -> InitializePatch -> Bool
> :: InitializePatch -> InitializePatch -> Bool
$c> :: InitializePatch -> InitializePatch -> Bool
<= :: InitializePatch -> InitializePatch -> Bool
$c<= :: InitializePatch -> InitializePatch -> Bool
< :: InitializePatch -> InitializePatch -> Bool
$c< :: InitializePatch -> InitializePatch -> Bool
compare :: InitializePatch -> InitializePatch -> Ordering
$ccompare :: InitializePatch -> InitializePatch -> Ordering
Ord, Int -> InitializePatch -> ShowS
[InitializePatch] -> ShowS
InitializePatch -> String
(Int -> InitializePatch -> ShowS)
-> (InitializePatch -> String)
-> ([InitializePatch] -> ShowS)
-> Show InitializePatch
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InitializePatch] -> ShowS
$cshowList :: [InitializePatch] -> ShowS
show :: InitializePatch -> String
$cshow :: InitializePatch -> String
showsPrec :: Int -> InitializePatch -> ShowS
$cshowsPrec :: Int -> InitializePatch -> ShowS
Show)

instance Pretty InitializePatch where
    format :: InitializePatch -> Doc
format (InitializeMidi [Message]
msgs) =
        Key -> Doc
Pretty.text Key
"InitializeMidi" Doc -> Doc -> Doc
Pretty.<+> [Message] -> Doc
forall a. Pretty a => a -> Doc
Pretty.format [Message]
msgs
    format InitializePatch
init = Key -> Doc
Pretty.text (InitializePatch -> Key
forall a. Show a => a -> Key
showt InitializePatch
init)

initialize_midi :: [Midi.ChannelMessage] -> InitializePatch
initialize_midi :: [ChannelMessage] -> InitializePatch
initialize_midi = [Message] -> InitializePatch
InitializeMidi ([Message] -> InitializePatch)
-> ([ChannelMessage] -> [Message])
-> [ChannelMessage]
-> InitializePatch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ChannelMessage -> Message) -> [ChannelMessage] -> [Message]
forall a b. (a -> b) -> [a] -> [b]
map (Velocity -> ChannelMessage -> Message
Midi.ChannelMessage Velocity
0)

-- ** AttributeMap

-- | This is a specialization of 'Common.AttributeMap' for MIDI.
-- You should use a constructor like 'keyswitches', which will call
-- 'Common.sort_attributes' to make sure there are no overlaps.
type AttributeMap = Common.AttributeMap ([Keyswitch], Maybe Keymap)

-- | A Keymap corresponds to a timbre selected by MIDI key range, rather than
-- keyswitches.  Unlike a keyswitch, this doesn't change the state of the MIDI
-- channel, so multiple keymapped notes can coexist, and keymap replaces the
-- pitch of the note.
data Keymap =
    -- | This ignores the event's pitch and instead emits the given MIDI key.
    -- This is appropriate for drumkit style patches, with a separate unpitched
    -- timbre on each key.
    UnpitchedKeymap !Midi.Key
    -- | The timbre is mapped over the inclusive MIDI key range from low to
    -- high, where the pitch of the low end of the range is given by the
    -- NoteNumber.  So this transposes the event's pitch and clips it to the
    -- given range.  low, high, nn
    | PitchedKeymap !Midi.Key !Midi.Key !Midi.Key
    deriving (Keymap -> Keymap -> Bool
(Keymap -> Keymap -> Bool)
-> (Keymap -> Keymap -> Bool) -> Eq Keymap
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Keymap -> Keymap -> Bool
$c/= :: Keymap -> Keymap -> Bool
== :: Keymap -> Keymap -> Bool
$c== :: Keymap -> Keymap -> Bool
Eq, Eq Keymap
Eq Keymap
-> (Keymap -> Keymap -> Ordering)
-> (Keymap -> Keymap -> Bool)
-> (Keymap -> Keymap -> Bool)
-> (Keymap -> Keymap -> Bool)
-> (Keymap -> Keymap -> Bool)
-> (Keymap -> Keymap -> Keymap)
-> (Keymap -> Keymap -> Keymap)
-> Ord Keymap
Keymap -> Keymap -> Bool
Keymap -> Keymap -> Ordering
Keymap -> Keymap -> Keymap
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Keymap -> Keymap -> Keymap
$cmin :: Keymap -> Keymap -> Keymap
max :: Keymap -> Keymap -> Keymap
$cmax :: Keymap -> Keymap -> Keymap
>= :: Keymap -> Keymap -> Bool
$c>= :: Keymap -> Keymap -> Bool
> :: Keymap -> Keymap -> Bool
$c> :: Keymap -> Keymap -> Bool
<= :: Keymap -> Keymap -> Bool
$c<= :: Keymap -> Keymap -> Bool
< :: Keymap -> Keymap -> Bool
$c< :: Keymap -> Keymap -> Bool
compare :: Keymap -> Keymap -> Ordering
$ccompare :: Keymap -> Keymap -> Ordering
Ord, Int -> Keymap -> ShowS
[Keymap] -> ShowS
Keymap -> String
(Int -> Keymap -> ShowS)
-> (Keymap -> String) -> ([Keymap] -> ShowS) -> Show Keymap
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Keymap] -> ShowS
$cshowList :: [Keymap] -> ShowS
show :: Keymap -> String
$cshow :: Keymap -> String
showsPrec :: Int -> Keymap -> ShowS
$cshowsPrec :: Int -> Keymap -> ShowS
Show)

instance Pretty Keymap where
    pretty :: Keymap -> Key
pretty (UnpitchedKeymap Key
k) = Key -> Key
forall a. Pretty a => a -> Key
pretty Key
k
    pretty (PitchedKeymap Key
low Key
high Key
nn) = Key -> Key
forall a. Pretty a => a -> Key
pretty Key
low Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> Key
"--"
        Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> Key -> Key
forall a. Pretty a => a -> Key
pretty Key
high Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> Key
"(" Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> Key -> Key
forall a. Pretty a => a -> Key
pretty Key
nn Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> Key
")"

-- | A Keyswitch changes the timbre of a patch, but does so in a channel-global
-- way.  So overlapping notes with different keyswitches will be split into
-- different channels, if possible.  See NOTE [midi-state].
data Keyswitch =
    Keyswitch !Midi.Key
    -- | This keyswitch is triggered by a control change.
    | ControlSwitch !Midi.Control !Midi.ControlValue
    -- | This is like 'ControlSwitch', except send a poly aftertouch value
    -- for the note's pitch.  This allows simultaneous different notes with
    -- different articulations.
    | Aftertouch !Midi.ControlValue
    deriving (Keyswitch -> Keyswitch -> Bool
(Keyswitch -> Keyswitch -> Bool)
-> (Keyswitch -> Keyswitch -> Bool) -> Eq Keyswitch
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Keyswitch -> Keyswitch -> Bool
$c/= :: Keyswitch -> Keyswitch -> Bool
== :: Keyswitch -> Keyswitch -> Bool
$c== :: Keyswitch -> Keyswitch -> Bool
Eq, Eq Keyswitch
Eq Keyswitch
-> (Keyswitch -> Keyswitch -> Ordering)
-> (Keyswitch -> Keyswitch -> Bool)
-> (Keyswitch -> Keyswitch -> Bool)
-> (Keyswitch -> Keyswitch -> Bool)
-> (Keyswitch -> Keyswitch -> Bool)
-> (Keyswitch -> Keyswitch -> Keyswitch)
-> (Keyswitch -> Keyswitch -> Keyswitch)
-> Ord Keyswitch
Keyswitch -> Keyswitch -> Bool
Keyswitch -> Keyswitch -> Ordering
Keyswitch -> Keyswitch -> Keyswitch
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Keyswitch -> Keyswitch -> Keyswitch
$cmin :: Keyswitch -> Keyswitch -> Keyswitch
max :: Keyswitch -> Keyswitch -> Keyswitch
$cmax :: Keyswitch -> Keyswitch -> Keyswitch
>= :: Keyswitch -> Keyswitch -> Bool
$c>= :: Keyswitch -> Keyswitch -> Bool
> :: Keyswitch -> Keyswitch -> Bool
$c> :: Keyswitch -> Keyswitch -> Bool
<= :: Keyswitch -> Keyswitch -> Bool
$c<= :: Keyswitch -> Keyswitch -> Bool
< :: Keyswitch -> Keyswitch -> Bool
$c< :: Keyswitch -> Keyswitch -> Bool
compare :: Keyswitch -> Keyswitch -> Ordering
$ccompare :: Keyswitch -> Keyswitch -> Ordering
Ord, Int -> Keyswitch -> ShowS
[Keyswitch] -> ShowS
Keyswitch -> String
(Int -> Keyswitch -> ShowS)
-> (Keyswitch -> String)
-> ([Keyswitch] -> ShowS)
-> Show Keyswitch
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Keyswitch] -> ShowS
$cshowList :: [Keyswitch] -> ShowS
show :: Keyswitch -> String
$cshow :: Keyswitch -> String
showsPrec :: Int -> Keyswitch -> ShowS
$cshowsPrec :: Int -> Keyswitch -> ShowS
Show)

instance DeepSeq.NFData Keymap where
    rnf :: Keymap -> ()
rnf (UnpitchedKeymap Key
k) = Key
k Key -> () -> ()
`seq` ()
    rnf (PitchedKeymap Key
k Key
_ Key
_) = Key
k Key -> () -> ()
`seq` ()

instance DeepSeq.NFData Keyswitch where
    rnf :: Keyswitch -> ()
rnf Keyswitch
k = Keyswitch
k Keyswitch -> () -> ()
`seq` () -- already strict

instance Pretty Keyswitch where
    format :: Keyswitch -> Doc
format (Keyswitch Key
key) = Doc
"key:" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Key -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Key
key
    format (ControlSwitch Velocity
cc Velocity
val) =
        Doc
"cc:" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Velocity -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Velocity
cc Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"/" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Velocity -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Velocity
val
    format (Aftertouch Velocity
val) = Doc
"at:" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Velocity -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Velocity
val

-- | Merge keyswitches for the mempty attrs.  This is because a patch may have
-- several kinds of state, which need to be undone to go back to the default
-- state.  There's less reason to overlap for non-empty attrs.
combine_empty :: [(Attrs.Attributes, [ks])] -> [(Attrs.Attributes, [ks])]
combine_empty :: forall ks. [(Attributes, [ks])] -> [(Attributes, [ks])]
combine_empty [(Attributes, [ks])]
attr_ks
    | [(Attributes, [ks])] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Attributes, [ks])]
empty = [(Attributes, [ks])]
nonempty
    | Bool
otherwise = (Attributes
forall a. Monoid a => a
mempty, ((Attributes, [ks]) -> [ks]) -> [(Attributes, [ks])] -> [ks]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Attributes, [ks]) -> [ks]
forall a b. (a, b) -> b
snd [(Attributes, [ks])]
empty) (Attributes, [ks]) -> [(Attributes, [ks])] -> [(Attributes, [ks])]
forall a. a -> [a] -> [a]
: [(Attributes, [ks])]
nonempty
    where
    ([(Attributes, [ks])]
empty, [(Attributes, [ks])]
nonempty) = ((Attributes, [ks]) -> Bool)
-> [(Attributes, [ks])]
-> ([(Attributes, [ks])], [(Attributes, [ks])])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition ((Attributes -> Attributes -> Bool
forall a. Eq a => a -> a -> Bool
==Attributes
forall a. Monoid a => a
mempty) (Attributes -> Bool)
-> ((Attributes, [ks]) -> Attributes) -> (Attributes, [ks]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Attributes, [ks]) -> Attributes
forall a b. (a, b) -> a
fst) [(Attributes, [ks])]
attr_ks

-- | An AttributeMap with a single Midi.Key keyswitch per Attribute.
single_keyswitches :: [(Attrs.Attributes, Midi.Key)] -> AttributeMap
single_keyswitches :: [(Attributes, Key)] -> AttributeMap
single_keyswitches = [(Attributes, [Keyswitch])] -> AttributeMap
keyswitches ([(Attributes, [Keyswitch])] -> AttributeMap)
-> ([(Attributes, Key)] -> [(Attributes, [Keyswitch])])
-> [(Attributes, Key)]
-> AttributeMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Attributes, Key) -> (Attributes, [Keyswitch]))
-> [(Attributes, Key)] -> [(Attributes, [Keyswitch])]
forall a b. (a -> b) -> [a] -> [b]
map ((Key -> [Keyswitch])
-> (Attributes, Key) -> (Attributes, [Keyswitch])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((Keyswitch -> [Keyswitch] -> [Keyswitch]
forall a. a -> [a] -> [a]
:[]) (Keyswitch -> [Keyswitch])
-> (Key -> Keyswitch) -> Key -> [Keyswitch]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Keyswitch
Keyswitch))

-- | An AttributeMap that uses 'ControlSwitch'es.  Each CC can have attrs at
-- several values.
cc_keyswitches :: [(Midi.Control, [(Attrs.Attributes, Midi.ControlValue)])]
    -> AttributeMap
cc_keyswitches :: [(Velocity, [(Attributes, Velocity)])] -> AttributeMap
cc_keyswitches [(Velocity, [(Attributes, Velocity)])]
ks = [(Attributes, [Keyswitch])] -> AttributeMap
keyswitches
    [ (Attributes
attrs, [Velocity -> Velocity -> Keyswitch
ControlSwitch Velocity
cc Velocity
val])
    | (Velocity
cc, [(Attributes, Velocity)]
attr_controls) <- [(Velocity, [(Attributes, Velocity)])]
ks
    , (Attributes
attrs, Velocity
val) <- [(Attributes, Velocity)]
attr_controls
    ]

-- | Like 'cc_keyswitches', except that all the controls are orthogonal, so
-- every cross-control combination of attributes is valid.
cc_keyswitches_permute
    :: [(Midi.Control, [(Attrs.Attributes, Midi.ControlValue)])] -> AttributeMap
cc_keyswitches_permute :: [(Velocity, [(Attributes, Velocity)])] -> AttributeMap
cc_keyswitches_permute [(Velocity, [(Attributes, Velocity)])]
ks =
    [(Attributes, [Keyswitch])] -> AttributeMap
keyswitches ([(Attributes, [Keyswitch])] -> AttributeMap)
-> [(Attributes, [Keyswitch])] -> AttributeMap
forall a b. (a -> b) -> a -> b
$ ([(Attributes, Keyswitch)] -> (Attributes, [Keyswitch]))
-> [[(Attributes, Keyswitch)]] -> [(Attributes, [Keyswitch])]
forall a b. (a -> b) -> [a] -> [b]
map (([Attributes] -> Attributes)
-> ([Attributes], [Keyswitch]) -> (Attributes, [Keyswitch])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [Attributes] -> Attributes
forall a. Monoid a => [a] -> a
mconcat (([Attributes], [Keyswitch]) -> (Attributes, [Keyswitch]))
-> ([(Attributes, Keyswitch)] -> ([Attributes], [Keyswitch]))
-> [(Attributes, Keyswitch)]
-> (Attributes, [Keyswitch])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Attributes, Keyswitch)] -> ([Attributes], [Keyswitch])
forall a b. [(a, b)] -> ([a], [b])
unzip) ([[(Attributes, Keyswitch)]] -> [(Attributes, [Keyswitch])])
-> [[(Attributes, Keyswitch)]] -> [(Attributes, [Keyswitch])]
forall a b. (a -> b) -> a -> b
$ [[(Attributes, Keyswitch)]] -> [[(Attributes, Keyswitch)]]
forall a. [[a]] -> [[a]]
Seq.cartesian
        [ [(Attributes
attrs, Velocity -> Velocity -> Keyswitch
ControlSwitch Velocity
cc Velocity
val) | (Attributes
attrs, Velocity
val) <- [(Attributes, Velocity)]
attr_controls]
        | (Velocity
cc, [(Attributes, Velocity)]
attr_controls) <- [(Velocity, [(Attributes, Velocity)])]
ks
        ]

-- | An AttributeMap with just 'Keyswitch'es.
keyswitches :: [(Attrs.Attributes, [Keyswitch])] -> AttributeMap
keyswitches :: [(Attributes, [Keyswitch])] -> AttributeMap
keyswitches [(Attributes, [Keyswitch])]
attr_ks = [(Attributes, ([Keyswitch], Maybe Keymap))] -> AttributeMap
forall a. [(Attributes, a)] -> AttributeMap a
Common.attribute_map
    [ (Attributes
attrs, ([Keyswitch]
ks, Maybe Keymap
forall a. Maybe a
Nothing))
    | (Attributes
attrs, [Keyswitch]
ks) <- [(Attributes, [Keyswitch])] -> [(Attributes, [Keyswitch])]
forall ks. [(Attributes, [ks])] -> [(Attributes, [ks])]
combine_empty [(Attributes, [Keyswitch])]
attr_ks
    ]

-- | An AttributeMap with just 'Keymap's.
keymap :: [(Attrs.Attributes, Keymap)] -> AttributeMap
keymap :: [(Attributes, Keymap)] -> AttributeMap
keymap [(Attributes, Keymap)]
table =
    [(Attributes, ([Keyswitch], Maybe Keymap))] -> AttributeMap
forall a. [(Attributes, a)] -> AttributeMap a
Common.attribute_map [(Attributes
attr, ([], Keymap -> Maybe Keymap
forall a. a -> Maybe a
Just Keymap
keymap)) | (Attributes
attr, Keymap
keymap) <- [(Attributes, Keymap)]
table]

-- | An AttributeMap with just unpitched keymaps.
unpitched_keymap :: [(Attrs.Attributes, Midi.Key)] -> AttributeMap
unpitched_keymap :: [(Attributes, Key)] -> AttributeMap
unpitched_keymap = [(Attributes, Keymap)] -> AttributeMap
keymap ([(Attributes, Keymap)] -> AttributeMap)
-> ([(Attributes, Key)] -> [(Attributes, Keymap)])
-> [(Attributes, Key)]
-> AttributeMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Attributes, Key) -> (Attributes, Keymap))
-> [(Attributes, Key)] -> [(Attributes, Keymap)]
forall a b. (a -> b) -> [a] -> [b]
map ((Key -> Keymap) -> (Attributes, Key) -> (Attributes, Keymap)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Key -> Keymap
UnpitchedKeymap)

-- | The MIDI message to activate the given Keyswitch.
keyswitch_on :: Midi.Key -> Keyswitch -> Midi.ChannelMessage
keyswitch_on :: Key -> Keyswitch -> ChannelMessage
keyswitch_on Key
midi_key Keyswitch
ks = case Keyswitch
ks of
    Keyswitch Key
key -> Key -> Velocity -> ChannelMessage
Midi.NoteOn Key
key Velocity
64
    ControlSwitch Velocity
cc Velocity
val -> Velocity -> Velocity -> ChannelMessage
Midi.ControlChange Velocity
cc Velocity
val
    Aftertouch Velocity
val -> Key -> Velocity -> ChannelMessage
Midi.Aftertouch Key
midi_key Velocity
val

keyswitch_off :: Keyswitch -> Maybe Midi.ChannelMessage
keyswitch_off :: Keyswitch -> Maybe ChannelMessage
keyswitch_off Keyswitch
ks = case Keyswitch
ks of
    Keyswitch Key
key -> ChannelMessage -> Maybe ChannelMessage
forall a. a -> Maybe a
Just (ChannelMessage -> Maybe ChannelMessage)
-> ChannelMessage -> Maybe ChannelMessage
forall a b. (a -> b) -> a -> b
$ Key -> Velocity -> ChannelMessage
Midi.NoteOff Key
key Velocity
64
    ControlSwitch {} -> Maybe ChannelMessage
forall a. Maybe a
Nothing
    Aftertouch {} -> Maybe ChannelMessage
forall a. Maybe a
Nothing

-- ** ModeMap

-- | The ModeMap is like the 'AttributeMap', but it's triggered by the
-- event Environ, rather than Attributes.  This is suitable for modes which
-- have mutually exclusive settings.  See NOTE [midi-state].
newtype ModeMap =
    -- map Key to (default, val_to_switch)
    ModeMap (Map EnvKey.Key
        ((ScoreT.Control, Signal.Y),
            Map Expr.MiniVal (ScoreT.Control, Signal.Y)))
    deriving (ModeMap -> ModeMap -> Bool
(ModeMap -> ModeMap -> Bool)
-> (ModeMap -> ModeMap -> Bool) -> Eq ModeMap
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ModeMap -> ModeMap -> Bool
$c/= :: ModeMap -> ModeMap -> Bool
== :: ModeMap -> ModeMap -> Bool
$c== :: ModeMap -> ModeMap -> Bool
Eq, Int -> ModeMap -> ShowS
[ModeMap] -> ShowS
ModeMap -> String
(Int -> ModeMap -> ShowS)
-> (ModeMap -> String) -> ([ModeMap] -> ShowS) -> Show ModeMap
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ModeMap] -> ShowS
$cshowList :: [ModeMap] -> ShowS
show :: ModeMap -> String
$cshow :: ModeMap -> String
showsPrec :: Int -> ModeMap -> ShowS
$cshowsPrec :: Int -> ModeMap -> ShowS
Show, [ModeMap] -> Doc
ModeMap -> Key
ModeMap -> Doc
(ModeMap -> Key)
-> (ModeMap -> Doc) -> ([ModeMap] -> Doc) -> Pretty ModeMap
forall a. (a -> Key) -> (a -> Doc) -> ([a] -> Doc) -> Pretty a
formatList :: [ModeMap] -> Doc
$cformatList :: [ModeMap] -> Doc
format :: ModeMap -> Doc
$cformat :: ModeMap -> Doc
pretty :: ModeMap -> Key
$cpretty :: ModeMap -> Key
Pretty)

make_mode_map
    :: [(EnvKey.Key, [(Expr.MiniVal, (ScoreT.Control, Midi.ControlValue))])]
    -> ModeMap
make_mode_map :: [(Key, [(MiniVal, (Control, Velocity))])] -> ModeMap
make_mode_map =
    Map Key ((Control, Double), Map MiniVal (Control, Double))
-> ModeMap
ModeMap (Map Key ((Control, Double), Map MiniVal (Control, Double))
 -> ModeMap)
-> ([(Key, [(MiniVal, (Control, Velocity))])]
    -> Map Key ((Control, Double), Map MiniVal (Control, Double)))
-> [(Key, [(MiniVal, (Control, Velocity))])]
-> ModeMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Key, ((Control, Double), Map MiniVal (Control, Double)))]
-> Map Key ((Control, Double), Map MiniVal (Control, Double))
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Key, ((Control, Double), Map MiniVal (Control, Double)))]
 -> Map Key ((Control, Double), Map MiniVal (Control, Double)))
-> ([(Key, [(MiniVal, (Control, Velocity))])]
    -> [(Key, ((Control, Double), Map MiniVal (Control, Double)))])
-> [(Key, [(MiniVal, (Control, Velocity))])]
-> Map Key ((Control, Double), Map MiniVal (Control, Double))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(MiniVal, (Control, Velocity))]
 -> Maybe ((Control, Double), Map MiniVal (Control, Double)))
-> [(Key, [(MiniVal, (Control, Velocity))])]
-> [(Key, ((Control, Double), Map MiniVal (Control, Double)))]
forall b b2 a. (b -> Maybe b2) -> [(a, b)] -> [(a, b2)]
Seq.map_maybe_snd
        ([(MiniVal, (Control, Double))]
-> Maybe ((Control, Double), Map MiniVal (Control, Double))
forall {k} {a}. Ord k => [(k, a)] -> Maybe (a, Map k a)
env_val ([(MiniVal, (Control, Double))]
 -> Maybe ((Control, Double), Map MiniVal (Control, Double)))
-> ([(MiniVal, (Control, Velocity))]
    -> [(MiniVal, (Control, Double))])
-> [(MiniVal, (Control, Velocity))]
-> Maybe ((Control, Double), Map MiniVal (Control, Double))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((MiniVal, (Control, Velocity)) -> (MiniVal, (Control, Double)))
-> [(MiniVal, (Control, Velocity))]
-> [(MiniVal, (Control, Double))]
forall a b. (a -> b) -> [a] -> [b]
map (((Control, Velocity) -> (Control, Double))
-> (MiniVal, (Control, Velocity)) -> (MiniVal, (Control, Double))
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((Velocity -> Double) -> (Control, Velocity) -> (Control, Double)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Velocity -> Double
Control.cval_to_val)))
    where
    env_val :: [(k, a)] -> Maybe (a, Map k a)
env_val [] = Maybe (a, Map k a)
forall a. Maybe a
Nothing
    env_val modes :: [(k, a)]
modes@((k
_, a
deflt) : [(k, a)]
_) = (a, Map k a) -> Maybe (a, Map k a)
forall a. a -> Maybe a
Just ((a
deflt, [(k, a)] -> Map k a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(k, a)]
modes))

-- | Construct a ModeMap that uses MIDI CC.
cc_mode_map :: [(EnvKey.Key, Midi.Control, [(Expr.MiniVal, Midi.ControlValue)])]
    -> (ModeMap, [(Midi.Control, ScoreT.Control)])
cc_mode_map :: [(Key, Velocity, [(MiniVal, Velocity)])]
-> (ModeMap, [(Velocity, Control)])
cc_mode_map [(Key, Velocity, [(MiniVal, Velocity)])]
modes = (, [(Velocity, Control)]
controls) (ModeMap -> (ModeMap, [(Velocity, Control)]))
-> ModeMap -> (ModeMap, [(Velocity, Control)])
forall a b. (a -> b) -> a -> b
$ [(Key, [(MiniVal, (Control, Velocity))])] -> ModeMap
make_mode_map
    [ (Key
key, [(MiniVal
mini_val, (Key -> Control
control Key
key, Velocity
cval)) | (MiniVal
mini_val, Velocity
cval) <- [(MiniVal, Velocity)]
vals])
    | (Key
key, Velocity
_, [(MiniVal, Velocity)]
vals) <- [(Key, Velocity, [(MiniVal, Velocity)])]
modes
    ]
    where
    controls :: [(Velocity, Control)]
controls = [(Velocity
cc, Key -> Control
control Key
key) | (Key
key, Velocity
cc, [(MiniVal, Velocity)]
_) <- [(Key, Velocity, [(MiniVal, Velocity)])]
modes]
    control :: Key -> Control
control = Key -> Control
ScoreT.Control

{- NOTE [midi-state]
    notes:
      . There are several mechanisms to set state: controls, Patch.Keyswitch,
        Patch.ControlSwitch, Patch.Aftertouch, and Patch.ModeMap.
        Patch.control_defaults is the way to initialize state for controls,
        while Keyswitch and (I think) Aftertouch is handled by the keyswitch
        mechanism in Midi.Perform.
      . The problem is that I have to manually put ModeMap and ControlSwitch
        in control_defaults, otherwise the channel gets stuck in the last state.
        E.g. Patch.cc_mode_map has to return controls and defaults.
      . Also ControlSwitch keyswitches are no longer handled like other
        keyswitches, but are merged with controls in Midi.Convert.
      . Historically, keyswitches were just keyswitches, which are exclusive.
        But ControlSwitches were introduced to be non-exclusive.
    other issues:
      / I think cc keyswitches should combine by default, so I don't need
        Patch.cc_keyswitches_permute.
        . Maybe they shouldn't be in the AttributeMap then?  Keymaps are also in
          the AttributeMap, and those are exclusive.
        . Keymaps are mostly for percussion strokes, but maybe Attributes are
          not really suited because strokes are exclusive... except true
          modifiers like variations.
        . Patch.Aftertouch is used by Reyong, for exclusive: cek, mute, open.
        . Patch.ControlSwitch used by:
          CUtil.make_cc_keymap, used by mridangam and pakhawaj, which tret them
          exclusively.
        . Ok, so maybe all other uses are actually exclusive.  I can go with
          permutations for now, but if I wind up with more, then I would have
          a separate "inclusive" attribute map.
        . This only applies to MIDI, and not many MIDI instruments are that
          expressive.  If I do my own instruments, it'll be in im, and so
          I can do inclusive attributes or controls.
      . >pianoteq/harp could use Patch.cc_keyswitches_permute
      . I wanted to change Keyswitch to Midi.Key in MIDI Event, but aftertouch
        has no control equivalent.
      . What if I just got rid of Patch.ControlSwitch?  The only other use is
        kendang and mridangam switches, but maybe those are legit?  Why don't
        I have issues resetting mridangam strokes?
        . Maybe I do!  The fact that I get the wrong kin/tan implies that
          they're not being set for thru at least.
      . Maybe I just don't use them in swam.  I can use postproc to turn attrs
        into controls.
      . It's awkward how Patch.ControlSwitch is in low level cc num and val,
        because I have to convert to Score.Control and back again.
        . Also it's error prone how I have to both assign controls and defaults.
        . Can't I put in default modes as defaults just like keyswitches?
-}