-- 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.Seq as Seq
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


{-
    "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" ([Patch] -> Synth) -> [Patch] -> Synth
forall a b. (a -> b) -> a -> b
$
        [(Control, Control)] -> [Patch] -> [Patch]
MidiInst.synth_controls [] [Patch]
patches
    where
    patches :: [Patch]
patches = ((Text, [NoteNumber]) -> Patch)
-> [(Text, [NoteNumber])] -> [Patch]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> [NoteNumber] -> Patch) -> (Text, [NoteNumber]) -> Patch
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 (Patch -> Patch) -> Patch -> Patch
forall a b. (a -> b) -> a -> b
$
    Lens Patch Code
MidiInst.code Lens Patch Code -> Code -> Patch -> Patch
forall f a. Lens f a -> a -> f -> f
#= Code
code (Patch -> Patch) -> Patch -> Patch
forall a b. (a -> b) -> a -> b
$
    Text -> [NoteNumber] -> Patch -> Patch
forall a. ToVal a => Text -> a -> Patch -> Patch
MidiInst.environ Text
EnvKey.open_strings [NoteNumber]
open_strings (Patch -> Patch) -> Patch -> Patch
forall a b. (a -> b) -> a -> b
$
    Patch :-> Patch
MidiInst.patch(Patch :-> Patch) -> Lens Patch ModeMap -> Lens Patch ModeMap
forall a b c. Lens a b -> Lens b c -> Lens a c
#Lens Patch ModeMap
Patch.mode_map Lens Patch ModeMap -> ModeMap -> Patch -> Patch
forall f a. Lens f a -> a -> f -> f
#= ModeMap
modes (Patch -> Patch) -> Patch -> Patch
forall a b. (a -> b) -> a -> b
$
    Patch :-> Patch
MidiInst.patch(Patch :-> Patch)
-> Lens Patch AttributeMap -> Lens Patch AttributeMap
forall a b c. Lens a b -> Lens b c -> Lens a c
#Lens Patch AttributeMap
Patch.attribute_map Lens Patch AttributeMap -> AttributeMap -> Patch -> Patch
forall f a. Lens f a -> a -> f -> f
#= AttributeMap
keyswitches (Patch -> Patch) -> Patch -> Patch
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)] (Patch -> Patch) -> Patch -> Patch
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
        [ Symbol -> Calls Note -> Call Note
forall d. Symbol -> Calls d -> Call d
MidiInst.both Symbol
"o" Calls Note
c_harmonic
        , Symbol -> Calls Note -> Call Note
forall d. Symbol -> Calls d -> Call d
MidiInst.both Symbol
"harsh" Calls Note
c_harsh
        , Symbol -> Calls Note -> Call Note
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)
        , Symbol -> Transformer Note -> Call Note
forall d. Symbol -> Transformer d -> Call d
MidiInst.transformer Symbol
"bow" Transformer Note
c_bow
        , Symbol -> Transformer Note -> Call Note
forall d. Symbol -> Transformer d -> Call d
MidiInst.transformer Symbol
"`downbow`" (Parser BowDirection -> Transformer Note
c_bow_direction (BowDirection -> Parser BowDirection
forall (f :: * -> *) a. Applicative f => a -> f a
pure BowDirection
Down))
        , Symbol -> Transformer Note -> Call Note
forall d. Symbol -> Transformer d -> Call d
MidiInst.transformer Symbol
"`upbow`" (Parser BowDirection -> Transformer Note
c_bow_direction (BowDirection -> Parser BowDirection
forall (f :: * -> *) a. Applicative f => a -> f a
pure BowDirection
Up))
        , Symbol -> Generator Note -> Call Note
forall d. Symbol -> Generator d -> Call d
MidiInst.generator Symbol
"damp" Generator Note
c_damp
        ]
        Code -> Code -> Code
forall a. Semigroup a => a -> a -> a
<> InstrumentPostproc -> Code
MidiInst.postproc ((,[]) InstrumentPostproc -> (Note -> Note) -> InstrumentPostproc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> Note
postproc)
    controls :: [(Control, Control)]
controls = [(Control, Control)]
mode_controls [(Control, Control)]
-> [(Control, Control)] -> [(Control, Control)]
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, [(Attributes
forall a. Monoid a => a
mempty, Control
10), (Attributes
Attrs.pizz, Control
60), (Attributes
Attrs.legno, Control
100)])
        , (Control
39, [(Attributes
forall a. Monoid a => a
mempty, Control
10), (Attributes
Attrs.harm, Control
60), (Attributes
Attrs.harmAttributes -> Attributes -> Attributes
forall a. Semigroup a => a -> a -> a
<>Attributes
Attrs.third, Control
100)])
        , (Control
41, [(Attributes
forall a. Monoid a => a
mempty, Control
10), (Attributes
Attrs.trem, Control
60), (Text -> Attributes
Attrs.attr Text
"trem-fast", Control
100)])
        , (Control
65, [(Attributes
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] (Note -> Note) -> (Note -> Note) -> Note -> Note
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
    | ControlMap -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ControlMap
sigs = Note
event
    | Bool
otherwise = Note
event
        { event_controls :: ControlMap
Score.event_controls = ControlMap
sigs ControlMap -> ControlMap -> ControlMap
forall a. Semigroup a => a -> a -> a
<> Note -> ControlMap
Score.event_controls Note
event }
    where
    sigs :: ControlMap
sigs = [(Control, Typed Control)] -> ControlMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Control, Typed Control)] -> ControlMap)
-> [(Control, Typed Control)] -> ControlMap
forall a b. (a -> b) -> a -> b
$ ((Control, Typed Control) -> (Control, Typed Control))
-> [(Control, Typed Control)] -> [(Control, Typed Control)]
forall a b. (a -> b) -> [a] -> [b]
map ((Typed Control -> Typed Control)
-> (Control, Typed Control) -> (Control, Typed Control)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Typed Control -> Typed Control
normalize) ([(Control, Typed Control)] -> [(Control, Typed Control)])
-> [(Control, Typed Control)] -> [(Control, Typed Control)]
forall a b. (a -> b) -> a -> b
$ (Maybe (Typed Control) -> Maybe (Typed Control))
-> [(Control, Maybe (Typed Control))] -> [(Control, Typed Control)]
forall b b2 a. (b -> Maybe b2) -> [(a, b)] -> [(a, b2)]
Seq.map_maybe_snd Maybe (Typed Control) -> Maybe (Typed Control)
forall a. a -> a
id ([(Control, Maybe (Typed Control))] -> [(Control, Typed Control)])
-> [(Control, Maybe (Typed Control))] -> [(Control, Typed Control)]
forall a b. (a -> b) -> a -> b
$
        (Control -> Maybe (Typed Control))
-> [Control] -> [(Control, Maybe (Typed Control))]
forall a k. (a -> k) -> [a] -> [(a, k)]
Seq.key_on_snd (\Control
c -> Control -> ControlMap -> Maybe (Typed Control)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Control
c (Note -> ControlMap
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 = Text -> Text -> (Note -> Note) -> Note -> Note
forall val.
(Typecheck val, Eq val) =>
Text -> val -> (Note -> Note) -> Note -> Note
when_val Text
"gesture" (Text
"bipolar" :: Text) ((Note -> Note) -> Note -> Note) -> (Note -> Note) -> Note -> Note
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 Text -> Environ -> Maybe val
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 val -> val -> Bool
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 = (Control -> Control) -> Typed Control -> Typed Control
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Y -> Control -> Control
forall {k} (kind :: k). Y -> Signal kind -> Signal kind
Signal.scalar_divide Y
2 (Control -> Control) -> (Control -> Control) -> Control -> Control
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Y -> Control -> Control
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 (ArgName -> BowDirection -> Doc -> Parser BowDirection
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> a -> 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 = Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF Note)
-> Transformer Note
forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.instrument CallName
"bow" Tags
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." (WithArgDoc (TransformerF Note) -> Transformer Note)
-> WithArgDoc (TransformerF Note) -> Transformer Note
forall a b. (a -> b) -> a -> b
$
    Parser BowDirection
-> (BowDirection -> TransformerF Note)
-> WithArgDoc (TransformerF Note)
forall y a d.
Taggable y =>
Parser a -> (a -> Transformer y d) -> WithArgDoc (Transformer y d)
Sig.callt Parser BowDirection
sig ((BowDirection -> TransformerF Note)
 -> WithArgDoc (TransformerF Note))
-> (BowDirection -> TransformerF Note)
-> WithArgDoc (TransformerF Note)
forall a b. (a -> b) -> a -> b
$
    \BowDirection
dir PassedArgs Note
_args -> BowDirection
-> Deriver State Error (Stream Note)
-> Deriver State Error (Stream Note)
forall {f :: * -> *}.
Functor f =>
BowDirection -> f (Stream Note) -> f (Stream Note)
bow BowDirection
dir (Deriver State Error (Stream Note)
 -> Deriver State Error (Stream Note))
-> (Deriver State Error (Stream Note)
    -> Deriver State Error (Stream Note))
-> Deriver State Error (Stream Note)
-> Deriver State Error (Stream Note)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> Text
-> Deriver State Error (Stream Note)
-> Deriver State Error (Stream Note)
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 -> (Note -> Note) -> Stream Note -> Stream Note
forall a b. (a -> b) -> Stream a -> Stream b
Post.emap1_ Note -> Note
invert_dyn (Stream Note -> Stream Note) -> f (Stream Note) -> f (Stream Note)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Stream Note)
deriver
        BowDirection
Up -> f (Stream Note)
deriver
        BowDirection
Alternate -> (UpDown, Stream Note) -> Stream Note
forall a b. (a, b) -> b
snd ((UpDown, Stream Note) -> Stream Note)
-> (Stream Note -> (UpDown, Stream Note))
-> Stream Note
-> Stream Note
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UpDown -> (Maybe Note, Note) -> (UpDown, Note))
-> UpDown -> Stream (Maybe Note, Note) -> (UpDown, Stream Note)
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
            (Stream (Maybe Note, Note) -> (UpDown, Stream Note))
-> (Stream Note -> Stream (Maybe Note, Note))
-> Stream Note
-> (UpDown, Stream Note)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Note -> Instrument) -> Stream Note -> Stream (Maybe Note, Note)
forall key a.
Eq key =>
(a -> key) -> Stream a -> Stream (Maybe a, a)
Post.prev_by Note -> Instrument
Score.event_instrument (Stream Note -> Stream Note) -> f (Stream Note) -> f (Stream Note)
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)
    | Bool -> (Note -> Bool) -> Maybe Note -> Bool
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 = Note -> Note
forall a. a -> a
id

invert_dyn :: Score.Event -> Score.Event
invert_dyn :: Note -> Note
invert_dyn = Control -> (Control -> Control) -> Note -> Note
Score.modify_control Control
Controls.dynamic (Y -> Control -> Control
forall {k} (kind :: k). Y -> Signal kind -> Signal kind
Signal.scalar_multiply (-Y
1))

data BowDirection = Down | Up | Alternate
    deriving (BowDirection -> BowDirection -> Bool
(BowDirection -> BowDirection -> Bool)
-> (BowDirection -> BowDirection -> Bool) -> Eq BowDirection
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
(Int -> BowDirection -> ShowS)
-> (BowDirection -> String)
-> ([BowDirection] -> ShowS)
-> Show BowDirection
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]
(BowDirection -> BowDirection)
-> (BowDirection -> BowDirection)
-> (Int -> BowDirection)
-> (BowDirection -> Int)
-> (BowDirection -> [BowDirection])
-> (BowDirection -> BowDirection -> [BowDirection])
-> (BowDirection -> BowDirection -> [BowDirection])
-> (BowDirection -> BowDirection -> BowDirection -> [BowDirection])
-> Enum 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
BowDirection -> BowDirection -> Bounded 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 = Symbol -> Calls Note -> Call Note
forall d. Symbol -> Calls d -> Call d
MidiInst.both Symbol
name (Calls Note -> Call Note) -> Calls Note -> Call Note
forall a b. (a -> b) -> a -> b
$
    Module
-> CallName
-> Tags
-> Doc
-> Parser Y
-> (Y
    -> Deriver State Error (Stream Note)
    -> Deriver State Error (Stream Note))
-> Calls Note
forall a.
Module
-> CallName
-> Tags
-> Doc
-> Parser a
-> (a
    -> Deriver State Error (Stream Note)
    -> Deriver State Error (Stream Note))
-> Calls Note
Make.transform_notes Module
Module.instrument (Symbol -> CallName
sym_to_name Symbol
name) Tags
forall a. Monoid a => a
mempty Doc
doc
    (ArgName -> Y -> Doc -> Parser Y
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> a -> Doc -> Parser a
Sig.defaulted ArgName
"val" Y
val Doc
"How much.") ((Y
  -> Deriver State Error (Stream Note)
  -> Deriver State Error (Stream Note))
 -> Calls Note)
-> (Y
    -> Deriver State Error (Stream Note)
    -> Deriver State Error (Stream Note))
-> Calls Note
forall a b. (a -> b) -> a -> b
$
    \Y
val -> (Stream Note -> Stream Note)
-> Deriver State Error (Stream Note)
-> Deriver State Error (Stream Note)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Stream Note -> Stream Note)
 -> Deriver State Error (Stream Note)
 -> Deriver State Error (Stream Note))
-> (Stream Note -> Stream Note)
-> Deriver State Error (Stream Note)
-> Deriver State Error (Stream Note)
forall a b. (a -> b) -> a -> b
$ (Note -> Note) -> Stream Note -> Stream Note
forall a b. (a -> b) -> Stream a -> Stream b
Post.emap1_ ((Note -> Note) -> Stream Note -> Stream Note)
-> (Note -> Note) -> Stream Note -> Stream Note
forall a b. (a -> b) -> a -> b
$ Control -> (Control -> Control) -> Note -> Note
Score.modify_control Control
control ((Control -> Control) -> Note -> Note)
-> (Control -> Control) -> Note -> Note
forall a b. (a -> b) -> a -> b
$
        Control -> Control -> Control
Signal.sig_add (Y -> Control
forall {k} (kind :: k). Y -> Signal kind
Signal.constant 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 = Module
-> CallName
-> Tags
-> Doc
-> Parser (Y, RealTime)
-> ((Y, RealTime)
    -> Deriver State Error (Stream Note)
    -> Deriver State Error (Stream Note))
-> Calls Note
forall a.
Module
-> CallName
-> Tags
-> Doc
-> Parser a
-> (a
    -> Deriver State Error (Stream Note)
    -> Deriver State Error (Stream Note))
-> Calls Note
Make.transform_notes Module
Module.instrument CallName
"harsh" Tags
forall a. Monoid a => a
mempty
    Doc
"Harsh attack." ((,)
    (Y -> RealTime -> (Y, RealTime))
-> Parser Y -> Parser (RealTime -> (Y, RealTime))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgName -> Y -> Doc -> Parser Y
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> a -> Doc -> Parser a
Sig.defaulted ArgName
"val" Y
1 Doc
"How much bow pressure."
    Parser (RealTime -> (Y, RealTime))
-> Parser RealTime -> Parser (Y, RealTime)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ArgName -> RealTime -> Doc -> Parser RealTime
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> a -> Doc -> Parser a
Sig.defaulted ArgName
"dur" RealTime
0.15 Doc
"How long."
    ) (((Y, RealTime)
  -> Deriver State Error (Stream Note)
  -> Deriver State Error (Stream Note))
 -> Calls Note)
-> ((Y, RealTime)
    -> Deriver State Error (Stream Note)
    -> Deriver State Error (Stream Note))
-> Calls Note
forall a b. (a -> b) -> a -> b
$ \(Y
val, RealTime
dur) -> (Stream Note -> Stream Note)
-> Deriver State Error (Stream Note)
-> Deriver State Error (Stream Note)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Stream Note -> Stream Note)
 -> Deriver State Error (Stream Note)
 -> Deriver State Error (Stream Note))
-> (Stream Note -> Stream Note)
-> Deriver State Error (Stream Note)
-> Deriver State Error (Stream Note)
forall a b. (a -> b) -> a -> b
$ (Note -> Note) -> Stream Note -> Stream Note
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_control Control
bow_force (Control -> Control -> Control
Signal.sig_add Control
forall {k} {kind :: k}. Signal kind
sig) Note
event
        where
        start :: RealTime
start = Note -> RealTime
Score.event_start Note
event
        sig :: Signal kind
sig = [(RealTime, Y)] -> Signal kind
forall {k} (kind :: k). [(RealTime, Y)] -> Signal kind
Signal.from_pairs [(RealTime
start, Y
val), (RealTime
startRealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
+RealTime
dur, Y
0)]

c_spiccato :: Library.Calls Derive.Note
c_spiccato :: Calls Note
c_spiccato = Module
-> CallName
-> Tags
-> Doc
-> Parser ControlRef
-> (ControlRef
    -> Deriver State Error (Stream Note)
    -> Deriver State Error (Stream Note))
-> Calls Note
forall a.
Module
-> CallName
-> Tags
-> Doc
-> Parser a
-> (a
    -> Deriver State Error (Stream Note)
    -> Deriver State Error (Stream Note))
-> Calls Note
Make.transform_notes Module
Module.instrument CallName
"spic" Tags
forall a. Monoid a => a
mempty Doc
"Spiccato."
    (ArgName -> ControlRef -> Doc -> Parser ControlRef
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> a -> Doc -> Parser a
Sig.defaulted ArgName
"dur" (Control -> Y -> Type -> ControlRef
Sig.typed_control Control
"spic-dur" Y
0.05 Type
ScoreT.Real)
        Doc
"How long."
    ) ((ControlRef
  -> Deriver State Error (Stream Note)
  -> Deriver State Error (Stream Note))
 -> Calls Note)
-> (ControlRef
    -> Deriver State Error (Stream Note)
    -> Deriver State Error (Stream Note))
-> Calls Note
forall a b. (a -> b) -> a -> b
$ \ControlRef
dur Deriver State Error (Stream Note)
deriver -> do
        Stream Note
events <- Text
-> Text
-> Deriver State Error (Stream Note)
-> Deriver State Error (Stream Note)
forall val a. ToVal val => Text -> val -> Deriver a -> Deriver a
Derive.with_val Text
"bow-lift" (Bool -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val Bool
True) Deriver State Error (Stream Note)
deriver
        -- This is a lot of work to make spic-dur be a signal, but it seems not
        -- actually that useful, since if I want variable durations I can just
        -- use sus-set directly.
        [RealTime]
durs <- TimeType -> ControlRef -> Stream Note -> Deriver [RealTime]
Post.duration_control TimeType
Typecheck.Real ControlRef
dur Stream Note
events
        Stream Note -> Deriver State Error (Stream Note)
forall (m :: * -> *) a. Monad m => a -> m a
return (Stream Note -> Deriver State Error (Stream Note))
-> Stream Note -> Deriver State Error (Stream Note)
forall a b. (a -> b) -> a -> b
$ ((RealTime, Note) -> Note)
-> Stream (RealTime, Note) -> Stream Note
forall a b. (a -> b) -> Stream a -> Stream b
Post.emap1_ ((RealTime -> Note -> Note) -> (RealTime, Note) -> Note
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry RealTime -> Note -> Note
Score.set_duration)
            ([RealTime] -> Stream Note -> Stream (RealTime, Note)
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 = Module
-> CallName
-> Tags
-> Doc
-> Parser (Int, ([Pitch], Maybe Pitch, Bool))
-> ((Int, ([Pitch], Maybe Pitch, Bool))
    -> Deriver State Error (Stream Note)
    -> Deriver State Error (Stream Note))
-> Calls Note
forall a.
Module
-> CallName
-> Tags
-> Doc
-> Parser a
-> (a
    -> Deriver State Error (Stream Note)
    -> Deriver State Error (Stream Note))
-> Calls Note
Make.transform_notes Module
Module.instrument CallName
"harmonic"
    (Tags
Tags.attr Tags -> Tags -> Tags
forall a. Semigroup a => a -> a -> a
<> Tags
Tags.ly)
    Doc
"Harmonic, with lilypond for natural and artificial harmonic notation."
    ((,)
    (Int
 -> ([Pitch], Maybe Pitch, Bool)
 -> (Int, ([Pitch], Maybe Pitch, Bool)))
-> Parser Int
-> Parser
     (([Pitch], Maybe Pitch, Bool)
      -> (Int, ([Pitch], Maybe Pitch, Bool)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgName -> Int -> Doc -> Parser Int
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> a -> Doc -> Parser a
Sig.defaulted ArgName
"n" Int
2 Doc
"Which harmonic. SWAM only supports 2 and 3."
    Parser
  (([Pitch], Maybe Pitch, Bool)
   -> (Int, ([Pitch], Maybe Pitch, Bool)))
-> Parser ([Pitch], Maybe Pitch, Bool)
-> Parser (Int, ([Pitch], Maybe Pitch, Bool))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ([Pitch], Maybe Pitch, Bool)
Articulation.lily_harmonic_sig
    ) (((Int, ([Pitch], Maybe Pitch, Bool))
  -> Deriver State Error (Stream Note)
  -> Deriver State Error (Stream Note))
 -> Calls Note)
-> ((Int, ([Pitch], Maybe Pitch, Bool))
    -> Deriver State Error (Stream Note)
    -> Deriver State Error (Stream Note))
-> Calls Note
forall a b. (a -> b) -> a -> b
$ \(Int
harm, ([Pitch], Maybe Pitch, Bool)
lily_args) Deriver State Error (Stream Note)
deriver -> Deriver State Error (Stream Note)
-> Deriver State Error (Stream Note)
-> Deriver State Error (Stream Note)
forall a. Deriver a -> Deriver a -> Deriver a
Ly.when_lilypond
        (([Pitch], Maybe Pitch, Bool)
-> HarmonicType
-> Deriver State Error (Stream Note)
-> Deriver State Error (Stream Note)
Articulation.lily_harmonic ([Pitch], Maybe Pitch, Bool)
lily_args (Int -> HarmonicType
forall {a}. (Eq a, Num a) => a -> HarmonicType
htype Int
harm) Deriver State Error (Stream Note)
deriver)
        (Int
-> Deriver State Error (Stream Note)
-> Deriver State Error (Stream Note)
forall {d}. Int -> Deriver d -> Deriver d
harmonic Int
harm Deriver State Error (Stream Note)
deriver)
    where
    harmonic :: Int -> Deriver d -> Deriver d
harmonic (Int
h :: Int) Deriver d
deriver = case Int
h of
        Int
2 -> Attributes -> Deriver d -> Deriver d
forall d. Attributes -> Deriver d -> Deriver d
Call.add_attributes Attributes
Attrs.harm (Deriver d -> Deriver d) -> Deriver d -> Deriver d
forall a b. (a -> b) -> a -> b
$
            Control -> Y -> Deriver d -> Deriver d
forall a. Control -> Y -> Deriver a -> Deriver a
Call.add_constant Control
Controls.nn (-Y
12) Deriver d
deriver
        Int
3 -> Attributes -> Deriver d -> Deriver d
forall d. Attributes -> Deriver d -> Deriver d
Call.add_attributes (Attributes
Attrs.harm Attributes -> Attributes -> Attributes
forall a. Semigroup a => a -> a -> a
<> Attributes
Attrs.third) (Deriver d -> Deriver d) -> Deriver d -> Deriver d
forall a b. (a -> b) -> a -> b
$
            Control -> Y -> Deriver d -> Deriver d
forall a. Control -> Y -> Deriver a -> Deriver a
Call.add_constant Control
Controls.nn (-Y
19) Deriver d
deriver
        Int
h -> Text -> Deriver d
forall a. HasCallStack => Text -> Deriver a
Derive.throw (Text -> Deriver d) -> Text -> Deriver d
forall a b. (a -> b) -> a -> b
$ Text
"only 2nd and 3rd harmonics supported: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
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 = Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF Note)
-> Generator Note
forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
Module.instrument CallName
"damp" Tags
forall a. Monoid a => a
mempty
    Doc
"Emit a damped stroke." (WithArgDoc (GeneratorF Note) -> Generator Note)
-> WithArgDoc (GeneratorF Note) -> Generator Note
forall a b. (a -> b) -> a -> b
$
    Parser (DefaultReal, Y)
-> ((DefaultReal, Y) -> GeneratorF Note)
-> WithArgDoc (GeneratorF Note)
forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,)
    (DefaultReal -> Y -> (DefaultReal, Y))
-> Parser DefaultReal -> Parser (Y -> (DefaultReal, Y))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgName -> DefaultReal -> Doc -> Parser DefaultReal
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> a -> Doc -> Parser a
Sig.defaulted ArgName
"dur" (RealTime -> DefaultReal
Typecheck.real RealTime
0.05) Doc
"Duration."
    Parser (Y -> (DefaultReal, Y))
-> Parser Y -> Parser (DefaultReal, Y)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ArgName -> Y -> Doc -> Parser Y
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> a -> Doc -> Parser a
Sig.defaulted ArgName
"dyn" Y
0.5 Doc
"Dynamic scale."
    ) (((DefaultReal, Y) -> GeneratorF Note)
 -> WithArgDoc (GeneratorF Note))
-> ((DefaultReal, Y) -> GeneratorF Note)
-> WithArgDoc (GeneratorF Note)
forall a b. (a -> b) -> a -> b
$ \(DefaultReal
dur, Y
dyn) -> GeneratorF Note -> GeneratorF Note
forall d.
(PassedArgs d -> Deriver State Error (Stream Note))
-> PassedArgs d -> Deriver State Error (Stream Note)
Sub.inverting (GeneratorF Note -> GeneratorF Note)
-> GeneratorF Note -> GeneratorF Note
forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
args -> do
        ScoreTime
dur <- DefaultReal -> Deriver ScoreTime
forall a. Time a => a -> Deriver ScoreTime
Derive.score DefaultReal
dur
        ScoreTime
-> ScoreTime
-> Deriver State Error (Stream Note)
-> Deriver State Error (Stream Note)
forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a
Derive.place (PassedArgs Note -> ScoreTime
forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs Note
args) ScoreTime
dur (Deriver State Error (Stream Note)
 -> Deriver State Error (Stream Note))
-> Deriver State Error (Stream Note)
-> Deriver State Error (Stream Note)
forall a b. (a -> b) -> a -> b
$
            Text
-> Text
-> Deriver State Error (Stream Note)
-> Deriver State Error (Stream Note)
forall val a. ToVal val => Text -> val -> Deriver a -> Deriver a
Derive.with_val Text
"bow-lift" (Bool -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val Bool
False) (Deriver State Error (Stream Note)
 -> Deriver State Error (Stream Note))
-> Deriver State Error (Stream Note)
-> Deriver State Error (Stream Note)
forall a b. (a -> b) -> a -> b
$
            Y
-> Deriver State Error (Stream Note)
-> Deriver State Error (Stream Note)
forall a. Y -> Deriver a -> Deriver a
Call.multiply_dynamic Y
dyn Deriver State Error (Stream Note)
Call.note