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