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

-- | Playing idioms of plucked or bowed strings.  Generally these calls expect
-- 'EnvKey.open_strings', and possibly 'EnvKey.string'.
module Derive.C.Idiom.String where
import qualified Data.Map as Map

import qualified Util.Lists as Lists
import qualified Util.Num as Num
import qualified Derive.Args as Args
import qualified Derive.Attrs as Attrs
import qualified Derive.Call as Call
import qualified Derive.Call.ControlUtil as ControlUtil
import qualified Derive.Call.GraceUtil as GraceUtil
import qualified Derive.Call.Ly as Ly
import qualified Derive.Call.Module as Module
import qualified Derive.Call.PitchUtil as PitchUtil
import qualified Derive.Call.Post as Post
import qualified Derive.Call.StringUtil as StringUtil
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.Env as Env
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Library as Library
import qualified Derive.PSignal as PSignal
import qualified Derive.Pitches as Pitches
import qualified Derive.Scale.Twelve as Twelve
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.RealTime as RealTime
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
        [ (Symbol
"gliss-a", Generator Event
c_gliss_absolute)
        , (Symbol
"gliss", Generator Event
c_gliss)
        , (Symbol
"on", Generator Event
c_nth_harmonic)
        , (Symbol
"o", Generator Event
c_harmonic)
        ]
    , forall call.
ToLibrary (Transformer call) =>
[(Symbol, Transformer call)] -> Library
Library.transformers
        [ (Symbol
"bent-string", Transformer Event
c_bent_string)
        , (Symbol
"stopped-string", Transformer Event
c_stopped_string)
        , (Symbol
"mute-end", Transformer Event
c_mute_end)
        ]
    ]

module_ :: Module.Module
module_ :: Module
module_ = Module
"idiom" forall a. Semigroup a => a -> a -> a
<> Module
"string"

c_bent_string :: Derive.Transformer Derive.Note
c_bent_string :: Transformer Event
c_bent_string = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
module_ CallName
"bent-string"
    (Tags
Tags.postproc forall a. Semigroup a => a -> a -> a
<> Tags
Tags.inst)
    (Doc
"Post-process events to play in a stopped string idiom, where\
    \ strings must be bent or stopped to reach non-open pitches.\
    \ Originally it was meant to play in the style of a 古箏 or\
    \ other zither, but may also be appropriate for stopped strings\
    \ like the violin family. As a side-effect, events get a"
    forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Text
EnvKey.string forall a. Semigroup a => a -> a -> a
<> Doc
" variable.\
    \\nFurther documentation is in 'Derive.Call.Idiom.String'.")
    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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"attack" (Double
0.15 :: Double)
        Doc
"Time for a string to bend to its desired pitch. A fast attack\
        \ sounds like a stopped string."
    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
"release" (Double
0.1 :: Double)
        Doc
"Time for a string to return to its original pitch."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"delay" (Double
0 :: Double)
        Doc
"If the string won't be used for the following note, it will be\
        \ released after this delay."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser [Pitch]
StringUtil.open_strings_env
    ) forall a b. (a -> b) -> a -> b
$ \(TypedFunction
attack, TypedFunction
release, TypedFunction
release_delay, [Pitch]
open_strings) PassedArgs Event
_args Deriver State Error (Stream Event)
deriver ->
    forall a. Deriver a -> Deriver a -> Deriver a
Ly.when_lilypond Deriver State Error (Stream Event)
deriver forall a b. (a -> b) -> a -> b
$ do
        -- TODO I used to use just the pitch, but the index is more useful when
        -- the pitch can change.  But I have to use pitch for harmonics below
        -- because they don't always require open_strings.
        [String]
open_strings <- [Pitch] -> Deriver [String]
StringUtil.indexed_strings [Pitch]
open_strings
        Config
config <- TypedFunction
-> TypedFunction -> TypedFunction -> [String] -> Deriver Config
make_config TypedFunction
attack TypedFunction
release_delay TypedFunction
release [String]
open_strings
        Config -> Stream Event -> Deriver State Error (Stream Event)
string_idiom Config
config forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Deriver State Error (Stream Event)
deriver

c_stopped_string :: Derive.Transformer Derive.Note
c_stopped_string :: Transformer Event
c_stopped_string = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
module_ CallName
"stopped-string"
    (Tags
Tags.postproc forall a. Semigroup a => a -> a -> a
<> Tags
Tags.inst)
    Doc
"A specialization of `bent-string` but for stopped strings, like the\
    \ violin family, where strings instantly jump to their pitches."
    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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"delay" (RealTime
0 :: RealTime) Doc
"String release delay time."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser [Pitch]
StringUtil.open_strings_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe Pitch)
StringUtil.string_env
    ) forall a b. (a -> b) -> a -> b
$ \(TypedFunction
release_delay, [Pitch]
open_strings, Maybe Pitch
string) PassedArgs Event
_args Deriver State Error (Stream Event)
deriver -> case Maybe Pitch
string of
        Just Pitch
_ -> Deriver State Error (Stream Event)
deriver -- presumably they will all get a constant string
        Maybe Pitch
Nothing -> do
            [String]
open_strings <- [Pitch] -> Deriver [String]
StringUtil.indexed_strings [Pitch]
open_strings
            Config
config <- TypedFunction
-> TypedFunction -> TypedFunction -> [String] -> Deriver Config
make_config
                (forall a. a -> Typed a
ScoreT.untyped (forall a b. a -> b -> a
const Double
0)) TypedFunction
release_delay
                (forall a. a -> Typed a
ScoreT.untyped (forall a b. a -> b -> a
const Double
0)) [String]
open_strings
            Config -> Stream Event -> Deriver State Error (Stream Event)
string_idiom Config
config forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Deriver State Error (Stream Event)
deriver

data Config = Config {
    Config -> Map NoteNumber String
_open_strings :: Map Pitch.NoteNumber StringUtil.String
    -- | (curve, time)
    , Config -> (Interpolate, TypedFunction)
_attack_curve :: (PitchUtil.Interpolate, ScoreT.TypedFunction)
    , Config -> (Interpolate, TypedFunction)
_release_curve :: (PitchUtil.Interpolate, ScoreT.TypedFunction)
    , Config -> TypedFunction
_release_delay :: ScoreT.TypedFunction
    }

make_config :: ScoreT.TypedFunction -> ScoreT.TypedFunction
    -> ScoreT.TypedFunction -> [StringUtil.String] -> Derive.Deriver Config
make_config :: TypedFunction
-> TypedFunction -> TypedFunction -> [String] -> Deriver Config
make_config TypedFunction
attack_dur TypedFunction
release_delay TypedFunction
release_dur [String]
open_strings = do
    RealTime
srate <- Deriver RealTime
Call.get_srate
    let linear :: Interpolate
linear = RealTime -> Curve -> Interpolate
PitchUtil.segment RealTime
srate Curve
ControlUtil.Linear
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Config
        { _open_strings :: Map NoteNumber String
_open_strings =
            forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a k. (a -> k) -> [a] -> [(k, a)]
Lists.keyOn String -> NoteNumber
StringUtil.str_nn [String]
open_strings
        , _attack_curve :: (Interpolate, TypedFunction)
_attack_curve = (Interpolate
linear, TypedFunction
attack_dur)
        , _release_curve :: (Interpolate, TypedFunction)
_release_curve = (Interpolate
linear, TypedFunction
release_dur)
        , _release_delay :: TypedFunction
_release_delay = TypedFunction
release_delay
        }

{- | Post-process events to play them in a string-like idiom.

    This tweaks the ends of the pitch signals of notes.  When a new note is
    played, the next event is examined to determine if it will share a string
    or not.

    If the string must be used for the following note, the end of the event is
    bent up to the next pitch before the next event is triggered.  This is
    called the \"attack\".  A fast attack gives the sound of a stopped string,
    a slow one sounds like a bent one.

    If the string won't be used for a long enough time, it will be released
    after a delay.  The release time determines how long it will take to reach
    its open pitch.  Since the release happens after the note ends, only
    instruments with a bit of decay will have an audible release.

    This does't do anything fancy like simulate hand position or alternate
    fingerings.  It just selects the lowest string below or at the lowest pitch
    in the note.
-}
string_idiom :: Config -> Stream.Stream Score.Event -> Derive.NoteDeriver
string_idiom :: Config -> Stream Event -> Deriver State Error (Stream Event)
string_idiom Config
config = do
    forall a b.
(a -> Event) -> (a -> Deriver b) -> Stream a -> Deriver (Stream b)
Post.emap1m_ (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall {b}. ((Event, String), Maybe (Event, b)) -> Deriver Event
event1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key a.
Eq key =>
(a -> key) -> Stream a -> Stream (a, Maybe a)
Post.next_by (String -> NoteNumber
StringUtil.str_nn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
        forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a b.
(a -> Event) -> (a -> Deriver b) -> Stream a -> Deriver (Stream b)
Post.emap1m_ forall a. a -> a
id Event -> Deriver State Error (Event, String)
assign
    where
    assign :: Event -> Deriver State Error (Event, String)
assign Event
event = do
        let (NoteNumber
nns, [(RealTime, Text)]
_warns) = Event -> (NoteNumber, [(RealTime, Text)])
Score.nn_signal Event
event
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall {k} (kind :: k). Signal kind -> Bool
Signal.null NoteNumber
nns) forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Text -> Deriver a
Derive.throw Text
"no pitch"
        let lowest :: NoteNumber
lowest = forall a. Real a => a -> NoteNumber
Pitch.nn forall a b. (a -> b) -> a -> b
$ forall {k} (kind :: k). Signal kind -> Double
Signal.minimum NoteNumber
nns
        String
string <- forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require (Text
"below lowest string: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty NoteNumber
lowest) forall a b. (a -> b) -> a -> b
$
            forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v. Ord k => k -> Map k v -> Maybe (k, v)
Map.lookupLE NoteNumber
lowest (Config -> Map NoteNumber String
_open_strings Config
config)
        forall (m :: * -> *) a. Monad m => a -> m a
return
            ( (Environ -> Environ) -> Event -> Event
Score.modify_environ (String -> Environ -> Environ
StringUtil.insert_string String
string) Event
event
            , String
string
            )
    event1 :: ((Event, String), Maybe (Event, b)) -> Deriver Event
event1 ((Event
event, String
string), Maybe (Event, b)
next) = Config -> Event -> String -> Maybe Event -> Deriver Event
process Config
config Event
event String
string (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Event, b)
next)

-- | The next note has the same string, so bend this one to prepare.
-- If it's over a certain threshold away, release this one.
-- TODO maybe skip release and attack if the next note is over a certain
-- threshold away?  If its > the decay time, pitch curves would be inaudible...
-- unless of course changing the pitch itself causes a sound, as it might for
-- a fret slide.
process :: Config -> Score.Event -> StringUtil.String
    -> Maybe Score.Event -> Derive.Deriver Score.Event
process :: Config -> Event -> String -> Maybe Event -> Deriver Event
process Config
config Event
event String
string Maybe Event
Nothing =
    Config -> Pitch -> Maybe RealTime -> Event -> Deriver Event
add_release Config
config (String -> Pitch
StringUtil.str_pitch String
string) forall a. Maybe a
Nothing Event
event
process Config
config Event
event String
string (Just Event
next_event) = do
    let next :: RealTime
next = Event -> RealTime
Score.event_start Event
next_event
    RealTime
attack_dur <- TypedFunction -> RealTime -> Deriver RealTime
Call.real_duration_at (forall a b. (a, b) -> b
snd (Config -> (Interpolate, TypedFunction)
_attack_curve Config
config)) RealTime
next
    Event
event <- Config -> Pitch -> Maybe RealTime -> Event -> Deriver Event
add_release Config
config (String -> Pitch
StringUtil.str_pitch String
string)
        (forall a. a -> Maybe a
Just (RealTime
next forall a. Num a => a -> a -> a
- RealTime
attack_dur)) Event
event
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Config -> RealTime -> Event -> Event -> Event
add_attack Config
config RealTime
attack_dur Event
next_event Event
event

-- | After releasing a note, you release your hand, which means the pitch
-- should bend down to the open string.
add_release :: Config -> PSignal.Pitch -> Maybe RealTime -> Score.Event
    -> Derive.Deriver Score.Event
add_release :: Config -> Pitch -> Maybe RealTime -> Event -> Deriver Event
add_release Config
config Pitch
open_string Maybe RealTime
maybe_next Event
event = do
    let end :: RealTime
end = Event -> RealTime
Score.event_end Event
event
    RealTime
delay <- TypedFunction -> RealTime -> Deriver RealTime
Call.real_duration_at (Config -> TypedFunction
_release_delay Config
config) RealTime
end
    RealTime
dur <- TypedFunction -> RealTime -> Deriver RealTime
Call.real_duration_at (forall a b. (a, b) -> b
snd (Config -> (Interpolate, TypedFunction)
_release_curve Config
config)) RealTime
end
    -- Release if there's enough time for both delay, release curve, and
    -- following attack curve.
    let enough_time :: Bool
enough_time = case Maybe RealTime
maybe_next of
            Maybe RealTime
Nothing -> Bool
True
            Just RealTime
next -> RealTime
next forall a. Num a => a -> a -> a
- RealTime
end forall a. Ord a => a -> a -> Bool
> RealTime
delay forall a. Num a => a -> a -> a
+ RealTime
dur
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Event
event forall a b. (a -> b) -> a -> b
$ if Bool -> Bool
not Bool
enough_time
        then forall a. Maybe a
Nothing else do
            Pitch
from_pitch <- RealTime -> Event -> Maybe Pitch
Score.pitch_at (RealTime
endforall a. Num a => a -> a -> a
+RealTime
delay) Event
event
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Interpolate
-> RealTime -> Pitch -> RealTime -> Pitch -> Event -> Event
merge_curve (forall a b. (a, b) -> a
fst (Config -> (Interpolate, TypedFunction)
_release_curve Config
config))
                (RealTime
end forall a. Num a => a -> a -> a
+ RealTime
delay) Pitch
from_pitch
                (RealTime
end forall a. Num a => a -> a -> a
+ RealTime
delay forall a. Num a => a -> a -> a
+ RealTime
dur) Pitch
open_string
                Event
event

-- | Bend the event up to the next note.
--
-- If there isn't enough time, do the bend faster.
-- TODO It might be nice to make the transition spill over into the next
-- attack.
add_attack :: Config -> RealTime -> Score.Event -> Score.Event -> Score.Event
add_attack :: Config -> RealTime -> Event -> Event -> Event
add_attack Config
config RealTime
dur Event
next_event Event
event
    | RealTime
dur forall a. Ord a => a -> a -> Bool
<= RealTime
0 = Event
event
    | Bool
otherwise = forall a. a -> Maybe a -> a
fromMaybe Event
event forall a b. (a -> b) -> a -> b
$ do
        let start_x :: RealTime
start_x = forall a. Ord a => a -> a -> a
max (Event -> RealTime
Score.event_start Event
event) (RealTime
next forall a. Num a => a -> a -> a
- RealTime
dur)
        Pitch
start_pitch <- RealTime -> Event -> Maybe Pitch
Score.pitch_at RealTime
start_x Event
event
        Pitch
next_pitch <- RealTime -> Event -> Maybe Pitch
Score.pitch_at RealTime
next Event
next_event
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Interpolate
-> RealTime -> Pitch -> RealTime -> Pitch -> Event -> Event
merge_curve (forall a b. (a, b) -> a
fst (Config -> (Interpolate, TypedFunction)
_attack_curve Config
config)) RealTime
start_x Pitch
start_pitch
            RealTime
next Pitch
next_pitch Event
event
    where next :: RealTime
next = Event -> RealTime
Score.event_start Event
next_event

merge_curve :: PitchUtil.Interpolate -> RealTime -> PSignal.Pitch
    -> RealTime -> PSignal.Pitch -> Score.Event -> Score.Event
merge_curve :: Interpolate
-> RealTime -> Pitch -> RealTime -> Pitch -> Event -> Event
merge_curve Interpolate
interpolate RealTime
x0 Pitch
y0 RealTime
x1 Pitch
y1 Event
event =
    PSignal -> Event -> Event
Score.set_pitch (Event -> PSignal
Score.event_pitch Event
event forall a. Semigroup a => a -> a -> a
<> PSignal
curve) Event
event
    where curve :: PSignal
curve = Interpolate
interpolate RealTime
x0 Pitch
y0 RealTime
x1 Pitch
y1


-- * mute end

c_mute_end :: Derive.Transformer Derive.Note
c_mute_end :: Transformer Event
c_mute_end = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
module_ CallName
"mute-end"
    (Tags
Tags.postproc forall a. Semigroup a => a -> a -> a
<> Tags
Tags.inst)
    (Doc
"Put a note and then +mute note at the end of each note, unless there's\
    \ another note on the same string. The " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Attributes
ring
    forall a. Semigroup a => a -> a -> a
<> Doc
" attr suppresses this.")
    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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"threshold" Doc
"Mute if the string is free for this long."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"dur" Doc
"Duration of mute note. If it's zero, its omitted\
        \ and only the +mute note is emitted."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"dyn" Doc
"Dyn of mute note."
    ) forall a b. (a -> b) -> a -> b
$ \(RealTime
threshold, RealTime -> RealTime
dur, Function
dyn) PassedArgs Event
_args Deriver State Error (Stream Event)
deriver -> forall a. Deriver a -> Deriver a -> Deriver a
Ly.when_lilypond Deriver State Error (Stream Event)
deriver forall a b. (a -> b) -> a -> b
$
        forall a. (a -> [Event]) -> Stream a -> Stream Event
Post.emap_ ((RealTime -> RealTime)
-> Function -> RealTime -> (Event, [Event]) -> [Event]
mute_end RealTime -> RealTime
dur Function
dyn RealTime
threshold)
            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 Event -> Maybe Text
string_of forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver State Error (Stream Event)
deriver
    where
    string_of :: Score.Event -> Maybe Text
    string_of :: Event -> Maybe Text
string_of = forall a. Typecheck a => Text -> Environ -> Maybe a
Env.maybe_val Text
EnvKey.string forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Environ
Score.event_environ

mute_end :: (RealTime -> RealTime) -> ScoreT.Function -> RealTime
    -> (Score.Event, [Score.Event]) -> [Score.Event]
mute_end :: (RealTime -> RealTime)
-> Function -> RealTime -> (Event, [Event]) -> [Event]
mute_end RealTime -> RealTime
dur_at Function
dyn_at RealTime
threshold (Event
event, [Event]
nexts)
    | Bool
should_mute = Event
event
        forall a. a -> [a] -> [a]
: [RealTime -> RealTime -> Double -> Event -> Event
mute_note RealTime
end RealTime
dur (Function
dyn_at RealTime
end) Event
event | RealTime
dur forall a. Ord a => a -> a -> Bool
> RealTime
0]
        forall a. [a] -> [a] -> [a]
++ [RealTime -> Event -> Event
set_mute (RealTime
end forall a. Num a => a -> a -> a
+ RealTime
dur) Event
event]
    | Bool
otherwise = [Event
event]
    where
    dur :: RealTime
dur = RealTime -> RealTime
dur_at RealTime
end
    end :: RealTime
end = Event -> RealTime
Score.event_end Event
event
    should_mute :: Bool
should_mute = Bool -> Bool
not (Attributes -> Event -> Bool
Score.has_attribute Attributes
ring Event
event) Bool -> Bool -> Bool
&& case [Event]
nexts of
        [] -> Bool
True
        Event
next : [Event]
_ -> Event -> RealTime
Score.event_start Event
next forall a. Num a => a -> a -> a
- RealTime
end forall a. Ord a => a -> a -> Bool
> RealTime
threshold

ring :: Attrs.Attributes
ring :: Attributes
ring = Text -> Attributes
Attrs.attr Text
"ring"

mute_note :: RealTime -> RealTime -> Signal.Y -> Score.Event -> Score.Event
mute_note :: RealTime -> RealTime -> Double -> Event -> Event
mute_note RealTime
start RealTime
dur Double
dyn Event
event = Double -> Event -> Event
Score.set_dynamic Double
dyn forall a b. (a -> b) -> a -> b
$ Event
event
    { event_start :: RealTime
Score.event_start = RealTime
start
    , event_duration :: RealTime
Score.event_duration = RealTime
dur
    }

set_mute :: RealTime -> Score.Event -> Score.Event
set_mute :: RealTime -> Event -> Event
set_mute RealTime
start Event
event = Attributes -> Event -> Event
Score.add_attributes Attributes
Attrs.mute forall a b. (a -> b) -> a -> b
$
    Event
event { event_start :: RealTime
Score.event_start = RealTime
start, event_duration :: RealTime
Score.event_duration = RealTime
0 }


-- * gliss

c_gliss_absolute, c_gliss :: Derive.Generator Derive.Note
c_gliss_absolute :: Generator Event
c_gliss_absolute = CallName -> Bool -> Generator Event
make_gliss CallName
"gliss-a" Bool
True
c_gliss :: Generator Event
c_gliss = CallName -> Bool -> Generator Event
make_gliss CallName
"gliss" Bool
False

-- | This provides two kinds of glissando: absolute takes an absolute amount
-- of time for the entire glissando, while non-absolute takes a certain amount
-- of time per string, and hence will have a different duration depending on
-- how many strings.
make_gliss :: Derive.CallName -> Bool -> Derive.Generator Derive.Note
make_gliss :: CallName -> Bool -> Generator Event
make_gliss CallName
name Bool
is_absolute = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
module_ CallName
name forall a. Monoid a => a
mempty
    Doc
"Glissando along the open strings. The standard version divides the `time`\
    \ among the number of notes, while the -a (absolute) version gives `time`\
    \ to each note."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,,,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"start"
        Doc
"Start this many strings above or below the destination pitch."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (if Bool
is_absolute
        then forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"time" (RealTime -> DefaultReal
Typecheck.real RealTime
0.25)
            Doc
"Time in which to play the glissando."
        else forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"time" (RealTime -> DefaultReal
Typecheck.real RealTime
0.075)
            Doc
"Time between each note.")
    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" (forall a. Maybe a
Nothing :: Maybe Sig.Dummy)
        Doc
"Start at this dyn, and interpolate\
        \ to the destination dyn. If not given, the dyn is constant."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser [Pitch]
StringUtil.open_strings_env
    ) forall a b. (a -> b) -> a -> b
$ \(Int
gliss_start, Typecheck.DefaultReal Duration
time, Maybe Double
maybe_start_dyn,
        [Pitch]
open_strings) ->
    forall d.
(PassedArgs d -> Deriver State Error (Stream Event))
-> PassedArgs d -> Deriver State Error (Stream Event)
Sub.inverting forall a b. (a -> b) -> a -> b
$ \PassedArgs Event
args -> do
        RealTime
end <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Event
args
        RealTime
time <- forall t1 t2. (Time t1, Time t2) => t1 -> t2 -> Deriver RealTime
Call.real_duration RealTime
end Duration
time
        Transposed
dest_pitch <- RealTime -> Deriver Transposed
Call.get_transposed RealTime
end
        Double
dest_dyn <- RealTime -> Deriver Double
Call.dynamic RealTime
end
        let start_dyn :: Double
start_dyn = forall a. a -> Maybe a -> a
fromMaybe Double
dest_dyn Maybe Double
maybe_start_dyn
        [Pitch]
pitches <- [Pitch] -> Transposed -> Int -> Deriver [Pitch]
gliss_pitches [Pitch]
open_strings Transposed
dest_pitch Int
gliss_start
        let total_time :: RealTime
total_time = if Bool
is_absolute then RealTime
time
                else RealTime
time forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pitch]
pitches)
        forall a. Deriver a -> Deriver a -> Deriver a
Ly.when_lilypond (forall d.
PassedArgs d
-> RealTime -> [Pitch] -> Deriver State Error (Stream Event)
GraceUtil.lily_grace PassedArgs Event
args (RealTime
end forall a. Num a => a -> a -> a
- RealTime
time) [Pitch]
pitches) forall a b. (a -> b) -> a -> b
$
            [Pitch]
-> RealTime
-> Double
-> Double
-> RealTime
-> Deriver State Error (Stream Event)
gliss [Pitch]
pitches RealTime
total_time Double
start_dyn Double
dest_dyn RealTime
end
                forall a. Semigroup a => a -> a -> a
<> forall d. PassedArgs d -> Deriver State Error (Stream Event)
Call.placed_note PassedArgs Event
args

gliss_pitches :: [PSignal.Pitch] -> PSignal.Transposed -> Int
    -> Derive.Deriver [PSignal.Pitch]
gliss_pitches :: [Pitch] -> Transposed -> Int -> Deriver [Pitch]
gliss_pitches [Pitch]
open_strings Transposed
dest_pitch Int
gliss_start = do
    -- Round the NN so a slightly off note start doesn't make this string get
    -- doubled.
    NoteNumber
dest_nn <- forall a b. (RealFrac a, Fractional b) => Int -> a -> b
Num.roundDigits Int
2 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Transposed -> Deriver State Error NoteNumber
Pitches.pitch_nn Transposed
dest_pitch
    -- TODO shouldn't need to eval them all
    [NoteNumber]
open_nns <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Transposed -> Deriver State Error NoteNumber
Pitches.pitch_nn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. RawPitch a -> RawPitch b
PSignal.coerce) [Pitch]
open_strings
    let strings :: [(Pitch, NoteNumber)]
strings = forall k a. Ord k => (a -> k) -> [a] -> [a]
Lists.sortOn forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Pitch]
open_strings [NoteNumber]
open_nns
    -- 0 2 4 6 8 10
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Int
gliss_start forall a. Ord a => a -> a -> Bool
>= Int
0
        -- 5 -> 6 8 10 -> 10 8 6 5
        then forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take Int
gliss_start forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$
            forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((forall a. Ord a => a -> a -> Bool
<=NoteNumber
dest_nn) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Pitch, NoteNumber)]
strings
        -- 5 -> 0 2 4
        else forall a. Int -> [a] -> [a]
Lists.takeEnd (-Int
gliss_start) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$
            forall a. (a -> Bool) -> [a] -> [a]
takeWhile ((forall a. Ord a => a -> a -> Bool
<NoteNumber
dest_nn) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Pitch, NoteNumber)]
strings

gliss :: [PSignal.Pitch] -> RealTime -> Signal.Y -> Signal.Y -> RealTime
    -> Derive.NoteDeriver
gliss :: [Pitch]
-> RealTime
-> Double
-> Double
-> RealTime
-> Deriver State Error (Stream Event)
gliss [Pitch]
pitches RealTime
time Double
start_dyn Double
end_dyn RealTime
end = do
    let dur :: RealTime
dur = RealTime
time forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pitch]
pitches)
        start :: RealTime
start = RealTime
end forall a. Num a => a -> a -> a
- RealTime
time
        ts :: [RealTime]
ts = forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pitch]
pitches) (forall a. Num a => a -> a -> [a]
Lists.range_ RealTime
start RealTime
dur)
        dyns :: [Double]
dyns = forall a b. (a -> b) -> [a] -> [b]
map (forall a. (Eq a, Num a) => a -> a -> a -> a
Num.scale Double
start_dyn Double
end_dyn forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function
RealTime.to_seconds
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Eq a, Fractional a) => a -> a -> a -> a
Num.normalize RealTime
start RealTime
end) [RealTime]
ts
    [ScoreTime]
score_ts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. Time a => a -> Deriver ScoreTime
Derive.score [RealTime]
ts
    ScoreTime
score_dur <- forall t1 t2. (Time t1, Time t2) => t1 -> t2 -> Deriver ScoreTime
Call.score_duration RealTime
end RealTime
dur
    let note :: (ScoreTime, Pitch, Double) -> Deriver State Error (Stream Event)
note (ScoreTime
t, Pitch
p, Double
dyn) = forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a
Derive.place ScoreTime
t ScoreTime
score_dur forall a b. (a -> b) -> a -> b
$ forall a. Double -> Deriver a -> Deriver a
Call.with_dynamic Double
dyn forall a b. (a -> b) -> a -> b
$
            Pitch -> Deriver State Error (Stream Event)
Call.pitched_note Pitch
p
    forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (ScoreTime, Pitch, Double) -> Deriver State Error (Stream Event)
note forall a b. (a -> b) -> a -> b
$ forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [ScoreTime]
score_ts [Pitch]
pitches [Double]
dyns


-- * harmonic

c_nth_harmonic :: Derive.Generator Derive.Note
c_nth_harmonic :: Generator Event
c_nth_harmonic = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
module_ CallName
"harmonic" Tags
Tags.inst
    Doc
"Play a specific harmonic on a specific string."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Positive a -> a
Typecheck.positive forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"n" (Int
1 :: Int) Doc
"Play this harmonic.")
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Double
finger_arg
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Typecheck a => Text -> Doc -> Parser a
Sig.required_environ_key Text
EnvKey.string Doc
"Play on this string."
    ) forall a b. (a -> b) -> a -> b
$ \(Double
harmonic, Double
finger, Pitch
string) -> forall d.
(PassedArgs d -> Deriver State Error (Stream Event))
-> PassedArgs d -> Deriver State Error (Stream Event)
Sub.inverting forall a b. (a -> b) -> a -> b
$ \PassedArgs Event
args -> do
        String
string <- Pitch -> Deriver String
StringUtil.string Pitch
string
        forall d a. PassedArgs d -> Deriver a -> Deriver a
Call.place PassedArgs Event
args forall a b. (a -> b) -> a -> b
$
            forall a. Control -> Double -> Deriver a -> Deriver a
Derive.with_constant_control Control
Controls.finger Double
finger forall a b. (a -> b) -> a -> b
$
            Pitch -> Deriver State Error (Stream Event)
Call.pitched_note forall a b. (a -> b) -> a -> b
$
            NoteNumber -> Pitch
Twelve.nn_pitch forall a b. (a -> b) -> a -> b
$ (Double -> Double) -> NoteNumber -> NoteNumber
Pitch.modify_hz (forall a. Num a => a -> a -> a
*Double
harmonic) forall a b. (a -> b) -> a -> b
$
            String -> NoteNumber
StringUtil.str_nn String
string

c_harmonic :: Derive.Generator Derive.Note
c_harmonic :: Generator Event
c_harmonic = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
module_ CallName
"harmonic" Tags
Tags.inst
    Doc
"Play the given pitch as a harmonic, possibly restricted to a string.\
    \ Otherwise, pick the lowest harmonic where the pitch fits."
    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 Double
finger_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
"h1" Bool
False
            Doc
"Ok to pick an open string as the 1st harmonic?"
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe Pitch)
StringUtil.string_env
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser [Pitch]
StringUtil.open_strings_env
    ) forall a b. (a -> b) -> a -> b
$ \(Double
finger, Bool
h1_ok, Maybe Pitch
maybe_string, [Pitch]
open_strings) -> forall d.
(PassedArgs d -> Deriver State Error (Stream Event))
-> PassedArgs d -> Deriver State Error (Stream Event)
Sub.inverting forall a b. (a -> b) -> a -> b
$
    \PassedArgs Event
args -> do
        NoteNumber
nn <- Transposed -> Deriver State Error NoteNumber
Pitches.pitch_nn forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RealTime -> Deriver Transposed
Call.get_transposed forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Event
args
        [String]
open_strings <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pitch -> Deriver String
StringUtil.string [Pitch]
open_strings
        Maybe String
maybe_string <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Pitch -> Deriver String
StringUtil.string Maybe Pitch
maybe_string
        (String
string, Int
harmonic) <- forall err a.
HasCallStack =>
(err -> Text) -> Either err a -> Deriver a
Derive.require_right forall a. a -> a
id forall a b. (a -> b) -> a -> b
$
            Bool
-> Int
-> [String]
-> Maybe String
-> NoteNumber
-> Either Text (String, Int)
StringUtil.find_harmonic Bool
h1_ok Int
highest_harmonic [String]
open_strings
                Maybe String
maybe_string NoteNumber
nn
        forall a. String -> Deriver a -> Deriver a
StringUtil.with_string String
string forall a b. (a -> b) -> a -> b
$ forall d a. PassedArgs d -> Deriver a -> Deriver a
Call.place PassedArgs Event
args forall a b. (a -> b) -> a -> b
$
            forall a. Control -> Double -> Deriver a -> Deriver a
Derive.with_constant_control Control
Controls.finger Double
finger forall a b. (a -> b) -> a -> b
$
            Pitch -> Deriver State Error (Stream Event)
Call.pitched_note forall a b. (a -> b) -> a -> b
$
            NoteNumber -> Pitch
Twelve.nn_pitch forall a b. (a -> b) -> a -> b
$ Int -> NoteNumber -> NoteNumber
touch_interval Int
harmonic (String -> NoteNumber
StringUtil.str_nn String
string)

highest_harmonic :: StringUtil.Harmonic
highest_harmonic :: Int
highest_harmonic = Int
13

touch_interval :: Int -> Pitch.NoteNumber -> Pitch.NoteNumber
touch_interval :: Int -> NoteNumber -> NoteNumber
touch_interval Int
harmonic = (Double -> Double) -> NoteNumber -> NoteNumber
Pitch.modify_hz (forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
harmonic)

finger_arg :: Sig.Parser Double
finger_arg :: Parser Double
finger_arg = forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"finger" (Double
0.035 :: Double)
    Doc
"Weight of the finger touching the string, in newtons."