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

-- | Ornaments for gender.  The unique thing about gender technique is the
-- delayed damping, so these calls deal with delayed damping.
module Derive.C.Bali.Gender (
    library, ngoret_variations
    , interval_arg, ngoret, c_realize_ngoret, realize_ngoret
    , weak, weak_call
) where
import qualified Util.Log as Log
import qualified Util.Lists as Lists
import qualified Derive.Args as Args
import qualified Derive.Call as Call
import qualified Derive.Call.Module as Module
import qualified Derive.Call.Post as Post
import qualified Derive.Call.Sub as Sub
import qualified Derive.Call.Tags as Tags
import qualified Derive.Controls as Controls
import qualified Derive.Derive as Derive
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Expr as Expr
import qualified Derive.Flags as Flags
import qualified Derive.Library as Library
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.Stream as Stream
import qualified Derive.Typecheck as Typecheck

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

import           Global
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 forall a b. (a -> b) -> a -> b
$
        ((Symbol
"weak", Generator Note
c_weak) forall a. a -> [a] -> [a]
: forall call. (Parser (Maybe Transpose) -> call) -> [(Symbol, call)]
ngoret_variations Parser (Maybe Transpose) -> Generator Note
gender_ngoret)
    , forall call.
ToLibrary (Transformer call) =>
[(Symbol, Transformer call)] -> Library
Library.transformers
        [ (Symbol
"realize-ngoret", Transformer Note
c_realize_ngoret)
        , (Symbol
"infer-damp-simple", Transformer Note
c_infer_damp_simple)
        ]
    ]

ngoret_variations :: (Sig.Parser (Maybe Pitch.Transpose) -> call)
    -> [(Expr.Symbol, call)]
ngoret_variations :: forall call. (Parser (Maybe Transpose) -> call) -> [(Symbol, call)]
ngoret_variations Parser (Maybe Transpose) -> call
make =
    [ (Symbol
"'", Parser (Maybe Transpose) -> call
make forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing)
    , (Symbol
"'n", Parser (Maybe Transpose) -> call
make forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Transpose
interval_arg)
    , (Symbol
"'^", Parser (Maybe Transpose) -> call
make forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Double -> Transpose
Pitch.Diatonic (-Double
1))
    , (Symbol
"'-", Parser (Maybe Transpose) -> call
make forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Double -> Transpose
Pitch.Diatonic Double
0)
    , (Symbol
"'_", Parser (Maybe Transpose) -> call
make forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Double -> Transpose
Pitch.Diatonic Double
1)
    ]

module_ :: Module.Module
module_ :: Module
module_ = Module
"bali" forall a. Semigroup a => a -> a -> a
<> Module
"gender"

-- * ngoret

gender_ngoret :: Sig.Parser (Maybe Pitch.Transpose)
    -> Derive.Generator Derive.Note
gender_ngoret :: Parser (Maybe Transpose) -> Generator Note
gender_ngoret = Module
-> Bool
-> Parser RealTimeFunction
-> Parser (Maybe Transpose)
-> Generator Note
ngoret Module
module_ Bool
True Parser RealTimeFunction
damp_arg
    where
    damp_arg :: Parser RealTimeFunction
damp_arg = forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"damp" (RealTime
0.5 :: RealTime)
        Doc
"Time that the grace note overlaps with this one. So the total\
        \ duration is time+damp, though it will be clipped to the\
        \ end of the current note."

interval_arg :: Sig.Parser Pitch.Transpose
interval_arg :: Parser Transpose
interval_arg = DefaultDiatonic -> Transpose
Typecheck.default_diatonic forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"interval"
    Doc
"The grace note is this interval from the destination pitch."

-- | Other instruments also have ngoret, but without gender's special damping
-- behaviour.
ngoret :: Module.Module -> Bool
    -- ^ Extend the previous note's duration to the end of the grace note.
    -> Sig.Parser Typecheck.RealTimeFunction
    -- ^ Time grace note overlaps with this one.
    -> Sig.Parser (Maybe Pitch.Transpose)
    -> Derive.Generator Derive.Note
ngoret :: Module
-> Bool
-> Parser RealTimeFunction
-> Parser (Maybe Transpose)
-> Generator Note
ngoret Module
module_ Bool
late_damping Parser RealTimeFunction
damp_arg Parser (Maybe Transpose)
interval_arg =
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
module_ CallName
"ngoret"
    (Tags
Tags.inst forall a. Semigroup a => a -> a -> a
<> Tags
Tags.ornament forall a. Semigroup a => a -> a -> a
<> Tags
Tags.requires_postproc)
    (Doc
"Insert an intermediate grace note in the \"ngoret\" style.\
    \ The grace note moves up for `'^`, down for `'_`, or is based\
    \ on the previous note's pitch for `'`.\
    \\nThis requires the `realize-ngoret` postproc."
    ) 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 (Maybe Transpose)
interval_arg
    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" (Double
0.1 :: Double)
        Doc
"Time between the grace note start and the main note. If there isn't\
        \ enough room after the previous note, it will be halfway between\
        \ the previous note and this one."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser RealTimeFunction
damp_arg
    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.75 :: Double)
        Doc
"The grace note's dyn will be this multiplier of the current dyn."
    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
"damp-threshold" EnvironDefault
Sig.Prefixed  (Double
0.15 :: Double)
        Doc
"A grace note with this much time will cause the previous note to be\
        \ shortened to not overlap. Under the threshold, and the damping of\
        \ the previous note will be delayed until the end of the grace note."
    ) forall a b. (a -> b) -> a -> b
$ \(Maybe Transpose
maybe_interval
        , Typecheck.RealTimeFunction RealTime -> Duration
time
        , Typecheck.RealTimeFunction RealTime -> Duration
damp
        , Double
dyn_scale
        , RealTime
damp_threshold
        ) PassedArgs Note
args ->
    forall d.
PassedArgs d
-> (PassedArgs d -> Deriver State Error (Stream Note))
-> Deriver State Error (Stream Note)
Sub.inverting_args PassedArgs Note
args 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
        RealTime
time <- forall a. Time a => a -> Deriver RealTime
Derive.real (RealTime -> Duration
time RealTime
start)
        RealTime
damp <- forall a. Time a => a -> Deriver RealTime
Derive.real (RealTime -> Duration
damp RealTime
start)
        Maybe (RawPitch Untransposed_)
maybe_pitch <- case Maybe Transpose
maybe_interval of
            Maybe Transpose
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            Just Transpose
transpose ->
                forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Transpose -> RawPitch a -> RawPitch a
Pitches.transpose Transpose
transpose forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RealTime -> Deriver (RawPitch Untransposed_)
Call.get_pitch RealTime
start
        Double
dyn <- (forall a. Num a => a -> a -> a
*Double
dyn_scale) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RealTime -> Deriver State Error Double
Call.dynamic RealTime
start

        ScoreTime
grace_start <- forall a. Time a => a -> Deriver ScoreTime
Derive.score (RealTime
start forall a. Num a => a -> a -> a
- RealTime
time)
        -- If there isn't room for the grace note, use the midpoint between the
        -- prev note and this one.
        ScoreTime
grace_start <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case forall a. PassedArgs a -> Maybe ScoreTime
Args.prev_start PassedArgs Note
args of
            Maybe ScoreTime
Nothing -> ScoreTime
grace_start
            Just ScoreTime
prev -> forall a. Ord a => a -> a -> a
max ScoreTime
grace_start forall a b. (a -> b) -> a -> b
$ (ScoreTime
prev forall a. Num a => a -> a -> a
+ forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs Note
args) forall a. Fractional a => a -> a -> a
/ ScoreTime
2
        RealTime
real_grace_start <- forall a. Time a => a -> Deriver RealTime
Derive.real ScoreTime
grace_start
        let with_flags :: Deriver State Error (Stream Note)
-> Deriver State Error (Stream Note)
with_flags
                | Bool
late_damping Bool -> Bool -> Bool
&& Bool
prev_touches = Flags
-> Deriver State Error (Stream Note)
-> Deriver State Error (Stream Note)
Call.add_flags forall a b. (a -> b) -> a -> b
$
                    if RealTime
start forall a. Num a => a -> a -> a
- RealTime
real_grace_start forall a. Ord a => a -> a -> Bool
< RealTime
damp_threshold
                        then Flags
extend_previous else Flags
shorten_previous
                | Bool
otherwise = forall a. a -> a
id
            prev_touches :: Bool
prev_touches = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (forall a. Ord a => a -> a -> Bool
>= forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs Note
args) (forall a. PassedArgs a -> Maybe ScoreTime
Args.prev_end PassedArgs Note
args)
        ScoreTime
overlap <- forall t1 t2. (Time t1, Time t2) => t1 -> t2 -> Deriver ScoreTime
Call.score_duration (forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs Note
args) RealTime
damp
        let grace_end :: ScoreTime
grace_end = forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs Note
args forall a. Num a => a -> a -> a
+ ScoreTime
overlap
            grace_note :: Deriver State Error (Stream Note)
grace_note = case Maybe (RawPitch Untransposed_)
maybe_pitch of
                Maybe (RawPitch Untransposed_)
Nothing -> Flags
-> Deriver State Error (Stream Note)
-> Deriver State Error (Stream Note)
Call.add_flags Flags
infer_pitch_flag Deriver State Error (Stream Note)
Call.note
                Just RawPitch Untransposed_
pitch -> RawPitch Untransposed_ -> Deriver State Error (Stream Note)
Call.pitched_note RawPitch Untransposed_
pitch
        forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a
Derive.place ScoreTime
grace_start (ScoreTime
grace_end forall a. Num a => a -> a -> a
- ScoreTime
grace_start)
                (Deriver State Error (Stream Note)
-> Deriver State Error (Stream Note)
with_flags forall a b. (a -> b) -> a -> b
$ forall a. Double -> Deriver a -> Deriver a
Call.with_dynamic Double
dyn Deriver State Error (Stream Note)
grace_note)
            forall a. Semigroup a => a -> a -> a
<> forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a
Derive.place (forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs Note
args) (forall a. PassedArgs a -> ScoreTime
Args.duration PassedArgs Note
args) Deriver State Error (Stream Note)
Call.note

-- ** realize

c_realize_ngoret :: Derive.Transformer Derive.Note
c_realize_ngoret :: Transformer Note
c_realize_ngoret = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
module_ CallName
"realize-ngoret"
    (Tags
Tags.inst forall a. Semigroup a => a -> a -> a
<> Tags
Tags.postproc)
    (Doc
"Realize pitches and positions emited by the `ngoret` call.\
    \ This is necessary because it needs to know the positions and pitches\
    \ of the previous and next notes, and those aren't necessarily available\
    \ when evaluating the track. This call needs a "
    forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Text
EnvKey.hand forall a. Semigroup a => a -> a -> a
<> Doc
" envron to figure out which which note\
    \ follows which."
    ) forall a b. (a -> b) -> a -> b
$ forall y d.
Taggable y =>
Transformer y d -> WithArgDoc (Transformer y d)
Sig.call0t forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
_ Deriver State Error (Stream Note)
deriver -> Stream Note -> Deriver State Error (Stream Note)
realize_ngoret forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Deriver State Error (Stream Note)
deriver

realize_ngoret :: Stream.Stream Score.Event -> Derive.NoteDeriver
realize_ngoret :: Stream Note -> Deriver State Error (Stream Note)
realize_ngoret =
    forall (f :: * -> *) a b.
Functor f =>
([a] -> f [b]) -> Stream a -> f (Stream b)
Post.apply_m forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Note]] -> [Note]
merge forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM [Note] -> Deriver State Error [Note]
realize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key a. Ord key => (a -> key) -> [a] -> [[a]]
Lists.groupSort Note -> (Instrument, Maybe Text)
Post.hand_key
    where
    -- TODO do I want to ignore streams with irrelevant instruments?
    realize :: [Note] -> Deriver State Error [Note]
realize = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Note -> Maybe Note -> Note
realize_damped) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [(a, Maybe a)]
Lists.zipNext)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {b}.
(Maybe Note -> Note -> Maybe Note -> Either Text b)
-> [Note] -> Deriver State Error [b]
apply Maybe Note -> Note -> Maybe Note -> Either Text Note
realize_infer_pitch
    apply :: (Maybe Note -> Note -> Maybe Note -> Either Text b)
-> [Note] -> Deriver State Error [b]
apply Maybe Note -> Note -> Maybe Note -> Either Text b
f = forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (forall {t} {t} {a}.
(t -> Note -> t -> Either Text a)
-> (t, Note, t) -> Deriver State Error (Maybe a)
apply1 Maybe Note -> Note -> Maybe Note -> Either Text b
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [(Maybe a, a, Maybe a)]
Lists.zipNeighbors
        where
        apply1 :: (t -> Note -> t -> Either Text a)
-> (t, Note, t) -> Deriver State Error (Maybe a)
apply1 t -> Note -> t -> Either Text a
f (t
prev, Note
event, t
next) = case t -> Note -> t -> Either Text a
f t
prev Note
event t
next of
            Right a
event -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just a
event
            Left Text
err -> do
                forall a. Note -> Deriver a -> Deriver a
Derive.with_event_stack Note
event forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn Text
err
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    merge :: [[Note]] -> [Note]
merge = forall k a. Ord k => (a -> k) -> [[a]] -> [a]
Lists.mergeLists Note -> RealTime
Score.event_start

realize_infer_pitch :: Maybe Score.Event -> Score.Event
    -> Maybe Score.Event -> Either Text Score.Event
realize_infer_pitch :: Maybe Note -> Note -> Maybe Note -> Either Text Note
realize_infer_pitch Maybe Note
maybe_prev Note
event Maybe Note
maybe_next
    | Flags -> Note -> Bool
Score.has_flags Flags
infer_pitch_flag Note
event = do
        Note
prev <- forall {a} {b}. a -> Maybe b -> Either a b
require Text
"no previous event" Maybe Note
maybe_prev
        Note
next <- forall {a} {b}. a -> Maybe b -> Either a b
require Text
"no next event" Maybe Note
maybe_next
        RawPitch Untransposed_
pitch <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text
"can't infer pitch: "<>) forall a b. (a -> b) -> a -> b
$ Note -> Note -> Either Text (RawPitch Untransposed_)
infer_pitch Note
prev Note
next
        -- Also make sure the grace note doesn't go past the end of the next
        -- note.
        let dur :: RealTime
dur = forall a. Ord a => a -> a -> a
min (Note -> RealTime
Score.event_duration Note
event)
                (Note -> RealTime
Score.event_end Note
next forall a. Num a => a -> a -> a
- Note -> RealTime
Score.event_start Note
event)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Flags -> Note -> Note
Score.remove_flags Flags
infer_pitch_flag forall a b. (a -> b) -> a -> b
$ RealTime -> Note -> Note
Score.set_duration RealTime
dur forall a b. (a -> b) -> a -> b
$
            Pitch -> Note -> Note
Score.set_pitch (RawPitch Untransposed_ -> Pitch
PSignal.constant RawPitch Untransposed_
pitch) Note
event
    | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return Note
event
    where require :: a -> Maybe b -> Either a b
require a
err = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left a
err) forall (m :: * -> *) a. Monad m => a -> m a
return

realize_damped :: Score.Event -> Maybe Score.Event -> Score.Event
realize_damped :: Note -> Maybe Note -> Note
realize_damped Note
event Maybe Note
maybe_next =
    Flags -> Note -> Note
Score.remove_flags (Flags
extend_previous forall a. Semigroup a => a -> a -> a
<> Flags
shorten_previous) forall a b. (a -> b) -> a -> b
$
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id Note -> Note -> Note
set_dur Maybe Note
maybe_next Note
event
    where
    set_dur :: Note -> Note -> Note
set_dur Note
next
        | Flags -> Note -> Bool
Score.has_flags Flags
extend_previous Note
next =
            RealTime -> Note -> Note
Score.set_duration (Note -> RealTime
Score.event_end Note
next forall a. Num a => a -> a -> a
- RealTime
start)
        | Flags -> Note -> Bool
Score.has_flags Flags
shorten_previous Note
next =
            RealTime -> Note -> Note
Score.set_duration (Note -> RealTime
Score.event_start Note
next forall a. Num a => a -> a -> a
- RealTime
start)
        | Bool
otherwise = forall a. a -> a
id
        where start :: RealTime
start = Note -> RealTime
Score.event_start Note
event

infer_pitch :: Score.Event -> Score.Event -> Either Text PSignal.Pitch
infer_pitch :: Note -> Note -> Either Text (RawPitch Untransposed_)
infer_pitch Note
prev Note
next = do
    NoteNumber
prev_nn <- forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
tryJust (Text
"no prev nn: " forall a. Semigroup a => a -> a -> a
<> Note -> Text
Score.short_event Note
prev) forall a b. (a -> b) -> a -> b
$
        Note -> Maybe NoteNumber
Score.initial_nn Note
prev
    NoteNumber
next_nn <- forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
tryJust (Text
"no next nn: " forall a. Semigroup a => a -> a -> a
<> Note -> Text
Score.short_event Note
next) forall a b. (a -> b) -> a -> b
$
        Note -> Maybe NoteNumber
Score.initial_nn Note
next
    let steps :: Step
steps
            | NoteNumber
prev_nn forall a. Eq a => a -> a -> Bool
== NoteNumber
next_nn = Step
0
            | NoteNumber
prev_nn forall a. Ord a => a -> a -> Bool
< NoteNumber
next_nn = -Step
1
            | Bool
otherwise = Step
1
    forall a. Step -> RawPitch a -> RawPitch a
Pitches.transpose_d Step
steps forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
tryJust (Text
"no pitch at " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (Note -> RealTime
Score.event_start Note
next))
            (RealTime -> Note -> Maybe (RawPitch Untransposed_)
Score.pitch_at (Note -> RealTime
Score.event_start Note
next) Note
next)

-- | Mark events whose should have their pitch inferred from the previous and
-- next events.
infer_pitch_flag :: Flags.Flags
infer_pitch_flag :: Flags
infer_pitch_flag = Text -> Flags
Flags.flag Text
"infer-pitch"

-- | Mark grace notes that were damped late, and whose previous event should be
-- extended to be damped together.
extend_previous :: Flags.Flags
extend_previous :: Flags
extend_previous = Text -> Flags
Flags.flag Text
"extend-previous-duration"

-- | Mark grace notes that don't cause a late damp.  The previous event's
-- duration should be shortened to end where the grace note begins.
shorten_previous :: Flags.Flags
shorten_previous :: Flags
shorten_previous = Text -> Flags
Flags.flag Text
"shorten-previous-duration"

-- * weak

c_weak :: Derive.Generator Derive.Note
c_weak :: Generator Note
c_weak = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
module_ CallName
"weak" Tags
Tags.inst
    Doc
"Weak notes are filler notes."
    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 a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.defaulted_env ArgName
"strength" EnvironDefault
Derive.Unprefixed (Double
0.5 :: Double)
        Doc
"From low strength to high, omit the note, then play it muted, and\
        \ then play it open but softly."
    ) forall a b. (a -> b) -> a -> b
$ \Double
strength -> forall d.
(PassedArgs d -> Deriver State Error (Stream Note))
-> PassedArgs d -> Deriver State Error (Stream Note)
Sub.inverting (forall a.
Double -> PassedArgs a -> Deriver State Error (Stream Note)
weak Double
strength)

weak :: Signal.Y -> Derive.PassedArgs a -> Derive.NoteDeriver
weak :: forall a.
Double -> PassedArgs a -> Deriver State Error (Stream Note)
weak Double
strength PassedArgs a
args = do
    -- This biases mute values to be lower, and 0 before it unmutes.
    let mute :: Double
mute = forall a. Ord a => a -> a -> a
max Double
0 forall a b. (a -> b) -> a -> b
$ Double
1 forall a. Num a => a -> a -> a
- (Double
strength forall a. Num a => a -> a -> a
+ (Double
1 forall a. Num a => a -> a -> a
- Double
unmute_threshold))
    if Double
strength forall a. Ord a => a -> a -> Bool
<= Double
omit_threshold then forall a. Monoid a => a
mempty
        else forall a. Control -> Double -> Deriver a -> Deriver a
Call.with_constant Control
Controls.mute Double
mute forall a b. (a -> b) -> a -> b
$ forall d. PassedArgs d -> Deriver State Error (Stream Note)
Call.placed_note PassedArgs a
args
    where
    omit_threshold :: Double
omit_threshold = Double
0.25
    unmute_threshold :: Double
unmute_threshold = Double
0.75

weak_call :: Derive.PassedArgs a -> Derive.NoteDeriver
weak_call :: forall d. PassedArgs d -> Deriver State Error (Stream Note)
weak_call PassedArgs a
args = do
    -- TODO This is nonstandard, because usually signals are resolved
    -- implicitly as arguments.  But DUtil.zero_duration doesn't really plug
    -- into Sig.call.  Maybe it should reapply `weak` instead of calling it
    -- directly?  In any case, I think the result should be the same.
    Double
strength <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Double
0.5 forall a. Typed a -> a
ScoreT.val_of) forall a b. (a -> b) -> a -> b
$
        Control -> RealTime -> Deriver State Error (Maybe (Typed Double))
Derive.control_at Control
"strength" 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
    forall a.
Double -> PassedArgs a -> Deriver State Error (Stream Note)
weak Double
strength (forall a. ScoreTime -> PassedArgs a -> PassedArgs a
Args.set_duration ScoreTime
dur PassedArgs a
args)
    where dur :: ScoreTime
dur = forall a. PassedArgs a -> ScoreTime
Args.next PassedArgs a
args forall a. Num a => a -> a -> a
- forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs a
args

-- * im

-- ** infer damp

{- |
    Simple version:
    - Any note immediately followed by the same pitch gets its duration
    extended to the end of the last note with the same pitch.

    Fancy version:
    - All notes ring until explicitly damped.
    - A gap between notes in the same hand adds a damp.  A pitch followed by a
    different one in the same hand adds a damp to the first.
    - The hand requires time to actually do the damp.  Adjacent pitches by 1 or
    2 can be simultaneous.  Otherwise, you need a certain amount of time when
    that hand is not busy damping.
-}
c_infer_damp_simple :: Derive.Transformer Derive.Note
c_infer_damp_simple :: Transformer Note
c_infer_damp_simple =
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer (Module
module_ forall a. Semigroup a => a -> a -> a
<> Module
"im") CallName
"infer-damp-simple" Tags
Tags.postproc
    (Doc
"Simple gender damping. Duration is extended if the next note on the same\
    \ hand has the same pitch and the gap is < " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc RealTime
gap forall a. Semigroup a => a -> a -> a
<> Doc
".")
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Transformer y d) -> WithArgDoc (Transformer y d)
Sig.callt (forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"insts" Doc
"Apply damping to these instruments.")
    forall a b. (a -> b) -> a -> b
$ \[Instrument]
insts PassedArgs Note
_args ->
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> Stream a -> Stream b
Post.emap1_ ([Instrument] -> (Note, [Note]) -> Note
infer [Instrument]
insts) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key a. Eq key => (a -> key) -> Stream a -> Stream (a, [a])
Post.nexts_by Note -> (Instrument, Maybe Text)
Post.hand_key
    where
    infer :: [Instrument] -> (Note, [Note]) -> Note
infer [Instrument]
insts =
        forall a event.
(a -> event) -> (event -> Bool) -> (a -> event) -> a -> event
Post.only forall a b. (a, b) -> a
fst ([Instrument] -> Note -> Bool
Post.has_instrument [Instrument]
insts) forall a b. (a -> b) -> a -> b
$ RealTime -> (Note, [Note]) -> Note
infer_damp_simple RealTime
gap
    -- Less than this much time before the next note of the same pitch means
    -- extend the duration.
    gap :: RealTime
gap = RealTime
0.15

infer_damp_simple :: RealTime -> (Score.Event, [Score.Event]) -> Score.Event
infer_damp_simple :: RealTime -> (Note, [Note]) -> Note
infer_damp_simple RealTime
gap (Note
event, [Note]
nexts)
    | Note -> RealTime
Score.event_duration Note
event forall a. Eq a => a -> a -> Bool
/= RealTime
0 Bool -> Bool -> Bool
&& RealTime
new_end forall a. Ord a => a -> a -> Bool
> Note -> RealTime
Score.event_end Note
event =
        RealTime -> Note -> Note
Score.set_duration (RealTime
new_end forall a. Num a => a -> a -> a
- Note -> RealTime
Score.event_start Note
event) Note
event
    | Bool
otherwise = Note
event
    where
    new_end :: RealTime
new_end = Note -> [Note] -> RealTime
go Note
event [Note]
nexts
    go :: Note -> [Note] -> RealTime
go Note
prev (Note
next:[Note]
nexts)
        | Note -> RealTime
Score.event_start Note
next forall a. Num a => a -> a -> a
- Note -> RealTime
Score.event_end Note
prev forall a. Ord a => a -> a -> Bool
<= RealTime
gap
                Bool -> Bool -> Bool
&& Note -> Maybe Note
Score.initial_note Note
prev forall a. Eq a => a -> a -> Bool
== Note -> Maybe Note
Score.initial_note Note
next
            = Note -> [Note] -> RealTime
go Note
next [Note]
nexts
    go Note
prev [Note]
_ = Note -> RealTime
Score.event_end Note
prev