-- 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.Lists as Lists
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 = forall a. Monoid a => [a] -> a
mconcat
    [ 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)))
        ]
    , 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."
    forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
args [Event]
events -> forall val a. ToVal val => Key -> val -> Deriver a -> Deriver a
Derive.with_val Key
"legato-dyn" (Double
1 :: Double) forall a b. (a -> b) -> a -> b
$
        Context Note -> Symbol -> [Term] -> [[Event]] -> NoteDeriver
Sub.reapply_call (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."
    forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
_args -> [Event] -> NoteDeriver
Sub.derive forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. [EventT a] -> [EventT a]
hold
    where
    hold :: [EventT a] -> [EventT a]
hold [EventT a]
events = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [EventT a]
events (\ScoreTime
e -> forall a b. (a -> b) -> [a] -> [b]
map (forall {a}. ScoreTime -> EventT a -> EventT a
set_end ScoreTime
e) [EventT a]
events) Maybe ScoreTime
end
        where end :: Maybe ScoreTime
end = forall a. Ord a => [a] -> Maybe a
Lists.maximum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map 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 forall a. Num a => a -> a -> a
- 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." forall a b. (a -> b) -> a -> b
$
    \PassedArgs Note
_args [EventT Pitch]
events -> if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EventT Pitch]
events then forall a. Monoid a => a
mempty else do
        Pitch
pitch <- Deriver Pitch
Derive.get_pitch
        let start :: ScoreTime
start = forall a. EventT a -> ScoreTime
SubT._start (forall a. [a] -> a
head [EventT Pitch]
events)
        [RealTime]
rstarts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a. Time a => a -> Deriver State Error RealTime
Derive.real forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. EventT a -> ScoreTime
SubT._start) [EventT Pitch]
events
        forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a
Derive.place ScoreTime
start (forall a. EventT a -> ScoreTime
SubT.end (forall a. [a] -> a
last [EventT Pitch]
events) forall a. Num a => a -> a -> a
- ScoreTime
start) forall a b. (a -> b) -> a -> b
$
            forall a. Pitch -> Deriver a -> Deriver a
Derive.with_pitch
                ([RealTime] -> [Pitch] -> Pitch
mksig [RealTime]
rstarts (forall a b. (a -> b) -> [a] -> [b]
map forall a. EventT a -> a
SubT._note [EventT Pitch]
events) 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 forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ (RealTime
start, Pitch
p) forall a. a -> [a] -> [a]
: forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (, Pitch
p)) Maybe RealTime
mb_end
        | ((RealTime
start, Maybe RealTime
mb_end), Pitch
p) <- forall a b. [a] -> [b] -> [(a, b)]
zip (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, forall a. a -> Maybe a
Just a
x2) forall a. a -> [a] -> [a]
: [a] -> [(a, Maybe a)]
pairs (a
x2forall a. a -> [a] -> [a]
:[a]
xs)
    pairs [a
x] = [(a
x, forall a. Maybe a
Nothing)]
    pairs [] = []

c_basic_grace :: Derive.Generator Derive.Note
c_basic_grace :: Generator Note
c_basic_grace = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
Module.prelude CallName
"basic-grace"
    (Tags
Tags.ornament 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."
    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.
Typecheck a =>
ArgName -> EnvironDefault -> Doc -> Parser a
Sig.required_env ArgName
"pitches" EnvironDefault
Sig.None Doc
GraceUtil.grace_pitches_doc
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a.
Typecheck a =>
ArgName -> EnvironDefault -> Doc -> Parser a
Sig.required_env ArgName
"dur" EnvironDefault
Sig.None Doc
"Duration of grace notes."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a.
Typecheck a =>
ArgName -> EnvironDefault -> Doc -> Parser a
Sig.required_env ArgName
"place" EnvironDefault
Sig.None Doc
GraceUtil.grace_place_doc
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.defaulted_env ArgName
"transformer" EnvironDefault
Sig.None (forall a. Maybe a
Nothing :: Maybe Sig.Dummy)
        Doc
"Apply a transformer to grace notes."
    ) forall a b. (a -> b) -> a -> b
$ \([Either Pitch (Typed Double)]
pitches, Duration
grace_dur, Normalized
place, Maybe Quoted
maybe_transform) ->
    forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
args -> do
        RealTime
start <- 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 = forall d.
(Callable (Transformer d), Taggable d) =>
Context d -> Quoted -> Deriver (Stream d) -> Deriver (Stream d)
Eval.eval_quoted_transformers (forall a. PassedArgs a -> Context a
Args.context PassedArgs Note
args)
        forall a. Deriver a -> Deriver a -> Deriver a
Ly.when_lilypond (forall d. PassedArgs d -> RealTime -> [Pitch] -> NoteDeriver
GraceUtil.lily_grace PassedArgs Note
args RealTime
start [Pitch]
pitches) forall a b. (a -> b) -> a -> b
$
            [Event] -> NoteDeriver
Sub.derive forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a.
PassedArgs a
-> [Pitch]
-> (NoteDeriver -> NoteDeriver)
-> Duration
-> Normalized
-> Deriver [Event]
GraceUtil.basic_grace_transform PassedArgs Note
args [Pitch]
pitches
                (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id Quoted -> NoteDeriver -> NoteDeriver
apply Maybe Quoted
maybe_transform) Duration
grace_dur Normalized
place


-- ** roll

c_roll :: Derive.Generator Derive.Note
c_roll :: Generator Note
c_roll = 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."
    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
"times" (Int
1 :: Int) Doc
"Number of grace notes."
    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
"time" DefaultReal
GraceUtil.default_grace_dur
        Doc
"Time between the strokes."
    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" (Double
0.5 :: Double) Doc
"Dyn scale for the grace notes."
    ) forall a b. (a -> b) -> a -> b
$ \(Double
times, Typecheck.DefaultReal Duration
time, Double
dyn_scale) ->
    forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting forall a b. (a -> b) -> a -> b
$ forall a. Int -> Duration -> Double -> PassedArgs a -> NoteDeriver
roll (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 <- 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 <- forall a. Int -> [a] -> [a]
Lists.dropEnd Int
1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
NoteDeriver
-> Int -> Duration -> Normalized -> PassedArgs a -> Deriver [Event]
GraceUtil.repeat_notes
        (forall a. Pitch -> Deriver a -> Deriver a
Call.with_pitch Pitch
pitch NoteDeriver
Call.note) (Int
timesforall a. Num a => a -> a -> a
+Int
1) Duration
time
            (Double -> Normalized
Typecheck.Normalized Double
0) PassedArgs a
args
    [Event] -> NoteDeriver
Sub.derive (forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Double -> Deriver a -> Deriver a
Call.with_dynamic (Double
dynforall a. Num a => a -> a -> a
*Double
dyn_scale))) [Event]
notes)
        forall a. Semigroup a => a -> a -> a
<> 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 = 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."
    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
"neighbor" (Transpose -> DefaultDiatonic
Typecheck.DefaultDiatonic Transpose
default_neighbor)
        Doc
"Neighbor pitch."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Double
GraceUtil.grace_dyn_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Duration, Normalized)
GraceUtil.grace_envs
    ) forall a b. (a -> b) -> a -> b
$ \(Typecheck.DefaultDiatonic Transpose
neighbor, Double
dyn, (Duration
grace_dur, Normalized
place)) ->
    forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
args ->
        forall a. Deriver a -> Deriver a -> Deriver a
Ly.when_lilypond (forall d. PassedArgs d -> Transpose -> NoteDeriver
lily_mordent PassedArgs Note
args Transpose
neighbor) forall a b. (a -> b) -> a -> b
$ do
            Pitch
pitch <- RealTime -> Deriver Pitch
Call.get_pitch forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. PassedArgs a -> Deriver State Error RealTime
Args.real_start PassedArgs Note
args
            PassedArgs Note
-> Double -> [Pitch] -> Duration -> Normalized -> NoteDeriver
GraceUtil.legato_grace PassedArgs Note
args Double
dyn
                [Pitch
pitch, forall a. Transpose -> RawPitch a -> RawPitch a
Pitches.transpose Transpose
neighbor Pitch
pitch] Duration
grace_dur Normalized
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 <- forall a. PassedArgs a -> Deriver State Error RealTime
Args.real_start PassedArgs d
args
    Pitch
pitch <- RealTime -> Deriver Pitch
Call.get_pitch RealTime
start
    forall d. PassedArgs d -> RealTime -> [Pitch] -> NoteDeriver
GraceUtil.lily_grace PassedArgs d
args RealTime
start [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 = 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."
    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. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"pitch" Doc
"Base pitch."
    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
"neighbor" (Transpose -> DefaultDiatonic
Typecheck.DefaultDiatonic Transpose
default_neighbor)
        Doc
"Neighbor pitch."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Duration
GraceUtil.grace_dur_env
    ) 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, forall a. Transpose -> RawPitch a -> RawPitch a
Pitches.transpose Transpose
neighbor Pitch
pitch, Pitch
pitch]
            (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 = 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`."
    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. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"pitch" Doc
"Base pitch."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser [Either Pitch (Typed Double)]
GraceUtil.grace_pitches_arg forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Duration
GraceUtil.grace_dur_env
    ) forall a b. (a -> b) -> a -> b
$ \(Pitch
pitch, [Either Pitch (Typed Double)]
pitches, Duration
grace_dur) PassedArgs Pitch
args -> do
        [Pitch]
ps <- (forall a. [a] -> [a] -> [a]
++[Pitch
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 (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 <- forall t1 t2.
(Time t1, Time t2) =>
t1 -> t2 -> Deriver State Error RealTime
Call.real_duration ScoreTime
start Duration
grace_dur
    RealTime
real_start <- forall a. Time a => a -> Deriver State Error RealTime
Derive.real ScoreTime
start
    RealTime
real_end <- forall a. Time a => a -> Deriver State Error RealTime
Derive.real ScoreTime
end
    let starts :: [RealTime]
starts = forall a. (Fractional a, Ord a) => a -> a -> Int -> a -> [a]
GraceUtil.fit_after RealTime
real_start RealTime
real_end (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pitch]
pitches)
            RealTime
real_dur
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [(RealTime, Pitch)] -> Pitch
PSignal.from_pairs forall a b. (a -> b) -> a -> b
$ forall y. [(RealTime, y)] -> [(RealTime, y)]
flat_segments forall a b. (a -> b) -> a -> b
$ 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 = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a} {b} {b}. ((a, b), Maybe (a, b)) -> [(a, b)]
to_pairs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. [a] -> [(a, Maybe a)]
Lists.zipNext
    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)]