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

{- | Calls that are similar to staff-notation articulations, or could be.
    This means calls that modify notes in relatively straightforward ways,
    either by adding an attribute or modifying their environment.

    There is already general purpose syntax to add attributes to notes, e.g.
    @attr = +x@ or @n +x@ or just @+x@, and instruments may supply special
    calls for their attributes, but there are several attributes which look
    nice with their own calls and are used by many instruments.

    TODO There are too many ways to apply attributes to notes, and they work in
    inconsistent ways.
-}
module Derive.C.Prelude.Articulation where
import qualified Data.Text as Text

import qualified Util.Lists as Lists
import qualified Derive.Args as Args
import qualified Derive.Attrs as Attrs
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.StringUtil as StringUtil
import qualified Derive.Call.Sub as Sub
import qualified Derive.Call.SubT as SubT
import qualified Derive.Call.Tags as Tags
import qualified Derive.Controls as Controls
import qualified Derive.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Expr as Expr
import qualified Derive.Library as Library
import qualified Derive.PSignal as PSignal
import qualified Derive.Parse as Parse
import qualified Derive.Scale.Twelve as Twelve
import qualified Derive.Score as Score
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Sig as Sig
import qualified Derive.Symbols as Symbols
import qualified Derive.Typecheck as Typecheck

import qualified Perform.Lilypond.Constants as Constants
import qualified Perform.Pitch as Pitch
import qualified Perform.RealTime as RealTime
import qualified Perform.Signal as Signal

import           Global
import           Types


library :: Library.Library
library :: Library
library = forall a. Monoid a => [a] -> a
mconcat
    [ forall d.
(ToLibrary (Generator d), ToLibrary (Transformer d)) =>
[(Symbol, Calls d)] -> Library
Library.both
        [ (Symbol
"o", Calls Note
c_harmonic)
        , (Symbol
Symbols.mute, Module -> Attributes -> Calls Note
Make.attributed_note Module
Module.prelude Attributes
Attrs.mute)
        , (Symbol
".", Module -> Attributes -> Calls Note
Make.attributed_note Module
Module.prelude Attributes
Attrs.staccato)
        , (Symbol
"{", Module -> Attributes -> Calls Note
Make.attributed_note Module
Module.prelude Attributes
Attrs.porta)
        -- I'd use '>', but then it overrides the empty instrument call in note
        -- tracks.  Besides, this way it has a nice symmetry with '^'.
        , (Symbol
Symbols.accent, Calls Note
c_accent)
        , (Symbol
Symbols.weak, Calls Note
c_weak)

        , (Symbol
"-", Bool -> Calls Note
c_shorten_lengthen Bool
True)
        , (Symbol
"+", Bool -> Calls Note
c_shorten_lengthen Bool
False)
        ]
    , forall call.
ToLibrary (Generator call) =>
[(Symbol, Generator call)] -> Library
Library.generators
        [ (Symbol
"(", Maybe UpDown -> Generator Note
c_slur forall a. Maybe a
Nothing)
        -- These do different things in lilypond mode, but in normal
        -- performance they are just the same as a slur.
        , (Symbol
"^(", Maybe UpDown -> Generator Note
c_slur (forall a. a -> Maybe a
Just UpDown
Call.Up))
        , (Symbol
"_(", Maybe UpDown -> Generator Note
c_slur (forall a. a -> Maybe a
Just UpDown
Call.Down))
        ]
    , forall call.
ToLibrary (Transformer call) =>
[(Symbol, Transformer call)] -> Library
Library.transformers
        [ (Symbol
"sus-a", Transformer Note
c_sustain_abs)
        , (Symbol
"sus", Transformer Note
c_sustain)
        ]
    , forall call. ToLibrary call => PatternCall call -> Library
Library.pattern PatternCall (Generator Note)
pattern_attr_generator
    , forall call. ToLibrary call => PatternCall call -> Library
Library.pattern PatternCall (Transformer Note)
pattern_attr_transformer
    ]

-- * attr pattern

pattern_attr_generator :: Derive.PatternCall (Derive.Generator Derive.Note)
pattern_attr_generator :: PatternCall (Generator Note)
pattern_attr_generator = forall call. (Attributes -> call) -> PatternCall call
make_pattern_attr forall a b. (a -> b) -> a -> b
$ \Attributes
attrs ->
    forall d. Calls d -> Generator d
Library.generator forall a b. (a -> b) -> a -> b
$ Module -> Attributes -> Calls Note
Make.attributed_note Module
Module.prelude Attributes
attrs

pattern_attr_transformer :: Derive.PatternCall (Derive.Transformer Derive.Note)
pattern_attr_transformer :: PatternCall (Transformer Note)
pattern_attr_transformer = forall call. (Attributes -> call) -> PatternCall call
make_pattern_attr forall a b. (a -> b) -> a -> b
$ \Attributes
attrs ->
    forall d. Calls d -> Transformer d
Library.transformer forall a b. (a -> b) -> a -> b
$ Module -> Attributes -> Calls Note
Make.attributed_note Module
Module.prelude Attributes
attrs

make_pattern_attr :: (Attrs.Attributes -> call) -> Derive.PatternCall call
make_pattern_attr :: forall call. (Attributes -> call) -> PatternCall call
make_pattern_attr Attributes -> call
call = Derive.PatternCall
    { pat_description :: Text
pat_description = Text
"attribute starting with `+` or `=`"
    , pat_doc :: DocumentedCall
pat_doc = forall d. Call d -> DocumentedCall
Derive.extract_doc forall a b. (a -> b) -> a -> b
$ forall d. Calls d -> Generator d
Library.generator forall a b. (a -> b) -> a -> b
$
        Module -> Attributes -> Calls Note
Make.attributed_note Module
Module.prelude (Text -> Attributes
Attrs.attr Text
"example-attr")
    , pat_function :: Symbol -> Deriver (Maybe call)
pat_function = \(Expr.Symbol Text
sym) -> forall {m :: * -> *}. Monad m => Text -> m (Maybe call)
parse_symbol Text
sym
    }
    where
    parse_symbol :: Text -> m (Maybe call)
parse_symbol Text
sym = case Text -> Maybe (Char, Text)
Text.uncons Text
sym of
        Just (Char
c, Text
_) | Char
c forall a. Eq a => a -> a -> Bool
== Char
'+' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'=' -> case Text -> Either Text Val
Parse.parse_val Text
sym of
            Right (DeriveT.VAttributes Attributes
attrs) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Attributes -> call
call Attributes
attrs)
            Either Text Val
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        Maybe (Char, Text)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

-- * harmonic

c_harmonic :: Library.Calls Derive.Note
c_harmonic :: Calls Note
c_harmonic = forall a.
Module
-> CallName
-> Tags
-> Doc
-> Parser a
-> (a -> NoteDeriver -> NoteDeriver)
-> Calls Note
Make.transform_notes Module
Module.prelude 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
"type" (forall a. Maybe a
Nothing :: Maybe Sig.Dummy) Doc
"Type of harmonic."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ([Pitch], Maybe Pitch, Bool)
lily_harmonic_sig
    ) forall a b. (a -> b) -> a -> b
$ \(Maybe HarmonicType
htype, ([Pitch], Maybe Pitch, Bool)
lily_args) NoteDeriver
deriver -> forall a. Deriver a -> Deriver a -> Deriver a
Ly.when_lilypond
            (([Pitch], Maybe Pitch, Bool)
-> HarmonicType -> NoteDeriver -> NoteDeriver
lily_harmonic ([Pitch], Maybe Pitch, Bool)
lily_args (forall a. a -> Maybe a -> a
fromMaybe HarmonicType
Natural Maybe HarmonicType
htype) NoteDeriver
deriver)
            (forall d. Attributes -> Deriver d -> Deriver d
Call.add_attributes (Attributes
Attrs.harm forall a. Semigroup a => a -> a -> a
<> Maybe HarmonicType -> Attributes
harm_attrs Maybe HarmonicType
htype) NoteDeriver
deriver)
    where
    harm_attrs :: Maybe HarmonicType -> Attributes
harm_attrs Maybe HarmonicType
htype = case Maybe HarmonicType
htype of
        Maybe HarmonicType
Nothing -> forall a. Monoid a => a
mempty
        Just HarmonicType
Natural -> Attributes
Attrs.natural
        Just HarmonicType
Artificial -> Attributes
Attrs.artificial

data HarmonicType = Natural | Artificial
    deriving (HarmonicType -> HarmonicType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HarmonicType -> HarmonicType -> Bool
$c/= :: HarmonicType -> HarmonicType -> Bool
== :: HarmonicType -> HarmonicType -> Bool
$c== :: HarmonicType -> HarmonicType -> Bool
Eq, Int -> HarmonicType -> ShowS
[HarmonicType] -> ShowS
HarmonicType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HarmonicType] -> ShowS
$cshowList :: [HarmonicType] -> ShowS
show :: HarmonicType -> String
$cshow :: HarmonicType -> String
showsPrec :: Int -> HarmonicType -> ShowS
$cshowsPrec :: Int -> HarmonicType -> ShowS
Show, HarmonicType
forall a. a -> a -> Bounded a
maxBound :: HarmonicType
$cmaxBound :: HarmonicType
minBound :: HarmonicType
$cminBound :: HarmonicType
Bounded, Int -> HarmonicType
HarmonicType -> Int
HarmonicType -> [HarmonicType]
HarmonicType -> HarmonicType
HarmonicType -> HarmonicType -> [HarmonicType]
HarmonicType -> HarmonicType -> HarmonicType -> [HarmonicType]
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 :: HarmonicType -> HarmonicType -> HarmonicType -> [HarmonicType]
$cenumFromThenTo :: HarmonicType -> HarmonicType -> HarmonicType -> [HarmonicType]
enumFromTo :: HarmonicType -> HarmonicType -> [HarmonicType]
$cenumFromTo :: HarmonicType -> HarmonicType -> [HarmonicType]
enumFromThen :: HarmonicType -> HarmonicType -> [HarmonicType]
$cenumFromThen :: HarmonicType -> HarmonicType -> [HarmonicType]
enumFrom :: HarmonicType -> [HarmonicType]
$cenumFrom :: HarmonicType -> [HarmonicType]
fromEnum :: HarmonicType -> Int
$cfromEnum :: HarmonicType -> Int
toEnum :: Int -> HarmonicType
$ctoEnum :: Int -> HarmonicType
pred :: HarmonicType -> HarmonicType
$cpred :: HarmonicType -> HarmonicType
succ :: HarmonicType -> HarmonicType
$csucc :: HarmonicType -> HarmonicType
Enum)

instance Typecheck.Typecheck HarmonicType
instance ShowVal.ShowVal HarmonicType where
    show_val :: HarmonicType -> Text
show_val HarmonicType
Natural = Text
"nat"
    show_val HarmonicType
Artificial = Text
"art"

-- | Args for 'lily_harmonic'.
lily_harmonic_sig :: Sig.Parser ([PSignal.Pitch], Maybe PSignal.Pitch, Bool)
lily_harmonic_sig :: Parser ([Pitch], Maybe Pitch, Bool)
lily_harmonic_sig = (,,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a deflt.
(Typecheck a, ToVal deflt) =>
Text -> deflt -> Doc -> Parser a
Sig.environ_key Text
EnvKey.open_strings ([] :: [Sig.Dummy])
        Doc
"Pitches of open strings."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
Text -> deflt -> Doc -> Parser a
Sig.environ_key Text
EnvKey.string (forall a. Maybe a
Nothing :: Maybe Sig.Dummy)
        Doc
"Play on this string."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
Text -> deflt -> Doc -> Parser a
Sig.environ_key Text
"harmonic-force-diamond" Bool
False
        Doc
"If true, use string+diamond notation even for the 2nd natural\
        \ harmonic."

lily_harmonic :: ([PSignal.Pitch], Maybe PSignal.Pitch, Bool)
    -> HarmonicType -> Derive.NoteDeriver -> Derive.NoteDeriver
lily_harmonic :: ([Pitch], Maybe Pitch, Bool)
-> HarmonicType -> NoteDeriver -> NoteDeriver
lily_harmonic ([Pitch]
open_strings, Maybe Pitch
string, Bool
force_diamond) HarmonicType
htype NoteDeriver
deriver = do
    [String]
open_strings <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pitch -> Deriver String
StringUtil.string [Pitch]
open_strings
    Maybe String
string <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Pitch -> Deriver String
StringUtil.string Maybe Pitch
string
    forall a b.
(a -> Note) -> (a -> Deriver [b]) -> Stream a -> Deriver (Stream b)
Post.emap_m_ forall a. a -> a
id
        (Bool
-> HarmonicType
-> [String]
-> Maybe String
-> Note
-> Deriver [Note]
lily_harmonic_event Bool
force_diamond HarmonicType
htype [String]
open_strings Maybe String
string)
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< NoteDeriver
deriver
    -- Ly should have one that skips code events

lily_harmonic_event :: Bool -> HarmonicType -> [StringUtil.String]
    -> Maybe StringUtil.String -> Score.Event -> Derive.Deriver [Score.Event]
lily_harmonic_event :: Bool
-> HarmonicType
-> [String]
-> Maybe String
-> Note
-> Deriver [Note]
lily_harmonic_event Bool
force_diamond HarmonicType
htype [String]
open_strings Maybe String
string Note
event = do
    NoteNumber
nn <- forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require Text
"no pitch" forall a b. (a -> b) -> a -> b
$ Note -> Maybe NoteNumber
Score.initial_nn Note
event
    (NoteNumber
string, Int
harmonic) <- forall err a.
HasCallStack =>
(err -> Text) -> Either err a -> Deriver a
Derive.require_right forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ case HarmonicType
htype of
        HarmonicType
Natural -> [String]
-> Maybe String -> NoteNumber -> Either Text (NoteNumber, Int)
natural_harmonic [String]
open_strings Maybe String
string NoteNumber
nn
        HarmonicType
Artificial -> NoteNumber -> NoteNumber -> Either Text (NoteNumber, Int)
artificial_harmonic NoteNumber
lowest NoteNumber
nn
            where
            lowest :: NoteNumber
lowest = forall b a. b -> (a -> b) -> Maybe a -> b
maybe NoteNumber
0 String -> NoteNumber
StringUtil.str_nn forall a b. (a -> b) -> a -> b
$
                Maybe String
string forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. [a] -> Maybe a
Lists.head [String]
open_strings
    -- When the lilypond backend sees Attrs.harm it knows it's inherently nv.
    let add_harm :: Note -> Note
add_harm = Attributes -> Note -> Note
Score.add_attributes Attributes
Attrs.harm
    forall a b. (a -> b) -> [a] -> [b]
map Note -> Note
add_harm forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> if Int
harmonic forall a. Ord a => a -> a -> Bool
<= Int
2 Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
force_diamond
        then forall (m :: * -> *) a. Monad m => a -> m a
return
            [Code -> Note -> Note
Ly.add_note_code (Distribution -> Position CodePosition
Ly.append Distribution
Constants.All, Text
"-\\flageolet") Note
event]
        else do
            NoteNumber
interval <- forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require
                (Text
"harmonic not supported: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
harmonic)
                (Int -> Maybe NoteNumber
touch_interval Int
harmonic)
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ NoteNumber -> NoteNumber -> Note -> [Note]
harmonic_code NoteNumber
string (NoteNumber
string forall a. Num a => a -> a -> a
+ NoteNumber
interval) Note
event

harmonic_code :: Pitch.NoteNumber -> Pitch.NoteNumber -> Score.Event
    -> [Score.Event]
harmonic_code :: NoteNumber -> NoteNumber -> Note -> [Note]
harmonic_code NoteNumber
stopped NoteNumber
touched Note
event =
    [ NoteNumber -> Note
with_pitch NoteNumber
stopped
    , Code -> Note -> Note
Ly.add_note_code (Distribution -> Position CodePosition
Ly.note_append Distribution
Constants.All, Text
"\\harmonic") forall a b. (a -> b) -> a -> b
$
        NoteNumber -> Note
with_pitch NoteNumber
touched
    ]
    where
    with_pitch :: NoteNumber -> Note
with_pitch NoteNumber
nn =
        Pitch -> Note -> Note
Score.set_pitch (Pitch -> Pitch
PSignal.constant (NoteNumber -> Pitch
Twelve.nn_pitch NoteNumber
nn)) Note
event

-- | Where should I touch the string to play the nth harmonic of a base
-- frequency?
touch_interval :: StringUtil.Harmonic -> Maybe Pitch.NoteNumber
touch_interval :: Int -> Maybe NoteNumber
touch_interval Int
harmonic = case Int
harmonic of
    Int
2 -> forall a. a -> Maybe a
Just NoteNumber
12
    Int
3 -> forall a. a -> Maybe a
Just NoteNumber
7
    Int
4 -> forall a. a -> Maybe a
Just NoteNumber
5
    Int
5 -> forall a. a -> Maybe a
Just NoteNumber
4
    Int
6 -> forall a. a -> Maybe a
Just NoteNumber
3
    Int
_ -> forall a. Maybe a
Nothing
    -- In principle I want the interval that corresponds to 1/harmonic of
    -- the string.  In practice, I need to show an integral pitch number, and
    -- high harmonics get too close and should be notated via some other means.
    -- So I'll just hard code some low harmonics and deal with high ones if
    -- I need them some day.

highest_harmonic :: StringUtil.Harmonic
highest_harmonic :: Int
highest_harmonic = Int
6

-- | If string is given, try to find this pitch in the harmonics of that
-- string.  Otherwise, find the string from open_strings which has this as
-- its lowest harmonic.
natural_harmonic :: [StringUtil.String] -> Maybe StringUtil.String
    -> Pitch.NoteNumber -> Either Text (Pitch.NoteNumber, StringUtil.Harmonic)
    -- ^ (selected string, harmonic)
natural_harmonic :: [String]
-> Maybe String -> NoteNumber -> Either Text (NoteNumber, Int)
natural_harmonic [] Maybe String
Nothing NoteNumber
nn = forall a b. b -> Either a b
Right ((Y -> Y) -> NoteNumber -> NoteNumber
Pitch.modify_hz (forall a. Fractional a => a -> a -> a
/Y
2) NoteNumber
nn, Int
2)
natural_harmonic [String]
open_strings Maybe String
maybe_string NoteNumber
nn =
    forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> NoteNumber
StringUtil.str_nn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Bool
-> Int
-> [String]
-> Maybe String
-> NoteNumber
-> Either Text (String, Int)
StringUtil.find_harmonic Bool
False Int
highest_harmonic [String]
open_strings
            Maybe String
maybe_string NoteNumber
nn

-- | Pick the lowest harmonic which is above the given lowest string.
artificial_harmonic :: Pitch.NoteNumber -> Pitch.NoteNumber
    -> Either Text (Pitch.NoteNumber, StringUtil.Harmonic)
    -- ^ (stopped pitch, harmonic)
artificial_harmonic :: NoteNumber -> NoteNumber -> Either Text (NoteNumber, Int)
artificial_harmonic NoteNumber
lowest_string NoteNumber
nn =
    forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
tryJust (Text
"artificial harmonic for " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty NoteNumber
nn
        forall a. Semigroup a => a -> a -> a
<> Text
" must be above lowest string " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty NoteNumber
lowest_string) forall a b. (a -> b) -> a -> b
$
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a. Real a => a -> NoteNumber
Pitch.nn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (RealFrac a, Integral b) => a -> b
round)) forall a b. (a -> b) -> a -> b
$
        forall a. [a] -> Maybe a
Lists.head forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Ord a => a -> a -> Bool
>NoteNumber
lowest_string) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$
        -- I assume the octave is not convenient for an artificial harmonic,
        -- but that's not true in higher pitches.  Maybe I could allow it, but
        -- make it least preferred?
        forall a k. (a -> k) -> [a] -> [(k, a)]
Lists.keyOn forall {a}. Integral a => a -> NoteNumber
base_of [Int
3..Int
highest_harmonic]
    where base_of :: a -> NoteNumber
base_of a
h = (Y -> Y) -> NoteNumber -> NoteNumber
Pitch.modify_hz (forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral a
h) NoteNumber
nn

-- * slur

-- | I'm not really sure how fancy calls should be.  On one hand, high level
-- calls should get a nice result automatically.  On the other hand, they're
-- not very composable if they override things like %sus-abs.
c_slur :: Maybe Call.UpDown -> Derive.Generator Derive.Note
c_slur :: Maybe UpDown -> Generator Note
c_slur Maybe UpDown
direction = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
Module.prelude CallName
"legato"
    (Tags
Tags.attr forall a. Semigroup a => a -> a -> a
<> Tags
Tags.subs forall a. Semigroup a => a -> a -> a
<> Tags
Tags.ly)
    Doc
"Play the transformed notes legato. This just makes all but the last\
    \ overlap slightly.\
    \\nYou can combine this with other controls to get fancier phrasing.\
    \ For example, you can be detached by default but have legato connect\
    \ notes, by setting `%legato-overlap = .05 | %sus-abs = -.05`.\
    \\nOtherwise, you can use the `detach` and `dyn` args.\
    \\nThe `^` and `_` variants are the same in normal performance, but force\
    \ lilypond slurs to go above or below, respectively."
    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
"overlap" (RealTime
0.1 :: RealTime)
        Doc
"All notes but the last have their durations extended by this amount."
    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
"detach" (forall a. Maybe a
Nothing :: Maybe Sig.Dummy)
        Doc
"Shorten the final note by this amount, by setting `%sus-abs`.\
        \ The distinction between not given and 0 is important, because 0\
        \ will still override `%sus-abs`, which you may not want."
    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
1 :: Double)
        Doc
"Scale dyn for notes after the first one by this amount."
    ) forall a b. (a -> b) -> a -> b
$ \(RealTime
overlap, Maybe RealTime
maybe_detach, Y
dyn) PassedArgs Note
args ->
    forall a. Deriver a -> Deriver a -> Deriver a
Ly.when_lilypond (forall d. Maybe UpDown -> PassedArgs d -> NoteDeriver
lily_slur Maybe UpDown
direction PassedArgs Note
args) forall a b. (a -> b) -> a -> b
$
        RealTime -> Maybe RealTime -> Y -> [[Event]] -> NoteDeriver
note_slur RealTime
overlap Maybe RealTime
maybe_detach Y
dyn forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall d. PassedArgs d -> Deriver [[Event]]
Sub.sub_events PassedArgs Note
args

note_slur :: RealTime -> Maybe RealTime -> Signal.Y -> [[SubT.Event]]
    -> Derive.NoteDeriver
note_slur :: RealTime -> Maybe RealTime -> Y -> [[Event]] -> NoteDeriver
note_slur RealTime
overlap Maybe RealTime
maybe_detach Y
dyn = [Event] -> NoteDeriver
Sub.derive forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [Event] -> [Event]
apply
    where
    apply :: [Event] -> [Event]
apply = forall a. (a -> a) -> [a] -> [a]
Lists.mapInit (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. RealTime -> Deriver a -> Deriver a
set_sustain RealTime
overlap))
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Y -> [Event] -> [Event]
apply_dyn Y
dyn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id RealTime -> [Event] -> [Event]
apply_detach Maybe RealTime
maybe_detach

lily_slur :: Maybe Call.UpDown -> Derive.PassedArgs d -> Derive.NoteDeriver
lily_slur :: forall d. Maybe UpDown -> PassedArgs d -> NoteDeriver
lily_slur Maybe UpDown
direction =
    forall d. Code -> Code -> PassedArgs d -> NoteDeriver
Ly.notes_around_ly (Distribution -> Position CodePosition
Ly.append Distribution
Constants.First, Text
prefix forall a. Semigroup a => a -> a -> a
<> Text
"(")
        (Distribution -> Position CodePosition
Ly.append Distribution
Constants.Last, Text
")")
    where
    prefix :: Text
prefix = case Maybe UpDown
direction of
        Maybe UpDown
Nothing -> Text
""
        Just UpDown
Call.Up -> Text
"^"
        Just UpDown
Call.Down -> Text
"_"

{- NOTE [legato]
    Previously, it would set @+legato@, and the default note deriver would
    then respond by overlapping with the next note.  The theory was that it
    would allow more flexibility since I could then swap out the default
    note deriver.  However, in practice, the note deriver doesn't know about
    the extent of the legato phrase, so it would need @+legato@ on all but
    the last note.  And I wound up swapping out the legato call itself since
    samplers with legato samples need the legato keyswitch on all notes, not
    just all-but-the-last, so I'd have to swap out both the legato call and
    the note call.  In addition, I added features like @detach@ and @dyn@
    and delegating note overlap to the note didn't make so much sense.
-}

-- | This is not in 'note_calls', instruments that support this are expected to
-- override @(@ with it.
c_attr_slur :: Attrs.Attributes -> Attrs.Attributes
    -> Derive.Generator Derive.Note
c_attr_slur :: Attributes -> Attributes -> Generator Note
c_attr_slur Attributes
first_attr Attributes
rest_attr = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
Module.instrument CallName
"legato"
    (Tags
Tags.attr forall a. Semigroup a => a -> a -> a
<> Tags
Tags.subs forall a. Semigroup a => a -> a -> a
<> Tags
Tags.ly)
    Doc
"Make a phrase legato by applying the `+legato` attribute. This is for\
    \ instruments that understand it, for instance with a keyswitch for\
    \ transition samples."
    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
"detach" (forall a. Maybe a
Nothing :: Maybe Sig.Dummy)
        Doc
"If set, shorten the final note by this\
        \ amount. This is to avoid triggering legato from the previous note."
    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
1 :: Double)
        Doc
"Scale dyn for notes after the first one by\
        \ this amount. Otherwise, transition samples can be too loud."
    ) forall a b. (a -> b) -> a -> b
$ \(Maybe RealTime
detach, Y
dyn) PassedArgs Note
args -> forall a. Deriver a -> Deriver a -> Deriver a
Ly.when_lilypond (forall d. Maybe UpDown -> PassedArgs d -> NoteDeriver
lily_slur forall a. Maybe a
Nothing PassedArgs Note
args) forall a b. (a -> b) -> a -> b
$
        RealTime -> Maybe RealTime -> Y -> [[Event]] -> NoteDeriver
note_slur RealTime
0.02 Maybe RealTime
detach Y
dyn
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a. (a -> a) -> [a] -> [a]
Lists.mapHead (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall d. Attributes -> Deriver d -> Deriver d
Call.add_attributes Attributes
first_attr)))
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a. (a -> a) -> [a] -> [a]
Lists.mapTail (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall d. Attributes -> Deriver d -> Deriver d
Call.add_attributes Attributes
rest_attr)))
                forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall d. PassedArgs d -> Deriver [[Event]]
Sub.sub_events PassedArgs Note
args

apply_detach :: RealTime -> [SubT.Event] -> [SubT.Event]
apply_detach :: RealTime -> [Event] -> [Event]
apply_detach RealTime
detach = forall a. (a -> a) -> [a] -> [a]
Lists.mapLast (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. RealTime -> Deriver a -> Deriver a
set_sustain (-RealTime
detach)))

apply_dyn :: Signal.Y -> [SubT.Event] -> [SubT.Event]
apply_dyn :: Y -> [Event] -> [Event]
apply_dyn Y
dyn = forall a. (a -> a) -> [a] -> [a]
Lists.mapTail (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Y -> Deriver a -> Deriver a
Call.multiply_dynamic Y
dyn))

set_sustain :: RealTime -> Derive.Deriver a -> Derive.Deriver a
set_sustain :: forall a. RealTime -> Deriver a -> Deriver a
set_sustain = forall a. Control -> Y -> Deriver a -> Deriver a
Call.with_constant Control
Controls.sustain_abs forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealTime -> Y
RealTime.to_seconds

-- * misc

-- | This is the same as 'c_lengthen', but it's here for symmetry with
-- 'c_sustain'.  Also, conceptually this is lower level, while c_lengthen
-- is meant to be modified to whatever is locally appropriate.
c_sustain_abs :: Derive.Transformer Derive.Note
c_sustain_abs :: Transformer Note
c_sustain_abs = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude CallName
"sus-a" forall a. Monoid a => a
mempty
    (Doc
"Simple legato, extend the duration of the transformed notes by the given\
    \ amount. This works by setting " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Control
Controls.sustain_abs
    forall a. Semigroup a => a -> a -> a
<> Doc
"."
    ) 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 (forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"time" (RealTime -> DefaultReal
Typecheck.real RealTime
0.25)
        Doc
"Add this duration to the note.")
    forall a b. (a -> b) -> a -> b
$ \(Typecheck.DefaultReal Duration
time) PassedArgs Note
args NoteDeriver
deriver -> do
        RealTime
time <- forall t1 t2. (Time t1, Time t2) => t1 -> t2 -> Deriver RealTime
Call.real_duration (forall a. PassedArgs a -> TrackTime
Args.end PassedArgs Note
args) Duration
time
        forall a. RealTime -> Deriver a -> Deriver a
set_sustain RealTime
time NoteDeriver
deriver

c_sustain :: Derive.Transformer Derive.Note
c_sustain :: Transformer Note
c_sustain = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude CallName
"sus" forall a. Monoid a => a
mempty
    (Doc
"Simple legato, extend the duration of the transformed notes by the given\
    \ amount. This works by setting " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Control
Controls.sustain
    forall a. Semigroup a => a -> a -> a
<> Doc
"."
    ) 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 (forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"amount" (Y
1.5 :: Double)
        Doc
"Multiply the note's duration by this.")
    forall a b. (a -> b) -> a -> b
$ \Y
amount PassedArgs Note
_args -> forall a. Control -> Y -> Deriver a -> Deriver a
Call.with_constant Control
Controls.sustain Y
amount

c_shorten_lengthen :: Bool -> Library.Calls Derive.Note
c_shorten_lengthen :: Bool -> Calls Note
c_shorten_lengthen Bool
shorten = forall a.
Module
-> CallName
-> Tags
-> Doc
-> Parser a
-> (a -> NoteDeriver -> NoteDeriver)
-> Calls Note
Make.transform_notes Module
Module.prelude
    (if Bool
shorten then CallName
"shorten" else CallName
"lengthen") forall a. Monoid a => a
mempty
    (Doc
"Lengthen or Shorten a note duration, by adding to or subtracting from "
        forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Control
Controls.sustain_abs forall a. Semigroup a => a -> a -> a
<> Doc
".")
    (forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"time" (Y
0.15 :: Double) Doc
"Subtract this duration.") forall a b. (a -> b) -> a -> b
$ \Y
time ->
        forall a. Control -> Y -> Deriver a -> Deriver a
Call.with_constant Control
Controls.sustain_abs
            (if Bool
shorten then -Y
time else Y
time)

c_accent :: Library.Calls Derive.Note
c_accent :: Calls Note
c_accent = forall a.
Module
-> CallName
-> Tags
-> Doc
-> Parser a
-> (a -> NoteDeriver -> NoteDeriver)
-> Calls Note
Make.transform_notes Module
Module.prelude CallName
"accent" Tags
Tags.ly
    Doc
"Accent the note by multiplying its dynamic."
    (forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"dyn" (Y
1.5 :: Double) Doc
"Multiply dynamic.") forall a b. (a -> b) -> a -> b
$ \Y
dyn ->
        -- Adding Attrs.accent makes lilypond attach a '>'.
        forall d. Attributes -> Deriver d -> Deriver d
Call.add_attributes Attributes
Attrs.accent forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Y -> Deriver a -> Deriver a
Call.multiply_dynamic Y
dyn

c_weak :: Library.Calls Derive.Note
c_weak :: Calls Note
c_weak = forall a.
Module
-> CallName
-> Tags
-> Doc
-> Parser a
-> (a -> NoteDeriver -> NoteDeriver)
-> Calls Note
Make.transform_notes Module
Module.prelude CallName
"weak" forall a. Monoid a => a
mempty
    Doc
"Weaken the note by multiplying its dynamic."
    (forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"dyn" (Y
0.35 :: Double) Doc
"Multiply dynamic.") forall a b. (a -> b) -> a -> b
$ \Y
dyn ->
        forall a. Y -> Deriver a -> Deriver a
Call.multiply_dynamic Y
dyn