-- 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.Lists as Lists
import qualified Util.Maps as Maps
import qualified Util.Texts as Texts

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 Instrument.Common as Common
import qualified Instrument.InstT as InstT
import qualified Instrument.Tag as Tag

import qualified Midi.Key as Key
import qualified Midi.Midi as Midi
import qualified Perform.Midi.Patch as Patch
import qualified Perform.Pitch as Pitch
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" 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 =
    forall a b. (a -> b) -> [a] -> [b]
map forall a. ShowVal a => a -> Text
ShowVal.show_val forall a b. (a -> b) -> a -> b
$ 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 = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. HasCallStack => String -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
untxt) forall a. a -> a
id (String -> Either Text Attributes
Parse.parse_attrs String
with_attrs)
    patch :: Patch
patch = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"patch not found: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Text
inst) forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((forall a. Eq a => a -> a -> Bool
==Text
inst) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Patch -> Text
Patch.patch_name 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" forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unlines forall a b. (a -> b) -> a -> b
$
    forall a b. (a -> b) -> [a] -> [b]
map (Instrument -> Text
show_matrix forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. Semigroup a => a -> a -> a
<> Text
":\n" forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unlines (forall a b. (a -> b) -> [a] -> [b]
map [[Attributes]] -> Text
format [[[Attributes]]]
matrices)
    where
    matrices :: [[[Attributes]]]
matrices = forall a. Int -> [a] -> [[a]]
Lists.chunked Int
cols forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a. Int -> [a] -> [[a]]
Lists.chunked Int
cols)
        (forall a b. ([a] -> [b]) -> [[a]] -> [[b]]
map_shape [Attributes] -> [Attributes]
strip [[Attributes]]
attrs)
    format :: [[Attributes]] -> Text
format = [Text] -> Text
Text.unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [[Text]] -> [Text]
Texts.columns Int
1
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (:) [Text]
col_header forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Text]
header:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map forall a. ShowVal a => a -> Text
ShowVal.show_val)
    header :: [Text]
header = forall a. Int -> [a] -> [a]
take Int
cols forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> Text
showt [Integer
1..]
    col_header :: [Text]
col_header = forall a. Int -> [a] -> [a]
take (Int
colsforall a. Num a => a -> a -> a
+Int
1) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Char -> Text
Text.singleton forall a b. (a -> b) -> a -> b
$ Char
'-' forall a. a -> [a] -> [a]
: [Char
'a'..]
    strip :: [Attributes] -> [Attributes]
strip = [Attributes] -> [Attributes]
strip_attrs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Attributes -> Attributes -> Attributes
`Attrs.difference` Attributes
variants)
    variants :: Attributes
variants = Attributes
VslInst.updown forall a. Semigroup a => a -> a -> a
<> Attributes
VslInst.crescdim 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 = forall {a}. [Int] -> [a] -> [[a]]
split (forall a b. (a -> b) -> [a] -> [b]
map forall (t :: * -> *) a. Foldable t => t a -> Int
length [[a]]
rows) forall a b. (a -> b) -> a -> b
$ [a] -> [b]
f (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 forall a. a -> [a] -> [a]
: [Int] -> [a] -> [[a]]
split [Int]
lens [a]
post
        where ([a]
pre, [a]
post) = 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 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 = forall a. a -> a
id
    open_strings (Just HarmonicMap
hmap) =
        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 = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a} {t}. ([a], t) -> [(a, t)]
tag forall a b. (a -> b) -> a -> b
$
    ([(Instrument, Maybe HarmonicMap)]
solo_string_instruments, Text
Tag.c_strings)
    forall a. a -> [a] -> [a]
: 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) = forall a b. (a -> b) -> [a] -> [b]
map (, t
t) [a]
inst
    no_hmap :: [([a], c)] -> [([(a, Maybe a)], c)]
no_hmap = forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a b. (a -> b) -> [a] -> [b]
map (, forall a. Maybe a
Nothing)))

solo_string_instruments :: [(VslInst.Instrument, Maybe HarmonicMap)]
solo_string_instruments :: [(Instrument, Maybe HarmonicMap)]
solo_string_instruments = forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second 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 = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ forall {a}. Attributes -> [a] -> [a]
with_attr Attributes
Attrs.trill [forall {d}. Symbol -> Generator d -> Call d
g Symbol
"tr" (Bool -> Maybe Direction -> Maybe Direction -> Generator Note
Trill.c_note_trill Bool
True forall a. Maybe a
Nothing forall a. Maybe a
Nothing)]
    , forall {a}. Attributes -> [a] -> [a]
with_attr Attributes
Attrs.trem [forall {d}. Symbol -> Generator d -> Call d
MidiInst.generator Symbol
"trem"
        (Maybe ([Attributes], Attributes) -> Generator Note
Trill.c_tremolo_generator (forall a. a -> Maybe a
Just ([Attributes
Attrs.harm], Attributes
VslInst.rep)))]
    , forall {a}. Attributes -> [a] -> [a]
with_attr Attributes
VslInst.grace [forall {d}. Symbol -> Generator d -> Call d
g Symbol
"g" ([Attributes] -> Generator Note
grace_call (Patch -> [Attributes]
patch_attributes Patch
patch))]
    , forall {a}. Attributes -> [a] -> [a]
with_attr Attributes
VslInst.legato
        [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)
    , [forall d. Symbol -> Calls d -> Call d
MidiInst.both Symbol
"sec" Calls Note
c_infer_seconds]
    ]
    where
    g :: Symbol -> Generator d -> Call d
g = 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."
        forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$
        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 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 = forall a. AttributeMap a -> [Attributes]
Common.mapped_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 = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Attributes -> Attributes -> Bool
`Attrs.contain` Attributes
attr) 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 (forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (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 = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$
    [(Int
n, Attributes
VslInst.grace forall a. Semigroup a => a -> a -> a
<> Attributes
VslInst.up forall a. Semigroup a => a -> a -> a
<> Attributes
attrs) | (Int
n, Attributes
attrs) <- [(Int, Attributes)]
ints]
    forall a. [a] -> [a] -> [a]
++ [(-Int
n, Attributes
VslInst.grace forall a. Semigroup a => a -> a -> a
<> Attributes
VslInst.down forall a. Semigroup a => a -> a -> a
<> Attributes
attrs) | (Int
n, Attributes
attrs) <- [(Int, Attributes)]
ints]
    where ints :: [(Int, Attributes)]
ints = 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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ 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 forall a. Semigroup a => a -> a -> a
<> Attributes
Attrs.natural) ->
            forall {a}.
Bool
-> Maybe Attributes -> Deriver State Error (Deriver a -> Deriver a)
natural_harmonic (Attributes -> Bool
has Attributes
Attrs.gliss) forall a b. (a -> b) -> a -> b
$
                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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Control -> Y -> Deriver a -> Deriver a
Call.add_constant Control
Controls.octave (-Y
1)
        | Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. a -> a
id
    NoteDeriver -> NoteDeriver
with_pitch 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 <- forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require Text
"note pitch"
            forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RealTime -> Deriver State Error (Maybe NoteNumber)
Derive.nn_at forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. PassedArgs a -> Deriver RealTime
Args.real_start NoteArgs
args
        let pitch :: Key
pitch = forall a. Integral a => a -> Key
Midi.to_key (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 -> forall a. HasCallStack => Text -> Deriver a
Derive.throw forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Text
pretty Key
pitch forall a. Semigroup a => a -> a -> a
<> Text
" unplayable on "
                forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. Pretty a => a -> Text
pretty (HarmonicMap -> [Attributes]
hmap_strings HarmonicMap
hmap)) forall a. Pretty a => a -> Text
pretty Maybe Attributes
maybe_string
            Just Key
key -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
                forall a. Pitch -> Deriver a -> Deriver a
Call.with_pitch (NoteNumber -> Pitch
PSignal.nn_pitch (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 (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall {b}. [(Attributes, b)] -> [(Attributes, b)]
strip (Instrument -> Instrument
make_instrument Instrument
inst))
    where strip :: [(Attributes, b)] -> [(Attributes, b)]
strip = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b. [a] -> [b] -> [(a, b)]
zip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [Attributes] -> [Attributes]
strip_attrs forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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, [Keyswitch]
keyswitches) =
    -- MidiInst.pressure means I expect to have velocity-xf enabled and
    -- assigned to cc2.
    Patch -> Patch
MidiInst.pressure forall a b. (a -> b) -> a -> b
$
    Patch :-> Common Code
MidiInst.commonforall a b c. Lens a b -> Lens b c -> Lens a c
#forall {code}. Common code :-> [Tag]
Common.tags forall f a. Lens f a -> (a -> a) -> f -> f
%= ((Text
Tag.category, Text
category) :) forall a b. (a -> b) -> a -> b
$
    Lens Patch AttributeMap
MidiInst.attribute_map forall f a. Lens f a -> a -> f -> f
#= [Keyswitch] -> AttributeMap
keyswitch_map [Keyswitch]
keyswitches 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]] -> [Keyswitch]
matrix Keys
keys [[Attributes]]
attrs)

keyswitch_map :: [Keyswitch] -> Patch.AttributeMap
keyswitch_map :: [Keyswitch] -> AttributeMap
keyswitch_map = [Keyswitch] -> AttributeMap
Patch.keyswitches forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => (a -> k) -> [a] -> [a]
Lists.sortOn (Attributes -> Int
priority forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {b}. [(Attributes, b)] -> [(Attributes, b)]
process
    where
    process :: [(Attributes, b)] -> [(Attributes, b)]
process [(Attributes, b)]
keyswitches = forall a b. [a] -> [b] -> [(a, b)]
zip [Attributes]
attrs [b]
ks
        where ([Attributes]
attrs, [b]
ks) = forall a b. [(a, b)] -> ([a], [b])
unzip (forall {b}. [(Attributes, b)] -> [(Attributes, b)]
drop_dups [(Attributes, b)]
keyswitches)
    drop_dups :: [(Attributes, b)] -> [(Attributes, b)]
drop_dups = forall k a. Ord k => (a -> k) -> [a] -> [a]
Lists.uniqueOn forall a b. (a, b) -> a
fst
    priority :: Attributes -> Int
priority Attributes
attrs = 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 = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ((forall a b. [a] -> [b] -> [(a, b)]
`zip` [-Int
1, -Int
2 ..]) (forall a. [a] -> [a]
reverse [Attributes]
high)) 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 forall a. Semigroup a => a -> a -> a
<> Attributes
VslInst.long
        ]
    low :: Map Attributes Int
low = 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]] -> [Keyswitch]
matrix Keys
keys = [[[Attributes]]] -> [Keyswitch]
add forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [[a]]
Lists.chunked Int
12 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a. Int -> [a] -> [[a]]
Lists.chunked Int
12)
    where
    add :: [[[Attributes]]] -> [Keyswitch]
add [[[Attributes]]]
matrices = do
        (Keyswitch
matrix_ks, [[Attributes]]
rows) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Keyswitch]
select_matrix [[[Attributes]]]
matrices
        (Keyswitch
row_ks, [Attributes]
row) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Keyswitch]
y_axis [[Attributes]]
rows
        (Keyswitch
col_ks, Attributes
cell) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Keyswitch]
x_axis [Attributes]
row
        ([Keyswitch]
ab_ks, Attributes
attrs) <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe [([], Attributes
cell)] (forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> [a] -> [a]
:[]) [Keyswitch]
ab)) forall a b. (a -> b) -> a -> b
$
            Attributes -> Maybe [Attributes]
expand_ab Attributes
cell
        forall (m :: * -> *) a. Monad m => a -> m a
return (Attributes
attrs, Keyswitch
matrix_ks forall a. a -> [a] -> [a]
: Keyswitch
row_ks forall a. a -> [a] -> [a]
: Keyswitch
col_ks 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 = 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 = forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Attributes
-> (Set Attributes, [Attributes]) -> (Set Attributes, [Attributes])
strip_attr (forall a. Ord a => [a] -> Set a
Set.fromList [Attributes]
attrs, [Attributes]
attrs) [Attributes]
strip
    where
    strip :: [Attributes]
strip = 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)
    | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Attributes -> Attributes -> Bool
`Attrs.contain` Attributes
attr) [Attributes]
all_attrs =
        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
        | forall a. Ord a => a -> Set a -> Bool
Set.member Attributes
stripped Set Attributes
attrs_set = (Set Attributes
attrs_set, Attributes
attrs)
        | Bool
otherwise = (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 =
        forall a. a -> Maybe a
Just [Attributes
stripped forall a. Semigroup a => a -> a -> a
<> Attributes
VslInst.up, Attributes
stripped forall a. Semigroup a => a -> a -> a
<> Attributes
VslInst.down]
    | Just Attributes
stripped <- Attributes -> Maybe Attributes
extract Attributes
VslInst.crescdim =
        forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Attributes -> Attributes -> Attributes
`Attrs.difference` Attributes
VslInst.dyn)
            [Attributes
stripped forall a. Semigroup a => a -> a -> a
<> Attributes
VslInst.cresc, Attributes
stripped forall a. Semigroup a => a -> a -> a
<> Attributes
VslInst.dim]
    | Just Attributes
stripped <- Attributes -> Maybe Attributes
extract Attributes
VslInst.highlow =
        forall a. a -> Maybe a
Just [Attributes
stripped forall a. Semigroup a => a -> a -> a
<> Attributes
VslInst.high, Attributes
stripped forall a. Semigroup a => a -> a -> a
<> Attributes
VslInst.low]
    | Bool
otherwise = forall a. Maybe a
Nothing
    where
    extract :: Attributes -> Maybe Attributes
extract Attributes
attr
        | Attributes -> Attributes -> Bool
Attrs.contain Attributes
attrs Attributes
attr = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Attributes -> Attributes -> Attributes
Attrs.difference Attributes
attrs Attributes
attr
        | Bool
otherwise = 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 -> ShowS
[HarmonicMap] -> ShowS
HarmonicMap -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HarmonicMap] -> ShowS
$cshowList :: [HarmonicMap] -> ShowS
show :: HarmonicMap -> String
$cshow :: HarmonicMap -> String
showsPrec :: Int -> HarmonicMap -> ShowS
$cshowsPrec :: Int -> HarmonicMap -> ShowS
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 =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
Lists.head) forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Maybe Attributes
maybe_str forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Attributes, Key)]
strings
    , hmap_string_nns :: [NoteNumber]
hmap_string_nns = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Num a => Key -> a
Midi.from_key forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Attributes, Key)]
strings
    , hmap_key_to_natural :: Map Key [(Attributes, Key)]
hmap_key_to_natural = 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 = 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 = forall k a. Ord k => [(k, a)] -> Map k [a]
Maps.multimap forall a b. (a -> b) -> a -> b
$ do
        (Integer
oct, (Attributes
str, Key
base)) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
0..] [(Attributes, Key)]
strings
        (Key
key, a
interval) <- [(Key, a)]
key_to_interval
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall {a}. Integral a => Key -> a -> Key
add Key
base a
interval, (Attributes
str, forall {a}. Integral a => Key -> a -> Key
add Key
key (Integer
oct forall a. Num a => a -> a -> a
* Integer
12)))
        where add :: Key -> a -> Key
add Key
key a
n = forall a. Integral a => a -> Key
Midi.to_key (forall a. Num a => Key -> a
Midi.from_key Key
key 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 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (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 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (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 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (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 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (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 = 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 = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b. [a] -> [b] -> [(a, b)]
zip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a. Int -> [a] -> [a]
drop Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl forall a. Num a => a -> a -> a
(+) Int
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [(a, b)] -> ([a], [b])
unzip

gliss_natural_harmonics :: [(Midi.Key, Int)]
gliss_natural_harmonics :: [(Key, Int)]
gliss_natural_harmonics = 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 = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b. [a] -> [b] -> [(a, b)]
zip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a. Int -> [a] -> [a]
drop Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl forall a. Num a => a -> a -> a
(+) Int
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = 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."
    ((,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"attrs" (forall a. Monoid a => a
mempty :: Attrs.Attributes)
        Doc
"Add these attributes."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"round" (forall a. Maybe a
Nothing :: Maybe Sig.Dummy)
        Doc
"Round up to a longer `+sec#` attribute,\
        \ down to a shorter one, or to the closest."
    ) forall a b. (a -> b) -> a -> b
$ \(Attributes
attrs, Maybe UpDown
round) NoteDeriver
deriver -> do
        (Instrument
_, Instrument
inst) <- Instrument -> Deriver State Error (Instrument, Instrument)
Derive.get_instrument forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Deriver Instrument
Call.get_instrument
        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)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            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 = forall k a. Ord k => (a -> k) -> [a] -> Maybe a
Lists.minimumOn (forall a. Num a => a -> a
abs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a -> a
subtract RealTime
dur forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ case Maybe UpDown
round of
        Maybe UpDown
Nothing -> [(RealTime, Attributes)]
relevant_attrs
        Just UpDown
Call.Up -> forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Ord a => a -> a -> Bool
>=RealTime
dur) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(RealTime, Attributes)]
relevant_attrs
        Just UpDown
Call.Down -> forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Ord a => a -> a -> Bool
<=RealTime
dur) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(RealTime, Attributes)]
relevant_attrs
    relevant_attrs :: [(RealTime, Attrs.Attributes)]
    relevant_attrs :: [(RealTime, Attributes)]
relevant_attrs = forall a. (a -> Bool) -> [a] -> [a]
filter (Attributes -> Attributes -> Bool
Attrs.contain Attributes
event_attrs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$
        forall a 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