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

-- | Functions to emit grace-note like things.
module Derive.Call.GraceUtil where
import qualified Data.Either as Either
import qualified Data.Map as Map
import qualified Data.Text as Text

import qualified Util.Doc as Doc
import qualified Util.Num as Num
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.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.PSignal as PSignal
import qualified Derive.Pitches as Pitches
import qualified Derive.Score as Score
import qualified Derive.ScoreT as ScoreT
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Sig as Sig
import qualified Derive.Typecheck as Typecheck

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

import           Global
import           Types


-- * standard args

grace_envs :: Sig.Parser (DeriveT.Duration, Typecheck.Normalized)
grace_envs :: Parser (Duration, Normalized)
grace_envs = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Duration
grace_dur_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Normalized
grace_place_env

grace_dur_env :: Sig.Parser DeriveT.Duration
grace_dur_env :: Parser Duration
grace_dur_env = DefaultReal -> Duration
Typecheck._real forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.environ ArgName
"dur" EnvironDefault
Sig.Both DefaultReal
default_grace_dur Doc
"Duration of grace notes."

grace_dyn_env :: Sig.Parser Double
grace_dyn_env :: Parser Y
grace_dyn_env =
    forall a. NonNegative a -> a
Typecheck.non_negative forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.environ ArgName
"grace-dyn" EnvironDefault
Sig.Unprefixed
        (Y
0.5 :: Double) Doc
"Scale the dyn of the grace notes."

grace_place_env :: Sig.Parser Typecheck.Normalized
grace_place_env :: Parser Normalized
grace_place_env = forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.environ ArgName
"place" EnvironDefault
Sig.Both (Y
0 :: Double) Doc
grace_place_doc

grace_place_doc :: Doc.Doc
grace_place_doc :: Doc
grace_place_doc =
    Doc
"At 0, grace notes fall before their base note.  At 1, grace notes fall on\
    \ the base note, and the base note is delayed."

-- | It's pretty much arbitrary, but this seems ok.
default_grace_dur :: Typecheck.DefaultReal
default_grace_dur :: DefaultReal
default_grace_dur = RealTime -> DefaultReal
Typecheck.real (RealTime
1forall a. Fractional a => a -> a -> a
/RealTime
12)

grace_pitches_arg :: Sig.Parser [Either PSignal.Pitch (ScoreT.Typed Signal.Y)]
grace_pitches_arg :: Parser [Either Pitch (Typed Y)]
grace_pitches_arg = forall a. Typecheck a => ArgName -> Doc -> Parser [a]
Sig.many ArgName
"pitch" Doc
grace_pitches_doc

grace_pitches_doc :: Doc.Doc
grace_pitches_doc :: Doc
grace_pitches_doc = Doc
"Grace note pitches. If they are numbers,\
    \ they are taken as transpositions and must all be the same type,\
    \ defaulting to diatonic."

-- * calls

-- | Make a grace call with the standard arguments.
make_grace :: Module.Module -> Doc.Doc
    -> (Derive.NoteDeriver -> Derive.NoteDeriver)
    -> (Derive.PassedArgs Score.Event -> [SubT.Event] -> Derive.NoteDeriver)
    -> Derive.Generator Derive.Note
make_grace :: Module
-> Doc
-> (NoteDeriver -> NoteDeriver)
-> (PassedArgs Note -> [Event] -> NoteDeriver)
-> Generator Note
make_grace Module
module_ Doc
doc NoteDeriver -> NoteDeriver
transform PassedArgs Note -> [Event] -> NoteDeriver
derive =
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
module_ CallName
"grace" (Tags
Tags.ornament forall a. Semigroup a => a -> a -> a
<> Tags
Tags.ly) Doc
doc
    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
<$> Parser [Either Pitch (Typed Y)]
grace_pitches_arg forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Y
grace_dyn_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Duration, Normalized)
grace_envs
    ) forall a b. (a -> b) -> a -> b
$ \([Either Pitch (Typed Y)]
pitches, Y
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 -> do
        RealTime
start <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Note
args
        Pitch
base <- RealTime -> Deriver Pitch
Call.get_pitch RealTime
start
        [Pitch]
pitches <- Pitch -> [Either Pitch (Typed Y)] -> Deriver [Pitch]
resolve_pitches Pitch
base [Either Pitch (Typed Y)]
pitches
        forall a. Deriver a -> Deriver a -> Deriver a
Ly.when_lilypond (forall d. PassedArgs d -> RealTime -> [Pitch] -> NoteDeriver
lily_grace PassedArgs Note
args RealTime
start [Pitch]
pitches) forall a b. (a -> b) -> a -> b
$ do
            Y
with_dyn <- (forall a. Num a => a -> a -> a
*Y
dyn) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RealTime -> Deriver State Error Y
Call.dynamic forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Note
args)
            PassedArgs Note -> [Event] -> NoteDeriver
derive PassedArgs Note
args forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a.
PassedArgs a
-> [Pitch]
-> (NoteDeriver -> NoteDeriver)
-> Duration
-> Normalized
-> Deriver [Event]
basic_grace_transform PassedArgs Note
args [Pitch]
pitches
                (NoteDeriver -> NoteDeriver
transform forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Y -> Deriver a -> Deriver a
Call.with_dynamic Y
with_dyn) Duration
grace_dur Normalized
place

-- | This is like 'make_grace', but gives you pitches instead of realized
-- events, in case you want to merge them or something.
make_grace_pitch :: Module.Module -> Doc.Doc
    -> (Derive.PassedArgs Score.Event -> [SubT.EventT PSignal.Pitch]
        -> Derive.NoteDeriver)
    -> Derive.Generator Derive.Note
make_grace_pitch :: Module
-> Doc
-> (PassedArgs Note -> [EventT Pitch] -> NoteDeriver)
-> Generator Note
make_grace_pitch Module
module_ Doc
doc PassedArgs Note -> [EventT Pitch] -> NoteDeriver
derive =
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
module_ CallName
"grace" (Tags
Tags.ornament forall a. Semigroup a => a -> a -> a
<> Tags
Tags.ly) Doc
doc
    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
<$> Parser [Either Pitch (Typed Y)]
grace_pitches_arg forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Duration, Normalized)
grace_envs
    ) forall a b. (a -> b) -> a -> b
$ \([Either Pitch (Typed Y)]
pitches, (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 -> do
        RealTime
start <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Note
args
        Pitch
base <- RealTime -> Deriver Pitch
Call.get_pitch RealTime
start
        [Pitch]
pitches <- Pitch -> [Either Pitch (Typed Y)] -> Deriver [Pitch]
resolve_pitches Pitch
base [Either Pitch (Typed Y)]
pitches
        forall a. Deriver a -> Deriver a -> Deriver a
Ly.when_lilypond (forall d. PassedArgs d -> RealTime -> [Pitch] -> NoteDeriver
lily_grace PassedArgs Note
args RealTime
start [Pitch]
pitches) forall a b. (a -> b) -> a -> b
$ do
            Pitch
here <- forall a. PassedArgs a -> Deriver Pitch
Call.get_pitch_here PassedArgs Note
args
            [EventT Pitch]
notes <- forall a note.
PassedArgs a
-> [note] -> Duration -> Normalized -> Deriver [EventT note]
basic_grace PassedArgs Note
args ([Pitch]
pitches forall a. [a] -> [a] -> [a]
++ [Pitch
here]) Duration
grace_dur Normalized
place
            PassedArgs Note -> [EventT Pitch] -> NoteDeriver
derive PassedArgs Note
args [EventT Pitch]
notes

repeat_notes :: Derive.NoteDeriver -> Int -> DeriveT.Duration
    -> Typecheck.Normalized -- ^ placement, 'grace_place_doc'
    -> Derive.PassedArgs a -> Derive.Deriver [SubT.Event]
repeat_notes :: forall a.
NoteDeriver
-> Int -> Duration -> Normalized -> PassedArgs a -> Deriver [Event]
repeat_notes NoteDeriver
note Int
times Duration
time Normalized
place PassedArgs a
args =
    forall note.
Maybe ScoreTime
-> (ScoreTime, ScoreTime)
-> [note]
-> Duration
-> Normalized
-> Deriver [EventT note]
make_grace_notes (forall a. PassedArgs a -> Maybe ScoreTime
Args.prev_start PassedArgs a
args)
        (forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range_or_next PassedArgs a
args) (forall a. Int -> a -> [a]
replicate Int
times NoteDeriver
note) Duration
time Normalized
place

make_grace_notes :: Maybe ScoreTime -> (ScoreTime, ScoreTime) -- ^ (start, end)
    -> [note] -- ^ the last note is the destination
    -> DeriveT.Duration
    -> Typecheck.Normalized -- ^ placement, see 'grace_place_doc'
    -> Derive.Deriver [SubT.EventT note]
make_grace_notes :: forall note.
Maybe ScoreTime
-> (ScoreTime, ScoreTime)
-> [note]
-> Duration
-> Normalized
-> Deriver [EventT note]
make_grace_notes Maybe ScoreTime
prev (ScoreTime
start, ScoreTime
end) [note]
notes Duration
grace_dur Normalized
place = do
    case Duration
grace_dur of
        DeriveT.ScoreDuration ScoreTime
grace_dur -> do
            let extents :: [(ScoreTime, ScoreTime)]
extents = forall a.
(Fractional a, Ord a) =>
Normalized -> Maybe a -> a -> a -> Int -> a -> [(a, a)]
fit_grace_durs Normalized
place Maybe ScoreTime
prev ScoreTime
start ScoreTime
end (forall (t :: * -> *) a. Foldable t => t a -> Int
length [note]
notes)
                    ScoreTime
grace_dur
            forall (m :: * -> *) a. Monad m => a -> m a
return [forall a. ScoreTime -> ScoreTime -> a -> EventT a
SubT.EventT ScoreTime
s ScoreTime
d note
n | ((ScoreTime
s, ScoreTime
d), note
n) <- forall a b. [a] -> [b] -> [(a, b)]
zip [(ScoreTime, ScoreTime)]
extents [note]
notes]
        DeriveT.RealDuration RealTime
grace_dur -> do
            RealTime
real_start <- forall a. Time a => a -> Deriver RealTime
Derive.real ScoreTime
start
            RealTime
real_end <- forall a. Time a => a -> Deriver RealTime
Derive.real ScoreTime
end
            Maybe RealTime
real_prev <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) ((forall a. a -> Maybe a
Just <$>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Time a => a -> Deriver RealTime
Derive.real) Maybe ScoreTime
prev
            let extents :: [(RealTime, RealTime)]
extents = forall a.
(Fractional a, Ord a) =>
Normalized -> Maybe a -> a -> a -> Int -> a -> [(a, a)]
fit_grace_durs Normalized
place Maybe RealTime
real_prev RealTime
real_start RealTime
real_end
                    (forall (t :: * -> *) a. Foldable t => t a -> Int
length [note]
notes) RealTime
grace_dur
            forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM forall {a} {a}.
(Time a, Num a) =>
(a, a) -> a -> Deriver State Error (EventT a)
note_real [(RealTime, RealTime)]
extents [note]
notes
    where
    note_real :: (a, a) -> a -> Deriver State Error (EventT a)
note_real (a
start, a
dur) a
note = do
        ScoreTime
score_start <- forall a. Time a => a -> Deriver ScoreTime
Derive.score a
start
        ScoreTime
score_end <- forall a. Time a => a -> Deriver ScoreTime
Derive.score (a
start forall a. Num a => a -> a -> a
+ a
dur)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. ScoreTime -> ScoreTime -> a -> EventT a
SubT.EventT ScoreTime
score_start (ScoreTime
score_end forall a. Num a => a -> a -> a
- ScoreTime
score_start) a
note

lily_grace :: Derive.PassedArgs d -> RealTime -> [PSignal.Pitch]
    -> Derive.NoteDeriver
lily_grace :: forall d. PassedArgs d -> RealTime -> [Pitch] -> NoteDeriver
lily_grace PassedArgs d
args RealTime
start [Pitch]
pitches = do
    Environ
env <- Deriver Environ
Derive.get_environ
    [Text]
pitches <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Environ -> Transposed -> Deriver Text
Ly.pitch_to_lily Environ
env)
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (RealTime -> Pitch -> Deriver Transposed
Derive.resolve_pitch RealTime
start) [Pitch]
pitches
    let ly_notes :: [Text]
ly_notes = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Semigroup a => a -> a -> a
<> forall a. ToLily a => a -> Text
Lilypond.to_lily Duration
Lilypond.D8) [Text]
pitches
        beamed :: [Text]
beamed = forall a. (a -> a) -> (a -> a) -> [a] -> [a]
Lists.firstLast (forall a. Semigroup a => a -> a -> a
<>Text
"[") (forall a. Semigroup a => a -> a -> a
<>Text
"]") [Text]
ly_notes
        -- I use \acciaccatura instead of \grace because it adds a slur
        -- automatically.
        code :: Text
code = Text
"\\acciaccatura { " forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unwords [Text]
beamed forall a. Semigroup a => a -> a -> a
<> Text
" } "
    -- Prepending to the note instead of emitting a separate code event ensures
    -- it stays with the note's voice.
    Code -> NoteDeriver -> NoteDeriver
Ly.add_first (Position CodePosition
Ly.prepend, Text
code) forall a b. (a -> b) -> a -> b
$ forall d a. PassedArgs d -> Deriver a -> Deriver a
Call.place PassedArgs d
args NoteDeriver
Call.note

-- * attr grace

c_attr_grace :: Map Int Attrs.Attributes
    -- ^ Map intervals in semitones (positive or negative) to attrs.
    -> Derive.Generator Derive.Note
c_attr_grace :: Map Int Attributes -> Generator Note
c_attr_grace Map Int Attributes
supported =
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
Module.instrument CallName
"grace" (Tags
Tags.ornament forall a. Semigroup a => a -> a -> a
<> Tags
Tags.ly)
    (Doc
"Emit grace notes as attrs, given a set of possible interval attrs.\
    \ If the grace note can't be expressed by the supported attrs, then emit\
    \ notes like the normal grace call.\nSupported: "
    forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
Doc.commas (forall a b. (a -> b) -> [a] -> [b]
map forall a. ShowVal a => a -> Doc
ShowVal.doc (forall k a. Map k a -> [a]
Map.elems Map Int Attributes
supported))
    ) 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
<$> Parser [Either Pitch (Typed Y)]
grace_pitches_arg forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Y
grace_dyn_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Duration, Normalized)
grace_envs
    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.environ ArgName
"attr" EnvironDefault
Sig.Prefixed (forall a. Maybe a
Nothing :: Maybe Sig.Dummy)
        Doc
"If given, put this attr on the grace notes. Otherwise, pick a grace\
        \ note from the support list."
    ) forall a b. (a -> b) -> a -> b
$ \([Either Pitch (Typed Y)]
pitches, Y
dyn, (Duration
grace_dur, Normalized
place), Maybe Attributes
attr) -> 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 RealTime
Args.real_start PassedArgs Note
args
        Pitch
base <- RealTime -> Deriver Pitch
Call.get_pitch RealTime
start
        [Pitch]
pitches <- Pitch -> [Either Pitch (Typed Y)] -> Deriver [Pitch]
resolve_pitches Pitch
base [Either Pitch (Typed Y)]
pitches
        forall a. Deriver a -> Deriver a -> Deriver a
Ly.when_lilypond (forall d. PassedArgs d -> RealTime -> [Pitch] -> NoteDeriver
lily_grace PassedArgs Note
args RealTime
start [Pitch]
pitches) forall a b. (a -> b) -> a -> b
$ case Maybe Attributes
attr of
            Just Attributes
attr -> forall d. Attributes -> Deriver d -> Deriver d
Call.add_attributes Attributes
attr forall a b. (a -> b) -> a -> b
$
                forall a.
Y
-> PassedArgs a -> [Pitch] -> Duration -> Normalized -> NoteDeriver
basic_grace_dyn Y
dyn PassedArgs Note
args [Pitch]
pitches Duration
grace_dur Normalized
place
            Maybe Attributes
Nothing -> do
                Maybe Attributes
maybe_attrs <- RealTime
-> Map Int Attributes
-> [Pitch]
-> Pitch
-> Deriver (Maybe Attributes)
grace_attributes RealTime
start Map Int Attributes
supported [Pitch]
pitches Pitch
base
                case Maybe Attributes
maybe_attrs of
                    Just Attributes
attrs -> forall {t2} {p} {a}.
(Time t2, Integral p) =>
RealTime -> PassedArgs a -> t2 -> p -> Attributes -> NoteDeriver
attr_grace RealTime
start PassedArgs Note
args Duration
grace_dur
                        (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pitch]
pitches) Attributes
attrs
                    -- Fall back on normal grace.
                    Maybe Attributes
Nothing -> PassedArgs Note
-> Y -> [Pitch] -> Duration -> Normalized -> NoteDeriver
legato_grace PassedArgs Note
args Y
dyn [Pitch]
pitches Duration
grace_dur Normalized
place
    where
    attr_grace :: RealTime -> PassedArgs a -> t2 -> p -> Attributes -> NoteDeriver
attr_grace RealTime
real_start PassedArgs a
args t2
grace_dur p
notes Attributes
attrs = do
        let (ScoreTime
start, ScoreTime
dur) = forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.extent PassedArgs a
args
        ScoreTime
grace_dur <- forall t1 t2. (Time t1, Time t2) => t1 -> t2 -> Deriver ScoreTime
Call.score_duration ScoreTime
start t2
grace_dur
        Y
dyn <- RealTime -> Deriver State Error Y
Call.dynamic RealTime
real_start
        let before :: ScoreTime
before = forall a b. (Integral a, Num b) => a -> b
fromIntegral p
notes forall a. Num a => a -> a -> a
* ScoreTime
grace_dur
        Pitch
pitch <- RealTime -> Deriver Pitch
Call.get_pitch RealTime
real_start
        forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a
Derive.place (ScoreTime
start forall a. Num a => a -> a -> a
- ScoreTime
before) (ScoreTime
dur forall a. Num a => a -> a -> a
+ ScoreTime
before) forall a b. (a -> b) -> a -> b
$
            forall d. Attributes -> Deriver d -> Deriver d
Call.add_attributes Attributes
attrs forall a b. (a -> b) -> a -> b
$ forall a. Y -> Deriver a -> Deriver a
Call.with_dynamic Y
dyn forall a b. (a -> b) -> a -> b
$
            Pitch -> NoteDeriver
Call.pitched_note Pitch
pitch

grace_attributes :: RealTime -> Map Int Attrs.Attributes -> [PSignal.Pitch]
    -> PSignal.Pitch -> Derive.Deriver (Maybe Attrs.Attributes)
grace_attributes :: RealTime
-> Map Int Attributes
-> [Pitch]
-> Pitch
-> Deriver (Maybe Attributes)
grace_attributes RealTime
pos Map Int Attributes
supported [Pitch
grace] Pitch
base = do
    NoteNumber
diff <- RealTime -> Pitch -> Pitch -> Deriver NoteNumber
Call.nn_difference RealTime
pos Pitch
base Pitch
grace
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (forall a b. (RealFrac a, Integral b) => a -> b
round NoteNumber
diff) Map Int Attributes
supported
grace_attributes RealTime
_ Map Int Attributes
_ [Pitch]
_ Pitch
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

-- * util

legato_grace :: Derive.NoteArgs -> Signal.Y -> [PSignal.Pitch]
    -> DeriveT.Duration -> Typecheck.Normalized -> Derive.NoteDeriver
legato_grace :: PassedArgs Note
-> Y -> [Pitch] -> Duration -> Normalized -> NoteDeriver
legato_grace PassedArgs Note
args Y
dyn_scale [Pitch]
pitches Duration
grace_dur Normalized
place = do
    Y
dyn <- (forall a. Num a => a -> a -> a
*Y
dyn_scale) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RealTime -> Deriver State Error Y
Call.dynamic forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Note
args)
    [Event]
events <- forall a.
PassedArgs a
-> [Pitch]
-> (NoteDeriver -> NoteDeriver)
-> Duration
-> Normalized
-> Deriver [Event]
basic_grace_transform PassedArgs Note
args [Pitch]
pitches (forall a. Y -> Deriver a -> Deriver a
Call.with_dynamic Y
dyn)
        Duration
grace_dur Normalized
place
    -- Normally legato notes emphasize the first note, but that's not
    -- appropriate for grace notes.
    forall val a. ToVal val => Text -> val -> Deriver a -> Deriver a
Derive.with_val Text
"legato-dyn" (Y
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]

basic_grace_dyn :: Signal.Y -> Derive.PassedArgs a -> [PSignal.Pitch]
    -> DeriveT.Duration -> Typecheck.Normalized -> Derive.NoteDeriver
basic_grace_dyn :: forall a.
Y
-> PassedArgs a -> [Pitch] -> Duration -> Normalized -> NoteDeriver
basic_grace_dyn Y
dyn_scale PassedArgs a
args [Pitch]
pitches Duration
grace_dur Normalized
place = do
    Y
dyn <- (forall a. Num a => a -> a -> a
*Y
dyn_scale) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RealTime -> Deriver State Error Y
Call.dynamic forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs a
args)
    [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]
basic_grace_transform PassedArgs a
args [Pitch]
pitches (forall a. Y -> Deriver a -> Deriver a
Call.with_dynamic Y
dyn)
        Duration
grace_dur Normalized
place

basic_grace_transform :: Derive.PassedArgs a -> [PSignal.Pitch]
    -> (Derive.NoteDeriver -> Derive.NoteDeriver)
    -> DeriveT.Duration -> Typecheck.Normalized -> Derive.Deriver [SubT.Event]
basic_grace_transform :: forall a.
PassedArgs a
-> [Pitch]
-> (NoteDeriver -> NoteDeriver)
-> Duration
-> Normalized
-> Deriver [Event]
basic_grace_transform PassedArgs a
args [Pitch]
pitches NoteDeriver -> NoteDeriver
transform = forall a note.
PassedArgs a
-> [note] -> Duration -> Normalized -> Deriver [EventT note]
basic_grace PassedArgs a
args [NoteDeriver]
notes
    where notes :: [NoteDeriver]
notes = forall a b. (a -> b) -> [a] -> [b]
map (NoteDeriver -> NoteDeriver
transform forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pitch -> NoteDeriver
Call.pitched_note) [Pitch]
pitches forall a. [a] -> [a] -> [a]
++ [NoteDeriver
Call.note]

basic_grace :: Derive.PassedArgs a -> [note]
    -> DeriveT.Duration -> Typecheck.Normalized
    -> Derive.Deriver [SubT.EventT note]
basic_grace :: forall a note.
PassedArgs a
-> [note] -> Duration -> Normalized -> Deriver [EventT note]
basic_grace PassedArgs a
args [note]
pitches =
    forall note.
Maybe ScoreTime
-> (ScoreTime, ScoreTime)
-> [note]
-> Duration
-> Normalized
-> Deriver [EventT note]
make_grace_notes (forall a. PassedArgs a -> Maybe ScoreTime
Args.prev_start PassedArgs a
args) (forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range_or_next PassedArgs a
args) [note]
pitches

-- | Determine grace note starting times and durations if they are to fit in
-- the given time range, shortening them if they don't fit.
fit_grace_durs :: (Fractional a, Ord a) => Typecheck.Normalized -> Maybe a
    -> a -> a -> Int -> a -> [(a, a)]
fit_grace_durs :: forall a.
(Fractional a, Ord a) =>
Normalized -> Maybe a -> a -> a -> Int -> a -> [(a, a)]
fit_grace_durs Normalized
place Maybe a
prev a
start a
end Int
notes a
dur =
    forall a b. (a -> b) -> [a] -> [b]
map (a, Maybe a) -> (a, a)
add_dur forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [(a, Maybe a)]
Lists.zipNext forall a b. (a -> b) -> a -> b
$ forall a.
(Fractional a, Ord a) =>
Normalized -> Maybe a -> a -> a -> Int -> a -> [a]
fit_grace Normalized
place Maybe a
prev a
start a
end Int
notes a
dur
    where
    add_dur :: (a, Maybe a) -> (a, a)
add_dur (a
x, Maybe a
Nothing) = (a
x, a
end forall a. Num a => a -> a -> a
- a
x)
    add_dur (a
x, Just a
next) = (a
x, a
next forall a. Num a => a -> a -> a
- a
x)

fit_grace :: (Fractional a, Ord a)
    => Typecheck.Normalized -- ^ placement, see 'grace_place_doc'
    -> Maybe a -> a -> a -> Int -> a -> [a]
fit_grace :: forall a.
(Fractional a, Ord a) =>
Normalized -> Maybe a -> a -> a -> Int -> a -> [a]
fit_grace (Typecheck.Normalized Y
place) Maybe a
maybe_prev a
start a
end Int
notes a
dur
    | Y
place forall a. Ord a => a -> a -> Bool
<= Y
0 = [a]
before
    | Y
place forall a. Ord a => a -> a -> Bool
>= Y
1 = [a]
after
    | Bool
otherwise =
        forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\a
x a
y -> forall a. (Eq a, Num a) => a -> a -> a -> a
Num.scale a
x a
y (forall a b. (Real a, Fractional b) => a -> b
realToFrac Y
place)) [a]
before [a]
after
    where
    after :: [a]
after = forall a. (Fractional a, Ord a) => a -> a -> Int -> a -> [a]
fit_after a
start a
end Int
notes a
dur
    before :: [a]
before = forall a. (Fractional a, Ord a) => Maybe a -> a -> Int -> a -> [a]
fit_before Maybe a
maybe_prev a
start Int
notes a
dur

fit_before :: (Fractional a, Ord a) => Maybe a -> a -> Int -> a -> [a]
fit_before :: forall a. (Fractional a, Ord a) => Maybe a -> a -> Int -> a -> [a]
fit_before Maybe a
maybe_prev a
start Int
notes a
dur =
    forall a. Int -> [a] -> [a]
take Int
notes forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop Int
1 forall a b. (a -> b) -> a -> b
$ forall a. Num a => a -> a -> [a]
Lists.range_ (a
start forall a. Num a => a -> a -> a
- a
notes_t forall a. Num a => a -> a -> a
* a
step) a
step
    where
    notes_t :: a
notes_t = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
notes
    step :: a
step
        | Just a
prev <- Maybe a
maybe_prev, a
start forall a. Num a => a -> a -> a
- a
dur forall a. Num a => a -> a -> a
* a
notes_t forall a. Ord a => a -> a -> Bool
< a
prev =
            (a
start forall a. Num a => a -> a -> a
- a
prev) forall a. Fractional a => a -> a -> a
/ a
notes_t
        | Bool
otherwise = a
dur

fit_after :: (Fractional a, Ord a) => a -> a -> Int -> a -> [a]
fit_after :: forall a. (Fractional a, Ord a) => a -> a -> Int -> a -> [a]
fit_after a
start a
end Int
notes a
dur = forall a. Int -> [a] -> [a]
take Int
notes forall a b. (a -> b) -> a -> b
$ forall a. Num a => a -> a -> [a]
Lists.range_ a
start a
step
    where
    notes_t :: a
notes_t = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
notes
    step :: a
step
        | a
dur forall a. Num a => a -> a -> a
* a
notes_t forall a. Ord a => a -> a -> Bool
>= a
end forall a. Num a => a -> a -> a
- a
start = (a
end forall a. Num a => a -> a -> a
- a
start) forall a. Fractional a => a -> a -> a
/ a
notes_t
        | Bool
otherwise = a
dur

resolve_pitches :: PSignal.Pitch
    -> [Either PSignal.Pitch (ScoreT.Typed Signal.Y)]
    -> Derive.Deriver [PSignal.Pitch]
resolve_pitches :: Pitch -> [Either Pitch (Typed Y)] -> Deriver [Pitch]
resolve_pitches Pitch
base = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => Text -> Deriver a
Derive.throw forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pitch -> [Either Pitch (Typed Y)] -> Either Text [Pitch]
check_pitches Pitch
base

check_pitches :: PSignal.Pitch -> [Either PSignal.Pitch (ScoreT.Typed Signal.Y)]
    -> Either Text [PSignal.Pitch]
check_pitches :: Pitch -> [Either Pitch (Typed Y)] -> Either Text [Pitch]
check_pitches Pitch
base [Either Pitch (Typed Y)]
pitches = do
    Y -> Transpose
make <- case forall a b. (a -> b) -> [a] -> [b]
map forall a. Typed a -> Type
ScoreT.type_of forall a b. (a -> b) -> a -> b
$ forall a b. [Either a b] -> [b]
Either.rights [Either Pitch (Typed Y)]
pitches of
        Type
t_ : [Type]
ts_
            | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
==Type
t) [Type]
ts -> case Type
t of
                Type
ScoreT.Diatonic -> forall a b. b -> Either a b
Right Y -> Transpose
Pitch.Diatonic
                Type
ScoreT.Chromatic -> forall a b. b -> Either a b
Right Y -> Transpose
Pitch.Chromatic
                Type
ScoreT.Nn -> forall a b. b -> Either a b
Right Y -> Transpose
Pitch.Nn
                Type
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"expected transpose type, but got " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Type
t
            | Bool
otherwise ->
                forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"arguments should all have the same type, got "
                    forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (Type
tforall a. a -> [a] -> [a]
:[Type]
ts)
            where
            t :: Type
t = Type -> Type -> Type
deflt Type
ScoreT.Diatonic Type
t_
            ts :: [Type]
ts = forall a b. (a -> b) -> [a] -> [b]
map (Type -> Type -> Type
deflt Type
t) [Type]
ts_
        [] -> forall a b. b -> Either a b
Right Y -> Transpose
Pitch.Diatonic
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id (forall {t}. (t -> Transpose) -> t -> Pitch
resolve Y -> Transpose
make forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Typed a -> a
ScoreT.val_of)) [Either Pitch (Typed Y)]
pitches
    where
    resolve :: (t -> Transpose) -> t -> Pitch
resolve t -> Transpose
make t
n = forall a. Transpose -> RawPitch a -> RawPitch a
Pitches.transpose (t -> Transpose
make t
n) Pitch
base
    deflt :: Type -> Type -> Type
deflt Type
typ Type
ScoreT.Untyped = Type
typ
    deflt Type
_ Type
typ = Type
typ