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