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

{- | Carnatic style pitch ornaments.

    The names don't correspond directly with anything traditional, as far as
    I know, but are inspired by <http://www.gswift.com/article-2.html>.

    Pitch ornaments can be expressed either as pitch calls, or as control
    calls meant for a transpose track.  They both have pros and cons:

    Transposition control signal:

    - I can keep the pitches separate and clear and collapse the pitch
    track.  This correctly reflects the underlying swaram, with the gamakam
    as separate ornamentation.

    - Related to the above, each call doesn't need to repeat the the pitch arg,
    so there's less redundancy.  Calls are also simpler with one fewer
    argument.

    Pitch signal:

    - A pitch call can use absolute (@t-nn@) or scalar (@t-diatonic@)
    transposition based on the type of its arguments, while the transpose
    signal has to either use a separate track, or the somewhat awkward @->@
    call.

    - The pitch signal can represent an ornament involving multiple pitches,
    e.g. a slide frome one pitch to another.  A transposition signal can only
    represent offsets from an external pitch.

    So the pitch signal is more powerful, but the transposition signal is often
    more convenient, and can lead to less redundant notation.  Unless I can
    think of a way to get the advantages of both, I might have to have both
    around, with their own versions of the same calls.
-}
module Derive.C.India.Gamakam where
import qualified Data.List.NonEmpty as NonEmpty

import qualified Util.Doc as Doc
import qualified Util.Lists as Lists

import qualified Derive.Args as Args
import qualified Derive.C.Prelude.Trill as Trill
import qualified Derive.Call as Call
import qualified Derive.Call.ControlUtil as ControlUtil
import qualified Derive.Call.Module as Module
import qualified Derive.Call.Tags as Tags
import qualified Derive.Controls as Controls
import qualified Derive.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Expr as Expr
import qualified Derive.Library as Library
import qualified Derive.PSignal as PSignal
import qualified Derive.ScoreT as ScoreT
import qualified Derive.Sig as Sig
import           Derive.Sig (defaulted, defaulted_env, required)
import qualified Derive.Typecheck as Typecheck

import qualified Perform.RealTime as RealTime
import qualified Perform.Signal as Signal

import           Global
import           Types


library :: Library.Library
library :: Library
library = forall a. Monoid a => [a] -> a
mconcat
    [ forall call.
ToLibrary (Generator call) =>
[(Symbol, Generator call)] -> Library
Library.generators forall a b. (a -> b) -> a -> b
$
        [(Symbol
"dip", Generator Pitch
c_dip)
        , (Symbol
"jaru", Generator Pitch
c_jaru)
        , (Symbol
"sgr", TransposeT -> [Y] -> Generator Pitch
c_jaru_intervals TransposeT
ScoreT.TDiatonic [-Y
1, Y
1])
        ] forall a. [a] -> [a] -> [a]
++ forall call.
Text
-> (Maybe Direction -> Maybe Direction -> call) -> [(Symbol, call)]
kampita_variations Text
"kam" Maybe Direction -> Maybe Direction -> Generator Pitch
c_kampita
    , forall call.
ToLibrary (Generator call) =>
[(Symbol, Generator call)] -> Library
Library.generators forall a b. (a -> b) -> a -> b
$
        [ (Symbol
"dip", Generator Control
c_dip_c)
        , (Symbol
"j)", CallName -> Maybe RealTime -> Doc -> Generator Control
jaru_transition_c CallName
"j)" forall a. Maybe a
Nothing
            Doc
"Time for each slide, defaults to `time`.")
        , (Symbol
"j]", CallName -> Maybe RealTime -> Doc -> Generator Control
jaru_transition_c CallName
"j]" (forall a. a -> Maybe a
Just (RealTime
jaru_time_default forall a. Fractional a => a -> a -> a
/ RealTime
2))
            Doc
"Time for each slide.")
        , (Symbol
"sgr", [Y] -> Generator Control
c_jaru_intervals_c [-Y
1, Y
1])
        ]
        forall a. [a] -> [a] -> [a]
++ forall call.
Text
-> (Maybe Direction -> Maybe Direction -> call) -> [(Symbol, call)]
kampita_variations Text
"kam" Maybe Direction -> Maybe Direction -> Generator Control
c_kampita_c
        forall a. [a] -> [a] -> [a]
++ forall call.
Text
-> (Maybe Direction -> Maybe Direction -> call) -> [(Symbol, call)]
kampita_variations Text
"nkam" Maybe Direction -> Maybe Direction -> Generator Control
c_nkampita_c
    ]

module_ :: Module.Module
module_ :: Module
module_ = Module
"india" forall a. Semigroup a => a -> a -> a
<> Module
"gamakam"

kampita_variations :: Text
    -> (Maybe Trill.Direction -> Maybe Trill.Direction -> call)
    -> [(Expr.Symbol, call)]
kampita_variations :: forall call.
Text
-> (Maybe Direction -> Maybe Direction -> call) -> [(Symbol, call)]
kampita_variations Text
name Maybe Direction -> Maybe Direction -> call
call =
    [ (Text -> Symbol
Expr.Symbol forall a b. (a -> b) -> a -> b
$ Maybe Direction -> Text
affix Maybe Direction
s forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Maybe Direction -> Text
affix Maybe Direction
e, Maybe Direction -> Maybe Direction -> call
call Maybe Direction
s Maybe Direction
e)
    | Maybe Direction
s <- [Maybe Direction]
dirs, Maybe Direction
e <- [Maybe Direction]
dirs
    ]
    where
    affix :: Maybe Direction -> Text
affix = Maybe Direction -> Text
Trill.direction_affix
    dirs :: [Maybe Direction]
dirs = [forall a. Maybe a
Nothing, forall a. a -> Maybe a
Just Direction
Trill.Low, forall a. a -> Maybe a
Just Direction
Trill.High]

-- * standard parameters

transition_default :: RealTime
transition_default :: RealTime
transition_default = RealTime
0.08

jaru_time_default :: RealTime
jaru_time_default :: RealTime
jaru_time_default = RealTime
0.15

speed_arg :: Sig.Parser Typecheck.RealTimeFunctionT
speed_arg :: Parser RealTimeFunctionT
speed_arg = forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
defaulted ArgName
"speed" (Int
6 :: Int) Doc
"Alternate pitches at this speed."

neighbor_arg :: Sig.Parser ScoreT.Function
neighbor_arg :: Parser Function
neighbor_arg = forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
defaulted ArgName
"neighbor" (Y
1 :: Double)
    Doc
"Alternate between 0 and this value."

lilt_env :: Sig.Parser Double
lilt_env :: Parser Y
lilt_env = forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.environ ArgName
"lilt" EnvironDefault
Sig.Both (Y
0 :: Double)
    Doc
"Lilt is a horizontal bias to the\
    \ vibrato. A lilt of 1 would place each neighbor on top of the\
    \ following unison, while -1 would place it on the previous one.\
    \ So it should range from -1 < lilt < 1."

-- * pitch calls

c_kampita :: Maybe Trill.Direction -> Maybe Trill.Direction
    -> Derive.Generator Derive.Pitch
c_kampita :: Maybe Direction -> Maybe Direction -> Generator Pitch
c_kampita Maybe Direction
start_dir Maybe Direction
end_dir = forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 CallName
"kam" forall a. Monoid a => a
mempty
    Doc
"This is a kind of trill, but its interval defaults to NNs,\
    \ and transitions between the notes are smooth.  It's intended for\
    \ the vocal microtonal trills common in Carnatic music."
    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
required ArgName
"pitch" Doc
"Base 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
defaulted ArgName
"neighbor" (Y
1 :: Double)
        Doc
"Alternate with a pitch at this interval."
    forall (f :: * -> *) a b. Applicative f => 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 -> EnvironDefault -> deflt -> Doc -> Parser a
defaulted_env ArgName
"transition" EnvironDefault
Sig.Both RealTime
transition_default
        Doc
"Time for each slide."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Duration
Trill.hold_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Y
lilt_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Adjust
Trill.adjust_env
    ) forall a b. (a -> b) -> a -> b
$ \(Pitch
pitch, Typecheck.NnTransposeFunctionT TransposeT
transpose_t Function
neighbor, RealTimeFunctionT
speed,
            RealTime
transition, Duration
hold, Y
lilt, Adjust
adjust) PassedArgs Pitch
args -> do
        Control
transpose <- forall a.
Maybe Direction
-> Maybe Direction
-> Adjust
-> Function
-> RealTimeFunctionT
-> RealTime
-> Duration
-> Y
-> PassedArgs a
-> Deriver Control
kampita Maybe Direction
start_dir Maybe Direction
end_dir Adjust
adjust Function
neighbor RealTimeFunctionT
speed
            RealTime
transition Duration
hold Y
lilt PassedArgs Pitch
args
        RealTime
start <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Pitch
args
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Control -> Typed Control -> Pitch -> Pitch
PSignal.apply_control
            (TransposeT -> Control
Typecheck.transpose_control TransposeT
transpose_t)
            (forall a. a -> Typed a
ScoreT.untyped Control
transpose)
            (RealTime -> Pitch -> Pitch
PSignal.from_sample RealTime
start Pitch
pitch)

trill_transitions :: Maybe Bool -> Trill.Adjust -> Double -> ScoreTime
    -> Typecheck.RealTimeFunctionT -> (ScoreTime, ScoreTime)
    -> Derive.Deriver [RealTime]
trill_transitions :: Maybe Bool
-> Adjust
-> Y
-> ScoreTime
-> RealTimeFunctionT
-> (ScoreTime, ScoreTime)
-> Deriver [RealTime]
trill_transitions Maybe Bool
even Adjust
adjust Y
bias ScoreTime
hold RealTimeFunctionT
speed (ScoreTime, ScoreTime)
start_end =
    Config
-> ScoreTime
-> Maybe Bool
-> (ScoreTime, ScoreTime)
-> Deriver [RealTime]
Trill.adjusted_transitions Config
config ScoreTime
hold Maybe Bool
even (ScoreTime, ScoreTime)
start_end
    where
    config :: Config
config = Trill.Config
        { _start_dir :: Maybe Direction
_start_dir = forall a. Maybe a
Nothing
        , _end_dir :: Maybe Direction
_end_dir = forall a. Maybe a
Nothing
        , _adjust :: Adjust
_adjust = Adjust
adjust
        , _hold :: Duration
_hold = ScoreTime -> Duration
DeriveT.ScoreDuration ScoreTime
0
        , _speed :: RealTimeFunctionT
_speed = RealTimeFunctionT
speed
        , _bias :: Y
_bias = Y
bias
        -- 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.
        , _include_end :: Bool
_include_end = Bool
True
        }

-- | Make a trill signal from a list of transition times.
trill_from_transitions :: ScoreT.Function -> ScoreT.Function
    -> [RealTime] -> [(RealTime, Signal.Y)]
trill_from_transitions :: Function -> Function -> [RealTime] -> [(RealTime, Y)]
trill_from_transitions Function
val1 Function
val2 [RealTime]
transitions =
    [(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])]

-- | Ok, this name is terrible but what else is better?
c_dip :: Derive.Generator Derive.Pitch
c_dip :: Generator Pitch
c_dip = forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 CallName
"dip" forall a. Monoid a => a
mempty
    Doc
"Alternate two intervals, dropping `dyn` on the second. This is useful\
    \ when avoiding a swaram, since it doesn't necessarily emit the base\
    \ pitch."
    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
required ArgName
"pitch" Doc
"Base 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
defaulted ArgName
"high" (Y -> DefaultDiatonic
Typecheck.diatonic Y
1) Doc
"High interval."
    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
defaulted ArgName
"low" (-Y
1 :: Double) Doc
"Low interval."
    forall (f :: * -> *) a b. Applicative f => 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
defaulted ArgName
"dyn" (Y
0.5 :: Double) Doc
"Multiply dyn by this amount."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.environ ArgName
"transition" EnvironDefault
Sig.Both RealTime
transition_default
        Doc
"Time for each slide."
    ) forall a b. (a -> b) -> a -> b
$ \(Pitch
pitch, Typecheck.DefaultDiatonic Transpose
high_, Y
low, RealTimeFunctionT
speed, Y
dyn_scale,
            RealTime
transition) PassedArgs Pitch
args -> do
        let (Y
high, Control
control) = Transpose -> (Y, Control)
Controls.transpose_control Transpose
high_
        Control
transpose <- Y
-> Y
-> RealTimeFunctionT
-> Y
-> RealTime
-> (ScoreTime, ScoreTime)
-> Deriver Control
dip Y
high Y
low RealTimeFunctionT
speed Y
dyn_scale RealTime
transition
            (forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range_or_next PassedArgs Pitch
args)
        RealTime
start <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Pitch
args
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Control -> Typed Control -> Pitch -> Pitch
PSignal.apply_control Control
control (forall a. a -> Typed a
ScoreT.untyped Control
transpose) forall a b. (a -> b) -> a -> b
$
            RealTime -> Pitch -> Pitch
PSignal.from_sample RealTime
start Pitch
pitch

c_jaru :: Derive.Generator Derive.Pitch
c_jaru :: Generator Pitch
c_jaru = forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 CallName
"jaru" forall a. Monoid a => a
mempty
    Doc
"This is a series of grace notes whose pitches are relative to the given\
    \ base pitch."
    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
required ArgName
"pitch" Doc
"Base pitch."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Typecheck a => ArgName -> Doc -> Parser (NonEmpty a)
Sig.many1 ArgName
"interval" Doc
"Intervals from base pitch."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.environ ArgName
"time" EnvironDefault
Sig.Both RealTime
jaru_time_default Doc
"Time for each note."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.environ ArgName
"transition" EnvironDefault
Sig.Both (forall a. Maybe a
Nothing :: Maybe Sig.Dummy)
        Doc
"Time for each slide, defaults to `time`."
    ) forall a b. (a -> b) -> a -> b
$ \(Pitch
pitch, NonEmpty DefaultDiatonic
intervals, RealTime
time, Maybe RealTime
maybe_transition) PassedArgs Pitch
args -> do
        RealTime
start <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Pitch
args
        RealTime
srate <- Deriver RealTime
Call.get_srate
        (NonEmpty Y
intervals, Control
control) <- NonEmpty DefaultDiatonic
-> Deriver State Error (NonEmpty Y, Control)
parse NonEmpty DefaultDiatonic
intervals
        let transition :: RealTime
transition = forall a. a -> Maybe a -> a
fromMaybe RealTime
time Maybe RealTime
maybe_transition
        let sig :: Control
sig = RealTime -> RealTime -> RealTime -> RealTime -> [Y] -> Control
jaru RealTime
srate RealTime
start RealTime
time RealTime
transition (forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Y
intervals)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Control -> Typed Control -> Pitch -> Pitch
PSignal.apply_control Control
control (forall a. a -> Typed a
ScoreT.untyped Control
sig) forall a b. (a -> b) -> a -> b
$
            RealTime -> Pitch -> Pitch
PSignal.from_sample RealTime
start Pitch
pitch
    where
    parse :: NonEmpty DefaultDiatonic
-> Deriver State Error (NonEmpty Y, Control)
parse NonEmpty DefaultDiatonic
intervals
        | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
==Control
control) [Control]
controls = forall (m :: * -> *) a. Monad m => a -> m a
return (NonEmpty Y
xs, Control
control)
        | Bool
otherwise = forall a. HasCallStack => Text -> Deriver a
Derive.throw Text
"all intervals must have the same type"
        where
        (NonEmpty Y
xs, Control
control :| [Control]
controls) = forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
NonEmpty.unzip forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NonEmpty.map
            (Transpose -> (Y, Control)
Controls.transpose_control forall b c a. (b -> c) -> (a -> b) -> a -> c
. DefaultDiatonic -> Transpose
Typecheck.default_diatonic)
            NonEmpty DefaultDiatonic
intervals

c_jaru_intervals :: ScoreT.TransposeT -> [Signal.Y]
    -> Derive.Generator Derive.Pitch
c_jaru_intervals :: TransposeT -> [Y] -> Generator Pitch
c_jaru_intervals TransposeT
transpose [Y]
intervals = forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 CallName
"jaru" forall a. Monoid a => a
mempty
    (Doc
"This is `jaru` hardcoded to " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
Doc.pretty [Y]
intervals 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
<$> forall a. Typecheck a => ArgName -> Doc -> Parser a
required ArgName
"pitch" Doc
"Base 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
defaulted ArgName
"time" RealTime
jaru_time_default Doc
"Time for each note."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
defaulted ArgName
"transition" (forall a. Maybe a
Nothing :: Maybe Sig.Dummy)
        Doc
"Time for each slide, defaults to `time`."
    ) forall a b. (a -> b) -> a -> b
$ \(Pitch
pitch, RealTime
time, Maybe RealTime
maybe_transition) PassedArgs Pitch
args -> do
        RealTime
start <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Pitch
args
        RealTime
srate <- Deriver RealTime
Call.get_srate
        let sig :: Control
sig = RealTime -> RealTime -> RealTime -> RealTime -> [Y] -> Control
jaru RealTime
srate RealTime
start RealTime
time (forall a. a -> Maybe a -> a
fromMaybe RealTime
time Maybe RealTime
maybe_transition)
                [Y]
intervals
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Control -> Typed Control -> Pitch -> Pitch
PSignal.apply_control (TransposeT -> Control
Typecheck.transpose_control TransposeT
transpose)
            (forall a. a -> Typed a
ScoreT.untyped Control
sig) (RealTime -> Pitch -> Pitch
PSignal.from_sample RealTime
start Pitch
pitch)


-- * control calls

c_kampita_c :: Maybe Trill.Direction -> Maybe Trill.Direction
    -> Derive.Generator Derive.Control
c_kampita_c :: Maybe Direction -> Maybe Direction -> Generator Control
c_kampita_c Maybe Direction
start_dir Maybe Direction
end_dir = forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 CallName
"kam" forall a. Monoid a => a
mempty
    Doc
"This is a trill with smooth transitions between the notes. It's intended\
    \ for the microtonal vocal trills common in Carnatic music. `^` is high\
    \ and `_` is low, so `^kam_` starts on the upper note, and ends on the\
    \ lower one. Otherwise, it starts on the unison note and ends on either."
    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 Function
neighbor_arg
    forall (f :: * -> *) a b. Applicative f => 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 -> EnvironDefault -> deflt -> Doc -> Parser a
defaulted_env ArgName
"transition" EnvironDefault
Sig.Both RealTime
transition_default
        Doc
"Time for each slide."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Duration
Trill.hold_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Y
lilt_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Adjust
Trill.adjust_env
    ) forall a b. (a -> b) -> a -> b
$ \(Function
neighbor, RealTimeFunctionT
speed, RealTime
transition, Duration
hold, Y
lilt, Adjust
adjust) PassedArgs Control
args ->
        forall a.
Maybe Direction
-> Maybe Direction
-> Adjust
-> Function
-> RealTimeFunctionT
-> RealTime
-> Duration
-> Y
-> PassedArgs a
-> Deriver Control
kampita Maybe Direction
start_dir Maybe Direction
end_dir Adjust
adjust Function
neighbor RealTimeFunctionT
speed RealTime
transition Duration
hold Y
lilt
            PassedArgs Control
args

-- | You don't think there are too many arguments, do you?
kampita :: Maybe Trill.Direction -> Maybe Trill.Direction -> Trill.Adjust
    -> ScoreT.Function -> Typecheck.RealTimeFunctionT -> RealTime
    -> DeriveT.Duration -> Double -> Derive.PassedArgs a
    -> Derive.Deriver Signal.Control
kampita :: forall a.
Maybe Direction
-> Maybe Direction
-> Adjust
-> Function
-> RealTimeFunctionT
-> RealTime
-> Duration
-> Y
-> PassedArgs a
-> Deriver Control
kampita Maybe Direction
start_dir Maybe Direction
end_dir Adjust
adjust Function
neighbor RealTimeFunctionT
speed RealTime
transition Duration
hold Y
lilt PassedArgs a
args = do
    RealTime
start <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs a
args
    let ((Function
val1, Function
val2), Maybe Bool
even_transitions) = RealTime
-> Function
-> Maybe Direction
-> Maybe Direction
-> ((Function, Function), Maybe Bool)
convert_directions RealTime
start Function
neighbor
            Maybe Direction
start_dir Maybe Direction
end_dir
    ScoreTime
hold <- forall t1 t2. (Time t1, Time t2) => t1 -> t2 -> Deriver ScoreTime
Call.score_duration (forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs a
args) Duration
hold
    RealTime -> Function -> Function -> [RealTime] -> Deriver Control
smooth_trill (-RealTime
transition) Function
val1 Function
val2
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe Bool
-> Adjust
-> Y
-> ScoreTime
-> RealTimeFunctionT
-> (ScoreTime, ScoreTime)
-> Deriver [RealTime]
trill_transitions Maybe Bool
even_transitions Adjust
adjust Y
lilt ScoreTime
hold RealTimeFunctionT
speed
            (forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range_or_next PassedArgs a
args)

smooth_trill :: RealTime -> ScoreT.Function -> ScoreT.Function
    -> [RealTime] -> Derive.Deriver Signal.Control
smooth_trill :: RealTime -> Function -> Function -> [RealTime] -> Deriver Control
smooth_trill RealTime
time Function
val1 Function
val2 [RealTime]
transitions = do
    RealTime
srate <- Deriver RealTime
Call.get_srate
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Curve -> RealTime -> RealTime -> [(RealTime, Y)] -> Control
ControlUtil.smooth_absolute Curve
ControlUtil.Linear RealTime
srate RealTime
time forall a b. (a -> b) -> a -> b
$
        Function -> Function -> [RealTime] -> [(RealTime, Y)]
trill_from_transitions Function
val1 Function
val2 [RealTime]
transitions

convert_directions :: RealTime -> ScoreT.Function -> Maybe Trill.Direction
    -> Maybe Trill.Direction -> ((ScoreT.Function, ScoreT.Function), Maybe Bool)
convert_directions :: RealTime
-> Function
-> Maybe Direction
-> Maybe Direction
-> ((Function, Function), Maybe Bool)
convert_directions RealTime
start_t Function
neighbor Maybe Direction
start Maybe Direction
end = ((Function, Function)
vals, Maybe Bool
even_transitions)
    where
    first :: AbsoluteMode
first = case Maybe Direction
start of
        Maybe Direction
Nothing -> AbsoluteMode
Trill.Unison
        Just Direction
Trill.Low -> if Bool
neighbor_low then AbsoluteMode
Trill.Neighbor else AbsoluteMode
Trill.Unison
        Just Direction
Trill.High -> if Bool
neighbor_low then AbsoluteMode
Trill.Unison else AbsoluteMode
Trill.Neighbor
    vals :: (Function, Function)
vals = case AbsoluteMode
first of
        AbsoluteMode
Trill.Unison -> (forall a b. a -> b -> a
const Y
0, Function
neighbor)
        AbsoluteMode
Trill.Neighbor -> (Function
neighbor, forall a b. a -> b -> a
const Y
0)
    -- 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
Trill.Unison -> Bool -> Bool
not Bool
neighbor_low
        AbsoluteMode
Trill.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
Trill.Low -> forall a. a -> Maybe a
Just (Bool -> Bool
not Bool
first_low)
        Just Direction
Trill.High -> forall a. a -> Maybe a
Just Bool
first_low
    neighbor_low :: Bool
neighbor_low = Function
neighbor RealTime
start_t forall a. Ord a => a -> a -> Bool
< Y
0

c_nkampita_c :: Maybe Trill.Direction -> Maybe Trill.Direction
    -> Derive.Generator Derive.Control
c_nkampita_c :: Maybe Direction -> Maybe Direction -> Generator Control
c_nkampita_c Maybe Direction
start_dir Maybe Direction
end_dir = forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 CallName
"nkam" forall a. Monoid a => a
mempty
    Doc
"`kam` with a set number of cycles. The speed adjusts to fit the cycles in\
    \ before the next event."
    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 Function
neighbor_arg
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a. Positive a -> a
Typecheck.positive forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
defaulted ArgName
"cycles" (Y
1 :: Double)
        Doc
"Number of cycles.")
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Y
lilt_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Duration
Trill.hold_env
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.environ ArgName
"transition" EnvironDefault
Sig.Both RealTime
transition_default
        Doc
"Time for each slide."
    ) forall a b. (a -> b) -> a -> b
$ \(Function
neighbor, Y
cycles, Y
lilt, Duration
hold, RealTime
transition) PassedArgs Control
args -> do
        (RealTime
start, RealTime
end) <- forall a. PassedArgs a -> Deriver (RealTime, RealTime)
Args.real_range_or_next PassedArgs Control
args
        let ((Function
val1, Function
val2), Maybe Bool
even_transitions) = RealTime
-> Function
-> Maybe Direction
-> Maybe Direction
-> ((Function, Function), Maybe Bool)
convert_directions RealTime
start
                Function
neighbor Maybe Direction
start_dir Maybe Direction
end_dir
        ScoreTime
hold <- forall t1 t2. (Time t1, Time t2) => t1 -> t2 -> Deriver ScoreTime
Call.score_duration (forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs Control
args) Duration
hold
        -- In order to hear the cycles clearly, I leave a one transition of
        -- flat space at the end.  This means nkam can't transition into the
        -- next note, but for now this seems more convenient.
        let num_transitions :: Y
num_transitions = Y
1 forall a. Num a => a -> a -> a
+ Y
cycles forall a. Num a => a -> a -> a
* Y
2
                forall a. Num a => a -> a -> a
+ (if Maybe Bool
even_transitions forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Bool
True then Y
0 else Y
1)
        let speed :: RealTimeFunctionT
speed = TimeT -> Function -> RealTimeFunctionT
Typecheck.RealTimeFunctionT TimeT
ScoreT.TReal
                (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ (Y
num_transitions forall a. Num a => a -> a -> a
- Y
1)
                    forall a. Fractional a => a -> a -> a
/ Function
RealTime.to_seconds (RealTime
end forall a. Num a => a -> a -> a
- RealTime
start))
        [RealTime]
transitions <- Maybe Bool
-> Adjust
-> Y
-> ScoreTime
-> RealTimeFunctionT
-> (ScoreTime, ScoreTime)
-> Deriver [RealTime]
trill_transitions forall a. Maybe a
Nothing Adjust
Trill.Shorten Y
lilt ScoreTime
hold RealTimeFunctionT
speed
                (forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range_or_next PassedArgs Control
args)
        RealTime -> Function -> Function -> [RealTime] -> Deriver Control
smooth_trill (-RealTime
transition) Function
val1 Function
val2 (forall a. Int -> [a] -> [a]
Lists.dropEnd Int
1 [RealTime]
transitions)

-- | Ok, this name is terrible but what else is better?
c_dip_c :: Derive.Generator Derive.Control
c_dip_c :: Generator Control
c_dip_c = forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 CallName
"dip" forall a. Monoid a => a
mempty
    Doc
"Alternate two intervals, dropping `dyn` on the second. This is useful\
    \ when avoiding a swaram, since it doesn't necessarily emit the base\
    \ pitch."
    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
defaulted ArgName
"high" (Y
1 :: Double) Doc
"High interval."
    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
defaulted ArgName
"low" (-Y
1 :: Double) Doc
"Low interval."
    forall (f :: * -> *) a b. Applicative f => 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
defaulted ArgName
"dyn" (Y
0.5 :: Double) Doc
"Multiply dyn by this amount."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.environ ArgName
"transition" EnvironDefault
Sig.Both RealTime
transition_default
        Doc
"Time for each slide."
    ) forall a b. (a -> b) -> a -> b
$ \(Y
high, Y
low, RealTimeFunctionT
speed, Y
dyn_scale, RealTime
transition) PassedArgs Control
args ->
        Y
-> Y
-> RealTimeFunctionT
-> Y
-> RealTime
-> (ScoreTime, ScoreTime)
-> Deriver Control
dip Y
high Y
low RealTimeFunctionT
speed Y
dyn_scale RealTime
transition (forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range_or_next PassedArgs Control
args)

dip :: Double -> Double -> Typecheck.RealTimeFunctionT -> Double
    -> RealTime -> (ScoreTime, ScoreTime) -> Derive.Deriver Signal.Control
dip :: Y
-> Y
-> RealTimeFunctionT
-> Y
-> RealTime
-> (ScoreTime, ScoreTime)
-> Deriver Control
dip Y
high Y
low RealTimeFunctionT
speed Y
dyn_scale RealTime
transition (ScoreTime
start, ScoreTime
end) = do
    RealTime
srate <- Deriver RealTime
Call.get_srate
    [RealTime]
transitions <- (ScoreTime, ScoreTime)
-> Bool -> RealTimeFunctionT -> Deriver [RealTime]
Trill.trill_transitions (ScoreTime
start, ScoreTime
end) Bool
False RealTimeFunctionT
speed
    let smooth :: [(RealTime, Y)] -> Control
smooth = Curve -> RealTime -> RealTime -> [(RealTime, Y)] -> Control
ControlUtil.smooth_absolute Curve
ControlUtil.Linear RealTime
srate
            (-RealTime
transition forall a. Fractional a => a -> a -> a
/ RealTime
2)
        transpose :: Control
transpose = [(RealTime, Y)] -> Control
smooth forall a b. (a -> b) -> a -> b
$
            Function -> Function -> [RealTime] -> [(RealTime, Y)]
trill_from_transitions (forall a b. a -> b -> a
const Y
high) (forall a b. a -> b -> a
const Y
low) [RealTime]
transitions
        dyn :: Control
dyn = [(RealTime, Y)] -> Control
smooth forall a b. (a -> b) -> a -> b
$
            Function -> Function -> [RealTime] -> [(RealTime, Y)]
trill_from_transitions (forall a b. a -> b -> a
const Y
1) (forall a b. a -> b -> a
const Y
dyn_scale) [RealTime]
transitions
    RealTime
end <- forall a. Time a => a -> Deriver RealTime
Derive.real ScoreTime
end
    RealTime -> Control -> Deriver ()
ControlUtil.multiply_dyn RealTime
end Control
dyn
    forall (m :: * -> *) a. Monad m => a -> m a
return Control
transpose

jaru_transition_c :: Derive.CallName -> Maybe RealTime -> Doc.Doc
    -> Derive.Generator Derive.Control
jaru_transition_c :: CallName -> Maybe RealTime -> Doc -> Generator Control
jaru_transition_c CallName
name Maybe RealTime
default_transition Doc
transition_doc =
    forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 CallName
name forall a. Monoid a => a
mempty
    Doc
"This is a series of grace notes with relative pitches."
    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 (NonEmpty a)
Sig.many1 ArgName
"interval" Doc
"Intervals from base pitch."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.environ ArgName
"time" EnvironDefault
Sig.Both RealTime
jaru_time_default Doc
"Time for each note."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.environ ArgName
"transition" EnvironDefault
Sig.Both Maybe RealTime
default_transition Doc
transition_doc
    ) forall a b. (a -> b) -> a -> b
$ \(NonEmpty Y
intervals, RealTime
time, Maybe RealTime
maybe_transition) PassedArgs Control
args -> do
        RealTime
start <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Control
args
        RealTime
srate <- Deriver RealTime
Call.get_srate
        let transition :: RealTime
transition = forall a. a -> Maybe a -> a
fromMaybe RealTime
time Maybe RealTime
maybe_transition
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ RealTime -> RealTime -> RealTime -> RealTime -> [Y] -> Control
jaru RealTime
srate RealTime
start RealTime
time RealTime
transition (forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Y
intervals)

c_jaru_intervals_c :: [Signal.Y] -> Derive.Generator Derive.Control
c_jaru_intervals_c :: [Y] -> Generator Control
c_jaru_intervals_c [Y]
intervals = forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 CallName
"jaru" forall a. Monoid a => a
mempty
    (Doc
"This is `jaru` hardcoded to " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
Doc.pretty [Y]
intervals 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
<$> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
defaulted ArgName
"time" RealTime
jaru_time_default Doc
"Time for each note."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
defaulted ArgName
"transition" (forall a. Maybe a
Nothing :: Maybe Sig.Dummy)
        Doc
"Time for each slide, defaults to `time`."
    ) forall a b. (a -> b) -> a -> b
$ \(RealTime
time, Maybe RealTime
maybe_transition) PassedArgs Control
args -> do
        RealTime
start <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Control
args
        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 -> RealTime -> RealTime -> [Y] -> Control
jaru RealTime
srate RealTime
start RealTime
time (forall a. a -> Maybe a -> a
fromMaybe RealTime
time Maybe RealTime
maybe_transition)
            [Y]
intervals

jaru :: RealTime -> RealTime -> RealTime -> RealTime -> [Signal.Y]
    -> Signal.Control
jaru :: RealTime -> RealTime -> RealTime -> RealTime -> [Y] -> Control
jaru RealTime
srate RealTime
start RealTime
time RealTime
transition [Y]
intervals =
    Curve -> RealTime -> RealTime -> [(RealTime, Y)] -> Control
ControlUtil.smooth_absolute Curve
ControlUtil.Linear RealTime
srate (-RealTime
transition) forall a b. (a -> b) -> a -> b
$
        forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. Num a => a -> a -> [a]
Lists.range_ RealTime
start RealTime
time) ([Y]
intervals forall a. [a] -> [a] -> [a]
++ [Y
0])

generator1 :: Derive.CallName -> Tags.Tags -> Doc.Doc
    -> Derive.WithArgDoc (Derive.PassedArgs d -> Derive.Deriver d)
    -> Derive.Call (Derive.GeneratorFunc d)
generator1 :: forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Generator d
Derive.generator1 Module
module_