-- 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 generate grace notes. These are short sequences of quick notes -- whose duration is generally independent of the tempo. module Derive.C.Prelude.Grace (library) where import qualified Util.Seq as Seq import qualified Derive.Args as Args import qualified Derive.Call as Call import qualified Derive.Call.GraceUtil as GraceUtil import qualified Derive.Call.Ly as Ly import qualified Derive.Call.Module as Module import qualified Derive.Call.Sub as Sub import qualified Derive.Call.SubT as SubT import qualified Derive.Call.Tags as Tags import qualified Derive.Derive as Derive import qualified Derive.DeriveT as DeriveT import qualified Derive.Eval as Eval import qualified Derive.Library as Library import qualified Derive.PSignal as PSignal import qualified Derive.Pitches as Pitches import qualified Derive.Sig as Sig import qualified Derive.Typecheck as Typecheck import qualified Perform.Pitch as Pitch import qualified Perform.Signal as Signal import Types library :: Library.Library library :: Library library = [Library] -> Library forall a. Monoid a => [a] -> a mconcat [ [(Symbol, Generator Note)] -> Library forall call. ToLibrary (Generator call) => [(Symbol, Generator call)] -> Library Library.generators -- Note [ (Symbol "g", Generator Note c_grace) , (Symbol "g-", Generator Note c_grace_hold) , (Symbol "g_", Generator Note c_grace_pitch) , (Symbol "grace", Generator Note c_basic_grace) , (Symbol "roll", Generator Note c_roll) , (Symbol "`mordent`", Transpose -> Generator Note c_mordent (Double -> Transpose Pitch.Diatonic Double 1)) , (Symbol "`rmordent`", Transpose -> Generator Note c_mordent (Double -> Transpose Pitch.Diatonic (-Double 1))) ] , [(Symbol, Generator Pitch)] -> Library forall call. ToLibrary (Generator call) => [(Symbol, Generator call)] -> Library Library.generators -- Pitch [ (Symbol "g", Generator Pitch c_grace_p) , (Symbol "`mordent`", Transpose -> Generator Pitch c_mordent_p (Double -> Transpose Pitch.Diatonic Double 1)) , (Symbol "`rmordent`", Transpose -> Generator Pitch c_mordent_p (Double -> Transpose Pitch.Diatonic (-Double 1))) ] ] -- * note calls c_grace :: Derive.Generator Derive.Note c_grace :: Generator Note c_grace = Module -> Doc -> (NoteDeriver -> NoteDeriver) -> (PassedArgs Note -> [Event] -> NoteDeriver) -> Generator Note GraceUtil.make_grace Module Module.prelude Doc "Emit grace notes. The grace notes go through the `(` call, so they will\ \ overlap or apply a keyswitch, or do whatever `(` does." NoteDeriver -> NoteDeriver forall a. a -> a id ((PassedArgs Note -> [Event] -> NoteDeriver) -> Generator Note) -> (PassedArgs Note -> [Event] -> NoteDeriver) -> Generator Note forall a b. (a -> b) -> a -> b $ \PassedArgs Note args [Event] events -> Key -> Double -> NoteDeriver -> NoteDeriver forall val a. ToVal val => Key -> val -> Deriver a -> Deriver a Derive.with_val Key "legato-dyn" (Double 1 :: Double) (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver forall a b. (a -> b) -> a -> b $ Context Note -> Symbol -> [Term] -> [[Event]] -> NoteDeriver Sub.reapply_call (PassedArgs Note -> Context Note forall a. PassedArgs a -> Context a Args.context PassedArgs Note args) Symbol "(" [] [[Event] events] c_grace_hold :: Derive.Generator Derive.Note c_grace_hold :: Generator Note c_grace_hold = Module -> Doc -> (NoteDeriver -> NoteDeriver) -> (PassedArgs Note -> [Event] -> NoteDeriver) -> Generator Note GraceUtil.make_grace Module Module.prelude Doc "Like `g`, but doesn't use `(`, and all notes are held to the duration of\ \ the event." NoteDeriver -> NoteDeriver forall a. a -> a id ((PassedArgs Note -> [Event] -> NoteDeriver) -> Generator Note) -> (PassedArgs Note -> [Event] -> NoteDeriver) -> Generator Note forall a b. (a -> b) -> a -> b $ \PassedArgs Note _args -> [Event] -> NoteDeriver Sub.derive ([Event] -> NoteDeriver) -> ([Event] -> [Event]) -> [Event] -> NoteDeriver forall b c a. (b -> c) -> (a -> b) -> a -> c . [Event] -> [Event] forall {a}. [EventT a] -> [EventT a] hold where hold :: [EventT a] -> [EventT a] hold [EventT a] events = [EventT a] -> (ScoreTime -> [EventT a]) -> Maybe ScoreTime -> [EventT a] forall b a. b -> (a -> b) -> Maybe a -> b maybe [EventT a] events (\ScoreTime e -> (EventT a -> EventT a) -> [EventT a] -> [EventT a] forall a b. (a -> b) -> [a] -> [b] map (ScoreTime -> EventT a -> EventT a forall {a}. ScoreTime -> EventT a -> EventT a set_end ScoreTime e) [EventT a] events) Maybe ScoreTime end where end :: Maybe ScoreTime end = [ScoreTime] -> Maybe ScoreTime forall a. Ord a => [a] -> Maybe a Seq.maximum ([ScoreTime] -> Maybe ScoreTime) -> [ScoreTime] -> Maybe ScoreTime forall a b. (a -> b) -> a -> b $ (EventT a -> ScoreTime) -> [EventT a] -> [ScoreTime] forall a b. (a -> b) -> [a] -> [b] map EventT a -> ScoreTime forall a. EventT a -> ScoreTime SubT.end [EventT a] events set_end :: ScoreTime -> EventT a -> EventT a set_end ScoreTime end EventT a event = EventT a event { _duration :: ScoreTime SubT._duration = ScoreTime end ScoreTime -> ScoreTime -> ScoreTime forall a. Num a => a -> a -> a - EventT a -> ScoreTime forall a. EventT a -> ScoreTime SubT._start EventT a event } c_grace_pitch :: Derive.Generator Derive.Note c_grace_pitch :: Generator Note c_grace_pitch = Module -> Doc -> (PassedArgs Note -> [EventT Pitch] -> NoteDeriver) -> Generator Note GraceUtil.make_grace_pitch Module Module.prelude Doc "Grace notes realized as one note with a pitch curve, rather than\ \ separate notes." ((PassedArgs Note -> [EventT Pitch] -> NoteDeriver) -> Generator Note) -> (PassedArgs Note -> [EventT Pitch] -> NoteDeriver) -> Generator Note forall a b. (a -> b) -> a -> b $ \PassedArgs Note _args [EventT Pitch] events -> if [EventT Pitch] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [EventT Pitch] events then NoteDeriver forall a. Monoid a => a mempty else do Pitch pitch <- Deriver Pitch Derive.get_pitch let start :: ScoreTime start = EventT Pitch -> ScoreTime forall a. EventT a -> ScoreTime SubT._start ([EventT Pitch] -> EventT Pitch forall a. [a] -> a head [EventT Pitch] events) [RealTime] rstarts <- (EventT Pitch -> Deriver State Error RealTime) -> [EventT Pitch] -> Deriver State Error [RealTime] forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM (ScoreTime -> Deriver State Error RealTime forall a. Time a => a -> Deriver State Error RealTime Derive.real (ScoreTime -> Deriver State Error RealTime) -> (EventT Pitch -> ScoreTime) -> EventT Pitch -> Deriver State Error RealTime forall b c a. (b -> c) -> (a -> b) -> a -> c . EventT Pitch -> ScoreTime forall a. EventT a -> ScoreTime SubT._start) [EventT Pitch] events ScoreTime -> ScoreTime -> NoteDeriver -> NoteDeriver forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a Derive.place ScoreTime start (EventT Pitch -> ScoreTime forall a. EventT a -> ScoreTime SubT.end ([EventT Pitch] -> EventT Pitch forall a. [a] -> a last [EventT Pitch] events) ScoreTime -> ScoreTime -> ScoreTime forall a. Num a => a -> a -> a - ScoreTime start) (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver forall a b. (a -> b) -> a -> b $ Pitch -> NoteDeriver -> NoteDeriver forall a. Pitch -> Deriver a -> Deriver a Derive.with_pitch ([RealTime] -> [Pitch] -> Pitch mksig [RealTime] rstarts ((EventT Pitch -> Pitch) -> [EventT Pitch] -> [Pitch] forall a b. (a -> b) -> [a] -> [b] map EventT Pitch -> Pitch forall a. EventT a -> a SubT._note [EventT Pitch] events) Pitch -> Pitch -> Pitch forall a. Semigroup a => a -> a -> a <> Pitch pitch) NoteDeriver Call.note where mksig :: [RealTime] -> [Pitch] -> Pitch mksig [RealTime] starts [Pitch] pitches = [(RealTime, Pitch)] -> Pitch PSignal.from_pairs ([(RealTime, Pitch)] -> Pitch) -> [(RealTime, Pitch)] -> Pitch forall a b. (a -> b) -> a -> b $ [[(RealTime, Pitch)]] -> [(RealTime, Pitch)] forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat [ (RealTime start, Pitch p) (RealTime, Pitch) -> [(RealTime, Pitch)] -> [(RealTime, Pitch)] forall a. a -> [a] -> [a] : [(RealTime, Pitch)] -> (RealTime -> [(RealTime, Pitch)]) -> Maybe RealTime -> [(RealTime, Pitch)] forall b a. b -> (a -> b) -> Maybe a -> b maybe [] (((RealTime, Pitch) -> [(RealTime, Pitch)] -> [(RealTime, Pitch)] forall a. a -> [a] -> [a] :[]) ((RealTime, Pitch) -> [(RealTime, Pitch)]) -> (RealTime -> (RealTime, Pitch)) -> RealTime -> [(RealTime, Pitch)] forall b c a. (b -> c) -> (a -> b) -> a -> c . (, Pitch p)) Maybe RealTime mb_end | ((RealTime start, Maybe RealTime mb_end), Pitch p) <- [(RealTime, Maybe RealTime)] -> [Pitch] -> [((RealTime, Maybe RealTime), Pitch)] forall a b. [a] -> [b] -> [(a, b)] zip ([RealTime] -> [(RealTime, Maybe RealTime)] forall {a}. [a] -> [(a, Maybe a)] pairs [RealTime] starts) [Pitch] pitches ] pairs :: [a] -> [(a, Maybe a)] pairs (a x1:a x2:[a] xs) = (a x1, a -> Maybe a forall a. a -> Maybe a Just a x2) (a, Maybe a) -> [(a, Maybe a)] -> [(a, Maybe a)] forall a. a -> [a] -> [a] : [a] -> [(a, Maybe a)] pairs (a x2a -> [a] -> [a] forall a. a -> [a] -> [a] :[a] xs) pairs [a x] = [(a x, Maybe a forall a. Maybe a Nothing)] pairs [] = [] c_basic_grace :: Derive.Generator Derive.Note c_basic_grace :: Generator Note c_basic_grace = Module -> CallName -> Tags -> Doc -> WithArgDoc (GeneratorF Note) -> Generator Note forall d. Module -> CallName -> Tags -> Doc -> WithArgDoc (GeneratorF d) -> Generator d Derive.generator Module Module.prelude CallName "basic-grace" (Tags Tags.ornament Tags -> Tags -> Tags forall a. Semigroup a => a -> a -> a <> Tags Tags.ly) Doc "This a grace call where all arguments are required. The idea is that this\ \ will be used as the implementation of more specific ornaments, perhaps\ \ defined in a definitions file." (WithArgDoc (GeneratorF Note) -> Generator Note) -> WithArgDoc (GeneratorF Note) -> Generator Note forall a b. (a -> b) -> a -> b $ Parser ([Either Pitch (Typed Double)], Duration, ControlRef, Maybe Quoted) -> (([Either Pitch (Typed Double)], Duration, ControlRef, Maybe Quoted) -> GeneratorF Note) -> WithArgDoc (GeneratorF Note) forall y a d. Taggable y => Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d) Sig.call ((,,,) ([Either Pitch (Typed Double)] -> Duration -> ControlRef -> Maybe Quoted -> ([Either Pitch (Typed Double)], Duration, ControlRef, Maybe Quoted)) -> Parser [Either Pitch (Typed Double)] -> Parser (Duration -> ControlRef -> Maybe Quoted -> ([Either Pitch (Typed Double)], Duration, ControlRef, Maybe Quoted)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> ArgName -> EnvironDefault -> Doc -> Parser [Either Pitch (Typed Double)] forall a. Typecheck a => ArgName -> EnvironDefault -> Doc -> Parser a Sig.required_env ArgName "pitches" EnvironDefault Sig.None Doc GraceUtil.grace_pitches_doc Parser (Duration -> ControlRef -> Maybe Quoted -> ([Either Pitch (Typed Double)], Duration, ControlRef, Maybe Quoted)) -> Parser Duration -> Parser (ControlRef -> Maybe Quoted -> ([Either Pitch (Typed Double)], Duration, ControlRef, Maybe Quoted)) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> ArgName -> EnvironDefault -> Doc -> Parser Duration forall a. Typecheck a => ArgName -> EnvironDefault -> Doc -> Parser a Sig.required_env ArgName "dur" EnvironDefault Sig.None Doc "Duration of grace notes." Parser (ControlRef -> Maybe Quoted -> ([Either Pitch (Typed Double)], Duration, ControlRef, Maybe Quoted)) -> Parser ControlRef -> Parser (Maybe Quoted -> ([Either Pitch (Typed Double)], Duration, ControlRef, Maybe Quoted)) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> ArgName -> EnvironDefault -> Doc -> Parser ControlRef forall a. Typecheck a => ArgName -> EnvironDefault -> Doc -> Parser a Sig.required_env ArgName "place" EnvironDefault Sig.None Doc GraceUtil.grace_place_doc Parser (Maybe Quoted -> ([Either Pitch (Typed Double)], Duration, ControlRef, Maybe Quoted)) -> Parser (Maybe Quoted) -> Parser ([Either Pitch (Typed Double)], Duration, ControlRef, Maybe Quoted) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> ArgName -> EnvironDefault -> Maybe Quoted -> Doc -> Parser (Maybe Quoted) forall a. (Typecheck a, ShowVal a) => ArgName -> EnvironDefault -> a -> Doc -> Parser a Sig.defaulted_env ArgName "transformer" EnvironDefault Sig.None Maybe Quoted forall a. Maybe a Nothing Doc "Apply a transformer to grace notes." ) ((([Either Pitch (Typed Double)], Duration, ControlRef, Maybe Quoted) -> GeneratorF Note) -> WithArgDoc (GeneratorF Note)) -> (([Either Pitch (Typed Double)], Duration, ControlRef, Maybe Quoted) -> GeneratorF Note) -> WithArgDoc (GeneratorF Note) forall a b. (a -> b) -> a -> b $ \([Either Pitch (Typed Double)] pitches, Duration grace_dur, ControlRef place, Maybe Quoted maybe_transform) -> GeneratorF Note -> GeneratorF Note forall d. (PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver Sub.inverting (GeneratorF Note -> GeneratorF Note) -> GeneratorF Note -> GeneratorF Note forall a b. (a -> b) -> a -> b $ \PassedArgs Note args -> do RealTime start <- PassedArgs Note -> Deriver State Error RealTime forall a. PassedArgs a -> Deriver State Error RealTime Args.real_start PassedArgs Note args Pitch base <- RealTime -> Deriver Pitch Call.get_pitch RealTime start [Pitch] pitches <- Pitch -> [Either Pitch (Typed Double)] -> Deriver [Pitch] GraceUtil.resolve_pitches Pitch base [Either Pitch (Typed Double)] pitches let apply :: Quoted -> NoteDeriver -> NoteDeriver apply = Context Note -> Quoted -> NoteDeriver -> NoteDeriver forall d. (Callable (Transformer d), Taggable d) => Context d -> Quoted -> Deriver (Stream d) -> Deriver (Stream d) Eval.eval_quoted_transformers (PassedArgs Note -> Context Note forall a. PassedArgs a -> Context a Args.context PassedArgs Note args) NoteDeriver -> NoteDeriver -> NoteDeriver forall a. Deriver a -> Deriver a -> Deriver a Ly.when_lilypond (PassedArgs Note -> RealTime -> [Pitch] -> NoteDeriver forall d. PassedArgs d -> RealTime -> [Pitch] -> NoteDeriver GraceUtil.lily_grace PassedArgs Note args RealTime start [Pitch] pitches) (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver forall a b. (a -> b) -> a -> b $ [Event] -> NoteDeriver Sub.derive ([Event] -> NoteDeriver) -> Deriver State Error [Event] -> NoteDeriver forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< PassedArgs Note -> [Pitch] -> (NoteDeriver -> NoteDeriver) -> Duration -> ControlRef -> Deriver State Error [Event] forall a. PassedArgs a -> [Pitch] -> (NoteDeriver -> NoteDeriver) -> Duration -> ControlRef -> Deriver State Error [Event] GraceUtil.basic_grace_transform PassedArgs Note args [Pitch] pitches ((NoteDeriver -> NoteDeriver) -> (Quoted -> NoteDeriver -> NoteDeriver) -> Maybe Quoted -> NoteDeriver -> NoteDeriver forall b a. b -> (a -> b) -> Maybe a -> b maybe NoteDeriver -> NoteDeriver forall a. a -> a id Quoted -> NoteDeriver -> NoteDeriver apply Maybe Quoted maybe_transform) Duration grace_dur ControlRef place -- ** roll c_roll :: Derive.Generator Derive.Note c_roll :: Generator Note c_roll = Module -> CallName -> Tags -> Doc -> WithArgDoc (GeneratorF Note) -> Generator Note forall d. Module -> CallName -> Tags -> Doc -> WithArgDoc (GeneratorF d) -> Generator d Derive.generator Module Module.prelude CallName "roll" Tags Tags.ornament Doc "These are like grace notes, but they all have the same pitch.\ \ The extra notes always fall before the main one, because `trem` covers\ \ the afterwards case." (WithArgDoc (GeneratorF Note) -> Generator Note) -> WithArgDoc (GeneratorF Note) -> Generator Note forall a b. (a -> b) -> a -> b $ Parser (Double, DefaultReal, Double) -> ((Double, DefaultReal, Double) -> GeneratorF Note) -> WithArgDoc (GeneratorF Note) forall y a d. Taggable y => Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d) Sig.call ((,,) (Double -> DefaultReal -> Double -> (Double, DefaultReal, Double)) -> Parser Double -> Parser (DefaultReal -> Double -> (Double, DefaultReal, Double)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> ArgName -> Double -> Doc -> Parser Double forall a. (Typecheck a, ShowVal a) => ArgName -> a -> Doc -> Parser a Sig.defaulted ArgName "times" Double 1 Doc "Number of grace notes." Parser (DefaultReal -> Double -> (Double, DefaultReal, Double)) -> Parser DefaultReal -> Parser (Double -> (Double, DefaultReal, Double)) forall (f :: * -> *) a b. Applicative f => 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 "time" DefaultReal GraceUtil.default_grace_dur Doc "Time between the strokes." Parser (Double -> (Double, DefaultReal, Double)) -> Parser Double -> Parser (Double, DefaultReal, Double) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> ArgName -> Double -> Doc -> Parser Double forall a. (Typecheck a, ShowVal a) => ArgName -> a -> Doc -> Parser a Sig.defaulted ArgName "dyn" Double 0.5 Doc "Dyn scale for the grace notes." ) (((Double, DefaultReal, Double) -> GeneratorF Note) -> WithArgDoc (GeneratorF Note)) -> ((Double, DefaultReal, Double) -> GeneratorF Note) -> WithArgDoc (GeneratorF Note) forall a b. (a -> b) -> a -> b $ \(Double times, Typecheck.DefaultReal Duration time, Double dyn_scale) -> GeneratorF Note -> GeneratorF Note forall d. (PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver Sub.inverting (GeneratorF Note -> GeneratorF Note) -> GeneratorF Note -> GeneratorF Note forall a b. (a -> b) -> a -> b $ Int -> Duration -> Double -> GeneratorF Note forall a. Int -> Duration -> Double -> PassedArgs a -> NoteDeriver roll (Double -> Int forall a b. (RealFrac a, Integral b) => a -> b round (Double times :: Double)) Duration time Double dyn_scale roll :: Int -> DeriveT.Duration -> Signal.Y -> Derive.PassedArgs a -> Derive.NoteDeriver roll :: forall a. Int -> Duration -> Double -> PassedArgs a -> NoteDeriver roll Int times Duration time Double dyn_scale PassedArgs a args = do RealTime start <- PassedArgs a -> Deriver State Error RealTime forall a. PassedArgs a -> Deriver State Error RealTime Args.real_start PassedArgs a args Pitch pitch <- RealTime -> Deriver Pitch Call.get_pitch RealTime start Double dyn <- RealTime -> Deriver Double Call.dynamic RealTime start [Event] notes <- Int -> [Event] -> [Event] forall a. Int -> [a] -> [a] Seq.rdrop Int 1 ([Event] -> [Event]) -> Deriver State Error [Event] -> Deriver State Error [Event] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> NoteDeriver -> Int -> Duration -> Double -> PassedArgs a -> Deriver State Error [Event] forall a. NoteDeriver -> Int -> Duration -> Double -> PassedArgs a -> Deriver State Error [Event] GraceUtil.repeat_notes (Pitch -> NoteDeriver -> NoteDeriver forall a. Pitch -> Deriver a -> Deriver a Call.with_pitch Pitch pitch NoteDeriver Call.note) (Int timesInt -> Int -> Int forall a. Num a => a -> a -> a +Int 1) Duration time Double 0 PassedArgs a args [Event] -> NoteDeriver Sub.derive ((Event -> Event) -> [Event] -> [Event] forall a b. (a -> b) -> [a] -> [b] map ((NoteDeriver -> NoteDeriver) -> Event -> Event forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (Double -> NoteDeriver -> NoteDeriver forall a. Double -> Deriver a -> Deriver a Call.with_dynamic (Double dynDouble -> Double -> Double forall a. Num a => a -> a -> a *Double dyn_scale))) [Event] notes) NoteDeriver -> NoteDeriver -> NoteDeriver forall a. Semigroup a => a -> a -> a <> PassedArgs a -> NoteDeriver forall d. PassedArgs d -> NoteDeriver Call.placed_note PassedArgs a args -- ** mordent c_mordent :: Pitch.Transpose -> Derive.Generator Derive.Note c_mordent :: Transpose -> Generator Note c_mordent Transpose default_neighbor = Module -> CallName -> Tags -> Doc -> WithArgDoc (GeneratorF Note) -> Generator Note forall d. Module -> CallName -> Tags -> Doc -> WithArgDoc (GeneratorF d) -> Generator d Derive.generator Module Module.prelude CallName "mordent" Tags Tags.ornament Doc "Like `g`, but hardcoded to play pitch, neighbor, pitch." (WithArgDoc (GeneratorF Note) -> Generator Note) -> WithArgDoc (GeneratorF Note) -> Generator Note forall a b. (a -> b) -> a -> b $ Parser (DefaultDiatonic, Double, (Duration, ControlRef)) -> ((DefaultDiatonic, Double, (Duration, ControlRef)) -> GeneratorF Note) -> WithArgDoc (GeneratorF Note) forall y a d. Taggable y => Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d) Sig.call ((,,) (DefaultDiatonic -> Double -> (Duration, ControlRef) -> (DefaultDiatonic, Double, (Duration, ControlRef))) -> Parser DefaultDiatonic -> Parser (Double -> (Duration, ControlRef) -> (DefaultDiatonic, Double, (Duration, ControlRef))) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> ArgName -> DefaultDiatonic -> Doc -> Parser DefaultDiatonic forall a. (Typecheck a, ShowVal a) => ArgName -> a -> Doc -> Parser a Sig.defaulted ArgName "neighbor" (Transpose -> DefaultDiatonic Typecheck.DefaultDiatonic Transpose default_neighbor) Doc "Neighbor pitch." Parser (Double -> (Duration, ControlRef) -> (DefaultDiatonic, Double, (Duration, ControlRef))) -> Parser Double -> Parser ((Duration, ControlRef) -> (DefaultDiatonic, Double, (Duration, ControlRef))) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser Double GraceUtil.grace_dyn_env Parser ((Duration, ControlRef) -> (DefaultDiatonic, Double, (Duration, ControlRef))) -> Parser (Duration, ControlRef) -> Parser (DefaultDiatonic, Double, (Duration, ControlRef)) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser (Duration, ControlRef) GraceUtil.grace_envs ) (((DefaultDiatonic, Double, (Duration, ControlRef)) -> GeneratorF Note) -> WithArgDoc (GeneratorF Note)) -> ((DefaultDiatonic, Double, (Duration, ControlRef)) -> GeneratorF Note) -> WithArgDoc (GeneratorF Note) forall a b. (a -> b) -> a -> b $ \(Typecheck.DefaultDiatonic Transpose neighbor, Double dyn, (Duration grace_dur, ControlRef place)) -> GeneratorF Note -> GeneratorF Note forall d. (PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver Sub.inverting (GeneratorF Note -> GeneratorF Note) -> GeneratorF Note -> GeneratorF Note forall a b. (a -> b) -> a -> b $ \PassedArgs Note args -> NoteDeriver -> NoteDeriver -> NoteDeriver forall a. Deriver a -> Deriver a -> Deriver a Ly.when_lilypond (PassedArgs Note -> Transpose -> NoteDeriver forall d. PassedArgs d -> Transpose -> NoteDeriver lily_mordent PassedArgs Note args Transpose neighbor) (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver forall a b. (a -> b) -> a -> b $ do Pitch pitch <- RealTime -> Deriver Pitch Call.get_pitch (RealTime -> Deriver Pitch) -> Deriver State Error RealTime -> Deriver Pitch forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< PassedArgs Note -> Deriver State Error RealTime forall a. PassedArgs a -> Deriver State Error RealTime Args.real_start PassedArgs Note args PassedArgs Note -> Double -> [Pitch] -> Duration -> ControlRef -> NoteDeriver GraceUtil.legato_grace PassedArgs Note args Double dyn [Pitch pitch, Transpose -> Pitch -> Pitch forall a. Transpose -> RawPitch a -> RawPitch a Pitches.transpose Transpose neighbor Pitch pitch] Duration grace_dur ControlRef place lily_mordent :: Derive.PassedArgs d -> Pitch.Transpose -> Derive.NoteDeriver lily_mordent :: forall d. PassedArgs d -> Transpose -> NoteDeriver lily_mordent PassedArgs d args Transpose neighbor = do RealTime start <- PassedArgs d -> Deriver State Error RealTime forall a. PassedArgs a -> Deriver State Error RealTime Args.real_start PassedArgs d args Pitch pitch <- RealTime -> Deriver Pitch Call.get_pitch RealTime start PassedArgs d -> RealTime -> [Pitch] -> NoteDeriver forall d. PassedArgs d -> RealTime -> [Pitch] -> NoteDeriver GraceUtil.lily_grace PassedArgs d args RealTime start [Pitch pitch, Transpose -> Pitch -> Pitch forall a. Transpose -> RawPitch a -> RawPitch a Pitches.transpose Transpose neighbor Pitch pitch] -- * pitch calls c_mordent_p :: Pitch.Transpose -> Derive.Generator Derive.Pitch c_mordent_p :: Transpose -> Generator Pitch c_mordent_p Transpose default_neighbor = Module -> CallName -> Tags -> Doc -> WithArgDoc (PassedArgs Pitch -> Deriver Pitch) -> Generator Pitch forall d. Module -> CallName -> Tags -> Doc -> WithArgDoc (PassedArgs d -> Deriver d) -> Generator d Derive.generator1 Module Module.prelude CallName "mordent" Tags Tags.ornament Doc "Like `g`, but hardcoded to play pitch, neighbor, pitch." (WithArgDoc (PassedArgs Pitch -> Deriver Pitch) -> Generator Pitch) -> WithArgDoc (PassedArgs Pitch -> Deriver Pitch) -> Generator Pitch forall a b. (a -> b) -> a -> b $ Parser (Pitch, DefaultDiatonic, Duration) -> ((Pitch, DefaultDiatonic, Duration) -> PassedArgs Pitch -> Deriver Pitch) -> WithArgDoc (PassedArgs Pitch -> Deriver Pitch) forall y a d. Taggable y => Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d) Sig.call ((,,) (Pitch -> DefaultDiatonic -> Duration -> (Pitch, DefaultDiatonic, Duration)) -> Parser Pitch -> Parser (DefaultDiatonic -> Duration -> (Pitch, DefaultDiatonic, Duration)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> ArgName -> Doc -> Parser Pitch forall a. Typecheck a => ArgName -> Doc -> Parser a Sig.required ArgName "pitch" Doc "Base pitch." Parser (DefaultDiatonic -> Duration -> (Pitch, DefaultDiatonic, Duration)) -> Parser DefaultDiatonic -> Parser (Duration -> (Pitch, DefaultDiatonic, Duration)) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> ArgName -> DefaultDiatonic -> Doc -> Parser DefaultDiatonic forall a. (Typecheck a, ShowVal a) => ArgName -> a -> Doc -> Parser a Sig.defaulted ArgName "neighbor" (Transpose -> DefaultDiatonic Typecheck.DefaultDiatonic Transpose default_neighbor) Doc "Neighbor pitch." Parser (Duration -> (Pitch, DefaultDiatonic, Duration)) -> Parser Duration -> Parser (Pitch, DefaultDiatonic, Duration) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser Duration GraceUtil.grace_dur_env ) (((Pitch, DefaultDiatonic, Duration) -> PassedArgs Pitch -> Deriver Pitch) -> WithArgDoc (PassedArgs Pitch -> Deriver Pitch)) -> ((Pitch, DefaultDiatonic, Duration) -> PassedArgs Pitch -> Deriver Pitch) -> WithArgDoc (PassedArgs Pitch -> Deriver Pitch) forall a b. (a -> b) -> a -> b $ \(Pitch pitch, Typecheck.DefaultDiatonic Transpose neighbor, Duration grace_dur) PassedArgs Pitch args -> Duration -> [Pitch] -> (ScoreTime, ScoreTime) -> Deriver Pitch grace_p Duration grace_dur [Pitch pitch, Transpose -> Pitch -> Pitch forall a. Transpose -> RawPitch a -> RawPitch a Pitches.transpose Transpose neighbor Pitch pitch, Pitch pitch] (PassedArgs Pitch -> (ScoreTime, ScoreTime) forall a. PassedArgs a -> (ScoreTime, ScoreTime) Args.range_or_next PassedArgs Pitch args) c_grace_p :: Derive.Generator Derive.Pitch c_grace_p :: Generator Pitch c_grace_p = Module -> CallName -> Tags -> Doc -> WithArgDoc (PassedArgs Pitch -> Deriver Pitch) -> Generator Pitch forall d. Module -> CallName -> Tags -> Doc -> WithArgDoc (PassedArgs d -> Deriver d) -> Generator d Derive.generator1 Module Module.prelude CallName "grace" Tags Tags.ornament Doc "Generate grace note pitches. They start on the event and have the given\ \ duration, but are shortened if the available duration is too short.\ \ The destination pitch is first, even though it plays last, so\ \ `g (c) (a) (b)` produces `a b c`." (WithArgDoc (PassedArgs Pitch -> Deriver Pitch) -> Generator Pitch) -> WithArgDoc (PassedArgs Pitch -> Deriver Pitch) -> Generator Pitch forall a b. (a -> b) -> a -> b $ Parser (Pitch, [Either Pitch (Typed Double)], Duration) -> ((Pitch, [Either Pitch (Typed Double)], Duration) -> PassedArgs Pitch -> Deriver Pitch) -> WithArgDoc (PassedArgs Pitch -> Deriver Pitch) forall y a d. Taggable y => Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d) Sig.call ((,,) (Pitch -> [Either Pitch (Typed Double)] -> Duration -> (Pitch, [Either Pitch (Typed Double)], Duration)) -> Parser Pitch -> Parser ([Either Pitch (Typed Double)] -> Duration -> (Pitch, [Either Pitch (Typed Double)], Duration)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> ArgName -> Doc -> Parser Pitch forall a. Typecheck a => ArgName -> Doc -> Parser a Sig.required ArgName "pitch" Doc "Base pitch." Parser ([Either Pitch (Typed Double)] -> Duration -> (Pitch, [Either Pitch (Typed Double)], Duration)) -> Parser [Either Pitch (Typed Double)] -> Parser (Duration -> (Pitch, [Either Pitch (Typed Double)], Duration)) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser [Either Pitch (Typed Double)] GraceUtil.grace_pitches_arg Parser (Duration -> (Pitch, [Either Pitch (Typed Double)], Duration)) -> Parser Duration -> Parser (Pitch, [Either Pitch (Typed Double)], Duration) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser Duration GraceUtil.grace_dur_env ) (((Pitch, [Either Pitch (Typed Double)], Duration) -> PassedArgs Pitch -> Deriver Pitch) -> WithArgDoc (PassedArgs Pitch -> Deriver Pitch)) -> ((Pitch, [Either Pitch (Typed Double)], Duration) -> PassedArgs Pitch -> Deriver Pitch) -> WithArgDoc (PassedArgs Pitch -> Deriver Pitch) forall a b. (a -> b) -> a -> b $ \(Pitch pitch, [Either Pitch (Typed Double)] pitches, Duration grace_dur) PassedArgs Pitch args -> do [Pitch] ps <- ([Pitch] -> [Pitch] -> [Pitch] forall a. [a] -> [a] -> [a] ++[Pitch pitch]) ([Pitch] -> [Pitch]) -> Deriver [Pitch] -> Deriver [Pitch] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Pitch -> [Either Pitch (Typed Double)] -> Deriver [Pitch] GraceUtil.resolve_pitches Pitch pitch [Either Pitch (Typed Double)] pitches Duration -> [Pitch] -> (ScoreTime, ScoreTime) -> Deriver Pitch grace_p Duration grace_dur [Pitch] ps (PassedArgs Pitch -> (ScoreTime, ScoreTime) forall a. PassedArgs a -> (ScoreTime, ScoreTime) Args.range_or_next PassedArgs Pitch args) grace_p :: DeriveT.Duration -> [PSignal.Pitch] -> (ScoreTime, ScoreTime) -> Derive.Deriver PSignal.PSignal grace_p :: Duration -> [Pitch] -> (ScoreTime, ScoreTime) -> Deriver Pitch grace_p Duration grace_dur [Pitch] pitches (ScoreTime start, ScoreTime end) = do RealTime real_dur <- ScoreTime -> Duration -> Deriver State Error RealTime forall t1 t2. (Time t1, Time t2) => t1 -> t2 -> Deriver State Error RealTime Call.real_duration ScoreTime start Duration grace_dur RealTime real_start <- ScoreTime -> Deriver State Error RealTime forall a. Time a => a -> Deriver State Error RealTime Derive.real ScoreTime start RealTime real_end <- ScoreTime -> Deriver State Error RealTime forall a. Time a => a -> Deriver State Error RealTime Derive.real ScoreTime end let starts :: [RealTime] starts = RealTime -> RealTime -> Int -> RealTime -> [RealTime] forall a. (Fractional a, Ord a) => a -> a -> Int -> a -> [a] GraceUtil.fit_after RealTime real_start RealTime real_end ([Pitch] -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length [Pitch] pitches) RealTime real_dur Pitch -> Deriver Pitch forall (m :: * -> *) a. Monad m => a -> m a return (Pitch -> Deriver Pitch) -> Pitch -> Deriver Pitch forall a b. (a -> b) -> a -> b $ [(RealTime, Pitch)] -> Pitch PSignal.from_pairs ([(RealTime, Pitch)] -> Pitch) -> [(RealTime, Pitch)] -> Pitch forall a b. (a -> b) -> a -> b $ [(RealTime, Pitch)] -> [(RealTime, Pitch)] forall y. [(RealTime, y)] -> [(RealTime, y)] flat_segments ([(RealTime, Pitch)] -> [(RealTime, Pitch)]) -> [(RealTime, Pitch)] -> [(RealTime, Pitch)] forall a b. (a -> b) -> a -> b $ [RealTime] -> [Pitch] -> [(RealTime, Pitch)] forall a b. [a] -> [b] -> [(a, b)] zip [RealTime] starts [Pitch] pitches flat_segments :: [(RealTime, y)] -> [(RealTime, y)] flat_segments :: forall y. [(RealTime, y)] -> [(RealTime, y)] flat_segments = (((RealTime, y), Maybe (RealTime, y)) -> [(RealTime, y)]) -> [((RealTime, y), Maybe (RealTime, y))] -> [(RealTime, y)] forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap ((RealTime, y), Maybe (RealTime, y)) -> [(RealTime, y)] forall {a} {b} {b}. ((a, b), Maybe (a, b)) -> [(a, b)] to_pairs ([((RealTime, y), Maybe (RealTime, y))] -> [(RealTime, y)]) -> ([(RealTime, y)] -> [((RealTime, y), Maybe (RealTime, y))]) -> [(RealTime, y)] -> [(RealTime, y)] forall b c a. (b -> c) -> (a -> b) -> a -> c . [(RealTime, y)] -> [((RealTime, y), Maybe (RealTime, y))] forall {a}. [a] -> [(a, Maybe a)] Seq.zip_next where to_pairs :: ((a, b), Maybe (a, b)) -> [(a, b)] to_pairs ((a x, b y), Maybe (a, b) next) = case Maybe (a, b) next of Maybe (a, b) Nothing -> [(a x, b y)] Just (a x2, b _) -> [(a x, b y), (a x2, b y)]