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

-- | Vienna Symphonic Library.
module User.Elaforge.Instrument.Vsl where
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO

import qualified Util.Maps as Maps
import qualified Util.Seq as Seq
import qualified Util.Texts as Texts

import qualified Midi.Key as Key
import qualified Midi.Midi as Midi
import qualified Cmd.Instrument.MidiInst as MidiInst
import qualified Derive.Args as Args
import qualified Derive.Attrs as Attrs
import qualified Derive.C.Prelude.Articulation as Articulation
import qualified Derive.C.Prelude.Note as Note
import qualified Derive.C.Prelude.Trill as Trill
import qualified Derive.Call as Call
import qualified Derive.Call.GraceUtil as GraceUtil
import qualified Derive.Call.Make as Make
import qualified Derive.Call.Module as Module
import qualified Derive.Call.Post as Post
import qualified Derive.Call.Tags as Tags
import qualified Derive.Controls as Controls
import qualified Derive.Derive as Derive
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Library as Library
import qualified Derive.PSignal as PSignal
import qualified Derive.Parse as Parse
import qualified Derive.Score as Score
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Sig as Sig

import qualified Perform.Midi.Patch as Patch
import qualified Perform.Pitch as Pitch
import qualified Instrument.Common as Common
import qualified Instrument.InstT as InstT
import qualified Instrument.Tag as Tag

import qualified User.Elaforge.Instrument.VslInst as VslInst
import Global
import Types


synth :: MidiInst.Synth
synth :: Synth
synth = Text -> Text -> [Patch] -> Synth
MidiInst.synth Text
"vsl" Text
"Vienna Symphonic Library" ([Patch] -> Synth) -> [Patch] -> Synth
forall a b. (a -> b) -> a -> b
$
    [(Control, Control)] -> [Patch] -> [Patch]
MidiInst.synth_controls [(Control, Control)]
controls [Patch]
patches
    where
    controls :: [(Control, Control)]
controls =
        [ (Control
11, Control
"expression") -- apparently like cc7 volume?
        , (Control
22, Control
"attack") -- attack time
        , (Control
23, Control
"release") -- release time
        , (Control
24, Control
"filter") -- low pass filter
        , (Control
20, Control
"slot-xf") -- xfade between a and b slot positions
        , (Control
2,  Control
"velocity-xf") -- xfade between vel layers, set breath dyn
        , (Control
28, Control
"velocity-xf-on") -- velocity xfade on/off
        , (Control
29, Control
"rsamp-on") -- release samples on/off
        , (Control
25, Control
"delay") -- scale per patch delay
        , (Control
26, Control
"tuning") -- scale out of tune curve
        , (Control
27, Control
"humanize") -- scale both 'delay' and 'tuning'
        , (Control
30, Control
"dyn-range") -- scale effect of velocity
        , (Control
21, Control
"start-scaler") -- scale start offset
        , (Control
14, Control
"reverb") -- reverb wet
        , (Control
15, Control
"reverb-on") -- reverb on/off
        ]

-- * util

-- | For interactive use, find keyswitches with the given attributes.
find_attrs :: InstT.Name -> String -> [Text]
find_attrs :: Text -> String -> [Text]
find_attrs Text
inst String
with_attrs =
    (Attributes -> Text) -> [Attributes] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Attributes -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val ([Attributes] -> [Text]) -> [Attributes] -> [Text]
forall a b. (a -> b) -> a -> b
$ (Attributes -> Bool) -> [Attributes] -> [Attributes]
forall a. (a -> Bool) -> [a] -> [a]
filter (Attributes -> Attributes -> Bool
`Attrs.contain` Attributes
search)
        (Patch -> [Attributes]
patch_attributes (Patch -> Patch
MidiInst.patch_patch Patch
patch))
    where
    search :: Attributes
search = (Text -> Attributes)
-> (Attributes -> Attributes)
-> Either Text Attributes
-> Attributes
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Attributes
forall a. HasCallStack => String -> a
error (String -> Attributes) -> (Text -> String) -> Text -> Attributes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
untxt) Attributes -> Attributes
forall a. a -> a
id (String -> Either Text Attributes
Parse.parse_attrs String
with_attrs)
    patch :: Patch
patch = Patch -> Maybe Patch -> Patch
forall a. a -> Maybe a -> a
fromMaybe (String -> Patch
forall a. HasCallStack => String -> a
error (String -> Patch) -> String -> Patch
forall a b. (a -> b) -> a -> b
$ String
"patch not found: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
inst) (Maybe Patch -> Patch) -> Maybe Patch -> Patch
forall a b. (a -> b) -> a -> b
$
        (Patch -> Bool) -> [Patch] -> Maybe Patch
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
==Text
inst) (Text -> Bool) -> (Patch -> Text) -> Patch -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Patch -> Text
Patch.patch_name (Patch -> Text) -> (Patch -> Patch) -> Patch -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Patch -> Patch
MidiInst.patch_patch) [Patch]
patches

-- | Write matrices to a file for visual reference.
write_matrices :: IO ()
write_matrices :: IO ()
write_matrices = String -> Text -> IO ()
Text.IO.writeFile String
"matrices.txt" (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
    (((Instrument, Maybe HarmonicMap), Text) -> Text)
-> [((Instrument, Maybe HarmonicMap), Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Instrument -> Text
show_matrix (Instrument -> Text)
-> (((Instrument, Maybe HarmonicMap), Text) -> Instrument)
-> ((Instrument, Maybe HarmonicMap), Text)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Instrument, Maybe HarmonicMap) -> Instrument
forall a b. (a, b) -> a
fst ((Instrument, Maybe HarmonicMap) -> Instrument)
-> (((Instrument, Maybe HarmonicMap), Text)
    -> (Instrument, Maybe HarmonicMap))
-> ((Instrument, Maybe HarmonicMap), Text)
-> Instrument
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Instrument, Maybe HarmonicMap), Text)
-> (Instrument, Maybe HarmonicMap)
forall a b. (a, b) -> a
fst) [((Instrument, Maybe HarmonicMap), Text)]
instruments

show_matrix :: VslInst.Instrument -> Text
show_matrix :: Instrument -> Text
show_matrix (Text
name, Keys
_, [[Attributes]]
attrs) =
    Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unlines (([[Attributes]] -> Text) -> [[[Attributes]]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map [[Attributes]] -> Text
format [[[Attributes]]]
matrices)
    where
    matrices :: [[[Attributes]]]
matrices = Int -> [[Attributes]] -> [[[Attributes]]]
forall a. Int -> [a] -> [[a]]
Seq.chunked Int
cols ([[Attributes]] -> [[[Attributes]]])
-> [[Attributes]] -> [[[Attributes]]]
forall a b. (a -> b) -> a -> b
$ ([Attributes] -> [[Attributes]])
-> [[Attributes]] -> [[Attributes]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> [Attributes] -> [[Attributes]]
forall a. Int -> [a] -> [[a]]
Seq.chunked Int
cols)
        (([Attributes] -> [Attributes]) -> [[Attributes]] -> [[Attributes]]
forall a b. ([a] -> [b]) -> [[a]] -> [[b]]
map_shape [Attributes] -> [Attributes]
strip [[Attributes]]
attrs)
    format :: [[Attributes]] -> Text
format = [Text] -> Text
Text.unlines ([Text] -> Text)
-> ([[Attributes]] -> [Text]) -> [[Attributes]] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [[Text]] -> [Text]
Texts.columns Int
1
        ([[Text]] -> [Text])
-> ([[Attributes]] -> [[Text]]) -> [[Attributes]] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> [Text] -> [Text]) -> [Text] -> [[Text]] -> [[Text]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (:) [Text]
col_header ([[Text]] -> [[Text]])
-> ([[Attributes]] -> [[Text]]) -> [[Attributes]] -> [[Text]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Text]
header:) ([[Text]] -> [[Text]])
-> ([[Attributes]] -> [[Text]]) -> [[Attributes]] -> [[Text]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Attributes] -> [Text]) -> [[Attributes]] -> [[Text]]
forall a b. (a -> b) -> [a] -> [b]
map ((Attributes -> Text) -> [Attributes] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Attributes -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val)
    header :: [Text]
header = Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
take Int
cols ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ (Integer -> Text) -> [Integer] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> Text
forall a. Show a => a -> Text
showt [Integer
1..]
    col_header :: [Text]
col_header = Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
take (Int
colsInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ (Char -> Text) -> String -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Text
Text.singleton (String -> [Text]) -> String -> [Text]
forall a b. (a -> b) -> a -> b
$ Char
'-' Char -> String -> String
forall a. a -> [a] -> [a]
: [Char
'a'..]
    strip :: [Attributes] -> [Attributes]
strip = [Attributes] -> [Attributes]
strip_attrs ([Attributes] -> [Attributes])
-> ([Attributes] -> [Attributes]) -> [Attributes] -> [Attributes]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Attributes -> Attributes) -> [Attributes] -> [Attributes]
forall a b. (a -> b) -> [a] -> [b]
map (Attributes -> Attributes -> Attributes
`Attrs.difference` Attributes
variants)
    variants :: Attributes
variants = Attributes
VslInst.updown Attributes -> Attributes -> Attributes
forall a. Semigroup a => a -> a -> a
<> Attributes
VslInst.crescdim Attributes -> Attributes -> Attributes
forall a. Semigroup a => a -> a -> a
<> Attributes
VslInst.highlow
    cols :: Int
cols = Int
12

-- | Transform elements but retain the matrix's shape.
map_shape :: ([a] -> [b]) -> [[a]] -> [[b]]
map_shape :: forall a b. ([a] -> [b]) -> [[a]] -> [[b]]
map_shape [a] -> [b]
f [[a]]
rows = [Int] -> [b] -> [[b]]
forall {a}. [Int] -> [a] -> [[a]]
split (([a] -> Int) -> [[a]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[a]]
rows) ([b] -> [[b]]) -> [b] -> [[b]]
forall a b. (a -> b) -> a -> b
$ [a] -> [b]
f ([[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[a]]
rows)
    where
    split :: [Int] -> [a] -> [[a]]
split (Int
len:[Int]
lens) [a]
xs = [a]
pre [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [Int] -> [a] -> [[a]]
split [Int]
lens [a]
post
        where ([a]
pre, [a]
post) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
len [a]
xs
    split [] [a]
_ = []

-- * instrument definition

patches :: [MidiInst.Patch]
patches :: [Patch]
patches =
    [ Maybe HarmonicMap -> Patch -> Patch
open_strings Maybe HarmonicMap
hmap (Patch -> Patch) -> Patch -> Patch
forall a b. (a -> b) -> a -> b
$ Maybe HarmonicMap -> Patch -> Patch
add_code Maybe HarmonicMap
hmap (Instrument -> Text -> Patch
make_patch Instrument
inst Text
category)
    | ((Instrument
inst, Maybe HarmonicMap
hmap), Text
category) <- [((Instrument, Maybe HarmonicMap), Text)]
instruments
    ]
    where
    add_code :: Maybe HarmonicMap -> Patch -> Patch
add_code Maybe HarmonicMap
hmap Patch
patch = Lens Patch Code
MidiInst.code
        #= MidiInst.note_calls (note_calls hmap (MidiInst.patch_patch patch)) $
            Patch
patch
    open_strings :: Maybe HarmonicMap -> Patch -> Patch
open_strings Maybe HarmonicMap
Nothing = Patch -> Patch
forall a. a -> a
id
    open_strings (Just HarmonicMap
hmap) =
        Text -> [NoteNumber] -> Patch -> Patch
forall a. ToVal a => Text -> a -> Patch -> Patch
MidiInst.environ Text
EnvKey.open_strings (HarmonicMap -> [NoteNumber]
hmap_string_nns HarmonicMap
hmap)

instruments :: [((VslInst.Instrument, Maybe HarmonicMap), Text)]
instruments :: [((Instrument, Maybe HarmonicMap), Text)]
instruments = (([(Instrument, Maybe HarmonicMap)], Text)
 -> [((Instrument, Maybe HarmonicMap), Text)])
-> [([(Instrument, Maybe HarmonicMap)], Text)]
-> [((Instrument, Maybe HarmonicMap), Text)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([(Instrument, Maybe HarmonicMap)], Text)
-> [((Instrument, Maybe HarmonicMap), Text)]
forall {a} {t}. ([a], t) -> [(a, t)]
tag ([([(Instrument, Maybe HarmonicMap)], Text)]
 -> [((Instrument, Maybe HarmonicMap), Text)])
-> [([(Instrument, Maybe HarmonicMap)], Text)]
-> [((Instrument, Maybe HarmonicMap), Text)]
forall a b. (a -> b) -> a -> b
$
    ([(Instrument, Maybe HarmonicMap)]
solo_string_instruments, Text
Tag.c_strings)
    ([(Instrument, Maybe HarmonicMap)], Text)
-> [([(Instrument, Maybe HarmonicMap)], Text)]
-> [([(Instrument, Maybe HarmonicMap)], Text)]
forall a. a -> [a] -> [a]
: [([Instrument], Text)]
-> [([(Instrument, Maybe HarmonicMap)], Text)]
forall {a} {c} {a}. [([a], c)] -> [([(a, Maybe a)], c)]
no_hmap
    [ ([Instrument]
VslInst.strings, Text
Tag.c_strings)
    , ([Instrument]
VslInst.harps, Text
Tag.c_strings)
    , ([Instrument]
VslInst.woodwinds1, Text
Tag.c_woodwinds)
    , ([Instrument]
VslInst.woodwinds2, Text
Tag.c_woodwinds)
    , ([Instrument]
VslInst.brass1, Text
Tag.c_brass)
    ]
    where
    tag :: ([a], t) -> [(a, t)]
tag ([a]
inst, t
t) = (a -> (a, t)) -> [a] -> [(a, t)]
forall a b. (a -> b) -> [a] -> [b]
map (, t
t) [a]
inst
    no_hmap :: [([a], c)] -> [([(a, Maybe a)], c)]
no_hmap = (([a], c) -> ([(a, Maybe a)], c))
-> [([a], c)] -> [([(a, Maybe a)], c)]
forall a b. (a -> b) -> [a] -> [b]
map (([a] -> [(a, Maybe a)]) -> ([a], c) -> ([(a, Maybe a)], c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((a -> (a, Maybe a)) -> [a] -> [(a, Maybe a)]
forall a b. (a -> b) -> [a] -> [b]
map (, Maybe a
forall a. Maybe a
Nothing)))

solo_string_instruments :: [(VslInst.Instrument, Maybe HarmonicMap)]
solo_string_instruments :: [(Instrument, Maybe HarmonicMap)]
solo_string_instruments = ((Instrument, HarmonicMap) -> (Instrument, Maybe HarmonicMap))
-> [(Instrument, HarmonicMap)] -> [(Instrument, Maybe HarmonicMap)]
forall a b. (a -> b) -> [a] -> [b]
map ((HarmonicMap -> Maybe HarmonicMap)
-> (Instrument, HarmonicMap) -> (Instrument, Maybe HarmonicMap)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second HarmonicMap -> Maybe HarmonicMap
forall a. a -> Maybe a
Just)
    [ (Instrument
VslInst.solo_violin, HarmonicMap
violin_harmonics)
    , (Instrument
VslInst.solo_viola, HarmonicMap
viola_harmonics)
    , (Instrument
VslInst.solo_cello, HarmonicMap
cello_harmonics)
    , (Instrument
VslInst.solo_bass, HarmonicMap
bass_harmonics)
    ]

-- | Add various note calls, depending on the attributes that the patch
-- understands.
note_calls :: Maybe HarmonicMap -> Patch.Patch -> [MidiInst.Call Derive.Note]
note_calls :: Maybe HarmonicMap -> Patch -> [Call Note]
note_calls Maybe HarmonicMap
maybe_hmap Patch
patch = [[Call Note]] -> [Call Note]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ Attributes -> [Call Note] -> [Call Note]
forall {a}. Attributes -> [a] -> [a]
with_attr Attributes
Attrs.trill [Symbol -> Generator Note -> Call Note
forall {d}. Symbol -> Generator d -> Call d
g Symbol
"tr" (Bool -> Maybe Direction -> Maybe Direction -> Generator Note
Trill.c_note_trill Bool
True Maybe Direction
forall a. Maybe a
Nothing Maybe Direction
forall a. Maybe a
Nothing)]
    , Attributes -> [Call Note] -> [Call Note]
forall {a}. Attributes -> [a] -> [a]
with_attr Attributes
Attrs.trem [Symbol -> Generator Note -> Call Note
forall {d}. Symbol -> Generator d -> Call d
MidiInst.generator Symbol
"trem"
        (Maybe ([Attributes], Attributes) -> Generator Note
Trill.c_tremolo_generator (([Attributes], Attributes) -> Maybe ([Attributes], Attributes)
forall a. a -> Maybe a
Just ([Attributes
Attrs.harm], Attributes
VslInst.rep)))]
    , Attributes -> [Call Note] -> [Call Note]
forall {a}. Attributes -> [a] -> [a]
with_attr Attributes
VslInst.grace [Symbol -> Generator Note -> Call Note
forall {d}. Symbol -> Generator d -> Call d
g Symbol
"g" ([Attributes] -> Generator Note
grace_call (Patch -> [Attributes]
patch_attributes Patch
patch))]
    , Attributes -> [Call Note] -> [Call Note]
forall {a}. Attributes -> [a] -> [a]
with_attr Attributes
VslInst.legato
        [Symbol -> Generator Note -> Call Note
forall {d}. Symbol -> Generator d -> Call d
g Symbol
"(" (Attributes -> Attributes -> Generator Note
Articulation.c_attr_slur Attributes
VslInst.fa Attributes
Attrs.legato)]
    , Generator Note -> [Call Note]
MidiInst.null_calls (Patch -> Generator Note
note_call Patch
patch)
    , [Symbol -> Calls Note -> Call Note
forall d. Symbol -> Calls d -> Call d
MidiInst.both Symbol
"sec" Calls Note
c_infer_seconds]
    ]
    where
    g :: Symbol -> Generator d -> Call d
g = Symbol -> Generator d -> Call d
forall {d}. Symbol -> Generator d -> Call d
MidiInst.generator
    with_attr :: Attributes -> [a] -> [a]
with_attr Attributes
attr [a]
calls = if Attributes -> Patch -> Bool
has_attr Attributes
attr Patch
patch then [a]
calls else []
    note_call :: Patch -> Generator Note
note_call Patch
patch = CallName -> Doc -> Tags -> GenerateNote -> Generator Note
Note.note_call CallName
""
        Doc
"This is like the standard note call, but ignores attrs that are\
            \ already handled with keyswitches."
        Tags
forall a. Monoid a => a
mempty (GenerateNote -> Generator Note) -> GenerateNote -> Generator Note
forall a b. (a -> b) -> a -> b
$
        GenerateNote
-> (HarmonicMap -> GenerateNote)
-> Maybe HarmonicMap
-> GenerateNote
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Config -> GenerateNote
Note.default_note Config
config)
            (AttributeMap -> Config -> HarmonicMap -> GenerateNote
harmonic (Patch -> AttributeMap
Patch.patch_attribute_map Patch
patch) Config
config)
            Maybe HarmonicMap
maybe_hmap
        where config :: Config
config = Patch -> Config
note_config Patch
patch
    note_config :: Patch -> Config
note_config Patch
patch = Config
Note.use_attributes
        { config_staccato :: Bool
Note.config_staccato = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Attributes -> Patch -> Bool
has_attr Attributes
Attrs.staccato Patch
patch }

patch_attributes :: Patch.Patch -> [Attrs.Attributes]
patch_attributes :: Patch -> [Attributes]
patch_attributes = AttributeMap -> [Attributes]
forall a. AttributeMap a -> [Attributes]
Common.mapped_attributes (AttributeMap -> [Attributes])
-> (Patch -> AttributeMap) -> Patch -> [Attributes]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Patch -> AttributeMap
Patch.patch_attribute_map

has_attr :: Attrs.Attributes -> Patch.Patch -> Bool
has_attr :: Attributes -> Patch -> Bool
has_attr Attributes
attr = (Attributes -> Bool) -> [Attributes] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Attributes -> Attributes -> Bool
`Attrs.contain` Attributes
attr) ([Attributes] -> Bool) -> (Patch -> [Attributes]) -> Patch -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Patch -> [Attributes]
patch_attributes

grace_call :: [Attrs.Attributes] -> Derive.Generator Derive.Note
grace_call :: [Attributes] -> Generator Note
grace_call [Attributes]
attrs =
    Map Int Attributes -> Generator Note
GraceUtil.c_attr_grace ((Attributes -> Bool) -> Map Int Attributes -> Map Int Attributes
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Attributes -> [Attributes] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Attributes]
attrs) Map Int Attributes
grace_intervals)

grace_intervals :: Map Int Attrs.Attributes
grace_intervals :: Map Int Attributes
grace_intervals = [(Int, Attributes)] -> Map Int Attributes
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Int, Attributes)] -> Map Int Attributes)
-> [(Int, Attributes)] -> Map Int Attributes
forall a b. (a -> b) -> a -> b
$
    [(Int
n, Attributes
VslInst.grace Attributes -> Attributes -> Attributes
forall a. Semigroup a => a -> a -> a
<> Attributes
VslInst.up Attributes -> Attributes -> Attributes
forall a. Semigroup a => a -> a -> a
<> Attributes
attrs) | (Int
n, Attributes
attrs) <- [(Int, Attributes)]
ints]
    [(Int, Attributes)] -> [(Int, Attributes)] -> [(Int, Attributes)]
forall a. [a] -> [a] -> [a]
++ [(-Int
n, Attributes
VslInst.grace Attributes -> Attributes -> Attributes
forall a. Semigroup a => a -> a -> a
<> Attributes
VslInst.down Attributes -> Attributes -> Attributes
forall a. Semigroup a => a -> a -> a
<> Attributes
attrs) | (Int
n, Attributes
attrs) <- [(Int, Attributes)]
ints]
    where ints :: [(Int, Attributes)]
ints = [Int] -> [Attributes] -> [(Int, Attributes)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [Attributes]
VslInst.intervals_to_oct

-- | If +harm+nat (and optionally a string) attributes are present, try to
-- play this pitch as a natural harmonic.  That means replacing the pitch and
-- reapplying the default note call.
harmonic :: Patch.AttributeMap -> Note.Config -> HarmonicMap
    -> Note.GenerateNote
harmonic :: AttributeMap -> Config -> HarmonicMap -> GenerateNote
harmonic AttributeMap
attr_map Config
config HarmonicMap
hmap NoteArgs
args = do
    Attributes
attrs <- Deriver Attributes
Call.get_attributes
    let has :: Attributes -> Bool
has = Attributes -> Attributes -> Bool
Attrs.contain Attributes
attrs
    let matched :: Attributes
matched = Attributes
-> ((Attributes, ([Keyswitch], Maybe Keymap)) -> Attributes)
-> Maybe (Attributes, ([Keyswitch], Maybe Keymap))
-> Attributes
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Attributes
forall a. Monoid a => a
mempty (Attributes, ([Keyswitch], Maybe Keymap)) -> Attributes
forall a b. (a, b) -> a
fst (Maybe (Attributes, ([Keyswitch], Maybe Keymap)) -> Attributes)
-> Maybe (Attributes, ([Keyswitch], Maybe Keymap)) -> Attributes
forall a b. (a -> b) -> a -> b
$ Attributes
-> AttributeMap -> Maybe (Attributes, ([Keyswitch], Maybe Keymap))
forall a. Attributes -> AttributeMap a -> Maybe (Attributes, a)
Common.lookup_attributes Attributes
attrs AttributeMap
attr_map
    NoteDeriver -> NoteDeriver
with_pitch <- if
        | Attributes -> Attributes -> Bool
Attrs.contain Attributes
matched (Attributes
Attrs.harm Attributes -> Attributes -> Attributes
forall a. Semigroup a => a -> a -> a
<> Attributes
Attrs.natural) ->
            Bool
-> Maybe Attributes
-> Deriver State Error (NoteDeriver -> NoteDeriver)
forall {a}.
Bool
-> Maybe Attributes -> Deriver State Error (Deriver a -> Deriver a)
natural_harmonic (Attributes -> Bool
has Attributes
Attrs.gliss) (Maybe Attributes
 -> Deriver State Error (NoteDeriver -> NoteDeriver))
-> Maybe Attributes
-> Deriver State Error (NoteDeriver -> NoteDeriver)
forall a b. (a -> b) -> a -> b
$
                (Attributes -> Bool) -> [Attributes] -> Maybe Attributes
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find Attributes -> Bool
has (HarmonicMap -> [Attributes]
hmap_strings HarmonicMap
hmap)
        -- VSL has its artificial harmonics pitched one octave too high.
        | Attributes -> Bool
has Attributes
Attrs.harm -> (NoteDeriver -> NoteDeriver)
-> Deriver State Error (NoteDeriver -> NoteDeriver)
forall (m :: * -> *) a. Monad m => a -> m a
return ((NoteDeriver -> NoteDeriver)
 -> Deriver State Error (NoteDeriver -> NoteDeriver))
-> (NoteDeriver -> NoteDeriver)
-> Deriver State Error (NoteDeriver -> NoteDeriver)
forall a b. (a -> b) -> a -> b
$ Control -> Y -> NoteDeriver -> NoteDeriver
forall a. Control -> Y -> Deriver a -> Deriver a
Call.add_constant Control
Controls.octave (-Y
1)
        | Bool
otherwise -> (NoteDeriver -> NoteDeriver)
-> Deriver State Error (NoteDeriver -> NoteDeriver)
forall (m :: * -> *) a. Monad m => a -> m a
return NoteDeriver -> NoteDeriver
forall a. a -> a
id
    NoteDeriver -> NoteDeriver
with_pitch (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall a b. (a -> b) -> a -> b
$ Config -> GenerateNote
Note.default_note Config
config NoteArgs
args
    where
    natural_harmonic :: Bool
-> Maybe Attributes -> Deriver State Error (Deriver a -> Deriver a)
natural_harmonic Bool
gliss Maybe Attributes
maybe_string = do
        NoteNumber
nn <- Text -> Maybe NoteNumber -> Deriver NoteNumber
forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require Text
"note pitch"
            (Maybe NoteNumber -> Deriver NoteNumber)
-> Deriver State Error (Maybe NoteNumber) -> Deriver NoteNumber
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RealTime -> Deriver State Error (Maybe NoteNumber)
Derive.nn_at (RealTime -> Deriver State Error (Maybe NoteNumber))
-> Deriver State Error RealTime
-> Deriver State Error (Maybe NoteNumber)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< NoteArgs -> Deriver State Error RealTime
forall a. PassedArgs a -> Deriver State Error RealTime
Args.real_start NoteArgs
args
        let pitch :: Key
pitch = Integer -> Key
forall a. Integral a => a -> Key
Midi.to_key (NoteNumber -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round NoteNumber
nn)
        case HarmonicMap -> Bool -> Key -> Maybe Attributes -> Maybe Key
find_harmonic HarmonicMap
hmap Bool
gliss Key
pitch Maybe Attributes
maybe_string of
            Maybe Key
Nothing -> Text -> Deriver State Error (Deriver a -> Deriver a)
forall a. HasCallStack => Text -> Deriver a
Derive.throw (Text -> Deriver State Error (Deriver a -> Deriver a))
-> Text -> Deriver State Error (Deriver a -> Deriver a)
forall a b. (a -> b) -> a -> b
$ Key -> Text
forall a. Pretty a => a -> Text
pretty Key
pitch Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" unplayable on "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> (Attributes -> Text) -> Maybe Attributes -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Attributes] -> Text
forall a. Pretty a => a -> Text
pretty (HarmonicMap -> [Attributes]
hmap_strings HarmonicMap
hmap)) Attributes -> Text
forall a. Pretty a => a -> Text
pretty Maybe Attributes
maybe_string
            Just Key
key -> (Deriver a -> Deriver a)
-> Deriver State Error (Deriver a -> Deriver a)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Deriver a -> Deriver a)
 -> Deriver State Error (Deriver a -> Deriver a))
-> (Deriver a -> Deriver a)
-> Deriver State Error (Deriver a -> Deriver a)
forall a b. (a -> b) -> a -> b
$
                Pitch -> Deriver a -> Deriver a
forall a. Pitch -> Deriver a -> Deriver a
Call.with_pitch (NoteNumber -> Pitch
PSignal.nn_pitch (Key -> NoteNumber
forall a. Num a => Key -> a
Midi.from_key Key
key))

-- * keyswitches

type Instrument = (InstT.Name, [Keyswitch])
type Keyswitch = (Attrs.Attributes, [Patch.Keyswitch])

make_patch :: VslInst.Instrument -> Text -> MidiInst.Patch
make_patch :: Instrument -> Text -> Patch
make_patch Instrument
inst Text
category =
    Text -> Instrument -> Patch
instrument_patch Text
category (([(Attributes, [Keyswitch])] -> [(Attributes, [Keyswitch])])
-> Instrument -> Instrument
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second [(Attributes, [Keyswitch])] -> [(Attributes, [Keyswitch])]
forall {b}. [(Attributes, b)] -> [(Attributes, b)]
strip (Instrument -> Instrument
make_instrument Instrument
inst))
    where strip :: [(Attributes, b)] -> [(Attributes, b)]
strip = ([Attributes] -> [b] -> [(Attributes, b)])
-> ([Attributes], [b]) -> [(Attributes, b)]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Attributes] -> [b] -> [(Attributes, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip (([Attributes], [b]) -> [(Attributes, b)])
-> ([(Attributes, b)] -> ([Attributes], [b]))
-> [(Attributes, b)]
-> [(Attributes, b)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Attributes] -> [Attributes])
-> ([Attributes], [b]) -> ([Attributes], [b])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [Attributes] -> [Attributes]
strip_attrs (([Attributes], [b]) -> ([Attributes], [b]))
-> ([(Attributes, b)] -> ([Attributes], [b]))
-> [(Attributes, b)]
-> ([Attributes], [b])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Attributes, b)] -> ([Attributes], [b])
forall a b. [(a, b)] -> ([a], [b])
unzip

instrument_patch :: Text -> Instrument -> MidiInst.Patch
instrument_patch :: Text -> Instrument -> Patch
instrument_patch Text
category (Text
name, [(Attributes, [Keyswitch])]
keyswitches) =
    -- MidiInst.pressure means I expect to have velocity-xf enabled and
    -- assigned to cc2.
    Patch -> Patch
MidiInst.pressure (Patch -> Patch) -> Patch -> Patch
forall a b. (a -> b) -> a -> b
$
    Patch :-> Common Code
MidiInst.common(Patch :-> Common Code)
-> Lens (Common Code) [Tag] -> Lens Patch [Tag]
forall a b c. Lens a b -> Lens b c -> Lens a c
#Lens (Common Code) [Tag]
forall {code}. Common code :-> [Tag]
Common.tags Lens Patch [Tag] -> ([Tag] -> [Tag]) -> Patch -> Patch
forall f a. Lens f a -> (a -> a) -> f -> f
%= ((Text
Tag.category, Text
category) :) (Patch -> Patch) -> Patch -> Patch
forall a b. (a -> b) -> a -> b
$
    Lens Patch AttributeMap
MidiInst.attribute_map Lens Patch AttributeMap -> AttributeMap -> Patch -> Patch
forall f a. Lens f a -> a -> f -> f
#= [(Attributes, [Keyswitch])] -> AttributeMap
keyswitch_map [(Attributes, [Keyswitch])]
keyswitches (Patch -> Patch) -> Patch -> Patch
forall a b. (a -> b) -> a -> b
$
        PbRange -> Text -> [(Control, Control)] -> Patch
MidiInst.named_patch (-Int
2, Int
2) Text
name []

make_instrument :: VslInst.Instrument -> Instrument
make_instrument :: Instrument -> Instrument
make_instrument (Text
name, Keys
keys, [[Attributes]]
attrs) = (Text
name, Keys -> [[Attributes]] -> [(Attributes, [Keyswitch])]
matrix Keys
keys [[Attributes]]
attrs)

keyswitch_map :: [Keyswitch] -> Patch.AttributeMap
keyswitch_map :: [(Attributes, [Keyswitch])] -> AttributeMap
keyswitch_map = [(Attributes, [Keyswitch])] -> AttributeMap
Patch.keyswitches ([(Attributes, [Keyswitch])] -> AttributeMap)
-> ([(Attributes, [Keyswitch])] -> [(Attributes, [Keyswitch])])
-> [(Attributes, [Keyswitch])]
-> AttributeMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Attributes, [Keyswitch]) -> Int)
-> [(Attributes, [Keyswitch])] -> [(Attributes, [Keyswitch])]
forall k a. Ord k => (a -> k) -> [a] -> [a]
Seq.sort_on (Attributes -> Int
priority (Attributes -> Int)
-> ((Attributes, [Keyswitch]) -> Attributes)
-> (Attributes, [Keyswitch])
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Attributes, [Keyswitch]) -> Attributes
forall a b. (a, b) -> a
fst) ([(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 {b}. [(Attributes, b)] -> [(Attributes, b)]
process
    where
    process :: [(Attributes, b)] -> [(Attributes, b)]
process [(Attributes, b)]
keyswitches = [Attributes] -> [b] -> [(Attributes, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Attributes]
attrs [b]
ks
        where ([Attributes]
attrs, [b]
ks) = [(Attributes, b)] -> ([Attributes], [b])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Attributes, b)] -> [(Attributes, b)]
forall {b}. [(Attributes, b)] -> [(Attributes, b)]
drop_dups [(Attributes, b)]
keyswitches)
    drop_dups :: [(Attributes, b)] -> [(Attributes, b)]
drop_dups = ((Attributes, b) -> Attributes)
-> [(Attributes, b)] -> [(Attributes, b)]
forall k a. Ord k => (a -> k) -> [a] -> [a]
Seq.unique_on (Attributes, b) -> Attributes
forall a b. (a, b) -> a
fst
    priority :: Attributes -> Int
priority Attributes
attrs = Int -> Attributes -> Map Attributes Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Int
0 Attributes
attrs Map Attributes Int
attribute_priority

-- | Order attributes by priority.  This should correspond to specificity, or
-- to perceptual importance, as documented in 'Patch.AttributeMap'.
attribute_priority :: Map Attrs.Attributes Int
attribute_priority :: Map Attributes Int
attribute_priority = [(Attributes, Int)] -> Map Attributes Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (([Attributes] -> [Int] -> [(Attributes, Int)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [-Int
1, -Int
2 ..]) ([Attributes] -> [Attributes]
forall a. [a] -> [a]
reverse [Attributes]
high)) Map Attributes Int -> Map Attributes Int -> Map Attributes Int
forall a. Semigroup a => a -> a -> a
<> Map Attributes Int
low
    where
    high :: [Attributes]
high =
        [ Attributes
VslInst.pizz
        , Attributes
VslInst.spiccato
        , Attributes
VslInst.harsh
        , Attributes
VslInst.staccato
        , Attributes
VslInst.detache
        , Attributes
VslInst.detache Attributes -> Attributes -> Attributes
forall a. Semigroup a => a -> a -> a
<> Attributes
VslInst.long
        ]
    low :: Map Attributes Int
low = [(Attributes, Int)] -> Map Attributes Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Attributes
VslInst.nv, Int
100)]

-- | Since the VSL matrix is only 12x12, a row of articulations greater than
-- that overflows to the next row.  Given that I'm definitely going to overflow
-- 12 rows, I wind up overflowing to the next matrix, and when counting tha AB
-- switch, each articulation has 3 or 4 keyswitches.
--
-- I could probably cram most instruments into 144 cells and only require 2-3
-- keyswitches, but it would be hard to read and easy to mess up, wouldn't let
-- me disable and enable cells by row, and with custom patches I'll probably
-- wind up with more than 144 anyway.
matrix :: VslInst.Keys -> [[Attrs.Attributes]] -> [Keyswitch]
matrix :: Keys -> [[Attributes]] -> [(Attributes, [Keyswitch])]
matrix Keys
keys = [[[Attributes]]] -> [(Attributes, [Keyswitch])]
add ([[[Attributes]]] -> [(Attributes, [Keyswitch])])
-> ([[Attributes]] -> [[[Attributes]]])
-> [[Attributes]]
-> [(Attributes, [Keyswitch])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [[Attributes]] -> [[[Attributes]]]
forall a. Int -> [a] -> [[a]]
Seq.chunked Int
12 ([[Attributes]] -> [[[Attributes]]])
-> ([[Attributes]] -> [[Attributes]])
-> [[Attributes]]
-> [[[Attributes]]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Attributes] -> [[Attributes]])
-> [[Attributes]] -> [[Attributes]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> [Attributes] -> [[Attributes]]
forall a. Int -> [a] -> [[a]]
Seq.chunked Int
12)
    where
    add :: [[[Attributes]]] -> [(Attributes, [Keyswitch])]
add [[[Attributes]]]
matrices = do
        (Keyswitch
matrix_ks, [[Attributes]]
rows) <- [Keyswitch] -> [[[Attributes]]] -> [(Keyswitch, [[Attributes]])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Keyswitch]
select_matrix [[[Attributes]]]
matrices
        (Keyswitch
row_ks, [Attributes]
row) <- [Keyswitch] -> [[Attributes]] -> [(Keyswitch, [Attributes])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Keyswitch]
y_axis [[Attributes]]
rows
        (Keyswitch
col_ks, Attributes
cell) <- [Keyswitch] -> [Attributes] -> [(Keyswitch, Attributes)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Keyswitch]
x_axis [Attributes]
row
        ([Keyswitch]
ab_ks, Attributes
attrs) <- [([Keyswitch], Attributes)]
-> ([Attributes] -> [([Keyswitch], Attributes)])
-> Maybe [Attributes]
-> [([Keyswitch], Attributes)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [([], Attributes
cell)] ([[Keyswitch]] -> [Attributes] -> [([Keyswitch], Attributes)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Keyswitch -> [Keyswitch]) -> [Keyswitch] -> [[Keyswitch]]
forall a b. (a -> b) -> [a] -> [b]
map (Keyswitch -> [Keyswitch] -> [Keyswitch]
forall a. a -> [a] -> [a]
:[]) [Keyswitch]
ab)) (Maybe [Attributes] -> [([Keyswitch], Attributes)])
-> Maybe [Attributes] -> [([Keyswitch], Attributes)]
forall a b. (a -> b) -> a -> b
$
            Attributes -> Maybe [Attributes]
expand_ab Attributes
cell
        (Attributes, [Keyswitch]) -> [(Attributes, [Keyswitch])]
forall (m :: * -> *) a. Monad m => a -> m a
return (Attributes
attrs, Keyswitch
matrix_ks Keyswitch -> [Keyswitch] -> [Keyswitch]
forall a. a -> [a] -> [a]
: Keyswitch
row_ks Keyswitch -> [Keyswitch] -> [Keyswitch]
forall a. a -> [a] -> [a]
: Keyswitch
col_ks Keyswitch -> [Keyswitch] -> [Keyswitch]
forall a. a -> [a] -> [a]
: [Keyswitch]
ab_ks)
    x_axis :: [Keyswitch]
x_axis = Key -> [Keyswitch]
keys_from (Keys -> Key
VslInst.key_x_axis Keys
keys)
    y_axis :: [Keyswitch]
y_axis = Key -> [Keyswitch]
keys_from (Keys -> Key
VslInst.key_y_axis Keys
keys)
    ab :: [Keyswitch]
ab = Key -> [Keyswitch]
keys_from (Keys -> Key
VslInst.key_ab Keys
keys)
    select_matrix :: [Keyswitch]
select_matrix = Key -> [Keyswitch]
keys_from (Keys -> Key
VslInst.key_matrix Keys
keys)

keys_from :: Midi.Key -> [Patch.Keyswitch]
keys_from :: Key -> [Keyswitch]
keys_from Key
low_key = (Key -> Keyswitch) -> [Key] -> [Keyswitch]
forall a b. (a -> b) -> [a] -> [b]
map Key -> Keyswitch
Patch.Keyswitch [Key
low_key ..]

-- * attrs

-- | Remove attrs which can be assumed as a default.  The idea is to make it
-- easier to address an articulation while still remaining non-ambiguous.
--
-- Attrs are removed in order unless removal would create a conflict with
-- another articulation.  The result is that the attrs early in the strip list
-- are removed first, so if you have both 'VslInst.med' and 'VslInst.short',
-- 'VslInst.med' will become the default, while 'VslInst.short' retains its
-- attribute.
strip_attrs :: [Attrs.Attributes] -> [Attrs.Attributes]
strip_attrs :: [Attributes] -> [Attributes]
strip_attrs [Attributes]
attrs = (Set Attributes, [Attributes]) -> [Attributes]
forall a b. (a, b) -> b
snd ((Set Attributes, [Attributes]) -> [Attributes])
-> (Set Attributes, [Attributes]) -> [Attributes]
forall a b. (a -> b) -> a -> b
$ (Attributes
 -> (Set Attributes, [Attributes])
 -> (Set Attributes, [Attributes]))
-> (Set Attributes, [Attributes])
-> [Attributes]
-> (Set Attributes, [Attributes])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Attributes
-> (Set Attributes, [Attributes]) -> (Set Attributes, [Attributes])
strip_attr ([Attributes] -> Set Attributes
forall a. Ord a => [a] -> Set a
Set.fromList [Attributes]
attrs, [Attributes]
attrs) [Attributes]
strip
    where
    strip :: [Attributes]
strip = [Attributes] -> [Attributes]
forall a. [a] -> [a]
reverse
        [ Attributes
VslInst.sus, Attributes
VslInst.vib, Attributes
VslInst.perf, Attributes
VslInst.fast, Attributes
VslInst.fa
        , Attributes
VslInst.norm, Attributes
VslInst.na, Attributes
VslInst.legato, Attributes
VslInst.v1, Attributes
Attrs.artificial
        , Attributes
VslInst.med, Attributes
VslInst.short
        ]

-- | Strip the given attr, but only if it wouldn't cause clashes.
strip_attr :: Attrs.Attributes -> (Set Attrs.Attributes, [Attrs.Attributes])
    -> (Set Attrs.Attributes, [Attrs.Attributes])
strip_attr :: Attributes
-> (Set Attributes, [Attributes]) -> (Set Attributes, [Attributes])
strip_attr Attributes
attr (Set Attributes
all_attrs_set, [Attributes]
all_attrs)
    | (Attributes -> Bool) -> [Attributes] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Attributes -> Attributes -> Bool
`Attrs.contain` Attributes
attr) [Attributes]
all_attrs =
        (Set Attributes -> Attributes -> (Set Attributes, Attributes))
-> Set Attributes -> [Attributes] -> (Set Attributes, [Attributes])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL Set Attributes -> Attributes -> (Set Attributes, Attributes)
strip_redundant Set Attributes
all_attrs_set [Attributes]
all_attrs
    | Bool
otherwise = (Set Attributes
all_attrs_set, [Attributes]
all_attrs)
    where
    -- Initially I had a naive version that search for clashes with a linear
    -- search in 'all_attrs'.  But it turns out to be slow since there are
    -- around 41 instruments * 12 attrs to strip * 285 attrs * 285 for linear
    -- search.  Or something.  Anyway, previously forcing all the patches took
    -- 0.39 CPU seconds, now it's down to 0.19.
    --
    -- This whole calculation winds up in 'patches' as a CAF, so it should be
    -- possible to run at compile time, presumably via TH.  In any case, even
    -- as a normal CAF, it only happens once per run.
    strip_redundant :: Set Attributes -> Attributes -> (Set Attributes, Attributes)
strip_redundant Set Attributes
attrs_set Attributes
attrs
        | Attributes -> Set Attributes -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Attributes
stripped Set Attributes
attrs_set = (Set Attributes
attrs_set, Attributes
attrs)
        | Bool
otherwise = (Attributes -> Set Attributes -> Set Attributes
forall a. Ord a => a -> Set a -> Set a
Set.insert Attributes
stripped Set Attributes
attrs_set, Attributes
stripped)
        where stripped :: Attributes
stripped = Attributes -> Attributes -> Attributes
Attrs.difference Attributes
attrs Attributes
attr

expand_ab :: Attrs.Attributes -> Maybe [Attrs.Attributes]
expand_ab :: Attributes -> Maybe [Attributes]
expand_ab Attributes
attrs
    | Just Attributes
stripped <- Attributes -> Maybe Attributes
extract Attributes
VslInst.updown =
        [Attributes] -> Maybe [Attributes]
forall a. a -> Maybe a
Just [Attributes
stripped Attributes -> Attributes -> Attributes
forall a. Semigroup a => a -> a -> a
<> Attributes
VslInst.up, Attributes
stripped Attributes -> Attributes -> Attributes
forall a. Semigroup a => a -> a -> a
<> Attributes
VslInst.down]
    | Just Attributes
stripped <- Attributes -> Maybe Attributes
extract Attributes
VslInst.crescdim =
        [Attributes] -> Maybe [Attributes]
forall a. a -> Maybe a
Just ([Attributes] -> Maybe [Attributes])
-> [Attributes] -> Maybe [Attributes]
forall a b. (a -> b) -> a -> b
$ (Attributes -> Attributes) -> [Attributes] -> [Attributes]
forall a b. (a -> b) -> [a] -> [b]
map (Attributes -> Attributes -> Attributes
`Attrs.difference` Attributes
VslInst.dyn)
            [Attributes
stripped Attributes -> Attributes -> Attributes
forall a. Semigroup a => a -> a -> a
<> Attributes
VslInst.cresc, Attributes
stripped Attributes -> Attributes -> Attributes
forall a. Semigroup a => a -> a -> a
<> Attributes
VslInst.dim]
    | Just Attributes
stripped <- Attributes -> Maybe Attributes
extract Attributes
VslInst.highlow =
        [Attributes] -> Maybe [Attributes]
forall a. a -> Maybe a
Just [Attributes
stripped Attributes -> Attributes -> Attributes
forall a. Semigroup a => a -> a -> a
<> Attributes
VslInst.high, Attributes
stripped Attributes -> Attributes -> Attributes
forall a. Semigroup a => a -> a -> a
<> Attributes
VslInst.low]
    | Bool
otherwise = Maybe [Attributes]
forall a. Maybe a
Nothing
    where
    extract :: Attributes -> Maybe Attributes
extract Attributes
attr
        | Attributes -> Attributes -> Bool
Attrs.contain Attributes
attrs Attributes
attr = Attributes -> Maybe Attributes
forall a. a -> Maybe a
Just (Attributes -> Maybe Attributes) -> Attributes -> Maybe Attributes
forall a b. (a -> b) -> a -> b
$ Attributes -> Attributes -> Attributes
Attrs.difference Attributes
attrs Attributes
attr
        | Bool
otherwise = Maybe Attributes
forall a. Maybe a
Nothing


-- * natural harmonics

data HarmonicMap = HarmonicMap {
    HarmonicMap -> [Attributes]
hmap_strings :: [OpenString]
    , HarmonicMap -> [NoteNumber]
hmap_string_nns :: [Pitch.NoteNumber]
    -- | Map sounding pitch to possible strings and the key to play to get that
    -- pitch on that string.
    , HarmonicMap -> Map Key [(Attributes, Key)]
hmap_key_to_natural :: Map Midi.Key [(OpenString, Midi.Key)]
    -- | Same as 'hmap_key_to_natural' except map from the gliss destination.
    , HarmonicMap -> Map Key [(Attributes, Key)]
hmap_key_to_gliss_destination :: Map Midi.Key [(OpenString, Midi.Key)]
    } deriving (Int -> HarmonicMap -> String -> String
[HarmonicMap] -> String -> String
HarmonicMap -> String
(Int -> HarmonicMap -> String -> String)
-> (HarmonicMap -> String)
-> ([HarmonicMap] -> String -> String)
-> Show HarmonicMap
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [HarmonicMap] -> String -> String
$cshowList :: [HarmonicMap] -> String -> String
show :: HarmonicMap -> String
$cshow :: HarmonicMap -> String
showsPrec :: Int -> HarmonicMap -> String -> String
$cshowsPrec :: Int -> HarmonicMap -> String -> String
Show)
type OpenString = Attrs.Attributes

find_harmonic :: HarmonicMap -> Bool -> Midi.Key -> Maybe OpenString
    -> Maybe Midi.Key
find_harmonic :: HarmonicMap -> Bool -> Key -> Maybe Attributes -> Maybe Key
find_harmonic HarmonicMap
hmap Bool
gliss Key
pitch Maybe Attributes
maybe_str =
    ([(Attributes, Key)] -> Maybe Key)
-> (Attributes -> [(Attributes, Key)] -> Maybe Key)
-> Maybe Attributes
-> [(Attributes, Key)]
-> Maybe Key
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (((Attributes, Key) -> Key) -> Maybe (Attributes, Key) -> Maybe Key
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Attributes, Key) -> Key
forall a b. (a, b) -> b
snd (Maybe (Attributes, Key) -> Maybe Key)
-> ([(Attributes, Key)] -> Maybe (Attributes, Key))
-> [(Attributes, Key)]
-> Maybe Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Attributes, Key)] -> Maybe (Attributes, Key)
forall a. [a] -> Maybe a
Seq.head) Attributes -> [(Attributes, Key)] -> Maybe Key
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Maybe Attributes
maybe_str ([(Attributes, Key)] -> Maybe Key)
-> Maybe [(Attributes, Key)] -> Maybe Key
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Key -> Map Key [(Attributes, Key)] -> Maybe [(Attributes, Key)]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Key
pitch Map Key [(Attributes, Key)]
m
    where
    m :: Map Key [(Attributes, Key)]
m = (if Bool
gliss then HarmonicMap -> Map Key [(Attributes, Key)]
hmap_key_to_gliss_destination else HarmonicMap -> Map Key [(Attributes, Key)]
hmap_key_to_natural)
        HarmonicMap
hmap

harmonic_map :: [(OpenString, Midi.Key)] -> HarmonicMap
harmonic_map :: [(Attributes, Key)] -> HarmonicMap
harmonic_map [(Attributes, Key)]
strings = HarmonicMap
    { hmap_strings :: [Attributes]
hmap_strings = ((Attributes, Key) -> Attributes)
-> [(Attributes, Key)] -> [Attributes]
forall a b. (a -> b) -> [a] -> [b]
map (Attributes, Key) -> Attributes
forall a b. (a, b) -> a
fst [(Attributes, Key)]
strings
    , hmap_string_nns :: [NoteNumber]
hmap_string_nns = ((Attributes, Key) -> NoteNumber)
-> [(Attributes, Key)] -> [NoteNumber]
forall a b. (a -> b) -> [a] -> [b]
map (Key -> NoteNumber
forall a. Num a => Key -> a
Midi.from_key (Key -> NoteNumber)
-> ((Attributes, Key) -> Key) -> (Attributes, Key) -> NoteNumber
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Attributes, Key) -> Key
forall a b. (a, b) -> b
snd) [(Attributes, Key)]
strings
    , hmap_key_to_natural :: Map Key [(Attributes, Key)]
hmap_key_to_natural = [(Key, Int)] -> Map Key [(Attributes, Key)]
forall {a}. Integral a => [(Key, a)] -> Map Key [(Attributes, Key)]
make [(Key, Int)]
natural_harmonics
    , hmap_key_to_gliss_destination :: Map Key [(Attributes, Key)]
hmap_key_to_gliss_destination = [(Key, Int)] -> Map Key [(Attributes, Key)]
forall {a}. Integral a => [(Key, a)] -> Map Key [(Attributes, Key)]
make [(Key, Int)]
gliss_natural_harmonics
    }
    where
    make :: [(Key, a)] -> Map Key [(Attributes, Key)]
make [(Key, a)]
key_to_interval = [(Key, (Attributes, Key))] -> Map Key [(Attributes, Key)]
forall k a. Ord k => [(k, a)] -> Map k [a]
Maps.multimap ([(Key, (Attributes, Key))] -> Map Key [(Attributes, Key)])
-> [(Key, (Attributes, Key))] -> Map Key [(Attributes, Key)]
forall a b. (a -> b) -> a -> b
$ do
        (Integer
oct, (Attributes
str, Key
base)) <- [Integer] -> [(Attributes, Key)] -> [(Integer, (Attributes, Key))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
0..] [(Attributes, Key)]
strings
        (Key
key, a
interval) <- [(Key, a)]
key_to_interval
        (Key, (Attributes, Key)) -> [(Key, (Attributes, Key))]
forall (m :: * -> *) a. Monad m => a -> m a
return (Key -> a -> Key
forall {a}. Integral a => Key -> a -> Key
add Key
base a
interval, (Attributes
str, Key -> Integer -> Key
forall {a}. Integral a => Key -> a -> Key
add Key
key (Integer
oct Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
12)))
        where add :: Key -> a -> Key
add Key
key a
n = a -> Key
forall a. Integral a => a -> Key
Midi.to_key (Key -> a
forall a. Num a => Key -> a
Midi.from_key Key
key a -> a -> a
forall a. Num a => a -> a -> a
+ a
n)

violin_harmonics, viola_harmonics, cello_harmonics, bass_harmonics
    :: HarmonicMap
violin_harmonics :: HarmonicMap
violin_harmonics = [(Attributes, Key)] -> HarmonicMap
harmonic_map ([(Attributes, Key)] -> HarmonicMap)
-> [(Attributes, Key)] -> HarmonicMap
forall a b. (a -> b) -> a -> b
$ ((Text, Key) -> (Attributes, Key))
-> [(Text, Key)] -> [(Attributes, Key)]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Attributes) -> (Text, Key) -> (Attributes, Key)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> Attributes
Attrs.attr)
    [(Text
"g", Key
Key.g3), (Text
"d", Key
Key.d4), (Text
"a", Key
Key.a4), (Text
"e", Key
Key.e4)]
viola_harmonics :: HarmonicMap
viola_harmonics = [(Attributes, Key)] -> HarmonicMap
harmonic_map ([(Attributes, Key)] -> HarmonicMap)
-> [(Attributes, Key)] -> HarmonicMap
forall a b. (a -> b) -> a -> b
$ ((Text, Key) -> (Attributes, Key))
-> [(Text, Key)] -> [(Attributes, Key)]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Attributes) -> (Text, Key) -> (Attributes, Key)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> Attributes
Attrs.attr)
    [(Text
"c", Key
Key.c3), (Text
"g", Key
Key.g3), (Text
"d", Key
Key.d4), (Text
"a", Key
Key.a4)]
cello_harmonics :: HarmonicMap
cello_harmonics = [(Attributes, Key)] -> HarmonicMap
harmonic_map ([(Attributes, Key)] -> HarmonicMap)
-> [(Attributes, Key)] -> HarmonicMap
forall a b. (a -> b) -> a -> b
$ ((Text, Key) -> (Attributes, Key))
-> [(Text, Key)] -> [(Attributes, Key)]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Attributes) -> (Text, Key) -> (Attributes, Key)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> Attributes
Attrs.attr)
    [(Text
"c", Key
Key.c2), (Text
"g", Key
Key.g2), (Text
"d", Key
Key.d3), (Text
"a", Key
Key.a3)]
bass_harmonics :: HarmonicMap
bass_harmonics = [(Attributes, Key)] -> HarmonicMap
harmonic_map ([(Attributes, Key)] -> HarmonicMap)
-> [(Attributes, Key)] -> HarmonicMap
forall a b. (a -> b) -> a -> b
$ ((Text, Key) -> (Attributes, Key))
-> [(Text, Key)] -> [(Attributes, Key)]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Attributes) -> (Text, Key) -> (Attributes, Key)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> Attributes
Attrs.attr)
    [(Text
"e", Key
Key.e1), (Text
"a", Key
Key.a1), (Text
"d", Key
Key.d2), (Text
"g", Key
Key.g2)]

natural_harmonics :: [(Midi.Key, Int)]
natural_harmonics :: [(Key, Int)]
natural_harmonics = [(Key, Int)] -> [(Key, Int)]
forall {a}. [(a, Int)] -> [(a, Int)]
absolute
    [ (Key
Key.c3, Int
0)
    , (Key
Key.d3, Int
12)
    , (Key
Key.e3, Int
7)
    , (Key
Key.f3, Int
5)
    , (Key
Key.g3, Int
4)
    , (Key
Key.gs3, Int
3)
    , (Key
Key.a3, Int
3)
    , (Key
Key.as3, Int
2)
    ]
    where absolute :: [(a, Int)] -> [(a, Int)]
absolute = ([a] -> [Int] -> [(a, Int)]) -> ([a], [Int]) -> [(a, Int)]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [a] -> [Int] -> [(a, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip (([a], [Int]) -> [(a, Int)])
-> ([(a, Int)] -> ([a], [Int])) -> [(a, Int)] -> [(a, Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Int] -> [Int]) -> ([a], [Int]) -> ([a], [Int])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
drop Int
1 ([Int] -> [Int]) -> ([Int] -> [Int]) -> [Int] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int) -> Int -> [Int] -> [Int]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Int
0) (([a], [Int]) -> ([a], [Int]))
-> ([(a, Int)] -> ([a], [Int])) -> [(a, Int)] -> ([a], [Int])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(a, Int)] -> ([a], [Int])
forall a b. [(a, b)] -> ([a], [b])
unzip

gliss_natural_harmonics :: [(Midi.Key, Int)]
gliss_natural_harmonics :: [(Key, Int)]
gliss_natural_harmonics = [(Key, Int)] -> [(Key, Int)]
forall {a}. [(a, Int)] -> [(a, Int)]
absolute
    [ (Key
Key.c3, Int
12)
    , (Key
Key.d3, Int
7)
    , (Key
Key.e3, Int
5)
    , (Key
Key.f3, Int
4)
    , (Key
Key.g3, Int
3)
    , (Key
Key.a3, Int
3)
    , (Key
Key.as3, Int
2)
    ]
    where absolute :: [(a, Int)] -> [(a, Int)]
absolute = ([a] -> [Int] -> [(a, Int)]) -> ([a], [Int]) -> [(a, Int)]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [a] -> [Int] -> [(a, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip (([a], [Int]) -> [(a, Int)])
-> ([(a, Int)] -> ([a], [Int])) -> [(a, Int)] -> [(a, Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Int] -> [Int]) -> ([a], [Int]) -> ([a], [Int])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
drop Int
1 ([Int] -> [Int]) -> ([Int] -> [Int]) -> [Int] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int) -> Int -> [Int] -> [Int]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Int
0) (([a], [Int]) -> ([a], [Int]))
-> ([(a, Int)] -> ([a], [Int])) -> [(a, Int)] -> ([a], [Int])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(a, Int)] -> ([a], [Int])
forall a b. [(a, b)] -> ([a], [b])
unzip

-- * infer seconds

c_infer_seconds :: Library.Calls Derive.Note
c_infer_seconds :: Calls Note
c_infer_seconds = Module
-> CallName
-> Tags
-> Doc
-> Parser (Attributes, Maybe UpDown)
-> ((Attributes, Maybe UpDown) -> NoteDeriver -> NoteDeriver)
-> Calls Note
forall a.
Module
-> CallName
-> Tags
-> Doc
-> Parser a
-> (a -> NoteDeriver -> NoteDeriver)
-> Calls Note
Make.transform_notes Module
Module.instrument CallName
"infer-seconds"
    Tags
Tags.attr
    Doc
"Infer a `+sec#` attr based on the duration of the event and the available\
    \ keymaps for the current instrument and attribute set."
    ((,)
    (Attributes -> Maybe UpDown -> (Attributes, Maybe UpDown))
-> Parser Attributes
-> Parser (Maybe UpDown -> (Attributes, Maybe UpDown))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgName -> Attributes -> Doc -> Parser Attributes
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> a -> Doc -> Parser a
Sig.defaulted ArgName
"attrs" Attributes
forall a. Monoid a => a
mempty Doc
"Add these attributes."
    Parser (Maybe UpDown -> (Attributes, Maybe UpDown))
-> Parser (Maybe UpDown) -> Parser (Attributes, Maybe UpDown)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ArgName -> Maybe UpDown -> Doc -> Parser (Maybe UpDown)
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> a -> Doc -> Parser a
Sig.defaulted ArgName
"round" Maybe UpDown
forall a. Maybe a
Nothing Doc
"Round up to a longer `+sec#` attribute,\
        \ down to a shorter one, or to the closest."
    ) (((Attributes, Maybe UpDown) -> NoteDeriver -> NoteDeriver)
 -> Calls Note)
-> ((Attributes, Maybe UpDown) -> NoteDeriver -> NoteDeriver)
-> Calls Note
forall a b. (a -> b) -> a -> b
$ \(Attributes
attrs, Maybe UpDown
round) NoteDeriver
deriver -> do
        (Instrument
_, Instrument
inst) <- Instrument -> Deriver (Instrument, Instrument)
Derive.get_instrument (Instrument -> Deriver (Instrument, Instrument))
-> Deriver State Error Instrument
-> Deriver (Instrument, Instrument)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Deriver State Error Instrument
Call.get_instrument
        (Note -> Note) -> Stream Note -> Stream Note
forall a b. (a -> b) -> Stream a -> Stream b
Post.emap1_ (Maybe UpDown -> [Attributes] -> Note -> Note
infer_seconds Maybe UpDown
round (Instrument -> [Attributes]
Derive.inst_attributes Instrument
inst)) (Stream Note -> Stream Note) -> NoteDeriver -> NoteDeriver
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            Attributes -> NoteDeriver -> NoteDeriver
forall d. Attributes -> Deriver d -> Deriver d
Call.add_attributes Attributes
attrs NoteDeriver
deriver

infer_seconds :: Maybe Call.UpDown -> [Attrs.Attributes] -> Score.Event
    -> Score.Event
infer_seconds :: Maybe UpDown -> [Attributes] -> Note -> Note
infer_seconds Maybe UpDown
round [Attributes]
inst_attrs Note
event = case Maybe (RealTime, Attributes)
closest of
    Maybe (RealTime, Attributes)
Nothing -> Note
event
    Just (RealTime
secs, Attributes
_) -> Attributes -> Note -> Note
Score.add_attributes (RealTime -> Attributes
VslInst.sec RealTime
secs) Note
event
    where
    dur :: RealTime
dur = Note -> RealTime
Score.event_duration Note
event
    closest :: Maybe (RealTime, Attributes)
closest = ((RealTime, Attributes) -> RealTime)
-> [(RealTime, Attributes)] -> Maybe (RealTime, Attributes)
forall k a. Ord k => (a -> k) -> [a] -> Maybe a
Seq.minimum_on (RealTime -> RealTime
forall a. Num a => a -> a
abs (RealTime -> RealTime)
-> ((RealTime, Attributes) -> RealTime)
-> (RealTime, Attributes)
-> RealTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
subtract RealTime
dur (RealTime -> RealTime)
-> ((RealTime, Attributes) -> RealTime)
-> (RealTime, Attributes)
-> RealTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RealTime, Attributes) -> RealTime
forall a b. (a, b) -> a
fst) ([(RealTime, Attributes)] -> Maybe (RealTime, Attributes))
-> [(RealTime, Attributes)] -> Maybe (RealTime, Attributes)
forall a b. (a -> b) -> a -> b
$ case Maybe UpDown
round of
        Maybe UpDown
Nothing -> [(RealTime, Attributes)]
relevant_attrs
        Just UpDown
Call.Up -> ((RealTime, Attributes) -> Bool)
-> [(RealTime, Attributes)] -> [(RealTime, Attributes)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((RealTime -> RealTime -> Bool
forall a. Ord a => a -> a -> Bool
>=RealTime
dur) (RealTime -> Bool)
-> ((RealTime, Attributes) -> RealTime)
-> (RealTime, Attributes)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RealTime, Attributes) -> RealTime
forall a b. (a, b) -> a
fst) [(RealTime, Attributes)]
relevant_attrs
        Just UpDown
Call.Down -> ((RealTime, Attributes) -> Bool)
-> [(RealTime, Attributes)] -> [(RealTime, Attributes)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((RealTime -> RealTime -> Bool
forall a. Ord a => a -> a -> Bool
<=RealTime
dur) (RealTime -> Bool)
-> ((RealTime, Attributes) -> RealTime)
-> (RealTime, Attributes)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RealTime, Attributes) -> RealTime
forall a b. (a, b) -> a
fst) [(RealTime, Attributes)]
relevant_attrs
    relevant_attrs :: [(RealTime, Attrs.Attributes)]
    relevant_attrs :: [(RealTime, Attributes)]
relevant_attrs = ((RealTime, Attributes) -> Bool)
-> [(RealTime, Attributes)] -> [(RealTime, Attributes)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Attributes -> Attributes -> Bool
Attrs.contain Attributes
event_attrs (Attributes -> Bool)
-> ((RealTime, Attributes) -> Attributes)
-> (RealTime, Attributes)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RealTime, Attributes) -> Attributes
forall a b. (a, b) -> b
snd) ([(RealTime, Attributes)] -> [(RealTime, Attributes)])
-> [(RealTime, Attributes)] -> [(RealTime, Attributes)]
forall a b. (a -> b) -> a -> b
$
        (Attributes -> Maybe (RealTime, Attributes))
-> [Attributes] -> [(RealTime, Attributes)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Attributes -> Maybe (RealTime, Attributes)
VslInst.parse_sec [Attributes]
inst_attrs
    event_attrs :: Attributes
event_attrs = Note -> Attributes
Score.event_attributes Note
event