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

{- | Various kinds of trills.

    Trills want to generate an integral number of cycles.  For the purpose of
    counting integral cycles, trills count the end (either the end of the
    event, or the start of the next event).  This is different than other
    control calls, which tend to omit the end point, expecting that the next
    call will place a sample there.  This is so that a trill can end on an off
    note if it exactly fits into its allotted space, otherwise a 16th note
    trill in a quarter note would degenerate into a mordent.

    Various flavors of trills:

    - Trill cycles depend on real duration of note.  Cycle durations are given
    in real time.

    - As above, but durations are given in score time.

    - Number of trill cycles given as argument, and note stretches normally.

    - Sung style vibrato in a sine wave rather than a square wave.

    - Trill that simply adds an attribute, instrument will handle it.

    The generic 'tr' symbol can be bound to whichever variant is locally
    appropriate.

    It's easy to think of more variants of trills: hold the starting note
    briefly, hold the final note briefly, inject a little randomness, smooth
    the pitch curve by a variable amount, or variants that cover the range
    between trill and vibrato, etc.  One can also imagine dynamic effects.

    Instead of trying to provide a million functions here or a few
    with a million parameters, it should be relatively easy to reuse the
    functions in here to write a specific kind of trill for the particular
    piece.
-}
module Derive.C.Prelude.Trill (
    library
    , c_note_trill, c_tremolo_generator
    , hold_env, tremolo_starts_curve
    -- * transitions
    , trill_transitions, adjusted_transitions
    -- * types
    , Config(..)
    , Direction(..), direction_affix
    , AbsoluteMode(..)
    , Adjust(..), adjust_env
    , get_trill_control_smooth

    -- testing
    , full_notes, chord_tremolo, get_trill_control, xcut_control
) where
import qualified Data.List as List
import qualified Data.Maybe as Maybe

import qualified Util.Doc as Doc
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.Ly as Ly
import qualified Derive.Call.Module as Module
import qualified Derive.Call.Speed as Speed
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.EnvKey as EnvKey
import qualified Derive.Eval as Eval
import qualified Derive.Expr as Expr
import qualified Derive.Library as Library
import qualified Derive.PSignal as PSignal
import qualified Derive.Pitches as Pitches
import qualified Derive.Scale as Scale
import qualified Derive.Scale.Theory as Theory
import qualified Derive.Scale.Twelve as Twelve
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.Constants as Constants
import qualified Perform.Lilypond.Convert as Lilypond.Convert
import qualified Perform.Lilypond.Types as Types
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


library :: Library.Library
library :: Library
library = forall a. Monoid a => [a] -> a
mconcat
    -- Note
    [ forall {call}.
ToLibrary (Generator call) =>
Text
-> (Maybe Direction -> Maybe Direction -> Generator call)
-> Library
make_trills Text
"tr" (Bool -> Maybe Direction -> Maybe Direction -> Generator Note
c_note_trill Bool
False)
    , forall call.
ToLibrary (Generator call) =>
[(Symbol, Generator call)] -> Library
Library.generators [(Symbol
"trem", Maybe ([Attributes], Attributes) -> Generator Note
c_tremolo_generator forall a. Maybe a
Nothing)]
    , forall call.
ToLibrary (Transformer call) =>
[(Symbol, Transformer call)] -> Library
Library.transformers [(Symbol
"trem", Transformer Note
c_tremolo_transformer)]
    -- Pitch
    , forall {call}.
ToLibrary (Generator call) =>
Text
-> (Maybe Direction -> Maybe Direction -> Generator call)
-> Library
make_trills Text
"tr" Maybe Direction -> Maybe Direction -> Generator PSignal
c_pitch_trill
    , forall {call}.
ToLibrary (Generator call) =>
Text
-> (Maybe Direction -> Maybe Direction -> Generator call)
-> Library
make_trills Text
"trs" Maybe Direction -> Maybe Direction -> Generator PSignal
c_pitch_trill_smooth
    , forall call.
ToLibrary (Generator call) =>
[(Symbol, Generator call)] -> Library
Library.generators
        [ (Symbol
"xcut", Bool -> Generator PSignal
c_xcut_pitch Bool
False)
        , (Symbol
"xcut-h", Bool -> Generator PSignal
c_xcut_pitch Bool
True)
        ]
    -- Control
    , forall {call}.
ToLibrary (Generator call) =>
Text
-> (Maybe Direction -> Maybe Direction -> Generator call)
-> Library
make_trills Text
"tr" Maybe Direction -> Maybe Direction -> Generator Control
c_control_trill
    , forall {call}.
ToLibrary (Generator call) =>
Text
-> (Maybe Direction -> Maybe Direction -> Generator call)
-> Library
make_trills Text
"trs" Maybe Direction -> Maybe Direction -> Generator Control
c_control_trill_smooth
    , forall call.
ToLibrary (Generator call) =>
[(Symbol, Generator call)] -> Library
Library.generators forall a b. (a -> b) -> a -> b
$
        [ (Symbol
"saw", Generator Control
c_saw)
        , (Symbol
"sine", SineMode -> Generator Control
c_sine SineMode
Bipolar)
        , (Symbol
"sine+", SineMode -> Generator Control
c_sine SineMode
Positive)
        , (Symbol
"sine-", SineMode -> Generator Control
c_sine SineMode
Negative)
        , (Symbol
"xcut", Bool -> Generator Control
c_xcut_control Bool
False)
        , (Symbol
"xcut-h", Bool -> Generator Control
c_xcut_control Bool
True)
        ]
    ]
    where
    make_trills :: Text
-> (Maybe Direction -> Maybe Direction -> Generator call)
-> Library
make_trills Text
prefix Maybe Direction -> Maybe Direction -> Generator call
make = forall call.
ToLibrary (Generator call) =>
[(Symbol, Generator call)] -> Library
Library.generators
        [(Symbol
name, Maybe Direction -> Maybe Direction -> Generator call
make Maybe Direction
start Maybe Direction
end) | (Symbol
name, Maybe Direction
start, Maybe Direction
end) <- Text -> [(Symbol, Maybe Direction, Maybe Direction)]
trill_variations Text
prefix]

-- * note calls

c_note_trill :: Bool -> Maybe Direction -> Maybe Direction
    -> Derive.Generator Derive.Note
c_note_trill :: Bool -> Maybe Direction -> Maybe Direction -> Generator Note
c_note_trill Bool
use_attributes Maybe Direction
hardcoded_start Maybe Direction
hardcoded_end =
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
Module.prelude CallName
"tr" Tags
Tags.ly
    (Doc
"Generate a note with a trill.\
    \\nUnlike a trill on a pitch track, this generates events for each\
    \ note of the trill. This is more appropriate for fingered trills,\
    \ or monophonic instruments that use legato to play slurred notes.\
    \\nInstruments that support +trill attributes should enable the attributes\
    \ version, which emits a single note with `+trill+half`, `+trill+whole`, or\
    \ all the notes with `+trill`, depending on the interval."
    forall a. Semigroup a => a -> a -> a
<> forall a. Maybe a -> Maybe a -> Doc
direction_doc Maybe Direction
hardcoded_start Maybe Direction
hardcoded_end
    ) 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 Neighbor
neighbor_arg
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Direction -> Maybe Direction -> Parser Config
config_arg Maybe Direction
hardcoded_start Maybe Direction
hardcoded_end
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
Text -> deflt -> Doc -> Parser a
Sig.environ_key Text
"tr-style" TrillStyle
Tr
        Doc
"Notation variant: tr symbol, tr~, or tremolo."
    ) forall a b. (a -> b) -> a -> b
$ \(Neighbor
neighbor, Config
config, TrillStyle
style) -> forall d.
(PassedArgs d -> Deriver (Stream Note))
-> PassedArgs d -> Deriver (Stream Note)
Sub.inverting forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
args ->
    forall a. Deriver a -> Deriver a -> Deriver a
Ly.when_lilypond (forall a.
TrillStyle -> PassedArgs a -> Neighbor -> Deriver (Stream Note)
note_trill_ly TrillStyle
style PassedArgs Note
args Neighbor
neighbor)
        (forall a.
Bool -> Neighbor -> Config -> PassedArgs a -> Deriver (Stream Note)
note_trill Bool
use_attributes Neighbor
neighbor Config
config PassedArgs Note
args)

type Neighbor = Either Typecheck.DiatonicTransposeFunctionT PSignal.Pitch

neighbor_arg :: Sig.Parser Neighbor
neighbor_arg :: Parser Neighbor
neighbor_arg = forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"neighbor" (forall a b. a -> Either a b
Left Int
1 :: Either Int Sig.Dummy)
    Doc
"Alternate with an interval or pitch."

note_trill :: Bool -> Neighbor -> Config
    -> Derive.PassedArgs a -> Derive.NoteDeriver
note_trill :: forall a.
Bool -> Neighbor -> Config -> PassedArgs a -> Deriver (Stream Note)
note_trill Bool
use_attributes Neighbor
neighbor Config
config PassedArgs a
args
    | Bool
use_attributes = Neighbor -> ScoreTime -> Deriver (Maybe Attributes)
trill_attributes Neighbor
neighbor (forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs a
args) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just Attributes
attr ->
            forall d. Attributes -> Deriver d -> Deriver d
Call.add_attributes (Attributes
Attrs.trill forall a. Semigroup a => a -> a -> a
<> Attributes
attr) (forall d. PassedArgs d -> Deriver (Stream Note)
Call.placed_note PassedArgs a
args)
        Maybe Attributes
Nothing -> forall d. Attributes -> Deriver d -> Deriver d
Call.add_attributes Attributes
Attrs.trill Deriver (Stream Note)
trill_notes
    | Bool
otherwise = Deriver (Stream Note)
trill_notes
    where
    trill_notes :: Deriver (Stream Note)
trill_notes = do
        (Function
neighbor, Control
control) <- ScoreTime -> Neighbor -> Deriver (Function, Control)
neighbor_to_function (forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs a
args) Neighbor
neighbor
        [(RealTime, Double)]
transpose <- Config
-> (ScoreTime, ScoreTime)
-> Function
-> Deriver [(RealTime, Double)]
get_trill_control Config
config (forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range_or_next PassedArgs a
args) Function
neighbor
        [Event] -> Deriver (Stream Note)
Sub.derive forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall {a} {b} {b}.
(Time a, Time b) =>
Control -> ((a, Double), Maybe (b, b)) -> Deriver State Error Event
note Control
control) (forall a. [a] -> [(a, Maybe a)]
Lists.zipNext [(RealTime, Double)]
transpose)
    note :: Control -> ((a, Double), Maybe (b, b)) -> Deriver State Error Event
note Control
control ((a
x, Double
transpose), Maybe (b, b)
next) = do
        ScoreTime
start <- forall a. Time a => a -> Deriver ScoreTime
Derive.score a
x
        let end :: ScoreTime
end = forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range PassedArgs a
args
        ScoreTime
next <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ScoreTime
end) (forall a. Time a => a -> Deriver ScoreTime
Derive.score forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) Maybe (b, b)
next
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. ScoreTime -> ScoreTime -> a -> EventT a
SubT.EventT ScoreTime
start (ScoreTime
nextforall a. Num a => a -> a -> a
-ScoreTime
start) forall a b. (a -> b) -> a -> b
$
            forall a. Control -> Double -> Deriver a -> Deriver a
Call.add_constant Control
control Double
transpose Deriver (Stream Note)
Call.note
    -- trill_notes = do
    --     neighbor <- neighbor_to_signal2 (Args.start args) neighbor
    --     (transpose, control) <- get_trill_control2
    --         (Args.range_or_next args) start_dir end_dir adjust hold
    --         neighbor speed
    --     xs <- mapM (Derive.score . fst) transpose
    --     let end = snd $ Args.range args
    --     let notes = do
    --             (x, maybe_next) <- Lists.zipNext xs
    --             let next = fromMaybe end maybe_next
    --             return $ SubT.EventT x (next-x) Call.note
    --     Call.add_control control (ScoreT.untyped transpose)
    --         (Sub.derive notes)

        -- TODO this is an implementation that directly uses the neighbor pitch
        -- instead of the roundabout signal thing.  But I still need the signal
        -- if it changes.  Implement when I'm not in such a hurry.

        -- neighbor <- case neighbor of
        --     Right p -> return p
        --     Left control -> undefined
        -- let neighbor_low = False -- TODO
        -- (who_first, transitions) <- get_trill_transitions
        --     (Args.range_or_next args) start_dir end_dir
        --     adjust hold speed neighbor_low
        -- base <- Call.get_pitch_here args
        -- let pitches = cycle $ case who_first of
        --         Unison -> [base, neighbor]
        --         Neighbor -> [neighbor, base]
        -- transitions <- mapM Derive.score transitions
        -- Sub.derive $ do
        --     (pitch, (x, maybe_next)) <-
        --         zip pitches (Lists.zipNext transitions)
        --     let next = fromMaybe (snd (Args.range args)) maybe_next
        --     return $ SubT.EventT x (next-x) (Call.pitched_note pitch)

neighbor_to_function :: ScoreTime -> Neighbor
    -> Derive.Deriver (ScoreT.Function, ScoreT.Control)
neighbor_to_function :: ScoreTime -> Neighbor -> Deriver (Function, Control)
neighbor_to_function ScoreTime
_ (Left (Typecheck.DiatonicTransposeFunctionT TransposeT
typ Function
f)) =
    forall (m :: * -> *) a. Monad m => a -> m a
return (Function
f, TransposeT -> Control
Typecheck.transpose_control TransposeT
typ)
neighbor_to_function ScoreTime
start (Right Pitch
neighbor) = do
    RealTime
start <- forall a. Time a => a -> Deriver RealTime
Derive.real ScoreTime
start
    Pitch
base <- RealTime -> Deriver Pitch
Call.get_pitch RealTime
start
    NoteNumber
diff <- RealTime -> Pitch -> Pitch -> Deriver NoteNumber
Call.nn_difference RealTime
start Pitch
neighbor Pitch
base
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> b -> a
const (forall a b. (Real a, Fractional b) => a -> b
realToFrac NoteNumber
diff), TransposeT -> Control
Typecheck.transpose_control TransposeT
ScoreT.TNn)

trill_attributes :: Neighbor -> ScoreTime
    -> Derive.Deriver (Maybe Attrs.Attributes)
trill_attributes :: Neighbor -> ScoreTime -> Deriver (Maybe Attributes)
trill_attributes Neighbor
neighbor ScoreTime
start = do
    RealTime
start <- forall a. Time a => a -> Deriver RealTime
Derive.real ScoreTime
start
    (Pitch
pitch, Pitch
neighbor) <- Neighbor -> RealTime -> Deriver (Pitch, Pitch)
pitch_and_neighbor Neighbor
neighbor RealTime
start
    NoteNumber
diff <- RealTime -> Pitch -> Pitch -> Deriver NoteNumber
Call.nn_difference RealTime
start Pitch
neighbor Pitch
pitch
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if
        | NoteNumber -> NoteNumber -> Bool
Pitch.nns_equal NoteNumber
diff NoteNumber
1 -> forall a. a -> Maybe a
Just Attributes
Attrs.half
        | NoteNumber -> NoteNumber -> Bool
Pitch.nns_equal NoteNumber
diff NoteNumber
2 -> forall a. a -> Maybe a
Just Attributes
Attrs.whole
        | Bool
otherwise -> forall a. Maybe a
Nothing

data TrillStyle = Tr | Span | Tremolo
    deriving (Int -> TrillStyle -> ShowS
[TrillStyle] -> ShowS
TrillStyle -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TrillStyle] -> ShowS
$cshowList :: [TrillStyle] -> ShowS
show :: TrillStyle -> String
$cshow :: TrillStyle -> String
showsPrec :: Int -> TrillStyle -> ShowS
$cshowsPrec :: Int -> TrillStyle -> ShowS
Show, TrillStyle -> TrillStyle -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TrillStyle -> TrillStyle -> Bool
$c/= :: TrillStyle -> TrillStyle -> Bool
== :: TrillStyle -> TrillStyle -> Bool
$c== :: TrillStyle -> TrillStyle -> Bool
Eq, Int -> TrillStyle
TrillStyle -> Int
TrillStyle -> [TrillStyle]
TrillStyle -> TrillStyle
TrillStyle -> TrillStyle -> [TrillStyle]
TrillStyle -> TrillStyle -> TrillStyle -> [TrillStyle]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: TrillStyle -> TrillStyle -> TrillStyle -> [TrillStyle]
$cenumFromThenTo :: TrillStyle -> TrillStyle -> TrillStyle -> [TrillStyle]
enumFromTo :: TrillStyle -> TrillStyle -> [TrillStyle]
$cenumFromTo :: TrillStyle -> TrillStyle -> [TrillStyle]
enumFromThen :: TrillStyle -> TrillStyle -> [TrillStyle]
$cenumFromThen :: TrillStyle -> TrillStyle -> [TrillStyle]
enumFrom :: TrillStyle -> [TrillStyle]
$cenumFrom :: TrillStyle -> [TrillStyle]
fromEnum :: TrillStyle -> Int
$cfromEnum :: TrillStyle -> Int
toEnum :: Int -> TrillStyle
$ctoEnum :: Int -> TrillStyle
pred :: TrillStyle -> TrillStyle
$cpred :: TrillStyle -> TrillStyle
succ :: TrillStyle -> TrillStyle
$csucc :: TrillStyle -> TrillStyle
Enum, TrillStyle
forall a. a -> a -> Bounded a
maxBound :: TrillStyle
$cmaxBound :: TrillStyle
minBound :: TrillStyle
$cminBound :: TrillStyle
Bounded)

instance Typecheck.Typecheck TrillStyle
instance Typecheck.ToVal TrillStyle
instance ShowVal.ShowVal TrillStyle

note_trill_ly :: TrillStyle -> Derive.PassedArgs a -> Neighbor
    -> Derive.NoteDeriver
note_trill_ly :: forall a.
TrillStyle -> PassedArgs a -> Neighbor -> Deriver (Stream Note)
note_trill_ly TrillStyle
style PassedArgs a
args Neighbor
neighbor = do
    RealTime
start <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs a
args
    (Pitch
pitch, Pitch
neighbor) <- Neighbor -> RealTime -> Deriver (Pitch, Pitch)
pitch_and_neighbor Neighbor
neighbor RealTime
start
    NoteNumber
diff <- RealTime -> Pitch -> Pitch -> Deriver NoteNumber
Call.nn_difference RealTime
start Pitch
neighbor Pitch
pitch
    let tremolo :: Deriver (Stream Note)
tremolo = Pitch -> Pitch -> ScoreTime -> ScoreTime -> Deriver (Stream Note)
tremolo_trill_ly Pitch
pitch Pitch
neighbor (forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs a
args)
            (forall a. PassedArgs a -> ScoreTime
Args.duration PassedArgs a
args)
    Environ
env <- Deriver Environ
Derive.get_environ
    let ly_pitch :: Deriver State Error Pitch
ly_pitch = forall err a.
HasCallStack =>
(err -> Text) -> Either err a -> Deriver a
Derive.require_right forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environ -> Transposed -> Either Text Pitch
Lilypond.Convert.pitch_to_lily Environ
env
            forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RealTime -> Pitch -> Deriver Transposed
Derive.resolve_pitch RealTime
start Pitch
neighbor
    case TrillStyle
style of
        TrillStyle
_ | Bool -> Bool
not (NoteNumber -> NoteNumber -> Bool
Pitch.nns_equal NoteNumber
diff NoteNumber
1) Bool -> Bool -> Bool
&& Bool -> Bool
not (NoteNumber -> NoteNumber -> Bool
Pitch.nns_equal NoteNumber
diff NoteNumber
2) ->
            Deriver (Stream Note)
tremolo
        TrillStyle
Tremolo -> Deriver (Stream Note)
tremolo
        TrillStyle
Tr -> do
            npitch :: Pitch
npitch@(Types.Pitch Int
_ PitchClass
_ Accidental
acc) <- Deriver State Error Pitch
ly_pitch
            Bool
in_key <- Pitch -> Deriver Bool
pitch_in_key Pitch
npitch
            let code :: Text
code = case Accidental
acc of
                    Accidental
_ | Bool
in_key -> Text
"\\trill"
                    Accidental
Types.FlatFlat -> Text
"^\\trFlatFlat"
                    Accidental
Types.Flat -> Text
"^\\trFlat"
                    Accidental
Types.Natural -> Text
"^\\trNatural"
                    Accidental
Types.Sharp -> Text
"^\\trSharp"
                    Accidental
Types.SharpSharp -> Text
"^\\trSharpSharp"
            -- TODO this should by Ly.note_append, but I can't put the \trFlat
            -- macros on a single pitch.
            Code -> Deriver (Stream Note) -> Deriver (Stream Note)
Ly.add_first (Distribution -> Position CodePosition
Ly.append Distribution
Constants.All, Text
code)
                (forall d. PassedArgs d -> Deriver (Stream Note)
Call.placed_note PassedArgs a
args)
        TrillStyle
Span -> do
            Pitch
npitch <- Deriver State Error Pitch
ly_pitch
            Code -> Deriver (Stream Note) -> Deriver (Stream Note)
Ly.add_first (Position CodePosition
Ly.prepend, Text
"\\pitchedTrill") forall a b. (a -> b) -> a -> b
$
                Code -> Deriver (Stream Note) -> Deriver (Stream Note)
Ly.add_first (Distribution -> Position CodePosition
Ly.append Distribution
Constants.First, Text
"\\startTrillSpan "
                    forall a. Semigroup a => a -> a -> a
<> forall a. ToLily a => a -> Text
Types.to_lily Pitch
npitch) forall a b. (a -> b) -> a -> b
$
                Code -> Deriver (Stream Note) -> Deriver (Stream Note)
Ly.add_first (Distribution -> Position CodePosition
Ly.append Distribution
Constants.Last, Text
"\\stopTrillSpan") forall a b. (a -> b) -> a -> b
$
                forall d. PassedArgs d -> Deriver (Stream Note)
Call.placed_note PassedArgs a
args

pitch_in_key :: Types.Pitch -> Derive.Deriver Bool
pitch_in_key :: Pitch -> Deriver Bool
pitch_in_key Pitch
ly_pitch = do
    Key
key <- Deriver Key
get_key
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Key -> Degree -> Bool
in_key Key
key (Pitch -> Degree
Pitch.pitch_degree (Pitch -> Pitch
Types.to_pitch Pitch
ly_pitch))

get_key :: Derive.Deriver Theory.Key
get_key :: Deriver Key
get_key = do
    Maybe Key
maybe_key <- Deriver (Maybe Key)
Call.lookup_key
    forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require (Text
"unrecognized key: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Maybe Key
maybe_key) forall a b. (a -> b) -> a -> b
$
        Maybe Key -> Maybe Key
Twelve.lookup_key Maybe Key
maybe_key

in_key :: Theory.Key -> Pitch.Degree -> Bool
in_key :: Key -> Degree -> Bool
in_key Key
key (Pitch.Degree Int
pc Int
acc) = Key -> Int -> Int
Theory.accidentals_at_pc Key
key Int
pc forall a. Eq a => a -> a -> Bool
== Int
acc

pitch_and_neighbor :: Neighbor -> RealTime
    -> Derive.Deriver (PSignal.Pitch, PSignal.Pitch)
pitch_and_neighbor :: Neighbor -> RealTime -> Deriver (Pitch, Pitch)
pitch_and_neighbor (Right Pitch
neighbor) RealTime
start =
    (, Pitch
neighbor) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RealTime -> Deriver Pitch
Call.get_pitch RealTime
start
pitch_and_neighbor (Left (Typecheck.DiatonicTransposeFunctionT TransposeT
typ Function
f))
        RealTime
start = do
    Pitch
base <- RealTime -> Deriver Pitch
Call.get_pitch RealTime
start
    let width :: Double
width = Function
f RealTime
start
    case (TransposeT
typ, Double
width) of
        (TransposeT
ScoreT.TChromatic, Double
1) ->
            (Pitch
base,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Transposed -> Deriver Pitch
chromatic_neighbor forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RealTime -> Pitch -> Deriver Transposed
Derive.resolve_pitch RealTime
start Pitch
base)
        (TransposeT, Double)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return
            (Pitch
base, forall a. Transpose -> RawPitch a -> RawPitch a
Pitches.transpose (TransposeT -> Double -> Transpose
Typecheck.to_transpose TransposeT
typ Double
width) Pitch
base)

-- | Given a pitch, find the enharmonic one chromatic step above it which is
-- at pitch class + 1.  This is because trills should alternate with the next
-- pitch class, so c to d flat, not c to c#.
chromatic_neighbor :: PSignal.Transposed -> Derive.Deriver PSignal.Pitch
chromatic_neighbor :: Transposed -> Deriver Pitch
chromatic_neighbor Transposed
pitch = do
    -- TODO this is way too complicated
    (Note -> Maybe Pitch
parse, Pitch -> Maybe Note
unparse, Transposition -> Int -> Pitch -> Maybe Pitch
transpose) <- Deriver
  (Note -> Maybe Pitch, Pitch -> Maybe Note,
   Transposition -> Int -> Pitch -> Maybe Pitch)
Call.get_pitch_functions
    Pitch
pitch <- forall a. (Note -> Maybe a) -> Transposed -> Deriver a
Call.parse_pitch Note -> Maybe Pitch
parse Transposed
pitch
    Key
key <- Deriver Key
get_key
    Pitch
neighbor <- forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require Text
"transpose" forall a b. (a -> b) -> a -> b
$ Transposition -> Int -> Pitch -> Maybe Pitch
transpose Transposition
Scale.Chromatic Int
1 Pitch
pitch
    Pitch
neighbor <- forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require Text
"enharmonic" forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((forall a. Eq a => a -> a -> Bool
== Pitch -> Int
Pitch.pitch_pc Pitch
pitch forall a. Num a => a -> a -> a
+ Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pitch -> Int
Pitch.pitch_pc) forall a b. (a -> b) -> a -> b
$
            Layout -> Pitch -> [Pitch]
Theory.enharmonics_of (Key -> Layout
Theory.key_layout Key
key) Pitch
neighbor
    Note
note <- forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require Text
"unparse" forall a b. (a -> b) -> a -> b
$ Pitch -> Maybe Note
unparse Pitch
neighbor
    Scale
scale <- Deriver Scale
Call.get_scale
    forall a. Scale -> Note -> Deriver (RawPitch a)
Eval.eval_note Scale
scale Note
note

-- | Emit the magic events to trigger lilypond's tremolo processing.
tremolo_trill_ly :: PSignal.Pitch -> PSignal.Pitch -> ScoreTime -> ScoreTime
    -> Derive.NoteDeriver
tremolo_trill_ly :: Pitch -> Pitch -> ScoreTime -> ScoreTime -> Deriver (Stream Note)
tremolo_trill_ly Pitch
pitch1 Pitch
pitch2 ScoreTime
start ScoreTime
dur =
    forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a
Derive.place ScoreTime
start ScoreTime
dur forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
        [ Code -> Deriver (Stream Note) -> Deriver (Stream Note)
Ly.add_first (forall pos. Text -> Position pos
Ly.SetEnviron Text
Constants.v_tremolo, Text
"") Deriver (Stream Note)
Call.note
        , Pitch -> Deriver (Stream Note)
Call.pitched_note Pitch
pitch1
        , Pitch -> Deriver (Stream Note)
Call.pitched_note Pitch
pitch2
        ]

c_tremolo_generator :: Maybe ([Attrs.Attributes], Attrs.Attributes)
    -> Derive.Generator Derive.Note
c_tremolo_generator :: Maybe ([Attributes], Attributes) -> Generator Note
c_tremolo_generator Maybe ([Attributes], Attributes)
attrs_unless =
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
Module.prelude CallName
"trem" Tags
Tags.ly
    (Doc
"Repeat a single note. Or, if there are sub-notes, alternate with each of\
    \ the sub-notes in turn." forall a. Semigroup a => a -> a -> a
<> case Maybe ([Attributes], Attributes)
attrs_unless of
        Maybe ([Attributes], Attributes)
Nothing -> Doc
""
        Just ([Attributes]
unless, Attributes
_) -> if Maybe ([Attributes], Attributes)
attrs_unless forall a. Eq a => a -> a -> Bool
== forall a. Maybe a
Nothing then Doc
"" else
            Doc
"\nThis version just derives plain notes with the "
            forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Attributes
Attrs.trem forall a. Semigroup a => a -> a -> a
<> Doc
" attribute, unless any of these\
            \ attributes are present: " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc [Attributes]
unless forall a. Semigroup a => a -> a -> a
<> Doc
".")
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser RealTimeFunctionT
Speed.arg forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Duration
hold_env) forall a b. (a -> b) -> a -> b
$ \(RealTimeFunctionT
speed, Duration
hold) PassedArgs Note
args -> do
        [ScoreTime]
starts <- Duration
-> RealTimeFunctionT
-> (ScoreTime, ScoreTime)
-> Deriver [ScoreTime]
tremolo_starts Duration
hold RealTimeFunctionT
speed (forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range_or_next PassedArgs Note
args)
        [[Event]]
notes <- forall d. PassedArgs d -> Deriver [[Event]]
Sub.sub_events PassedArgs Note
args
        Attributes
attrs <- Deriver Attributes
Call.get_attributes
        let use_attrs :: Bool
use_attrs = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Attributes -> Attributes -> Bool
Attrs.contain Attributes
attrs)forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
                Maybe ([Attributes], Attributes)
attrs_unless
        let trem_attrs :: Attributes
trem_attrs = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty forall a b. (a, b) -> b
snd Maybe ([Attributes], Attributes)
attrs_unless
        case forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [[Event]]
notes of
            [] -> forall d.
PassedArgs d
-> (PassedArgs d -> Deriver (Stream Note)) -> Deriver (Stream Note)
Sub.inverting_args PassedArgs Note
args forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
args -> forall d.
Code
-> PassedArgs d -> Deriver (Stream Note) -> Deriver (Stream Note)
Ly.note_code Code
code PassedArgs Note
args forall a b. (a -> b) -> a -> b
$
                if Bool
use_attrs
                    then forall d. Attributes -> Deriver d -> Deriver d
Call.add_attributes Attributes
Attrs.trem Deriver (Stream Note)
Call.note
                    else forall d. Attributes -> Deriver d -> Deriver d
Call.add_attributes Attributes
trem_attrs forall a b. (a -> b) -> a -> b
$
                        [ScoreTime] -> [Deriver (Stream Note)] -> Deriver (Stream Note)
simple_tremolo [ScoreTime]
starts [Deriver (Stream Note)
Call.note]
            [[Event]]
notes -> forall d.
Code
-> PassedArgs d -> Deriver (Stream Note) -> Deriver (Stream Note)
Ly.notes_code Code
code PassedArgs Note
args forall a b. (a -> b) -> a -> b
$ if Bool
use_attrs
                then forall d. Attributes -> Deriver d -> Deriver d
Call.add_attributes Attributes
Attrs.trem forall a b. (a -> b) -> a -> b
$ [[Event]] -> Deriver (Stream Note)
Sub.derive_tracks [[Event]]
notes
                else forall d. Attributes -> Deriver d -> Deriver d
Call.add_attributes Attributes
trem_attrs forall a b. (a -> b) -> a -> b
$
                    [Event] -> Deriver (Stream Note)
Sub.derive forall a b. (a -> b) -> a -> b
$ forall a. [ScoreTime] -> [[EventT a]] -> [EventT a]
chord_tremolo [ScoreTime]
starts [[Event]]
notes
    where
    code :: Code
code = (Distribution -> Position CodePosition
Ly.append Distribution
Constants.All, Text
":32")

c_tremolo_transformer :: Derive.Transformer Derive.Note
c_tremolo_transformer :: Transformer Note
c_tremolo_transformer = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude CallName
"trem" Tags
Tags.subs
    Doc
"Repeat the transformed note. The generator is creating the notes so it\
    \ can set them to the appropriate duration, but this one has to stretch\
    \ them to fit." 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
<$> Parser RealTimeFunctionT
Speed.arg forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Duration
hold_env) forall a b. (a -> b) -> a -> b
$
    \(RealTimeFunctionT
speed, Duration
hold) PassedArgs Note
args Deriver (Stream Note)
deriver -> do
        [ScoreTime]
starts <- Duration
-> RealTimeFunctionT
-> (ScoreTime, ScoreTime)
-> Deriver [ScoreTime]
tremolo_starts Duration
hold RealTimeFunctionT
speed (forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range_or_next PassedArgs Note
args)
        [ScoreTime] -> [Deriver (Stream Note)] -> Deriver (Stream Note)
simple_tremolo [ScoreTime]
starts [forall a b. PassedArgs a -> Deriver b -> Deriver b
Args.normalized PassedArgs Note
args Deriver (Stream Note)
deriver]

tremolo_starts :: DeriveT.Duration -> Typecheck.RealTimeFunctionT
    -> (ScoreTime, ScoreTime) -> Derive.Deriver [ScoreTime]
    -- ^ start time for each note, and one for the end of the last one
tremolo_starts :: Duration
-> RealTimeFunctionT
-> (ScoreTime, ScoreTime)
-> Deriver [ScoreTime]
tremolo_starts Duration
hold (Typecheck.RealTimeFunctionT TimeT
ttype Function
speed) (ScoreTime
start, ScoreTime
end) = do
    ScoreTime
hold <- forall t1 t2. (Time t1, Time t2) => t1 -> t2 -> Deriver ScoreTime
Call.score_duration ScoreTime
start Duration
hold
    (ScoreTime, ScoreTime) -> ScoreTime -> [ScoreTime] -> [ScoreTime]
add_hold (ScoreTime
start, ScoreTime
end) ScoreTime
hold forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case TimeT
ttype of
        TimeT
ScoreT.TReal -> do
            RealTime
start <- forall a. Time a => a -> Deriver RealTime
Derive.real (ScoreTime
start forall a. Num a => a -> a -> a
+ ScoreTime
hold)
            RealTime
end <- forall a. Time a => a -> Deriver RealTime
Derive.real ScoreTime
end
            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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => a -> [a] -> [a]
full_notes RealTime
end
                forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Function -> RealTime -> RealTime -> Deriver [RealTime]
Speed.real_starts Function
speed RealTime
start RealTime
end
        TimeT
ScoreT.TScore -> do
            [ScoreTime]
starts <- Function -> ScoreTime -> ScoreTime -> Deriver [ScoreTime]
Speed.score_starts Function
speed (ScoreTime
start forall a. Num a => a -> a -> a
+ ScoreTime
hold) ScoreTime
end
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> [a] -> [a]
full_notes ScoreTime
end [ScoreTime]
starts

-- | This is like 'tremolo_starts', but takes a start and end speed instead
-- of a speed signal.  In exchange, it can have start and end be different
-- time types, which a signal can't express.  Of course I could make the
-- signal into duration and then do the reciprocal in the score as a val call,
-- but that seems too complicated for tracklang.
tremolo_starts_curve :: ControlUtil.CurveF -> DeriveT.Duration
    -> Speed.Speed -> Speed.Speed -> (ScoreTime, ScoreTime)
    -> Derive.Deriver [ScoreTime]
    -- ^ start time for each note, and one for the end of the last one
tremolo_starts_curve :: CurveF
-> Duration
-> Speed
-> Speed
-> (ScoreTime, ScoreTime)
-> Deriver [ScoreTime]
tremolo_starts_curve CurveF
curvef Duration
hold Speed
start_speed Speed
end_speed (ScoreTime
start, ScoreTime
end) = do
    ScoreTime
hold <- forall t1 t2. (Time t1, Time t2) => t1 -> t2 -> Deriver ScoreTime
Call.score_duration ScoreTime
start Duration
hold
    (RealTime, RealTime)
real_range <- (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Time a => a -> Deriver RealTime
Derive.real ScoreTime
start forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Time a => a -> Deriver RealTime
Derive.real ScoreTime
end
    ((ScoreTime, ScoreTime) -> ScoreTime -> [ScoreTime] -> [ScoreTime]
add_hold (ScoreTime
start, ScoreTime
end) ScoreTime
hold forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => a -> [a] -> [a]
full_notes ScoreTime
end <$>) forall a b. (a -> b) -> a -> b
$
        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 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CurveF
-> Speed
-> Speed
-> (RealTime, RealTime)
-> Bool
-> Deriver [RealTime]
Speed.starts_curve CurveF
curvef Speed
start_speed Speed
end_speed
            (RealTime, RealTime)
real_range Bool
include_end
    where include_end :: Bool
include_end = Bool
True -- because the end time is also included.

-- | Add the hold time to the first tremolo note.
add_hold :: (ScoreTime, ScoreTime) -> ScoreTime -> [ScoreTime] -> [ScoreTime]
add_hold :: (ScoreTime, ScoreTime) -> ScoreTime -> [ScoreTime] -> [ScoreTime]
add_hold (ScoreTime
start, ScoreTime
end) ScoreTime
hold [ScoreTime]
starts
    | ScoreTime
hold forall a. Ord a => a -> a -> Bool
>= ScoreTime
end forall a. Num a => a -> a -> a
- ScoreTime
start = [ScoreTime
start, ScoreTime
end]
    | ScoreTime
hold forall a. Ord a => a -> a -> Bool
> ScoreTime
0 = ScoreTime
start forall a. a -> [a] -> [a]
: [ScoreTime]
starts
    | Bool
otherwise = [ScoreTime]
starts

-- | Alternate each note with the other notes within its range, in order from
-- the lowest track to the highest.
--
-- This doesn't restart the tremolo when a new note enters, if you want that
-- you can have multiple tremolo events.
chord_tremolo :: forall a. [ScoreTime] -> [[SubT.EventT a]] -> [SubT.EventT a]
chord_tremolo :: forall a. [ScoreTime] -> [[EventT a]] -> [EventT a]
chord_tremolo [ScoreTime]
starts [[EventT a]]
note_tracks =
    forall a. [Maybe a] -> [a]
Maybe.catMaybes forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL forall {a} {a}.
Ord a =>
(a, [(a, EventT a)])
-> (ScoreTime, ScoreTime)
-> ((a, [(a, EventT a)]), Maybe (EventT a))
emit (-Int
1, [(Int, EventT a)]
by_track) forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [ScoreTime]
starts (forall a. Int -> [a] -> [a]
drop Int
1 [ScoreTime]
starts)
    where
    emit :: (a, [(a, EventT a)])
-> (ScoreTime, ScoreTime)
-> ((a, [(a, EventT a)]), Maybe (EventT a))
emit (a
last_tracknum, [(a, EventT a)]
notes_) (ScoreTime
pos, ScoreTime
next_pos) = case Maybe (a, EventT a)
chosen of
        Maybe (a, EventT a)
Nothing -> ((a
last_tracknum, [(a, EventT a)]
notes), forall a. Maybe a
Nothing)
        Just (a
tracknum, EventT a
note) -> ((a
tracknum, [(a, EventT a)]
notes),
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. ScoreTime -> ScoreTime -> a -> EventT a
SubT.EventT ScoreTime
pos (ScoreTime
next_posforall a. Num a => a -> a -> a
-ScoreTime
pos) (forall a. EventT a -> a
SubT._note EventT a
note))
        where
        chosen :: Maybe (a, EventT a)
chosen =
            forall k a. Ord k => (a -> k) -> [a] -> Maybe a
Lists.minimumOn forall a b. (a, b) -> a
fst (forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Ord a => a -> a -> Bool
>a
last_tracknum) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(a, EventT a)]
overlapping)
                forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall k a. Ord k => (a -> k) -> [a] -> Maybe a
Lists.minimumOn forall a b. (a, b) -> a
fst [(a, EventT a)]
overlapping
        overlapping :: [(a, EventT a)]
overlapping = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. ScoreTime -> EventT a -> Bool
SubT.overlaps ScoreTime
pos forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(a, EventT a)]
notes
        notes :: [(a, EventT a)]
notes = forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((forall a. Ord a => a -> a -> Bool
<=ScoreTime
pos) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. EventT a -> ScoreTime
SubT.end forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(a, EventT a)]
notes_
    by_track :: [(TrackNum, SubT.EventT a)]
    by_track :: [(Int, EventT a)]
by_track = forall k a. Ord k => (a -> k) -> [a] -> [a]
Lists.sortOn (forall a. EventT a -> ScoreTime
SubT.end forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
        [ (Int
tracknum, EventT a
event)
        | (Int
tracknum, [EventT a]
track) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [[EventT a]]
note_tracks, EventT a
event <- [EventT a]
track
        ]

-- | Just cycle the given notes.
simple_tremolo :: [ScoreTime] -> [Derive.NoteDeriver] -> Derive.NoteDeriver
simple_tremolo :: [ScoreTime] -> [Deriver (Stream Note)] -> Deriver (Stream Note)
simple_tremolo [ScoreTime]
starts [Deriver (Stream Note)]
notes = [Event] -> Deriver (Stream Note)
Sub.derive
    [ forall a. ScoreTime -> ScoreTime -> a -> EventT a
SubT.EventT ScoreTime
start (ScoreTime
end forall a. Num a => a -> a -> a
- ScoreTime
start) Deriver (Stream Note)
note
    | (ScoreTime
start, ScoreTime
end, Deriver (Stream Note)
note) <- forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [ScoreTime]
starts (forall a. Int -> [a] -> [a]
drop Int
1 [ScoreTime]
starts) forall a b. (a -> b) -> a -> b
$
        if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Deriver (Stream Note)]
notes then [] else forall a. [a] -> [a]
cycle [Deriver (Stream Note)]
notes
    ]

-- | Given start times, return only ones whose full duration fits before the
-- end time.  This is the tremolo analog to 'full_cycles'.  Unlike a trill, it
-- emits both the starts and ends, and therefore the last sample will be at the
-- end time, rather than before it.  It should always emit an even number of
-- elements.
full_notes :: Ord a => a -> [a] -> [a]
full_notes :: forall a. Ord a => a -> [a] -> [a]
full_notes a
end [a
t]
    | a
t forall a. Ord a => a -> a -> Bool
< a
end = [a
t, a
end]
    | Bool
otherwise = []
full_notes a
end [a]
ts = [a] -> [a]
go [a]
ts
    where
    go :: [a] -> [a]
go [] = []
    go (a
t1:[a]
ts) = case [a]
ts of
        a
t2 : [a]
_
            | a
t2 forall a. Ord a => a -> a -> Bool
> a
end -> [a
end]
            | Bool
otherwise -> a
t1 forall a. a -> [a] -> [a]
: [a] -> [a]
go [a]
ts
        [] -> [a
end]
    -- This is surprisingly tricky.


-- * pitch calls

c_pitch_trill :: Maybe Direction -> Maybe Direction
    -> Derive.Generator Derive.Pitch
c_pitch_trill :: Maybe Direction -> Maybe Direction -> Generator PSignal
c_pitch_trill Maybe Direction
hardcoded_start Maybe Direction
hardcoded_end =
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Generator d
Derive.generator1 Module
Module.prelude CallName
"tr" forall a. Monoid a => a
mempty
    (Doc
"Generate a pitch signal of alternating pitches."
    forall a. Semigroup a => a -> a -> a
<> forall a. Maybe a -> Maybe a -> Doc
direction_doc Maybe Direction
hardcoded_start Maybe Direction
hardcoded_end
    ) 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
"note" Doc
"Base pitch."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Neighbor
neighbor_arg
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Direction -> Maybe Direction -> Parser Config
config_arg Maybe Direction
hardcoded_start Maybe Direction
hardcoded_end
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Curve
ControlUtil.curve_env
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Function
transition_env
    ) forall a b. (a -> b) -> a -> b
$ \(Pitch
note, Neighbor
neighbor, Config
config, Curve
curve, Function
transition) PassedArgs PSignal
args -> do
        (Function
neighbor, Control
control) <- ScoreTime -> Neighbor -> Deriver (Function, Control)
neighbor_to_function (forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs PSignal
args) Neighbor
neighbor
        [(RealTime, Double)]
transpose <- Config
-> (ScoreTime, ScoreTime)
-> Function
-> Deriver [(RealTime, Double)]
get_trill_control Config
config (forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range_or_next PassedArgs PSignal
args) Function
neighbor
        Control
transpose <- Function -> Curve -> [(RealTime, Double)] -> Deriver Control
smooth_trill Function
transition Curve
curve [(RealTime, Double)]
transpose
        RealTime
start <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs PSignal
args
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Control -> Typed Control -> PSignal -> PSignal
PSignal.apply_control Control
control (forall a. a -> Typed a
ScoreT.untyped Control
transpose) forall a b. (a -> b) -> a -> b
$
            RealTime -> Pitch -> PSignal
PSignal.from_sample RealTime
start Pitch
note

c_pitch_trill_smooth :: Maybe Direction -> Maybe Direction
    -> Derive.Generator Derive.Pitch
c_pitch_trill_smooth :: Maybe Direction -> Maybe Direction -> Generator PSignal
c_pitch_trill_smooth Maybe Direction
hardcoded_start Maybe Direction
hardcoded_end =
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Generator d
Derive.generator1 Module
Module.prelude CallName
"trs" forall a. Monoid a => a
mempty
    (Doc
"Generate a pitch signal of alternating pitches. Like `tr`, but with\
    \ defaults for smooth transitions."
    forall a. Semigroup a => a -> a -> a
<> forall a. Maybe a -> Maybe a -> Doc
direction_doc Maybe Direction
hardcoded_start Maybe Direction
hardcoded_end
    ) 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
"note" Doc
"Base pitch."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Neighbor
neighbor_arg
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Direction -> Maybe Direction -> Parser Config
config_arg Maybe Direction
hardcoded_start Maybe Direction
hardcoded_end
    ) forall a b. (a -> b) -> a -> b
$ \(Pitch
note, Neighbor
neighbor, Config
config) PassedArgs PSignal
args -> do
        (Function
neighbor, Control
control) <- ScoreTime -> Neighbor -> Deriver (Function, Control)
neighbor_to_function (forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs PSignal
args) Neighbor
neighbor
        Control
transpose <- Config
-> Curve -> (ScoreTime, ScoreTime) -> Function -> Deriver Control
get_trill_control_smooth Config
config Curve
curve
            (forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range_or_next PassedArgs PSignal
args) Function
neighbor
        RealTime
start <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs PSignal
args
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Control -> Typed Control -> PSignal -> PSignal
PSignal.apply_control Control
control (forall a. a -> Typed a
ScoreT.untyped Control
transpose) forall a b. (a -> b) -> a -> b
$
            RealTime -> Pitch -> PSignal
PSignal.from_sample RealTime
start Pitch
note
    where
    curve :: Curve
curve = CurveF -> Curve
ControlUtil.Function forall a b. (a -> b) -> a -> b
$ Double -> Double -> CurveF
ControlUtil.sigmoid Double
0.5 Double
0.5

c_xcut_pitch :: Bool -> Derive.Generator Derive.Pitch
c_xcut_pitch :: Bool -> Generator PSignal
c_xcut_pitch Bool
hold = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Generator d
Derive.generator1 Module
Module.prelude CallName
"xcut" forall a. Monoid a => a
mempty
    Doc
"Cross-cut between two pitches.  The `-h` variant holds the value at the\
    \ beginning of each transition."
    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
"fst" Doc
"First pitch."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"snd" Doc
"Second 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
"speed" (Int
14 :: Int) Doc
"Speed."
    ) forall a b. (a -> b) -> a -> b
$ \(PSignal
xcut1, PSignal
xcut2, RealTimeFunctionT
speed) PassedArgs PSignal
args -> do
        [RealTime]
transitions <- forall t.
Time t =>
RealTimeFunctionT -> (t, t) -> Bool -> Deriver [RealTime]
Speed.starts RealTimeFunctionT
speed (forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range_or_next PassedArgs PSignal
args) Bool
False
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> PSignal -> PSignal -> [RealTime] -> PSignal
xcut_pitch Bool
hold PSignal
xcut1 PSignal
xcut2 [RealTime]
transitions

xcut_pitch :: Bool -> PSignal.PSignal -> PSignal.PSignal -> [RealTime]
    -> PSignal.PSignal
xcut_pitch :: Bool -> PSignal -> PSignal -> [RealTime] -> PSignal
xcut_pitch Bool
hold PSignal
val1 PSignal
val2 = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (PSignal, RealTime) -> PSignal
slice forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. [a] -> [a]
cycle [PSignal
val1, PSignal
val2])
    where
    slice :: (PSignal, RealTime) -> PSignal
slice (PSignal
val, RealTime
t)
        | Bool
hold = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (RealTime -> Pitch -> PSignal
PSignal.from_sample RealTime
t) (PSignal -> RealTime -> Maybe Pitch
PSignal.at PSignal
val RealTime
t)
        | Bool
otherwise = RealTime -> PSignal -> PSignal
PSignal.clip_before RealTime
t PSignal
val


-- * control calls

c_control_trill :: Maybe Direction -> Maybe Direction
    -> Derive.Generator Derive.Control
c_control_trill :: Maybe Direction -> Maybe Direction -> Generator Control
c_control_trill Maybe Direction
hardcoded_start Maybe Direction
hardcoded_end =
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Generator d
Derive.generator1 Module
Module.prelude CallName
"tr" forall a. Monoid a => a
mempty
    (Doc
"The control version of the pitch trill. It generates a signal of values\
    \ alternating with 0, which can be used as a transposition signal."
    forall a. Semigroup a => a -> a -> a
<> forall a. Maybe a -> Maybe a -> Doc
direction_doc Maybe Direction
hardcoded_start Maybe Direction
hardcoded_end
    ) forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"neighbor" (Int
1 :: Int) Doc
"Alternate with this value."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Direction -> Maybe Direction -> Parser Config
config_arg Maybe Direction
hardcoded_start Maybe Direction
hardcoded_end
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Function
transition_env
    ) forall a b. (a -> b) -> a -> b
$ \(Function
neighbor, Config
config, Function
transition) PassedArgs Control
args -> do
        [(RealTime, Double)]
transpose <- Config
-> (ScoreTime, ScoreTime)
-> Function
-> Deriver [(RealTime, Double)]
get_trill_control Config
config (forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range_or_next PassedArgs Control
args) Function
neighbor
        Function -> Curve -> [(RealTime, Double)] -> Deriver Control
smooth_trill Function
transition Curve
ControlUtil.Linear [(RealTime, Double)]
transpose

c_control_trill_smooth :: Maybe Direction -> Maybe Direction
    -> Derive.Generator Derive.Control
c_control_trill_smooth :: Maybe Direction -> Maybe Direction -> Generator Control
c_control_trill_smooth Maybe Direction
hardcoded_start Maybe Direction
hardcoded_end =
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Generator d
Derive.generator1 Module
Module.prelude CallName
"tr" forall a. Monoid a => a
mempty
    (Doc
"The control version of the pitch trill. It generates a signal of values\
    \ alternating with 0, which can be used as a transposition signal."
    forall a. Semigroup a => a -> a -> a
<> forall a. Maybe a -> Maybe a -> Doc
direction_doc Maybe Direction
hardcoded_start Maybe Direction
hardcoded_end
    ) forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"neighbor" (Int
1 :: Int) Doc
"Alternate with this value."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Direction -> Maybe Direction -> Parser Config
config_arg Maybe Direction
hardcoded_start Maybe Direction
hardcoded_end
    ) forall a b. (a -> b) -> a -> b
$ \(Function
neighbor, Config
config) PassedArgs Control
args -> do
        Control
transpose <- Config
-> Curve -> (ScoreTime, ScoreTime) -> Function -> Deriver Control
get_trill_control_smooth Config
config Curve
curve
            (forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range_or_next PassedArgs Control
args) Function
neighbor
        forall (m :: * -> *) a. Monad m => a -> m a
return Control
transpose
    where
    curve :: Curve
curve = CurveF -> Curve
ControlUtil.Function forall a b. (a -> b) -> a -> b
$ Double -> Double -> CurveF
ControlUtil.sigmoid Double
0.5 Double
0.5

c_saw :: Derive.Generator Derive.Control
c_saw :: Generator Control
c_saw = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Generator d
Derive.generator1 Module
Module.prelude CallName
"saw" forall a. Monoid a => a
mempty
    Doc
"Emit a sawtooth.  By default it has a downward slope, but you can make\
    \ an upward slope by setting `from` and `to`."
    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 RealTimeFunctionT
Speed.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
"from" (Double
1 :: Double) Doc
"Start from this value."
    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
"to" (Double
0 :: Double) Doc
"End at this value."
    ) forall a b. (a -> b) -> a -> b
$ \(RealTimeFunctionT
speed, Double
from, Double
to) PassedArgs Control
args -> do
        [RealTime]
starts <- forall t.
Time t =>
RealTimeFunctionT -> (t, t) -> Bool -> Deriver [RealTime]
Speed.starts RealTimeFunctionT
speed (forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range_or_next PassedArgs Control
args) Bool
True
        RealTime
srate <- Deriver RealTime
Call.get_srate
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ RealTime -> [RealTime] -> Double -> Double -> Control
saw RealTime
srate [RealTime]
starts Double
from Double
to

saw :: RealTime -> [RealTime] -> Double -> Double -> Signal.Control
saw :: RealTime -> [RealTime] -> Double -> Double -> Control
saw RealTime
srate [RealTime]
starts Double
from Double
to = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith RealTime -> RealTime -> Control
saw [RealTime]
starts (forall a. Int -> [a] -> [a]
drop Int
1 [RealTime]
starts)
    where saw :: RealTime -> RealTime -> Control
saw RealTime
t1 RealTime
t2 = RealTime
-> Curve -> RealTime -> Double -> RealTime -> Double -> Control
ControlUtil.segment RealTime
srate Curve
ControlUtil.Linear RealTime
t1 Double
from RealTime
t2 Double
to

-- ** sine

data SineMode = Bipolar | Negative | Positive deriving (Int -> SineMode -> ShowS
[SineMode] -> ShowS
SineMode -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SineMode] -> ShowS
$cshowList :: [SineMode] -> ShowS
show :: SineMode -> String
$cshow :: SineMode -> String
showsPrec :: Int -> SineMode -> ShowS
$cshowsPrec :: Int -> SineMode -> ShowS
Show)

-- | This is probably not terribly convenient to use on its own, I should
-- have some more specialized calls based on this.
c_sine :: SineMode -> Derive.Generator Derive.Control
c_sine :: SineMode -> Generator Control
c_sine SineMode
mode = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Generator d
Derive.generator1 Module
Module.prelude CallName
"sine" forall a. Monoid a => a
mempty
    Doc
"Emit a sine wave. The default version is centered on the `offset`,\
    \ and the `+` and `-` variants are above and below it, respectively."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"speed" (RealTime
1 :: RealTime) Doc
"Frequency."
    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
"amp" (Double
1 :: Double) Doc
"Amplitude, measured center to peak."
    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
"offset" (Double
0 :: Double) Doc
"Center point."
    ) forall a b. (a -> b) -> a -> b
$ \(Typecheck.RealTimeFunctionT TimeT
time_type Function
speed, Double
amp, Double
offset) PassedArgs Control
args -> do
        case TimeT
time_type of
            TimeT
ScoreT.TScore -> forall a. HasCallStack => Text -> Deriver a
Derive.throw Text
"RealTime signal required"
            TimeT
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        RealTime
srate <- Deriver RealTime
Call.get_srate
        let sign :: Double
sign = case SineMode
mode of
                SineMode
Bipolar -> Double
0
                SineMode
Negative -> -Double
amp
                SineMode
Positive -> Double
amp
        (RealTime
start, RealTime
end) <- forall a. PassedArgs a -> Deriver State Error (RealTime, RealTime)
Args.real_range_or_next PassedArgs Control
args
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall {k} (kind :: k). CurveF -> Signal kind -> Signal kind
Signal.map_y_linear ((forall a. Num a => a -> a -> a
+(Double
offsetforall a. Num a => a -> a -> a
+Double
sign)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
*Double
amp)) forall a b. (a -> b) -> a -> b
$
            RealTime -> RealTime -> RealTime -> Function -> Control
sine RealTime
srate RealTime
start RealTime
end Function
speed

sine :: RealTime -> RealTime -> RealTime -> ScoreT.Function -> Signal.Control
sine :: RealTime -> RealTime -> RealTime -> Function -> Control
sine RealTime
srate RealTime
start RealTime
end Function
freq_sig = forall {k} state (kind :: k).
(state -> Maybe ((RealTime, Double), state))
-> state -> Signal kind
Signal.unfoldr (RealTime, Double)
-> Maybe ((RealTime, Double), (RealTime, Double))
go (RealTime
start, Double
0)
    where
    go :: (RealTime, Double)
-> Maybe ((RealTime, Double), (RealTime, Double))
go (RealTime
pos, Double
phase)
        | RealTime
pos forall a. Ord a => a -> a -> Bool
>= RealTime
end = forall a. Maybe a
Nothing
        | Bool
otherwise = forall a. a -> Maybe a
Just ((RealTime
pos, forall a. Floating a => a -> a
sin Double
phase), (RealTime
pos forall a. Num a => a -> a -> a
+ RealTime
1forall a. Fractional a => a -> a -> a
/RealTime
srate, Double
next_phase))
        where
        next_phase :: Double
next_phase = Double
phase forall a. Num a => a -> a -> a
+ Double
1 forall a. Fractional a => a -> a -> a
/ Function
RealTime.to_seconds RealTime
srate forall a. Num a => a -> a -> a
* Double
2forall a. Num a => a -> a -> a
*forall a. Floating a => a
pi forall a. Num a => a -> a -> a
* Function
freq_sig RealTime
pos


-- ** xcut

c_xcut_control :: Bool -> Derive.Generator Derive.Control
c_xcut_control :: Bool -> Generator Control
c_xcut_control Bool
hold = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Generator d
Derive.generator1 Module
Module.prelude CallName
"xcut" forall a. Monoid a => a
mempty
    Doc
"Cross-cut between two signals.  The `-h` variant holds the value at the\
    \ beginning of each transition."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"fst" (Int
1 :: Int) Doc
"First value."
    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
"snd" (Int
0 :: Int) Doc
"Second value."
    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
"speed" (Int
14 :: Int) Doc
"Speed."
    ) forall a b. (a -> b) -> a -> b
$ \(Control
xcut1, Control
xcut2, RealTimeFunctionT
speed) PassedArgs Control
args -> do
        [RealTime]
transitions <- forall t.
Time t =>
RealTimeFunctionT -> (t, t) -> Bool -> Deriver [RealTime]
Speed.starts RealTimeFunctionT
speed (forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range_or_next PassedArgs Control
args) Bool
False
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> Control -> Control -> [RealTime] -> Control
xcut_control Bool
hold Control
xcut1 Control
xcut2 [RealTime]
transitions

-- TODO(polymorphic-signals) This is the same as 'xcut_pitch'
xcut_control :: Bool -> Signal.Control -> Signal.Control -> [RealTime]
    -> Signal.Control
xcut_control :: Bool -> Control -> Control -> [RealTime] -> Control
xcut_control Bool
hold Control
val1 Control
val2 = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {k} {kind :: k}. (Signal kind, RealTime) -> Signal kind
slice forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. [a] -> [a]
cycle [Control
val1, Control
val2])
    where
    slice :: (Signal kind, RealTime) -> Signal kind
slice (Signal kind
val, RealTime
t)
        | Bool
hold = forall {k} (kind :: k). RealTime -> Double -> Signal kind
Signal.from_sample RealTime
t (forall {k} (kind :: k). Signal kind -> Function
Signal.at Signal kind
val RealTime
t)
        | Bool
otherwise = forall {k} (kind :: k). RealTime -> Signal kind -> Signal kind
Signal.clip_before RealTime
t Signal kind
val

-- * util

trill_speed_arg :: Sig.Parser Typecheck.RealTimeFunctionT
trill_speed_arg :: Parser RealTimeFunctionT
trill_speed_arg =
    forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"speed" (Int
14 :: Int)
    Doc
"Trill at this speed. If it's a RealTime, the value is the number of\
    \ cycles per second, which will be unaffected by the tempo. If it's\
    \ a ScoreTime, the value is the number of cycles per ScoreTime\
    \ unit, and will stretch along with tempo changes. In either case,\
    \ this will emit only whole notes, i.e. it will end sooner to avoid\
    \ emitting a cut-off note at the end."

-- | Whether the trill starts or ends on the high or low note.  This is another
-- way to express 'AbsoluteMode'.
--
-- I had a lot of debate about whether I should use High and Low, or Unison and
-- Neighbor.  Unison-Neighbor is more convenient for the implementation but
-- High-Low I think is more musically intuitive.
data Direction = High | Low deriving (Direction
forall a. a -> a -> Bounded a
maxBound :: Direction
$cmaxBound :: Direction
minBound :: Direction
$cminBound :: Direction
Bounded, Direction -> Direction -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Direction -> Direction -> Bool
$c/= :: Direction -> Direction -> Bool
== :: Direction -> Direction -> Bool
$c== :: Direction -> Direction -> Bool
Eq, Int -> Direction
Direction -> Int
Direction -> [Direction]
Direction -> Direction
Direction -> Direction -> [Direction]
Direction -> Direction -> Direction -> [Direction]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Direction -> Direction -> Direction -> [Direction]
$cenumFromThenTo :: Direction -> Direction -> Direction -> [Direction]
enumFromTo :: Direction -> Direction -> [Direction]
$cenumFromTo :: Direction -> Direction -> [Direction]
enumFromThen :: Direction -> Direction -> [Direction]
$cenumFromThen :: Direction -> Direction -> [Direction]
enumFrom :: Direction -> [Direction]
$cenumFrom :: Direction -> [Direction]
fromEnum :: Direction -> Int
$cfromEnum :: Direction -> Int
toEnum :: Int -> Direction
$ctoEnum :: Int -> Direction
pred :: Direction -> Direction
$cpred :: Direction -> Direction
succ :: Direction -> Direction
$csucc :: Direction -> Direction
Enum, Int -> Direction -> ShowS
[Direction] -> ShowS
Direction -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Direction] -> ShowS
$cshowList :: [Direction] -> ShowS
show :: Direction -> String
$cshow :: Direction -> String
showsPrec :: Int -> Direction -> ShowS
$cshowsPrec :: Int -> Direction -> ShowS
Show)
instance ShowVal.ShowVal Direction
instance Typecheck.Typecheck Direction
instance Typecheck.ToVal Direction

-- | This is the like 'Direction', but in terms of the unison and neighbor
-- pitches, instead of high and low.
data AbsoluteMode = Unison | Neighbor deriving (AbsoluteMode
forall a. a -> a -> Bounded a
maxBound :: AbsoluteMode
$cmaxBound :: AbsoluteMode
minBound :: AbsoluteMode
$cminBound :: AbsoluteMode
Bounded, AbsoluteMode -> AbsoluteMode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AbsoluteMode -> AbsoluteMode -> Bool
$c/= :: AbsoluteMode -> AbsoluteMode -> Bool
== :: AbsoluteMode -> AbsoluteMode -> Bool
$c== :: AbsoluteMode -> AbsoluteMode -> Bool
Eq, Int -> AbsoluteMode
AbsoluteMode -> Int
AbsoluteMode -> [AbsoluteMode]
AbsoluteMode -> AbsoluteMode
AbsoluteMode -> AbsoluteMode -> [AbsoluteMode]
AbsoluteMode -> AbsoluteMode -> AbsoluteMode -> [AbsoluteMode]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: AbsoluteMode -> AbsoluteMode -> AbsoluteMode -> [AbsoluteMode]
$cenumFromThenTo :: AbsoluteMode -> AbsoluteMode -> AbsoluteMode -> [AbsoluteMode]
enumFromTo :: AbsoluteMode -> AbsoluteMode -> [AbsoluteMode]
$cenumFromTo :: AbsoluteMode -> AbsoluteMode -> [AbsoluteMode]
enumFromThen :: AbsoluteMode -> AbsoluteMode -> [AbsoluteMode]
$cenumFromThen :: AbsoluteMode -> AbsoluteMode -> [AbsoluteMode]
enumFrom :: AbsoluteMode -> [AbsoluteMode]
$cenumFrom :: AbsoluteMode -> [AbsoluteMode]
fromEnum :: AbsoluteMode -> Int
$cfromEnum :: AbsoluteMode -> Int
toEnum :: Int -> AbsoluteMode
$ctoEnum :: Int -> AbsoluteMode
pred :: AbsoluteMode -> AbsoluteMode
$cpred :: AbsoluteMode -> AbsoluteMode
succ :: AbsoluteMode -> AbsoluteMode
$csucc :: AbsoluteMode -> AbsoluteMode
Enum, Int -> AbsoluteMode -> ShowS
[AbsoluteMode] -> ShowS
AbsoluteMode -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AbsoluteMode] -> ShowS
$cshowList :: [AbsoluteMode] -> ShowS
show :: AbsoluteMode -> String
$cshow :: AbsoluteMode -> String
showsPrec :: Int -> AbsoluteMode -> ShowS
$cshowsPrec :: Int -> AbsoluteMode -> ShowS
Show)

transition_env :: Sig.Parser ScoreT.Function
transition_env :: Parser Function
transition_env =
    forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.environ ArgName
"tr-transition" EnvironDefault
Sig.Unprefixed (Int
0 :: Int)
    Doc
"Take this long to reach the neighbor, as a proportion of time available."

-- | A bundle of standard configuration for trills.
config_arg :: Maybe Direction -> Maybe Direction -> Sig.Parser Config
config_arg :: Maybe Direction -> Maybe Direction -> Parser Config
config_arg Maybe Direction
start_dir Maybe Direction
end_dir =
    RealTimeFunctionT
-> Maybe Direction
-> Maybe Direction
-> Duration
-> Adjust
-> Double
-> Bool
-> Config
Config forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser RealTimeFunctionT
trill_speed_arg forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe Direction)
start forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe Direction)
end forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Duration
hold_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Adjust
adjust_env
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Double
bias forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    where
    start :: Parser (Maybe Direction)
start = case Maybe Direction
start_dir of
        Maybe Direction
Nothing -> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.environ ArgName
"tr-start" EnvironDefault
Sig.Unprefixed
            (forall a. Maybe a
Nothing :: Maybe Direction)
            Doc
"Which note the trill starts with. If not given, it will start\
            \ the unison note, which means it may move up or down."
        Just Direction
dir -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Direction
dir
    end :: Parser (Maybe Direction)
end = case Maybe Direction
end_dir of
        Maybe Direction
Nothing -> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.environ ArgName
"tr-end" EnvironDefault
Sig.Unprefixed
            (forall a. Maybe a
Nothing :: Maybe Direction)
            Doc
"Which note the trill ends with. If not given, it can end with\
            \ either."
        Just Direction
dir -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Direction
dir
    bias :: Parser Double
bias = NormalizedBipolar -> Double
Typecheck.normalized_bipolar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.environ ArgName
"tr-bias" EnvironDefault
Sig.Unprefixed (Double -> NormalizedBipolar
Typecheck.NormalizedBipolar Double
0)
            Doc
"Offset every other transition by this amount."

data Config = Config {
    -- | transition speed
    Config -> RealTimeFunctionT
_speed :: !Typecheck.RealTimeFunctionT
    , Config -> Maybe Direction
_start_dir :: !(Maybe Direction)
    , Config -> Maybe Direction
_end_dir :: !(Maybe Direction)
    -- | extend the first transition by this amount
    , Config -> Duration
_hold :: !DeriveT.Duration
    -- | how to fit the transitions into the time range
    , Config -> Adjust
_adjust :: !Adjust
    -- | offset every other transition by this amount, from -1--1
    , Config -> Double
_bias :: !Double
    -- | include a transition at the end time
    , Config -> Bool
_include_end :: !Bool
    }

-- Its default is both prefixed and unprefixed so you can put in a tr-hold
-- globally, and so you can have a short @hold=n |@ for a single call.
hold_env :: Sig.Parser DeriveT.Duration
hold_env :: Parser Duration
hold_env = DefaultReal -> Duration
Typecheck._real forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.environ (Text -> ArgName
Derive.ArgName Text
EnvKey.hold) EnvironDefault
Sig.Both
        (RealTime -> DefaultReal
Typecheck.real RealTime
0) Doc
"Time to hold the first note."

trill_variations :: Text -> [(Expr.Symbol, Maybe Direction, Maybe Direction)]
trill_variations :: Text -> [(Symbol, Maybe Direction, Maybe Direction)]
trill_variations Text
prefix =
    [ (Text -> Symbol
Expr.Symbol forall a b. (a -> b) -> a -> b
$ Text
prefix
            forall a. Semigroup a => a -> a -> a
<> (if Maybe Direction
start forall a. Eq a => a -> a -> Bool
== forall a. Maybe a
Nothing Bool -> Bool -> Bool
&& Maybe Direction
end forall a. Eq a => a -> a -> Bool
/= forall a. Maybe a
Nothing
                then Text
"-" else Maybe Direction -> Text
direction_affix Maybe Direction
start)
            forall a. Semigroup a => a -> a -> a
<> Maybe Direction -> Text
direction_affix Maybe Direction
end,
        Maybe Direction
start, Maybe Direction
end)
    | Maybe Direction
start <- [Maybe Direction]
dirs, Maybe Direction
end <- [Maybe Direction]
dirs
    ]
    where dirs :: [Maybe Direction]
dirs = [forall a. Maybe a
Nothing, forall a. a -> Maybe a
Just Direction
High, forall a. a -> Maybe a
Just Direction
Low]

direction_affix :: Maybe Direction -> Text
direction_affix :: Maybe Direction -> Text
direction_affix Maybe Direction
Nothing = Text
""
direction_affix (Just Direction
High) = Text
"^"
direction_affix (Just Direction
Low) = Text
"_"

direction_doc :: Maybe a -> Maybe a -> Doc.Doc
direction_doc :: forall a. Maybe a -> Maybe a -> Doc
direction_doc Maybe a
Nothing Maybe a
Nothing = Doc
""
direction_doc Maybe a
_ Maybe a
_ = Doc
"\nA `^` suffix makes the trill starts on the higher value,\
    \ while `_` makes it start on the lower value. A second suffix causes it\
    \ to end on the higher or lower value, e.g. `^_` starts high and ends low.\
    \ `-_` has start unspecified, and ends low.\
    \ No suffix causes it to obey the settings in scope."

-- | How to adjust an ornament to fulfill its 'Direction' restrictions.
data Adjust =
    -- | Adjust by shortening the ornament.
    Shorten
    -- | Adjust by increasing the speed.
    | Stretch
    deriving (Adjust
forall a. a -> a -> Bounded a
maxBound :: Adjust
$cmaxBound :: Adjust
minBound :: Adjust
$cminBound :: Adjust
Bounded, Adjust -> Adjust -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Adjust -> Adjust -> Bool
$c/= :: Adjust -> Adjust -> Bool
== :: Adjust -> Adjust -> Bool
$c== :: Adjust -> Adjust -> Bool
Eq, Int -> Adjust
Adjust -> Int
Adjust -> [Adjust]
Adjust -> Adjust
Adjust -> Adjust -> [Adjust]
Adjust -> Adjust -> Adjust -> [Adjust]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Adjust -> Adjust -> Adjust -> [Adjust]
$cenumFromThenTo :: Adjust -> Adjust -> Adjust -> [Adjust]
enumFromTo :: Adjust -> Adjust -> [Adjust]
$cenumFromTo :: Adjust -> Adjust -> [Adjust]
enumFromThen :: Adjust -> Adjust -> [Adjust]
$cenumFromThen :: Adjust -> Adjust -> [Adjust]
enumFrom :: Adjust -> [Adjust]
$cenumFrom :: Adjust -> [Adjust]
fromEnum :: Adjust -> Int
$cfromEnum :: Adjust -> Int
toEnum :: Int -> Adjust
$ctoEnum :: Int -> Adjust
pred :: Adjust -> Adjust
$cpred :: Adjust -> Adjust
succ :: Adjust -> Adjust
$csucc :: Adjust -> Adjust
Enum, Int -> Adjust -> ShowS
[Adjust] -> ShowS
Adjust -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Adjust] -> ShowS
$cshowList :: [Adjust] -> ShowS
show :: Adjust -> String
$cshow :: Adjust -> String
showsPrec :: Int -> Adjust -> ShowS
$cshowsPrec :: Int -> Adjust -> ShowS
Show)

instance ShowVal.ShowVal Adjust
instance Typecheck.Typecheck Adjust
instance Typecheck.ToVal Adjust

adjust_env :: Sig.Parser Adjust
adjust_env :: Parser Adjust
adjust_env = forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.environ ArgName
"adjust" EnvironDefault
Sig.Both Adjust
Shorten
    Doc
"How to adjust a trill to fulfill its start and end pitch restrictions."

-- ** transitions

-- | A signal that alternates between the base and neighbor values.
get_trill_control :: Config -> (ScoreTime, ScoreTime)
    -> ScoreT.Function -> Derive.Deriver [(RealTime, Signal.Y)]
get_trill_control :: Config
-> (ScoreTime, ScoreTime)
-> Function
-> Deriver [(RealTime, Double)]
get_trill_control Config
config (ScoreTime
start, ScoreTime
end) Function
neighbor = do
    RealTime
real_start <- forall a. Time a => a -> Deriver RealTime
Derive.real ScoreTime
start
    let neighbor_low :: Bool
neighbor_low = Function
neighbor RealTime
real_start forall a. Ord a => a -> a -> Bool
< Double
0
    (AbsoluteMode
who_first, [RealTime]
transitions) <- Config
-> (ScoreTime, ScoreTime)
-> Bool
-> Deriver (AbsoluteMode, [RealTime])
get_trill_transitions Config
config (ScoreTime
start, ScoreTime
end)
        Bool
neighbor_low
    let (Function
val1, Function
val2) = case AbsoluteMode
who_first of
            AbsoluteMode
Unison -> (forall a b. a -> b -> a
const Double
0, Function
neighbor)
            AbsoluteMode
Neighbor -> (Function
neighbor, forall a b. a -> b -> a
const Double
0)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Function
-> Function -> RealTime -> [RealTime] -> [(RealTime, Double)]
trill_from_transitions Function
val1 Function
val2 RealTime
real_start [RealTime]
transitions

-- | Like 'get_trill_control', but for a curved trill.
get_trill_control_smooth :: Config
    -> ControlUtil.Curve -> (ScoreTime, ScoreTime) -> ScoreT.Function
    -> Derive.Deriver Signal.Control
get_trill_control_smooth :: Config
-> Curve -> (ScoreTime, ScoreTime) -> Function -> Deriver Control
get_trill_control_smooth Config
config Curve
curve (ScoreTime, ScoreTime)
range Function
neighbor = do
    [(RealTime, Double)]
transpose <- Config
-> (ScoreTime, ScoreTime)
-> Function
-> Deriver [(RealTime, Double)]
get_trill_control
        -- Trills usually omit the transition that coincides with the end
        -- because that would create a zero duration note.  But these
        -- trills are smoothed and thus will still have a segment leading
        -- to the cut-off transition.
        (Config
config { _include_end :: Bool
_include_end = Bool
True })
        (ScoreTime, ScoreTime)
range Function
neighbor
    Control
signal <- Function -> Curve -> [(RealTime, Double)] -> Deriver Control
smooth_trill (forall a b. a -> b -> a
const Double
1) Curve
curve [(RealTime, Double)]
transpose
    forall (m :: * -> *) a. Monad m => a -> m a
return Control
signal


-- | The points in time where the trill should transition between pitches.
get_trill_transitions :: Config -> (ScoreTime, ScoreTime) -> Bool
    -> Derive.Deriver (AbsoluteMode, [RealTime])
get_trill_transitions :: Config
-> (ScoreTime, ScoreTime)
-> Bool
-> Deriver (AbsoluteMode, [RealTime])
get_trill_transitions Config
config (ScoreTime
start, ScoreTime
end) Bool
neighbor_low = do
    let (AbsoluteMode
who_first, Maybe Bool
even_transitions) =
            Bool
-> Maybe Direction -> Maybe Direction -> (AbsoluteMode, Maybe Bool)
convert_direction Bool
neighbor_low (Config -> Maybe Direction
_start_dir Config
config) (Config -> Maybe Direction
_end_dir Config
config)
    ScoreTime
hold <- forall t1 t2. (Time t1, Time t2) => t1 -> t2 -> Deriver ScoreTime
Call.score_duration ScoreTime
start (Config -> Duration
_hold Config
config)
    (AbsoluteMode
who_first,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Config
-> ScoreTime
-> Maybe Bool
-> (ScoreTime, ScoreTime)
-> Deriver [RealTime]
adjusted_transitions Config
config ScoreTime
0 Maybe Bool
even_transitions (ScoreTime
start forall a. Num a => a -> a -> a
+ ScoreTime
hold, ScoreTime
end)

-- | Resolve start and end Directions to the first and second trill notes.
convert_direction :: Bool -> Maybe Direction -> Maybe Direction
    -> (AbsoluteMode, Maybe Bool)
    -- ^ Who starts the trill.  The boolean indicates whether the transitions
    -- should be even to end on the expected end Direction, and Nothing if it
    -- doesn't matter.
convert_direction :: Bool
-> Maybe Direction -> Maybe Direction -> (AbsoluteMode, Maybe Bool)
convert_direction Bool
neighbor_low Maybe Direction
start Maybe Direction
end = (AbsoluteMode
first, Maybe Bool
even_transitions)
    where
    first :: AbsoluteMode
first = case Maybe Direction
start of
        Maybe Direction
Nothing -> AbsoluteMode
Unison
        Just Direction
Low -> if Bool
neighbor_low then AbsoluteMode
Neighbor else AbsoluteMode
Unison
        Just Direction
High -> if Bool
neighbor_low then AbsoluteMode
Unison else AbsoluteMode
Neighbor
    -- If I end Low, and neighbor is low, and I started with Unison, then val2
    -- is low, so I want even transitions.  Why is it so complicated just to
    -- get a trill to end high or low?
    first_low :: Bool
first_low = case AbsoluteMode
first of
        AbsoluteMode
Unison -> Bool -> Bool
not Bool
neighbor_low
        AbsoluteMode
Neighbor -> Bool
neighbor_low
    even_transitions :: Maybe Bool
even_transitions = case Maybe Direction
end of
        Maybe Direction
Nothing -> forall a. Maybe a
Nothing
        Just Direction
Low -> forall a. a -> Maybe a
Just (Bool -> Bool
not Bool
first_low)
        Just Direction
High -> forall a. a -> Maybe a
Just Bool
first_low

-- | Turn transition times into a trill control.
smooth_trill :: ScoreT.Function -- ^ time to take make the transition,
    -- where 0 is instant and 1 is all available time
    -> ControlUtil.Curve
    -> [(RealTime, Signal.Y)]
    -> Derive.Deriver Signal.Control
smooth_trill :: Function -> Curve -> [(RealTime, Double)] -> Deriver Control
smooth_trill Function
time Curve
curve [(RealTime, Double)]
transitions = do
    RealTime
srate <- Deriver RealTime
Call.get_srate
    -- I used to optimize sig_function == const 0, but it probably doesn't make
    -- much difference.
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Curve -> RealTime -> Function -> [(RealTime, Double)] -> Control
ControlUtil.smooth_relative Curve
curve RealTime
srate Function
time [(RealTime, Double)]
transitions

-- | Get trill transition times, adjusted for all the various fancy parameters
-- that trills have.
adjusted_transitions :: Config
    -> ScoreTime
    -> Maybe Bool -- ^ emit an even number of transitions, or Nothing for
    -- however many will fit
    -> (ScoreTime, ScoreTime) -> Derive.Deriver [RealTime]
adjusted_transitions :: Config
-> ScoreTime
-> Maybe Bool
-> (ScoreTime, ScoreTime)
-> Deriver [RealTime]
adjusted_transitions Config
config ScoreTime
hold Maybe Bool
even (ScoreTime
start, ScoreTime
end) = do
    RealTime
real_end <- forall a. Time a => a -> Deriver RealTime
Derive.real ScoreTime
end
    [RealTime] -> Deriver [RealTime]
add_hold forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> [RealTime] -> [RealTime]
add_bias (Config -> Double
_bias Config
config)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealTime -> Adjust -> [RealTime] -> [RealTime]
adjust_transitions RealTime
real_end (Config -> Adjust
_adjust Config
config)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
trim
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ScoreTime, ScoreTime)
-> Bool -> RealTimeFunctionT -> Deriver [RealTime]
trill_transitions (ScoreTime
start forall a. Num a => a -> a -> a
+ ScoreTime
hold, ScoreTime
end)
            (Config -> Bool
_include_end Config
config) (Config -> RealTimeFunctionT
_speed Config
config)
    where
    add_hold :: [RealTime] -> Deriver [RealTime]
add_hold [RealTime]
transitions
        | ScoreTime
hold forall a. Ord a => a -> a -> Bool
> ScoreTime
0 = (forall a. a -> [a] -> [a]
: forall a. Int -> [a] -> [a]
drop Int
1 [RealTime]
transitions) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Time a => a -> Deriver RealTime
Derive.real ScoreTime
start
        | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return [RealTime]
transitions
    trim :: [a] -> [a]
trim = case Maybe Bool
even of
        Maybe Bool
Nothing -> forall a. a -> a
id
        Just Bool
even -> if Bool
even then forall a. [a] -> [a]
take_even else forall a. [a] -> [a]
take_odd
    take_even :: [a] -> [a]
take_even (a
x:a
y:[a]
zs) = a
x forall a. a -> [a] -> [a]
: a
y forall a. a -> [a] -> [a]
: [a] -> [a]
take_even [a]
zs
    take_even [a]
_ = []
    take_odd :: [a] -> [a]
take_odd [a
x, a
_] = [a
x]
    take_odd (a
x:a
y:[a]
zs) = a
x forall a. a -> [a] -> [a]
: a
y forall a. a -> [a] -> [a]
: [a] -> [a]
take_odd [a]
zs
    take_odd [a]
xs = [a]
xs

adjust_transitions :: RealTime -> Adjust -> [RealTime] -> [RealTime]
adjust_transitions :: RealTime -> Adjust -> [RealTime] -> [RealTime]
adjust_transitions RealTime
_ Adjust
Shorten [RealTime]
ts = [RealTime]
ts
adjust_transitions RealTime
end Adjust
Stretch ts :: [RealTime]
ts@(RealTime
_:RealTime
_:[RealTime]
_) = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. Num a => a -> a -> a
(+) [RealTime]
offsets [RealTime]
ts
    where
    -- (_:_:_) above means both the last and division are safe.
    stretch :: RealTime
stretch = forall a. Ord a => a -> a -> a
max RealTime
0 (RealTime
end forall a. Num a => a -> a -> a
- forall a. [a] -> a
last [RealTime]
ts) 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 [RealTime]
ts forall a. Num a => a -> a -> a
- Int
1)
    offsets :: [RealTime]
offsets = forall a. Num a => a -> a -> [a]
Lists.range_ RealTime
0 RealTime
stretch
adjust_transitions RealTime
_ Adjust
Stretch [RealTime]
ts = [RealTime]
ts

add_bias :: Double -> [RealTime] -> [RealTime]
add_bias :: Double -> [RealTime] -> [RealTime]
add_bias Double
_ [] = []
add_bias Double
bias (RealTime
t:[RealTime]
ts)
    | Double
bias forall a. Eq a => a -> a -> Bool
== Double
0 = RealTime
t forall a. a -> [a] -> [a]
: [RealTime]
ts
    | Double
bias forall a. Ord a => a -> a -> Bool
> Double
0 = RealTime
t forall a. a -> [a] -> [a]
: forall {t}. (Eq t, Num t) => t -> [t] -> [t]
positive (forall a. Ord a => a -> a -> a
min RealTime
1 (Double -> RealTime
RealTime.seconds Double
bias)) [RealTime]
ts
    | Bool
otherwise = forall {t}. (Eq t, Num t) => t -> [t] -> [t]
negative (forall a. Ord a => a -> a -> a
min RealTime
1 (Double -> RealTime
RealTime.seconds (forall a. Num a => a -> a
abs Double
bias))) (RealTime
tforall a. a -> [a] -> [a]
:[RealTime]
ts)
    where
    positive :: t -> [t] -> [t]
positive t
bias (t
x:t
y:[t]
zs) = forall a. (Eq a, Num a) => a -> a -> a -> a
Num.scale t
x t
y t
bias forall a. a -> [a] -> [a]
: t
y forall a. a -> [a] -> [a]
: t -> [t] -> [t]
positive t
bias [t]
zs
    positive t
_ [t]
xs = [t]
xs
    negative :: t -> [t] -> [t]
negative t
bias (t
x:t
y:[t]
zs) = t
x forall a. a -> [a] -> [a]
: forall a. (Eq a, Num a) => a -> a -> a -> a
Num.scale t
x t
y t
bias forall a. a -> [a] -> [a]
: t -> [t] -> [t]
negative t
bias [t]
zs
    negative t
_ [t]
xs = [t]
xs

-- | Make a trill signal from a list of transition times.  It will alternate
-- between values from the given Functions.
trill_from_transitions :: ScoreT.Function -> ScoreT.Function
    -> RealTime -> [RealTime] -> [(RealTime, Signal.Y)]
trill_from_transitions :: Function
-> Function -> RealTime -> [RealTime] -> [(RealTime, Double)]
trill_from_transitions Function
val1 Function
val2 RealTime
start [RealTime]
transitions =
    [(RealTime, Double)]
initial forall a. [a] -> [a] -> [a]
++ [(RealTime
x, Function
sig RealTime
x) | (RealTime
x, Function
sig) <- forall a b. [a] -> [b] -> [(a, b)]
zip [RealTime]
transitions (forall a. [a] -> [a]
cycle [Function
val1, Function
val2])]
    where
    -- Hold might have push the first transition forward, so make a flat
    -- segment for it.
    initial :: [(RealTime, Double)]
initial = case [RealTime]
transitions of
        RealTime
x : [RealTime]
_ | RealTime
start forall a. Ord a => a -> a -> Bool
< RealTime
x -> [(RealTime
start, Function
val1 RealTime
start)]
        [RealTime]
_ -> []

-- | Create trill transition points from a speed.
trill_transitions :: (ScoreTime, ScoreTime) -> Bool
    -> Typecheck.RealTimeFunctionT -> Derive.Deriver [RealTime]
trill_transitions :: (ScoreTime, ScoreTime)
-> Bool -> RealTimeFunctionT -> Deriver [RealTime]
trill_transitions (ScoreTime, ScoreTime)
range Bool
include_end (Typecheck.RealTimeFunctionT TimeT
ttype Function
speed) =
    case TimeT
ttype of
        TimeT
ScoreT.TReal -> (ScoreTime, ScoreTime) -> Bool -> Function -> Deriver [RealTime]
real_transitions (ScoreTime, ScoreTime)
range Bool
include_end Function
speed
        TimeT
ScoreT.TScore -> (ScoreTime, ScoreTime) -> Bool -> Function -> Deriver [RealTime]
score_transitions (ScoreTime, ScoreTime)
range Bool
include_end Function
speed

real_transitions :: (ScoreTime, ScoreTime) -> Bool -> ScoreT.Function
    -> Derive.Deriver [RealTime]
real_transitions :: (ScoreTime, ScoreTime) -> Bool -> Function -> Deriver [RealTime]
real_transitions (ScoreTime
start, ScoreTime
end) Bool
include_end Function
speed = do
    RealTime
start <- forall a. Time a => a -> Deriver RealTime
Derive.real ScoreTime
start
    RealTime
end <- forall a. Time a => a -> Deriver RealTime
Derive.real ScoreTime
end
    forall a. (Ord a, Num a) => a -> a -> Bool -> [a] -> [a]
full_cycles RealTime
RealTime.eta RealTime
end Bool
include_end forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Function -> RealTime -> RealTime -> Deriver [RealTime]
Speed.real_starts Function
speed RealTime
start RealTime
end

score_transitions :: (ScoreTime, ScoreTime) -> Bool -> ScoreT.Function
    -> Derive.Deriver [RealTime]
score_transitions :: (ScoreTime, ScoreTime) -> Bool -> Function -> Deriver [RealTime]
score_transitions (ScoreTime
start, ScoreTime
end) Bool
include_end Function
speed = do
    [ScoreTime]
all_transitions <- Function -> ScoreTime -> ScoreTime -> Deriver [ScoreTime]
Speed.score_starts Function
speed ScoreTime
start ScoreTime
end
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. Time a => a -> Deriver RealTime
Derive.real forall a b. (a -> b) -> a -> b
$ forall a. (Ord a, Num a) => a -> a -> Bool -> [a] -> [a]
full_cycles ScoreTime
ScoreTime.eta ScoreTime
end Bool
include_end [ScoreTime]
all_transitions

-- | Given a list of trill transition times, take only ones with a complete
-- duration.  Otherwise a trill can wind up with a short note at the end, which
-- sounds funny.  However it's ok if the note is slightly too short, as tends
-- to happen with floating point.
full_cycles :: (Ord a, Num a) => a -> a -> Bool -> [a] -> [a]
full_cycles :: forall a. (Ord a, Num a) => a -> a -> Bool -> [a] -> [a]
full_cycles a
eta a
end Bool
include_end [a]
vals
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
cycles = forall a. Int -> [a] -> [a]
take Int
1 [a]
vals
    | Bool
otherwise = [a]
cycles
    where
    cycles :: [a]
cycles = [a] -> [a]
go [a]
vals
    go :: [a] -> [a]
go (a
x1 : [a]
xs) = case [a]
xs of
        a
x2 : [a]
_ | a
x2 forall a. Ord a => a -> a -> Bool
<= a
end forall a. Num a => a -> a -> a
+ a
eta -> a
x1 forall a. a -> [a] -> [a]
: [a] -> [a]
go [a]
xs
        [a]
_ | Bool
include_end Bool -> Bool -> Bool
&& a
x1 forall a. Num a => a -> a -> a
- a
eta forall a. Ord a => a -> a -> Bool
<= a
end -> [a
x1]
        [a]
_ -> []
    go [] = []