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

-- | Audio Modeling's SWAM.
module User.Elaforge.Instrument.Swam (synth) where
import qualified Data.Map as Map

import qualified Util.Doc as Doc
import qualified Util.Lists as Lists
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.Call as Call
import qualified Derive.Call.Ly as Ly
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.Sub as Sub
import qualified Derive.Call.Tags as Tags
import qualified Derive.Controls as Controls
import qualified Derive.Derive as Derive
import qualified Derive.Env as Env
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Expr as Expr
import qualified Derive.Library as Library
import qualified Derive.Score as Score
import qualified Derive.ScoreT as ScoreT
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Sig as Sig
import qualified Derive.Stream as Stream
import qualified Derive.Typecheck as Typecheck

import qualified Instrument.InstT as InstT
import qualified Midi.CC as CC
import qualified Perform.Midi.Patch as Patch
import qualified Perform.NN as NN
import qualified Perform.Pitch as Pitch
import qualified Perform.Signal as Signal

import           Global
import           Types


{-
    "Random bow" and "Random finger" = 0.  It leads to inconsistent harmonics,
    and I can randomize myself if I want.

    "Manual Trem / BowC KS" = BowCh.  Otherwise keyswitch tremolo is on note
    attack per note.  Though I don't use that yet.

    "Expr. Trigger Mode" = "off". It's unclear what this actually does, but it
    seems to have no effect for me.  It implies that without it, the note will
    be played even when there is no pressure, but of course it won't.  Off
    because I do my own attack, and it implies it will make an attack for me
    when on.

    Attack = Expression
    PortTime = CC

    Automatic tremolo uses +trem to turn it on, then %trem-speed to configure
    it.  It's convenient but lacks control.

    If I want exact tremolo speed or accents or something, I have to do it
    manually.  Just calling 'trem' doesn't reverse bow direction.  I probably
    have to set the gesture=bipolar to force bow changes.

    Things I'd like:

    - Better documentation: what is "dynamic transitions"?  What is "env attack
    speed" and how excatly does the automatic env generation work?

    - Explicit control over string selection per note, to avoid all the
    automatic string selection heuristics.

    - More harmonics.

    - Harmonic gliss, e.g. hold a note, then change pitch+pitch bend to affect
    the touch point.

    - More extreme sul pont / sul tasto, from on the bridge to middle of the
    string.

    - Custom open strings.
-}

synth :: MidiInst.Synth
synth :: Synth
synth =
    Text -> Text -> [Patch] -> Synth
MidiInst.synth Text
"swam" Text
"Audio Modeling SWAM" forall a b. (a -> b) -> a -> b
$
        [(Control, Control)] -> [Patch] -> [Patch]
MidiInst.synth_controls [] [Patch]
patches
    where
    patches :: [Patch]
patches = forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> [NoteNumber] -> Patch
string)
        [ (Text
"violin", [NoteNumber
NN.g3, NoteNumber
NN.d4, NoteNumber
NN.a4, NoteNumber
NN.e4])
        , (Text
"viola", [NoteNumber
NN.c3, NoteNumber
NN.g3, NoteNumber
NN.d4, NoteNumber
NN.a4])
        , (Text
"cello", [NoteNumber
NN.c2, NoteNumber
NN.g2, NoteNumber
NN.d3, NoteNumber
NN.a3])
        , (Text
"bass", [NoteNumber
NN.e1, NoteNumber
NN.a1, NoteNumber
NN.d2, NoteNumber
NN.g2])
        ]

{-
    - mono-sx - damp "from" string according to interval.

    - mono - never damp "from" string.

    - double - Play two notes at once.  It selects the strings
    automatically, but can't do legato.

    - double-hold - Like double, but use str-select.  Can do legato on one
    string.  The second played string is assumed to be the moving one, so you
    have to tweak start times based on who is moving, and even so movements on
    the lower string often stop the upper string.

    - auto - try to detect, but add latency.
-}

string :: InstT.Name -> [Pitch.NoteNumber] -> MidiInst.Patch
string :: Text -> [NoteNumber] -> Patch
string Text
name [NoteNumber]
open_strings = Patch -> Patch
MidiInst.pressure forall a b. (a -> b) -> a -> b
$
    Lens Patch Code
MidiInst.code forall f a. Lens f a -> a -> f -> f
#= Code
code forall a b. (a -> b) -> a -> b
$
    forall a. ToVal a => Text -> a -> Patch -> Patch
MidiInst.environ Text
EnvKey.open_strings [NoteNumber]
open_strings forall a b. (a -> b) -> a -> b
$
    Patch :-> Patch
MidiInst.patchforall a b c. Lens a b -> Lens b c -> Lens a c
#Patch :-> ModeMap
Patch.mode_map forall f a. Lens f a -> a -> f -> f
#= ModeMap
modes forall a b. (a -> b) -> a -> b
$
    Patch :-> Patch
MidiInst.patchforall a b c. Lens a b -> Lens b c -> Lens a c
#Patch :-> AttributeMap
Patch.attribute_map forall f a. Lens f a -> a -> f -> f
#= AttributeMap
keyswitches forall a b. (a -> b) -> a -> b
$
    -- defaults apply after the bipolar conversion
    [(Control, Y)] -> Patch -> Patch
MidiInst.control_defaults [(Control
bow_force, Y
0.5), (Control
bow_pos, Y
0.5)] forall a b. (a -> b) -> a -> b
$
    PbRange -> Text -> [(Control, Control)] -> Patch
MidiInst.named_patch (-Int
24, Int
24) Text
name [(Control, Control)]
controls
    where
    code :: Code
code = [Call Note] -> Code
MidiInst.note_calls
        [ forall d. Symbol -> Calls d -> Call d
MidiInst.both Symbol
"o" Calls Note
c_harmonic
        , forall d. Symbol -> Calls d -> Call d
MidiInst.both Symbol
"harsh" Calls Note
c_harsh
        , forall d. Symbol -> Calls d -> Call d
MidiInst.both Symbol
"spic" Calls Note
c_spiccato
        , Symbol -> Doc -> Control -> Y -> Call Note
control_call Symbol
"pont" Doc
"Sul ponticello." Control
bow_pos (-Y
1)
        , Symbol -> Doc -> Control -> Y -> Call Note
control_call Symbol
"tasto" Doc
"Sul tasto." Control
bow_pos Y
1
        , Symbol -> Doc -> Control -> Y -> Call Note
control_call Symbol
"flaut" Doc
"Flautando." Control
bow_force (-Y
1)
        , forall d. Symbol -> Transformer d -> Call d
MidiInst.transformer Symbol
"bow" Transformer Note
c_bow
        , forall d. Symbol -> Transformer d -> Call d
MidiInst.transformer Symbol
"`downbow`" (Parser BowDirection -> Transformer Note
c_bow_direction (forall (f :: * -> *) a. Applicative f => a -> f a
pure BowDirection
Down))
        , forall d. Symbol -> Transformer d -> Call d
MidiInst.transformer Symbol
"`upbow`" (Parser BowDirection -> Transformer Note
c_bow_direction (forall (f :: * -> *) a. Applicative f => a -> f a
pure BowDirection
Up))
        , forall d. Symbol -> Generator d -> Call d
MidiInst.generator Symbol
"damp" Generator Note
c_damp
        ]
        forall a. Semigroup a => a -> a -> a
<> InstrumentPostproc -> Code
MidiInst.postproc ((,[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> Note
postproc)
    controls :: [(Control, Control)]
controls = [(Control, Control)]
mode_controls forall a. [a] -> [a] -> [a]
++
        [ (Control
CC.mod, Control
Controls.vib)
        , (Control
CC.vib_speed, Control
Controls.vib_speed)
        , (Control
CC.pan, Control
Controls.pan)
        -- Set to >0 to turn legato into portamento.  The VST defaults to 0 is
        -- slow, 1 is fast, but I reversed it so the default 0 gets noraml
        -- legato.
        , (Control
5, Control
"port-time")
        -- When there's a string crossing on a portamento, this is ratio of
        -- string 1 to string 2.
        , (Control
14, Control
"port-split")
        , (Control
15, Control
bow_force)
        , (Control
16, Control
bow_pos)
        , (Control
17, Control
"bow-noise")
        , (Control
20, Control
"trem-speed")
        -- <64 or >=64
        -- called sustain, but I use that name for something else
        , (Control
64, Control
Controls.pedal)
        ]
    -- CC breakpoints are <=42, <=84, >=85
    keyswitches :: AttributeMap
keyswitches = [(Control, [(Attributes, Control)])] -> AttributeMap
Patch.cc_keyswitches_permute
        [ (Control
32, [(forall a. Monoid a => a
mempty, Control
10), (Attributes
Attrs.pizz, Control
60), (Attributes
Attrs.legno, Control
100)])
        , (Control
39, [(forall a. Monoid a => a
mempty, Control
10), (Attributes
Attrs.harm, Control
60), (Attributes
Attrs.harmforall a. Semigroup a => a -> a -> a
<>Attributes
Attrs.third, Control
100)])
        , (Control
41, [(forall a. Monoid a => a
mempty, Control
10), (Attributes
Attrs.trem, Control
60), (Text -> Attributes
Attrs.attr Text
"trem-fast", Control
100)])
        , (Control
65, [(forall a. Monoid a => a
mempty, Control
0), (Attributes
Attrs.mute, Control
127)]) -- con sord
        ]
    (ModeMap
modes, [(Control, Control)]
mode_controls) = [(Text, Control, [(MiniVal, Control)])]
-> (ModeMap, [(Control, Control)])
Patch.cc_mode_map
        [ (Text
"gesture", Control
33, [(MiniVal
"expr", Control
10), (MiniVal
"bipolar", Control
60), (MiniVal
"bowing", Control
100)])
        -- Which strings to select for double-stops mode.
        , (Text
"str-select", Control
34, [(MiniVal
"4-3", Control
10), (MiniVal
"3-2", Control
80), (MiniVal
"2-1", Control
100)])
        , (Text
"poly-mode", Control
35, [(MiniVal
"mono-sx", Control
10), (MiniVal
"mono", Control
40),
            (MiniVal
"double", Control
60), (MiniVal
"double-hold", Control
80), (MiniVal
"auto", Control
120)])
        , (Text
"fingering", Control
36, [(MiniVal
"mid", Control
10), (MiniVal
"bridge", Control
60), (MiniVal
"nut", Control
100)])
        , (Text
"bow-lift", Control
37, [(MiniVal
"t", Control
10), (MiniVal
"f", Control
80)])
        , (Text
"bow-start", Control
38, [(MiniVal
"d", Control
10), (MiniVal
"u", Control
80)])
        ]

bow_force :: ScoreT.Control
bow_force :: Control
bow_force = Control
"bow-force"

bow_pos :: ScoreT.Control
bow_pos :: Control
bow_pos = Control
"bow-pos"

postproc :: Score.Event -> Score.Event
postproc :: Note -> Note
postproc = [Control] -> Note -> Note
bipolar_controls [Control
bow_force, Control
bow_pos] forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> Note
bipolar_expression

bipolar_controls :: [ScoreT.Control] -> Score.Event -> Score.Event
bipolar_controls :: [Control] -> Note -> Note
bipolar_controls [Control]
controls Note
event
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map Control (Typed Control)
sigs = Note
event
    | Bool
otherwise = (Environ -> Environ) -> Note -> Note
Score.modify_environ (Map Control (Typed Control) -> Environ
Env.from_controls Map Control (Typed Control)
sigs <>) Note
event
    where
    sigs :: Map Control (Typed Control)
sigs = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Typed Control -> Typed Control
normalize) forall a b. (a -> b) -> a -> b
$ forall b b2 a. (b -> Maybe b2) -> [(a, b)] -> [(a, b2)]
Lists.mapMaybeSnd forall a. a -> a
id forall a b. (a -> b) -> a -> b
$
        forall a k. (a -> k) -> [a] -> [(a, k)]
Lists.keyOnSnd (\Control
c -> forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Control
c (Note -> Map Control (Typed Control)
Score.event_controls Note
event))
            [Control]
controls

-- | When gesture=bipolar, the expression control is 0--62 for downbow, 64-127
-- for upbow.
bipolar_expression :: Score.Event -> Score.Event
bipolar_expression :: Note -> Note
bipolar_expression = forall val.
(Typecheck val, Eq val) =>
Text -> val -> (Note -> Note) -> Note -> Note
when_val Text
"gesture" (Text
"bipolar" :: Text) forall a b. (a -> b) -> a -> b
$
    [Control] -> Note -> Note
bipolar_controls [Control
Controls.dynamic]

when_val :: (Typecheck.Typecheck val, Eq val) => EnvKey.Key -> val
    -> (Score.Event -> Score.Event) -> Score.Event -> Score.Event
when_val :: forall val.
(Typecheck val, Eq val) =>
Text -> val -> (Note -> Note) -> Note -> Note
when_val Text
key val
val Note -> Note
modify Note
event =
    case forall a. Typecheck a => Text -> Environ -> Maybe a
Env.maybe_val Text
key (Note -> Environ
Score.event_environ Note
event) of
        Just val
v | val
v forall a. Eq a => a -> a -> Bool
== val
val -> Note -> Note
modify Note
event
        Maybe val
_ -> Note
event

-- Normalize -1--1 to 0--1.
normalize :: ScoreT.Typed Signal.Control -> ScoreT.Typed Signal.Control
normalize :: Typed Control -> Typed Control
normalize = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall {k} (kind :: k). Y -> Signal kind -> Signal kind
Signal.scalar_divide Y
2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (kind :: k). Y -> Signal kind -> Signal kind
Signal.scalar_add Y
1)

-- * calls

-- Up and Down mean set gesture=bipolar, and leave dyn alone or invert it.
-- Alternate means each non-overlapping note gets inverted direction
c_bow :: Derive.Transformer Derive.Note
c_bow :: Transformer Note
c_bow = Parser BowDirection -> Transformer Note
c_bow_direction (forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"dir" BowDirection
Alternate Doc
"Bow direction.")

c_bow_direction :: Sig.Parser BowDirection -> Derive.Transformer Derive.Note
c_bow_direction :: Parser BowDirection -> Transformer Note
c_bow_direction Parser BowDirection
sig = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.instrument CallName
"bow" forall a. Monoid a => a
mempty
    Doc
"Set bow direction, either to up or down, or alternate. Alternate means\
    \ the bow changes as soon as there is a non-overlapping note." forall a b. (a -> b) -> a -> b
$
    forall y a d.
Taggable y =>
Parser a -> (a -> Transformer y d) -> WithArgDoc (Transformer y d)
Sig.callt Parser BowDirection
sig forall a b. (a -> b) -> a -> b
$
    \BowDirection
dir PassedArgs Note
_args -> forall {f :: * -> *}.
Functor f =>
BowDirection -> f (Stream Note) -> f (Stream Note)
bow BowDirection
dir forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall val a. ToVal val => Text -> val -> Deriver a -> Deriver a
Derive.with_val Text
"gesture" (Text
"bipolar" :: Text)
    where
    bow :: BowDirection -> f (Stream Note) -> f (Stream Note)
bow BowDirection
dir f (Stream Note)
deriver = case BowDirection
dir of
        BowDirection
Down -> forall a b. (a -> b) -> Stream a -> Stream b
Post.emap1_ Note -> Note
invert_dyn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Stream Note)
deriver
        BowDirection
Up -> f (Stream Note)
deriver
        BowDirection
Alternate -> forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall state a b.
(state -> a -> (state, b))
-> state -> Stream a -> (state, Stream b)
Post.emap1 UpDown -> (Maybe Note, Note) -> (UpDown, Note)
alternate_bowing UpDown
Call.Down
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key a.
Eq key =>
(a -> key) -> Stream a -> Stream (Maybe a, a)
Post.prev_by Note -> Instrument
Score.event_instrument forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Stream Note)
deriver

alternate_bowing :: Call.UpDown -> (Maybe Score.Event, Score.Event)
    -> (Call.UpDown, Score.Event)
alternate_bowing :: UpDown -> (Maybe Note, Note) -> (UpDown, Note)
alternate_bowing UpDown
dir (Maybe Note
prev, Note
event)
    | forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Note -> Note -> Bool
Score.events_overlap Note
event) Maybe Note
prev = (UpDown
dir, UpDown -> Note -> Note
set UpDown
dir Note
event)
    | Bool
otherwise = (UpDown -> UpDown
rev UpDown
dir, UpDown -> Note -> Note
set (UpDown -> UpDown
rev UpDown
dir) Note
event)
    where
    rev :: UpDown -> UpDown
rev UpDown
Call.Up = UpDown
Call.Down
    rev UpDown
Call.Down = UpDown
Call.Up
    set :: UpDown -> Note -> Note
set UpDown
Call.Down = Note -> Note
invert_dyn
    set UpDown
Call.Up = forall a. a -> a
id

invert_dyn :: Score.Event -> Score.Event
invert_dyn :: Note -> Note
invert_dyn = Control -> (Y -> Y) -> Note -> Note
Score.modify_control_vals Control
Controls.dynamic forall a. Num a => a -> a
negate

data BowDirection = Down | Up | Alternate
    deriving (BowDirection -> BowDirection -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BowDirection -> BowDirection -> Bool
$c/= :: BowDirection -> BowDirection -> Bool
== :: BowDirection -> BowDirection -> Bool
$c== :: BowDirection -> BowDirection -> Bool
Eq, Int -> BowDirection -> ShowS
[BowDirection] -> ShowS
BowDirection -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BowDirection] -> ShowS
$cshowList :: [BowDirection] -> ShowS
show :: BowDirection -> String
$cshow :: BowDirection -> String
showsPrec :: Int -> BowDirection -> ShowS
$cshowsPrec :: Int -> BowDirection -> ShowS
Show, Int -> BowDirection
BowDirection -> Int
BowDirection -> [BowDirection]
BowDirection -> BowDirection
BowDirection -> BowDirection -> [BowDirection]
BowDirection -> BowDirection -> BowDirection -> [BowDirection]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: BowDirection -> BowDirection -> BowDirection -> [BowDirection]
$cenumFromThenTo :: BowDirection -> BowDirection -> BowDirection -> [BowDirection]
enumFromTo :: BowDirection -> BowDirection -> [BowDirection]
$cenumFromTo :: BowDirection -> BowDirection -> [BowDirection]
enumFromThen :: BowDirection -> BowDirection -> [BowDirection]
$cenumFromThen :: BowDirection -> BowDirection -> [BowDirection]
enumFrom :: BowDirection -> [BowDirection]
$cenumFrom :: BowDirection -> [BowDirection]
fromEnum :: BowDirection -> Int
$cfromEnum :: BowDirection -> Int
toEnum :: Int -> BowDirection
$ctoEnum :: Int -> BowDirection
pred :: BowDirection -> BowDirection
$cpred :: BowDirection -> BowDirection
succ :: BowDirection -> BowDirection
$csucc :: BowDirection -> BowDirection
Enum, BowDirection
forall a. a -> a -> Bounded a
maxBound :: BowDirection
$cmaxBound :: BowDirection
minBound :: BowDirection
$cminBound :: BowDirection
Bounded)

instance Typecheck.Typecheck BowDirection
instance Typecheck.ToVal BowDirection
instance ShowVal.ShowVal BowDirection

control_call :: Expr.Symbol -> Doc.Doc -> ScoreT.Control
    -> Signal.Y -> MidiInst.Call Derive.Note
control_call :: Symbol -> Doc -> Control -> Y -> Call Note
control_call Symbol
name Doc
doc Control
control Y
val = forall d. Symbol -> Calls d -> Call d
MidiInst.both Symbol
name forall a b. (a -> b) -> a -> b
$
    forall a.
Module
-> CallName
-> Tags
-> Doc
-> Parser a
-> (a -> Deriver (Stream Note) -> Deriver (Stream Note))
-> Calls Note
Make.transform_notes Module
Module.instrument (Symbol -> CallName
sym_to_name Symbol
name) forall a. Monoid a => a
mempty Doc
doc
    (forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"val" Y
val Doc
"How much.") forall a b. (a -> b) -> a -> b
$
    \Y
val -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> Stream a -> Stream b
Post.emap1_ forall a b. (a -> b) -> a -> b
$ Control -> (Y -> Y) -> Note -> Note
Score.modify_control_vals Control
control (forall a. Num a => a -> a -> a
+Y
val)
    where
    sym_to_name :: Symbol -> CallName
sym_to_name (Expr.Symbol Text
a) = Text -> CallName
Derive.CallName Text
a

c_harsh :: Library.Calls Derive.Note
c_harsh :: Calls Note
c_harsh = forall a.
Module
-> CallName
-> Tags
-> Doc
-> Parser a
-> (a -> Deriver (Stream Note) -> Deriver (Stream Note))
-> Calls Note
Make.transform_notes Module
Module.instrument CallName
"harsh" forall a. Monoid a => a
mempty
    Doc
"Harsh attack." ((,)
    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
"val" (Y
1 :: Double) Doc
"How much bow pressure."
    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
"dur" (Y
0.15 :: Double) Doc
"How long."
    ) forall a b. (a -> b) -> a -> b
$ \(Y
val, RealTime
dur) -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> Stream a -> Stream b
Post.emap1_ (Y -> RealTime -> Note -> Note
attack Y
val RealTime
dur)
    where
    attack :: Y -> RealTime -> Note -> Note
attack Y
val RealTime
dur Note
event =
        Control -> (Control -> Control) -> Note -> Note
Score.modify_signal Control
bow_force (Control -> Control -> Control
Signal.sig_add forall {k} {kind :: k}. Signal kind
sig) Note
event
        where
        start :: RealTime
start = Note -> RealTime
Score.event_start Note
event
        sig :: Signal kind
sig = forall {k} (kind :: k). [(RealTime, Y)] -> Signal kind
Signal.from_pairs [(RealTime
start, Y
val), (RealTime
startforall a. Num a => a -> a -> a
+RealTime
dur, Y
0)]

c_spiccato :: Library.Calls Derive.Note
c_spiccato :: Calls Note
c_spiccato = forall a.
Module
-> CallName
-> Tags
-> Doc
-> Parser a
-> (a -> Deriver (Stream Note) -> Deriver (Stream Note))
-> Calls Note
Make.transform_notes Module
Module.instrument CallName
"spic" forall a. Monoid a => a
mempty Doc
"Spiccato."
    (forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"dur" (RealTime
0.05 :: RealTime) Doc
"How long."
    ) forall a b. (a -> b) -> a -> b
$ \(Typecheck.RealTimeFunctionT TimeT
dur_t Function
dur) Deriver (Stream Note)
deriver -> do
        Stream Note
events <- forall val a. ToVal val => Text -> val -> Deriver a -> Deriver a
Derive.with_val Text
"bow-lift" (forall a. ShowVal a => a -> Text
ShowVal.show_val Bool
True) Deriver (Stream Note)
deriver
        [RealTime]
durs <- TimeT -> Function -> Stream Note -> Deriver [RealTime]
Post.duration_control TimeT
dur_t Function
dur Stream Note
events
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> Stream a -> Stream b
Post.emap1_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry RealTime -> Note -> Note
Score.set_duration)
            (forall a x. [a] -> Stream x -> Stream (a, x)
Stream.zip [RealTime]
durs Stream Note
events)

c_harmonic :: Library.Calls Derive.Note
c_harmonic :: Calls Note
c_harmonic = forall a.
Module
-> CallName
-> Tags
-> Doc
-> Parser a
-> (a -> Deriver (Stream Note) -> Deriver (Stream Note))
-> Calls Note
Make.transform_notes Module
Module.instrument CallName
"harmonic"
    (Tags
Tags.attr forall a. Semigroup a => a -> a -> a
<> Tags
Tags.ly)
    Doc
"Harmonic, with lilypond for natural and artificial harmonic notation."
    ((,)
    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
"n" (Y
2 :: Double)
        Doc
"Which harmonic. SWAM only supports 2 and 3."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ([Pitch], Maybe Pitch, Bool)
Articulation.lily_harmonic_sig
    ) forall a b. (a -> b) -> a -> b
$ \(Int
harm, ([Pitch], Maybe Pitch, Bool)
lily_args) Deriver (Stream Note)
deriver -> forall a. Deriver a -> Deriver a -> Deriver a
Ly.when_lilypond
        (([Pitch], Maybe Pitch, Bool)
-> HarmonicType -> Deriver (Stream Note) -> Deriver (Stream Note)
Articulation.lily_harmonic ([Pitch], Maybe Pitch, Bool)
lily_args (forall {a}. (Eq a, Num a) => a -> HarmonicType
htype Int
harm) Deriver (Stream Note)
deriver)
        (forall {d}. Int -> Deriver d -> Deriver d
harmonic Int
harm Deriver (Stream Note)
deriver)
    where
    harmonic :: Int -> Deriver d -> Deriver d
harmonic (Int
h :: Int) Deriver d
deriver = case Int
h of
        Int
2 -> forall d. Attributes -> Deriver d -> Deriver d
Call.add_attributes Attributes
Attrs.harm forall a b. (a -> b) -> a -> b
$
            forall a. Control -> Y -> Deriver a -> Deriver a
Call.add_constant Control
Controls.nn (-Y
12) Deriver d
deriver
        Int
3 -> forall d. Attributes -> Deriver d -> Deriver d
Call.add_attributes (Attributes
Attrs.harm forall a. Semigroup a => a -> a -> a
<> Attributes
Attrs.third) forall a b. (a -> b) -> a -> b
$
            forall a. Control -> Y -> Deriver a -> Deriver a
Call.add_constant Control
Controls.nn (-Y
19) Deriver d
deriver
        Int
h -> forall a. HasCallStack => Text -> Deriver a
Derive.throw forall a b. (a -> b) -> a -> b
$ Text
"only 2nd and 3rd harmonics supported: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
h
    -- TODO this doesn't look at open strings, so it will produce lilypond that
    -- doesn't correspond to what the synth plays.  Or maybe it's that the
    -- synth will happily play impossible things, but the notation tries to
    -- be realistic.
    htype :: a -> HarmonicType
htype a
2 = HarmonicType
Articulation.Natural
    htype a
_ = HarmonicType
Articulation.Artificial

-- | Emit a short note with reduced dyn, bow-lift=f.
c_damp :: Derive.Generator Derive.Note
c_damp :: Generator Note
c_damp = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
Module.instrument CallName
"damp" forall a. Monoid a => a
mempty
    Doc
"Emit a damped stroke." forall a b. (a -> b) -> a -> b
$
    forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"dur" (RealTime -> DefaultReal
Typecheck.real RealTime
0.05) Doc
"Duration."
    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
"dyn" (Y
0.5 :: Double) Doc
"Dynamic scale."
    ) forall a b. (a -> b) -> a -> b
$ \(Typecheck.DefaultReal Duration
dur, Y
dyn) -> forall d.
(PassedArgs d -> Deriver (Stream Note))
-> PassedArgs d -> Deriver (Stream Note)
Sub.inverting forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
args -> do
        ScoreTime
dur <- forall a. Time a => a -> Deriver ScoreTime
Derive.score Duration
dur
        forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a
Derive.place (forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs Note
args) ScoreTime
dur forall a b. (a -> b) -> a -> b
$
            forall val a. ToVal val => Text -> val -> Deriver a -> Deriver a
Derive.with_val Text
"bow-lift" (forall a. ShowVal a => a -> Text
ShowVal.show_val Bool
False) forall a b. (a -> b) -> a -> b
$
            forall a. Y -> Deriver a -> Deriver a
Call.multiply_dynamic Y
dyn Deriver (Stream Note)
Call.note