{-# LANGUAGE CPP #-}
module Perform.Midi.Patch (
Config(..), config_addrs
, merge_defaults
, allocation, control_defaults, initialization, settings
, config
, Initialization(..), Addr, Voices
, has_flag
, Control.PbRange
, Settings(..)
, pitch_bend_range, decay, scale, flags
, Patch(..), name, control_map
, initialize, attribute_map, mode_map, defaults
, patch
, default_name
, Scale(..)
, make_scale
, convert_scale, nn_at
, scale_nns, scale_offsets, scale_tuning
, Flag(..)
, add_flag, remove_flag
, InitializePatch(..)
, initialize_midi
, AttributeMap, Keymap(..), Keyswitch(..)
, keyswitches, single_keyswitches, cc_keyswitches, cc_keyswitches_permute
, keymap, unpitched_keymap
, keyswitch_on, keyswitch_off
, 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
data Config = Config {
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_
data Initialization =
Tuning
| NrpnTuning
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
type Addr = (Midi.WriteDevice, Midi.Channel)
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)
data Settings = Settings {
Settings -> Maybe (Set Flag)
config_flags :: !(Maybe (Set Flag))
, Settings -> Maybe Scale
config_scale :: !(Maybe Scale)
, Settings -> Maybe RealTime
config_decay :: !(Maybe RealTime)
, Settings -> Maybe PbRange
config_pitch_bend_range :: !(Maybe Control.PbRange)
, 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) })
data Patch = Patch {
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) })
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 }
}
default_name :: InstT.Name
default_name :: Key
default_name = Key
""
data Scale = Scale {
Scale -> Key
scale_name :: !Text
, 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]
no_pitch :: Double
no_pitch :: Double
no_pitch = -Double
1
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
-> Maybe Pitch.NoteNumber
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
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)]
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
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
data Flag =
Pressure
| HoldKeyswitch
| ResumePlay
| UseFinalNoteOff
| 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
data InitializePatch =
InitializeMidi ![Midi.Message]
| 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)
type AttributeMap = Common.AttributeMap ([Keyswitch], Maybe Keymap)
data Keymap =
UnpitchedKeymap !Midi.Key
| 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
")"
data Keyswitch =
Keyswitch !Midi.Key
| ControlSwitch !Midi.Control !Midi.ControlValue
| 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` ()
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
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
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))
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
]
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
]
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
]
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]
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)
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
newtype ModeMap =
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))
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