-- 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.Seq as Seq

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.RealTime as RealTime
import qualified Perform.Signal as Signal

import qualified Ui.ScoreTime as ScoreTime

import           Global
import           Types


-- * standard args

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

grace_dur_env :: Sig.Parser DeriveT.Duration
grace_dur_env :: Parser Duration
grace_dur_env = DefaultReal -> Duration
Typecheck._real (DefaultReal -> Duration) -> Parser DefaultReal -> Parser Duration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    ArgName
-> EnvironDefault -> DefaultReal -> Doc -> Parser DefaultReal
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> EnvironDefault -> a -> 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 =
    NonNegative Y -> Y
forall a. NonNegative a -> a
Typecheck.non_negative (NonNegative Y -> Y) -> Parser (NonNegative Y) -> Parser Y
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgName
-> EnvironDefault -> NonNegative Y -> Doc -> Parser (NonNegative Y)
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> EnvironDefault -> a -> Doc -> Parser a
Sig.environ ArgName
"grace-dyn" EnvironDefault
Sig.Unprefixed
        NonNegative Y
0.5 Doc
"Scale the dyn of the grace notes."

grace_place_env :: Sig.Parser DeriveT.ControlRef
grace_place_env :: Parser ControlRef
grace_place_env = ArgName -> EnvironDefault -> ControlRef -> Doc -> Parser ControlRef
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> EnvironDefault -> a -> Doc -> Parser a
Sig.environ ArgName
"place" EnvironDefault
Sig.Both
    (Control -> Y -> ControlRef
Sig.control Control
"place" Y
0) 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
1RealTime -> RealTime -> RealTime
forall 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 = ArgName -> Doc -> Parser [Either Pitch (Typed Y)]
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 =
    Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF Note)
-> Generator Note
forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
module_ CallName
"grace" (Tags
Tags.ornament Tags -> Tags -> Tags
forall a. Semigroup a => a -> a -> a
<> Tags
Tags.ly) Doc
doc
    (WithArgDoc (GeneratorF Note) -> Generator Note)
-> WithArgDoc (GeneratorF Note) -> Generator Note
forall a b. (a -> b) -> a -> b
$ Parser ([Either Pitch (Typed Y)], Y, (Duration, ControlRef))
-> (([Either Pitch (Typed Y)], Y, (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 ((,,)
    ([Either Pitch (Typed Y)]
 -> Y
 -> (Duration, ControlRef)
 -> ([Either Pitch (Typed Y)], Y, (Duration, ControlRef)))
-> Parser [Either Pitch (Typed Y)]
-> Parser
     (Y
      -> (Duration, ControlRef)
      -> ([Either Pitch (Typed Y)], Y, (Duration, ControlRef)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [Either Pitch (Typed Y)]
grace_pitches_arg Parser
  (Y
   -> (Duration, ControlRef)
   -> ([Either Pitch (Typed Y)], Y, (Duration, ControlRef)))
-> Parser Y
-> Parser
     ((Duration, ControlRef)
      -> ([Either Pitch (Typed Y)], Y, (Duration, ControlRef)))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Y
grace_dyn_env Parser
  ((Duration, ControlRef)
   -> ([Either Pitch (Typed Y)], Y, (Duration, ControlRef)))
-> Parser (Duration, ControlRef)
-> Parser ([Either Pitch (Typed Y)], Y, (Duration, ControlRef))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Duration, ControlRef)
grace_envs
    ) ((([Either Pitch (Typed Y)], Y, (Duration, ControlRef))
  -> GeneratorF Note)
 -> WithArgDoc (GeneratorF Note))
-> (([Either Pitch (Typed Y)], Y, (Duration, ControlRef))
    -> GeneratorF Note)
-> WithArgDoc (GeneratorF Note)
forall a b. (a -> b) -> a -> b
$ \([Either Pitch (Typed Y)]
pitches, Y
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 -> do
        RealTime
start <- PassedArgs Note -> Deriver RealTime
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
        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
lily_grace PassedArgs Note
args RealTime
start [Pitch]
pitches) (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall a b. (a -> b) -> a -> b
$ do
            Y
with_dyn <- (Y -> Y -> Y
forall a. Num a => a -> a -> a
*Y
dyn) (Y -> Y) -> Deriver State Error Y -> Deriver State Error Y
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RealTime -> Deriver State Error Y
Call.dynamic (RealTime -> Deriver State Error Y)
-> Deriver RealTime -> Deriver State Error Y
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PassedArgs Note -> Deriver RealTime
forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Note
args)
            PassedArgs Note -> [Event] -> NoteDeriver
derive PassedArgs Note
args ([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]
basic_grace_transform PassedArgs Note
args [Pitch]
pitches
                (NoteDeriver -> NoteDeriver
transform (NoteDeriver -> NoteDeriver)
-> (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Y -> NoteDeriver -> NoteDeriver
forall a. Y -> Deriver a -> Deriver a
Call.with_dynamic Y
with_dyn) Duration
grace_dur ControlRef
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 =
    Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF Note)
-> Generator Note
forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
module_ CallName
"grace" (Tags
Tags.ornament Tags -> Tags -> Tags
forall a. Semigroup a => a -> a -> a
<> Tags
Tags.ly) Doc
doc
    (WithArgDoc (GeneratorF Note) -> Generator Note)
-> WithArgDoc (GeneratorF Note) -> Generator Note
forall a b. (a -> b) -> a -> b
$ Parser ([Either Pitch (Typed Y)], (Duration, ControlRef))
-> (([Either Pitch (Typed Y)], (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 ((,)
    ([Either Pitch (Typed Y)]
 -> (Duration, ControlRef)
 -> ([Either Pitch (Typed Y)], (Duration, ControlRef)))
-> Parser [Either Pitch (Typed Y)]
-> Parser
     ((Duration, ControlRef)
      -> ([Either Pitch (Typed Y)], (Duration, ControlRef)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [Either Pitch (Typed Y)]
grace_pitches_arg Parser
  ((Duration, ControlRef)
   -> ([Either Pitch (Typed Y)], (Duration, ControlRef)))
-> Parser (Duration, ControlRef)
-> Parser ([Either Pitch (Typed Y)], (Duration, ControlRef))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Duration, ControlRef)
grace_envs
    ) ((([Either Pitch (Typed Y)], (Duration, ControlRef))
  -> GeneratorF Note)
 -> WithArgDoc (GeneratorF Note))
-> (([Either Pitch (Typed Y)], (Duration, ControlRef))
    -> GeneratorF Note)
-> WithArgDoc (GeneratorF Note)
forall a b. (a -> b) -> a -> b
$ \([Either Pitch (Typed Y)]
pitches, (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 -> do
        RealTime
start <- PassedArgs Note -> Deriver RealTime
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
        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
lily_grace PassedArgs Note
args RealTime
start [Pitch]
pitches) (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall a b. (a -> b) -> a -> b
$ do
            Pitch
here <- PassedArgs Note -> Deriver Pitch
forall a. PassedArgs a -> Deriver Pitch
Call.get_pitch_here PassedArgs Note
args
            [EventT Pitch]
notes <- PassedArgs Note
-> [Pitch] -> Duration -> ControlRef -> Deriver [EventT Pitch]
forall a note.
PassedArgs a
-> [note] -> Duration -> ControlRef -> Deriver [EventT note]
basic_grace PassedArgs Note
args ([Pitch]
pitches [Pitch] -> [Pitch] -> [Pitch]
forall a. [a] -> [a] -> [a]
++ [Pitch
here]) Duration
grace_dur ControlRef
place
            PassedArgs Note -> [EventT Pitch] -> NoteDeriver
derive PassedArgs Note
args [EventT Pitch]
notes

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

make_grace_notes :: Maybe ScoreTime -> (ScoreTime, ScoreTime) -- ^ (start, end)
    -> [note] -- ^ the last note is the destination
    -> DeriveT.Duration
    -> DeriveT.ControlRef -- ^ placement, see 'grace_place_doc'
    -> Derive.Deriver [SubT.EventT note]
make_grace_notes :: forall note.
Maybe ScoreTime
-> (ScoreTime, ScoreTime)
-> [note]
-> Duration
-> ControlRef
-> Deriver [EventT note]
make_grace_notes Maybe ScoreTime
prev (ScoreTime
start, ScoreTime
end) [note]
notes Duration
grace_dur ControlRef
place = do
    RealTime
real_start <- ScoreTime -> Deriver RealTime
forall a. Time a => a -> Deriver RealTime
Derive.real ScoreTime
start
    Y
place <- Y -> Y -> Y -> Y
forall a. Ord a => a -> a -> a -> a
Num.clamp Y
0 Y
1 (Y -> Y) -> Deriver State Error Y -> Deriver State Error Y
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ControlRef -> RealTime -> Deriver State Error Y
Call.control_at ControlRef
place RealTime
real_start
    case Duration
grace_dur of
        DeriveT.ScoreDuration ScoreTime
grace_dur -> do
            let extents :: [(ScoreTime, ScoreTime)]
extents = ScoreTime
-> Maybe ScoreTime
-> ScoreTime
-> ScoreTime
-> Int
-> ScoreTime
-> [(ScoreTime, ScoreTime)]
forall a.
(Fractional a, Ord a) =>
a -> Maybe a -> a -> a -> Int -> a -> [(a, a)]
fit_grace_durs (Y -> ScoreTime
ScoreTime.from_double Y
place)
                    Maybe ScoreTime
prev ScoreTime
start ScoreTime
end ([note] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [note]
notes) ScoreTime
grace_dur
            [EventT note] -> Deriver [EventT note]
forall (m :: * -> *) a. Monad m => a -> m a
return [ScoreTime -> ScoreTime -> note -> EventT note
forall a. ScoreTime -> ScoreTime -> a -> EventT a
SubT.EventT ScoreTime
s ScoreTime
d note
n | ((ScoreTime
s, ScoreTime
d), note
n) <- [(ScoreTime, ScoreTime)]
-> [note] -> [((ScoreTime, ScoreTime), note)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(ScoreTime, ScoreTime)]
extents [note]
notes]
        DeriveT.RealDuration RealTime
grace_dur -> do
            RealTime
real_end <- ScoreTime -> Deriver RealTime
forall a. Time a => a -> Deriver RealTime
Derive.real ScoreTime
end
            Maybe RealTime
real_prev <- Deriver State Error (Maybe RealTime)
-> (ScoreTime -> Deriver State Error (Maybe RealTime))
-> Maybe ScoreTime
-> Deriver State Error (Maybe RealTime)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe RealTime -> Deriver State Error (Maybe RealTime)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe RealTime
forall a. Maybe a
Nothing) ((RealTime -> Maybe RealTime
forall a. a -> Maybe a
Just <$>) (Deriver RealTime -> Deriver State Error (Maybe RealTime))
-> (ScoreTime -> Deriver RealTime)
-> ScoreTime
-> Deriver State Error (Maybe RealTime)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScoreTime -> Deriver RealTime
forall a. Time a => a -> Deriver RealTime
Derive.real) Maybe ScoreTime
prev
            let extents :: [(RealTime, RealTime)]
extents = RealTime
-> Maybe RealTime
-> RealTime
-> RealTime
-> Int
-> RealTime
-> [(RealTime, RealTime)]
forall a.
(Fractional a, Ord a) =>
a -> Maybe a -> a -> a -> Int -> a -> [(a, a)]
fit_grace_durs (Y -> RealTime
RealTime.seconds Y
place)
                    Maybe RealTime
real_prev RealTime
real_start RealTime
real_end ([note] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [note]
notes) RealTime
grace_dur
            ((RealTime, RealTime) -> note -> Deriver State Error (EventT note))
-> [(RealTime, RealTime)] -> [note] -> Deriver [EventT note]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (RealTime, RealTime) -> note -> Deriver State Error (EventT note)
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 <- a -> Deriver ScoreTime
forall a. Time a => a -> Deriver ScoreTime
Derive.score a
start
        ScoreTime
score_end <- a -> Deriver ScoreTime
forall a. Time a => a -> Deriver ScoreTime
Derive.score (a
start a -> a -> a
forall a. Num a => a -> a -> a
+ a
dur)
        EventT a -> Deriver State Error (EventT a)
forall (m :: * -> *) a. Monad m => a -> m a
return (EventT a -> Deriver State Error (EventT a))
-> EventT a -> Deriver State Error (EventT a)
forall a b. (a -> b) -> a -> b
$ ScoreTime -> ScoreTime -> a -> EventT a
forall a. ScoreTime -> ScoreTime -> a -> EventT a
SubT.EventT ScoreTime
score_start (ScoreTime
score_end ScoreTime -> ScoreTime -> ScoreTime
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 <- (Transposed -> Deriver State Error Text)
-> [Transposed] -> Deriver State Error [Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Environ -> Transposed -> Deriver State Error Text
Ly.pitch_to_lily Environ
env)
        ([Transposed] -> Deriver State Error [Text])
-> Deriver State Error [Transposed] -> Deriver State Error [Text]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Pitch -> Deriver State Error Transposed)
-> [Pitch] -> Deriver State Error [Transposed]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (RealTime -> Pitch -> Deriver State Error Transposed
Derive.resolve_pitch RealTime
start) [Pitch]
pitches
    let ly_notes :: [Text]
ly_notes = (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Duration -> Text
forall a. ToLily a => a -> Text
Lilypond.to_lily Duration
Lilypond.D8) [Text]
pitches
        beamed :: [Text]
beamed = (Text -> Text) -> (Text -> Text) -> [Text] -> [Text]
forall a. (a -> a) -> (a -> a) -> [a] -> [a]
Seq.first_last (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>Text
"[") (Text -> Text -> 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 { " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unwords [Text]
beamed Text -> Text -> Text
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) (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall a b. (a -> b) -> a -> b
$ PassedArgs d -> NoteDeriver -> NoteDeriver
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 =
    Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF Note)
-> Generator Note
forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
Module.instrument CallName
"grace" (Tags
Tags.ornament Tags -> Tags -> Tags
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: "
    Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
Doc.commas ((Attributes -> Doc) -> [Attributes] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Attributes -> Doc
forall a. ShowVal a => a -> Doc
ShowVal.doc (Map Int Attributes -> [Attributes]
forall k a. Map k a -> [a]
Map.elems Map Int Attributes
supported))
    ) (WithArgDoc (GeneratorF Note) -> Generator Note)
-> WithArgDoc (GeneratorF Note) -> Generator Note
forall a b. (a -> b) -> a -> b
$ Parser
  ([Either Pitch (Typed Y)], Y, (Duration, ControlRef),
   Maybe Attributes)
-> (([Either Pitch (Typed Y)], Y, (Duration, ControlRef),
     Maybe Attributes)
    -> 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 Y)]
 -> Y
 -> (Duration, ControlRef)
 -> Maybe Attributes
 -> ([Either Pitch (Typed Y)], Y, (Duration, ControlRef),
     Maybe Attributes))
-> Parser [Either Pitch (Typed Y)]
-> Parser
     (Y
      -> (Duration, ControlRef)
      -> Maybe Attributes
      -> ([Either Pitch (Typed Y)], Y, (Duration, ControlRef),
          Maybe Attributes))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [Either Pitch (Typed Y)]
grace_pitches_arg Parser
  (Y
   -> (Duration, ControlRef)
   -> Maybe Attributes
   -> ([Either Pitch (Typed Y)], Y, (Duration, ControlRef),
       Maybe Attributes))
-> Parser Y
-> Parser
     ((Duration, ControlRef)
      -> Maybe Attributes
      -> ([Either Pitch (Typed Y)], Y, (Duration, ControlRef),
          Maybe Attributes))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Y
grace_dyn_env Parser
  ((Duration, ControlRef)
   -> Maybe Attributes
   -> ([Either Pitch (Typed Y)], Y, (Duration, ControlRef),
       Maybe Attributes))
-> Parser (Duration, ControlRef)
-> Parser
     (Maybe Attributes
      -> ([Either Pitch (Typed Y)], Y, (Duration, ControlRef),
          Maybe Attributes))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Duration, ControlRef)
grace_envs
    Parser
  (Maybe Attributes
   -> ([Either Pitch (Typed Y)], Y, (Duration, ControlRef),
       Maybe Attributes))
-> Parser (Maybe Attributes)
-> Parser
     ([Either Pitch (Typed Y)], Y, (Duration, ControlRef),
      Maybe Attributes)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ArgName
-> EnvironDefault
-> Maybe Attributes
-> Doc
-> Parser (Maybe Attributes)
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> EnvironDefault -> a -> Doc -> Parser a
Sig.environ ArgName
"attr" EnvironDefault
Sig.Prefixed Maybe Attributes
forall a. Maybe a
Nothing
        Doc
"If given, put this attr on the grace notes. Otherwise, pick a grace\
        \ note from the support list."
    ) ((([Either Pitch (Typed Y)], Y, (Duration, ControlRef),
   Maybe Attributes)
  -> GeneratorF Note)
 -> WithArgDoc (GeneratorF Note))
-> (([Either Pitch (Typed Y)], Y, (Duration, ControlRef),
     Maybe Attributes)
    -> GeneratorF Note)
-> WithArgDoc (GeneratorF Note)
forall a b. (a -> b) -> a -> b
$ \([Either Pitch (Typed Y)]
pitches, Y
dyn, (Duration
grace_dur, ControlRef
place), Maybe Attributes
attr) -> 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 RealTime
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
        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
lily_grace PassedArgs Note
args RealTime
start [Pitch]
pitches) (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall a b. (a -> b) -> a -> b
$ case Maybe Attributes
attr of
            Just Attributes
attr -> Attributes -> NoteDeriver -> NoteDeriver
forall d. Attributes -> Deriver d -> Deriver d
Call.add_attributes Attributes
attr (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall a b. (a -> b) -> a -> b
$
                Y
-> PassedArgs Note
-> [Pitch]
-> Duration
-> ControlRef
-> NoteDeriver
forall a.
Y
-> PassedArgs a -> [Pitch] -> Duration -> ControlRef -> NoteDeriver
basic_grace_dyn Y
dyn PassedArgs Note
args [Pitch]
pitches Duration
grace_dur ControlRef
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 -> RealTime
-> PassedArgs Note -> Duration -> Int -> Attributes -> NoteDeriver
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
                        ([Pitch] -> Int
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 -> ControlRef -> NoteDeriver
legato_grace PassedArgs Note
args Y
dyn [Pitch]
pitches Duration
grace_dur ControlRef
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) = PassedArgs a -> (ScoreTime, ScoreTime)
forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.extent PassedArgs a
args
        ScoreTime
grace_dur <- ScoreTime -> t2 -> Deriver ScoreTime
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 = p -> ScoreTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral p
notes ScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
* ScoreTime
grace_dur
        Pitch
pitch <- RealTime -> Deriver Pitch
Call.get_pitch RealTime
real_start
        ScoreTime -> ScoreTime -> NoteDeriver -> NoteDeriver
forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a
Derive.place (ScoreTime
start ScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
- ScoreTime
before) (ScoreTime
dur ScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
+ ScoreTime
before) (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall a b. (a -> b) -> a -> b
$
            Attributes -> NoteDeriver -> NoteDeriver
forall d. Attributes -> Deriver d -> Deriver d
Call.add_attributes Attributes
attrs (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
forall a b. (a -> b) -> a -> b
$ Y -> NoteDeriver -> NoteDeriver
forall a. Y -> Deriver a -> Deriver a
Call.with_dynamic Y
dyn (NoteDeriver -> NoteDeriver) -> NoteDeriver -> NoteDeriver
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
    Maybe Attributes -> Deriver (Maybe Attributes)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Attributes -> Deriver (Maybe Attributes))
-> Maybe Attributes -> Deriver (Maybe Attributes)
forall a b. (a -> b) -> a -> b
$ Int -> Map Int Attributes -> Maybe Attributes
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (NoteNumber -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round NoteNumber
diff) Map Int Attributes
supported
grace_attributes RealTime
_ Map Int Attributes
_ [Pitch]
_ Pitch
_ = Maybe Attributes -> Deriver (Maybe Attributes)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Attributes
forall a. Maybe a
Nothing

-- * util

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

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

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

basic_grace :: Derive.PassedArgs a -> [note]
    -> DeriveT.Duration -> DeriveT.ControlRef
    -> Derive.Deriver [SubT.EventT note]
basic_grace :: forall a note.
PassedArgs a
-> [note] -> Duration -> ControlRef -> Deriver [EventT note]
basic_grace PassedArgs a
args [note]
pitches =
    Maybe ScoreTime
-> (ScoreTime, ScoreTime)
-> [note]
-> Duration
-> ControlRef
-> Deriver [EventT note]
forall note.
Maybe ScoreTime
-> (ScoreTime, ScoreTime)
-> [note]
-> Duration
-> ControlRef
-> Deriver [EventT note]
make_grace_notes (PassedArgs a -> Maybe ScoreTime
forall a. PassedArgs a -> Maybe ScoreTime
Args.prev_start PassedArgs a
args) (PassedArgs a -> (ScoreTime, ScoreTime)
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) => a -> Maybe a -> a -> a -> Int -> a
    -> [(a, a)]
fit_grace_durs :: forall a.
(Fractional a, Ord a) =>
a -> Maybe a -> a -> a -> Int -> a -> [(a, a)]
fit_grace_durs a
place Maybe a
prev a
start a
end Int
notes a
dur =
    ((a, Maybe a) -> (a, a)) -> [(a, Maybe a)] -> [(a, a)]
forall a b. (a -> b) -> [a] -> [b]
map (a, Maybe a) -> (a, a)
add_dur ([(a, Maybe a)] -> [(a, a)]) -> [(a, Maybe a)] -> [(a, a)]
forall a b. (a -> b) -> a -> b
$ [a] -> [(a, Maybe a)]
forall a. [a] -> [(a, Maybe a)]
Seq.zip_next ([a] -> [(a, Maybe a)]) -> [a] -> [(a, Maybe a)]
forall a b. (a -> b) -> a -> b
$ a -> Maybe a -> a -> a -> Int -> a -> [a]
forall a.
(Fractional a, Ord a) =>
a -> Maybe a -> a -> a -> Int -> a -> [a]
fit_grace a
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 a -> a -> a
forall a. Num a => a -> a -> a
- a
x)
    add_dur (a
x, Just a
next) = (a
x, a
next a -> a -> a
forall a. Num a => a -> a -> a
- a
x)

fit_grace :: (Fractional a, Ord a) => a -- ^ placement, see 'grace_place_doc'
    -> Maybe a -> a -> a -> Int -> a -> [a]
fit_grace :: forall a.
(Fractional a, Ord a) =>
a -> Maybe a -> a -> a -> Int -> a -> [a]
fit_grace a
place Maybe a
maybe_prev a
start a
end Int
notes a
dur
    | a
place a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
0 = [a]
before
    | a
place a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
1 = [a]
after
    | Bool
otherwise = (a -> a -> a) -> [a] -> [a] -> [a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\a
x a
y -> a -> a -> a -> a
forall a. (Eq a, Num a) => a -> a -> a -> a
Num.scale a
x a
y a
place) [a]
before [a]
after
    where
    after :: [a]
after = a -> a -> Int -> a -> [a]
forall a. (Fractional a, Ord a) => a -> a -> Int -> a -> [a]
fit_after a
start a
end Int
notes a
dur
    before :: [a]
before = Maybe a -> a -> Int -> a -> [a]
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 =
    Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
notes ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
1 ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ a -> a -> [a]
forall a. Num a => a -> a -> [a]
Seq.range_ (a
start a -> a -> a
forall a. Num a => a -> a -> a
- a
notes_t a -> a -> a
forall a. Num a => a -> a -> a
* a
step) a
step
    where
    notes_t :: a
notes_t = Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
notes
    step :: a
step
        | Just a
prev <- Maybe a
maybe_prev, a
start a -> a -> a
forall a. Num a => a -> a -> a
- a
dur a -> a -> a
forall a. Num a => a -> a -> a
* a
notes_t a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
prev =
            (a
start a -> a -> a
forall a. Num a => a -> a -> a
- a
prev) a -> a -> a
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 = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
notes ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ a -> a -> [a]
forall a. Num a => a -> a -> [a]
Seq.range_ a
start a
step
    where
    notes_t :: a
notes_t = Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
notes
    step :: a
step
        | a
dur a -> a -> a
forall a. Num a => a -> a -> a
* a
notes_t a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
end a -> a -> a
forall a. Num a => a -> a -> a
- a
start = (a
end a -> a -> a
forall a. Num a => a -> a -> a
- a
start) a -> a -> a
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 = (Text -> Deriver [Pitch])
-> ([Pitch] -> Deriver [Pitch])
-> Either Text [Pitch]
-> Deriver [Pitch]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Deriver [Pitch]
forall a. HasCallStack => Text -> Deriver a
Derive.throw [Pitch] -> Deriver [Pitch]
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text [Pitch] -> Deriver [Pitch])
-> ([Either Pitch (Typed Y)] -> Either Text [Pitch])
-> [Either Pitch (Typed Y)]
-> Deriver [Pitch]
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 (Typed Y -> Type) -> [Typed Y] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Typed Y -> Type
forall a. Typed a -> Type
ScoreT.type_of ([Typed Y] -> [Type]) -> [Typed Y] -> [Type]
forall a b. (a -> b) -> a -> b
$ [Either Pitch (Typed Y)] -> [Typed Y]
forall a b. [Either a b] -> [b]
Either.rights [Either Pitch (Typed Y)]
pitches of
        Type
t_ : [Type]
ts_
            | (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
==Type
t) [Type]
ts -> case Type
t of
                Type
ScoreT.Diatonic -> (Y -> Transpose) -> Either Text (Y -> Transpose)
forall a b. b -> Either a b
Right Y -> Transpose
Pitch.Diatonic
                Type
ScoreT.Chromatic -> (Y -> Transpose) -> Either Text (Y -> Transpose)
forall a b. b -> Either a b
Right Y -> Transpose
Pitch.Chromatic
                Type
ScoreT.Nn -> (Y -> Transpose) -> Either Text (Y -> Transpose)
forall a b. b -> Either a b
Right Y -> Transpose
Pitch.Nn
                Type
_ -> Text -> Either Text (Y -> Transpose)
forall a b. a -> Either a b
Left (Text -> Either Text (Y -> Transpose))
-> Text -> Either Text (Y -> Transpose)
forall a b. (a -> b) -> a -> b
$ Text
"expected transpose type, but got " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Type -> Text
forall a. Pretty a => a -> Text
pretty Type
t
            | Bool
otherwise ->
                Text -> Either Text (Y -> Transpose)
forall a b. a -> Either a b
Left (Text -> Either Text (Y -> Transpose))
-> Text -> Either Text (Y -> Transpose)
forall a b. (a -> b) -> a -> b
$ Text
"arguments should all have the same type, got "
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Type] -> Text
forall a. Pretty a => a -> Text
pretty (Type
tType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
ts)
            where
            t :: Type
t = Type -> Type -> Type
deflt Type
ScoreT.Diatonic Type
t_
            ts :: [Type]
ts = (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Type -> Type
deflt Type
t) [Type]
ts_
        [] -> (Y -> Transpose) -> Either Text (Y -> Transpose)
forall a b. b -> Either a b
Right Y -> Transpose
Pitch.Diatonic
    [Pitch] -> Either Text [Pitch]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Pitch] -> Either Text [Pitch]) -> [Pitch] -> Either Text [Pitch]
forall a b. (a -> b) -> a -> b
$ (Either Pitch (Typed Y) -> Pitch)
-> [Either Pitch (Typed Y)] -> [Pitch]
forall a b. (a -> b) -> [a] -> [b]
map ((Pitch -> Pitch)
-> (Typed Y -> Pitch) -> Either Pitch (Typed Y) -> Pitch
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Pitch -> Pitch
forall a. a -> a
id ((Y -> Transpose) -> Y -> Pitch
forall {t}. (t -> Transpose) -> t -> Pitch
resolve Y -> Transpose
make (Y -> Pitch) -> (Typed Y -> Y) -> Typed Y -> Pitch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Typed Y -> Y
forall a. Typed a -> a
ScoreT.typed_val)) [Either Pitch (Typed Y)]
pitches
    where
    resolve :: (t -> Transpose) -> t -> Pitch
resolve t -> Transpose
make t
n = Transpose -> Pitch -> Pitch
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