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

-- | Basic calls for control tracks.
module Derive.C.Prelude.Control (library) where
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map as Map

import qualified Util.Doc as Doc
import qualified Util.Num as Num
import qualified Derive.Args as Args
import qualified Derive.Call as Call
import qualified Derive.Call.ControlUtil as ControlUtil
import qualified Derive.Call.Module as Module
import qualified Derive.Call.Post as Post
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.Expr as Expr
import qualified Derive.Library as Library
import qualified Derive.Parse as Parse
import qualified Derive.ScoreT as ScoreT
import qualified Derive.Sig as Sig
import qualified Derive.Stream as Stream
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
"set", Generator Control
c_set)
        , (Symbol
"'", Generator Control
c_set_prev)
        , (Symbol
"p", Generator Control
c_porta)
        , (Symbol
"abs", Generator Control
c_abs)
        , (Symbol
"dyn-pp", CallName -> Y -> Generator Control
c_dynamic CallName
"pp" Y
0.05)
        , (Symbol
"dyn-p", CallName -> Y -> Generator Control
c_dynamic CallName
"p" Y
0.25)
        , (Symbol
"dyn-mf", CallName -> Y -> Generator Control
c_dynamic CallName
"mf" Y
0.5)
        , (Symbol
"dyn-f", CallName -> Y -> Generator Control
c_dynamic CallName
"f" Y
0.75)
        , (Symbol
"dyn-ff", CallName -> Y -> Generator Control
c_dynamic CallName
"ff" Y
0.95)

        -- misc
        , (Symbol
"bp>", Generator Control
c_breakpoint_next)
        , (Symbol
"bpm", Generator Control
c_bpm)
        , (Symbol
"n", Generator Control
c_neighbor)
        , (Symbol
"d", Generator Control
c_down)
        , (Symbol
"df", Generator Control
c_down_from)
        , (Symbol
"uf", Generator Control
c_up_from)
        , (Symbol
"u", Generator Control
c_up)

        -- not sure which one I'll like better
        , (Symbol
"`ped`", Generator Control
c_pedal)
        , (Symbol
"ped", Generator Control
c_pedal)
        , (Symbol
"swell", Generator Control
c_swell)
        ] forall a. [a] -> [a] -> [a]
++ [(Symbol, Generator Control)]
ControlUtil.interpolator_variations
    , forall call. ToLibrary call => PatternCall call -> Library
Library.pattern PatternCall (Generator Control)
pattern_generator
    , forall call. ToLibrary call => PatternCall call -> Library
Library.pattern PatternCall (Transformer Control)
pattern_transformer
    ]

-- | This is a special pattern for control tracks that lets you directly type
-- a number, and have that be interpreted as setting the control to that value.
-- In addition, it allows a special hex syntax
--
-- Formerly, control tracks used a slightly different parser to enable the same
-- thing, but that turned out to be awkward when I wanted to implement
-- 'Derive.Eval.eval_event'.
pattern_generator :: Derive.PatternCall (Derive.Generator Derive.Control)
pattern_generator :: PatternCall (Generator Control)
pattern_generator = forall d. (Y -> Call d) -> PatternCall (Call d)
pattern_call forall a b. (a -> b) -> a -> b
$ \Y
val -> forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 CallName
"set" forall a. Monoid a => a
mempty
    Doc
"Emit a sample with no interpolation. This accepts either decimal\
    \ numbers or hex numbers that look like `\\`0x\\`xx`.  The hex\
    \ is divided by 255, so they represent a number between 0 and 1.\n" forall a b. (a -> b) -> a -> b
$
    forall y d.
Taggable y =>
Generator y d -> WithArgDoc (Generator y d)
Sig.call0 forall a b. (a -> b) -> a -> b
$ \PassedArgs Control
args -> do
        RealTime
pos <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Control
args
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall {k} (kind :: k). RealTime -> Y -> Signal kind
Signal.from_sample RealTime
pos Y
val

pattern_transformer :: Derive.PatternCall (Derive.Transformer Derive.Control)
pattern_transformer :: PatternCall (Transformer Control)
pattern_transformer = forall d. (Y -> Call d) -> PatternCall (Call d)
pattern_call forall a b. (a -> b) -> a -> b
$ \Y
val ->
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude CallName
"set" forall a. Monoid a => a
mempty
    Doc
"Prepend a sample to a signal. This is useful to create a discontinuity,\
    \ e.g. interpolate to a value and then jump to another one."
    forall a b. (a -> b) -> a -> b
$ forall y d.
Taggable y =>
Transformer y d -> WithArgDoc (Transformer y d)
Sig.call0t forall a b. (a -> b) -> a -> b
$ \PassedArgs Control
args Deriver (Stream Control)
deriver -> do
        RealTime
pos <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Control
args
        forall sig.
Monoid sig =>
(sig -> sig) -> Deriver (Stream sig) -> Deriver (Stream sig)
Post.signal (forall a. Semigroup a => a -> a -> a
<> forall {k} (kind :: k). RealTime -> Y -> Signal kind
Signal.from_sample RealTime
pos Y
val) Deriver (Stream Control)
deriver

pattern_call :: (Signal.Y -> Derive.Call d)
    -> Derive.PatternCall (Derive.Call d)
pattern_call :: forall d. (Y -> Call d) -> PatternCall (Call d)
pattern_call Y -> Call d
call = Derive.PatternCall
    { pat_description :: Text
pat_description = Text
"numbers and hex"
    , pat_doc :: DocumentedCall
pat_doc = forall d. Call d -> DocumentedCall
Derive.extract_doc (Y -> Call d
call Y
0)
    , pat_function :: Symbol -> Deriver (Maybe (Call d))
pat_function = \(Expr.Symbol Text
sym) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! case Text -> Either Text Y
Parse.parse_num Text
sym of
        Left Text
_ -> forall a. Maybe a
Nothing
        Right Y
val -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Y -> Call d
call Y
val
    }

c_set :: Derive.Generator Derive.Control
c_set :: Generator Control
c_set = forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 CallName
"set" forall a. Monoid a => a
mempty Doc
"Emit a sample with no interpolation." forall a b. (a -> b) -> a -> b
$
    forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call (forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"to" Doc
"Destination value.") forall a b. (a -> b) -> a -> b
$ \Y
to PassedArgs Control
args -> do
        RealTime
pos <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Control
args
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall {k} (kind :: k). RealTime -> Y -> Signal kind
Signal.from_sample RealTime
pos Y
to

c_set_prev :: Derive.Generator Derive.Control
c_set_prev :: Generator Control
c_set_prev = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
Module.prelude CallName
"set-prev" Tags
Tags.prev
    Doc
"Re-set the previous value. This can be used to extend a breakpoint."
    forall a b. (a -> b) -> a -> b
$ forall y d.
Taggable y =>
Generator y d -> WithArgDoc (Generator y d)
Sig.call0 forall a b. (a -> b) -> a -> b
$ \PassedArgs Control
args -> case PassedArgs Control -> Maybe (RealTime, Y)
Args.prev_control PassedArgs Control
args of
        Maybe (RealTime, Y)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Stream a
Stream.empty
        Just (RealTime
x, Y
y) -> do
            RealTime
start <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Control
args
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if RealTime
start forall a. Ord a => a -> a -> Bool
> RealTime
x
                then forall a. a -> Stream a
Stream.from_event forall a b. (a -> b) -> a -> b
$ forall {k} (kind :: k). RealTime -> Y -> Signal kind
Signal.from_sample RealTime
start Y
y
                else forall a. Stream a
Stream.empty

c_porta :: Derive.Generator Derive.Control
c_porta :: Generator Control
c_porta = forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 CallName
"porta" forall a. Monoid a => a
mempty
    Doc
"Interpolate between two values. This is similar to `i>>`,  but intended\
    \ to be higher level, in that instruments or scores can override it to\
    \ represent an idiomatic portamento."
    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
"to" Doc
"Destination value."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (DefaultReal -> Duration
Typecheck._real 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
"time"
        DefaultReal
ControlUtil.default_interpolation_time Doc
"Time to reach destination.")
    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.defaulted_env ArgName
"place" EnvironDefault
Sig.Both (Y -> Normalized
Typecheck.Normalized Y
1)
        Doc
"Placement, from before to after the call."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe Y)
ControlUtil.from_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Curve
ControlUtil.curve_env
    ) forall a b. (a -> b) -> a -> b
$ \(Y
to, Duration
time, Normalized
place, Maybe Y
from, Curve
curve) PassedArgs Control
args -> do
        let maybe_from :: Maybe Y
maybe_from = Maybe Y
from forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PassedArgs Control -> Maybe (RealTime, Y)
Args.prev_control PassedArgs Control
args)
        Duration
time <- if forall a. PassedArgs a -> TrackTime
Args.duration PassedArgs Control
args forall a. Eq a => a -> a -> Bool
== TrackTime
0
            then forall (m :: * -> *) a. Monad m => a -> m a
return Duration
time
            else RealTime -> Duration
DeriveT.RealDuration forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. PassedArgs a -> Deriver RealTime
Args.real_duration PassedArgs Control
args
        (RealTime
start, RealTime
end) <- Normalized -> TrackTime -> Duration -> Deriver (RealTime, RealTime)
ControlUtil.place_range Normalized
place (forall a. PassedArgs a -> TrackTime
Args.start PassedArgs Control
args) Duration
time
        Curve -> RealTime -> Maybe Y -> RealTime -> Y -> Deriver Control
ControlUtil.make_segment_from Curve
curve RealTime
start Maybe Y
maybe_from RealTime
end Y
to

c_abs :: Derive.Generator Derive.Control
c_abs :: Generator Control
c_abs = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Generator d
Derive.generator1 Module
Module.prelude CallName
"abs" forall a. Monoid a => a
mempty
    Doc
"Set the control to an absolute value, provided this control is combined\
    \ via multiplication."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call (forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"val" Doc
"Set to this value.") forall a b. (a -> b) -> a -> b
$ \Y
val PassedArgs Control
args ->
        Y -> RealTime -> Deriver Control
set_absolute Y
val forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Control
args

c_dynamic :: Derive.CallName -> Signal.Y -> Derive.Generator Derive.Control
c_dynamic :: CallName -> Y -> Generator Control
c_dynamic CallName
name Y
val = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Generator d
Derive.generator1 Module
Module.prelude CallName
name forall a. Monoid a => a
mempty
    Doc
"Set the control to an absolute value. This is useful for the `dyn`\
    \ control, so a part can override the dynamic in scope."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call (forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"val" Y
val Doc
"Set to this value.") forall a b. (a -> b) -> a -> b
$ \Y
val PassedArgs Control
args ->
        Y -> RealTime -> Deriver Control
set_absolute Y
val forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Control
args

set_absolute :: Signal.Y -> RealTime -> Derive.Deriver Signal.Control
set_absolute :: Y -> RealTime -> Deriver Control
set_absolute Y
val RealTime
pos = do
    Maybe Text
control <- forall a. Typecheck a => Text -> Deriver (Maybe a)
Derive.lookup_val Text
EnvKey.control
    Maybe Text
merge <- forall a. Typecheck a => Text -> Deriver (Maybe a)
Derive.lookup_val Text
EnvKey.merge
    Y
out <- Maybe Text -> Maybe Text -> Deriver State Error Y
set Maybe Text
control Maybe Text
merge
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall {k} (kind :: k). RealTime -> Y -> Signal kind
Signal.from_sample RealTime
pos Y
out
    where
    set :: Maybe Text -> Maybe Text -> Deriver State Error Y
set Maybe Text
Nothing Maybe Text
_ = forall (m :: * -> *) a. Monad m => a -> m a
return Y
val
    set (Just Text
control) Maybe Text
Nothing =
        forall a. HasCallStack => Text -> Deriver a
Derive.throw forall a b. (a -> b) -> a -> b
$ Text
"merge not set for " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Text
control
    set (Just Text
control) (Just Text
merge) =
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return Y
val) (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
. Text -> Y -> Y -> Either Text Y
invert_merge Text
merge Y
val)
            forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Control -> RealTime -> Deriver (Maybe Y)
Derive.untyped_control_at (Text -> Control
ScoreT.Control Text
control) RealTime
pos

-- | Figure out what value to emit which, once merged with the signal in scope,
-- will become the given absolute value.  TODO this is kind of a crazy hack and
-- I'm not sure if I'm in love with it.
invert_merge :: Text -> Signal.Y -> Signal.Y -> Either Text Signal.Y
invert_merge :: Text -> Y -> Y -> Either Text Y
invert_merge Text
merge Y
val Y
current_val = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
merge Map Text (Y -> Y -> Y)
inverters of
    Maybe (Y -> Y -> Y)
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"no way to invert merge type: " forall a. Semigroup a => a -> a -> a
<> Text
merge
    Just Y -> Y -> Y
f -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Y -> Y -> Y
f Y
current_val Y
val
    where
    inverters :: Map Text (Y -> Y -> Y)
inverters = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (Text
"set", \Y
_ Y
new -> Y
new)
        , (Merger -> Text
n Merger
Derive.merge_add, \Y
old Y
new -> Y
new forall a. Num a => a -> a -> a
- Y
old)
        , (Merger -> Text
n Merger
Derive.merge_sub, \Y
old Y
new -> Y
old forall a. Num a => a -> a -> a
- Y
new)
        , (Merger -> Text
n Merger
Derive.merge_mul, \Y
old Y
new -> if Y
old forall a. Eq a => a -> a -> Bool
== Y
0 then Y
0 else Y
new forall a. Fractional a => a -> a -> a
/ Y
old)
        , (Merger -> Text
n Merger
Derive.merge_scale, Y -> Y -> Y
Signal.scale_invert)
        ]
    n :: Merger -> Text
n (Derive.Merger Text
name Control -> Control -> Control
_ Y
_) = Text
name
    n Merger
Derive.Set = Text
"set"
    n Merger
Derive.Unset = Text
"unset"


-- * misc

-- TODO it's linear for now, but I could add an env val to set interpolation
c_breakpoint_next :: Derive.Generator Derive.Control
c_breakpoint_next :: Generator Control
c_breakpoint_next = forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 CallName
"breakpoint" forall a. Monoid a => a
mempty
    Doc
"Interpolate between the given values. Breakpoints start at this event and\
    \ end at the next one."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call (forall a. Typecheck a => ArgName -> Doc -> Parser (NonEmpty a)
Sig.many1 ArgName
"val" Doc
"Breakpoints are distributed evenly between\
        \ this event and the next event.")
    forall a b. (a -> b) -> a -> b
$ \NonEmpty Y
vals PassedArgs Control
args -> do
        (RealTime
start, RealTime
end) <- forall a. PassedArgs a -> Deriver (RealTime, RealTime)
Args.real_range_or_next 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 -> Curve -> [(RealTime, Y)] -> Control
ControlUtil.breakpoints RealTime
srate Curve
ControlUtil.Linear forall a b. (a -> b) -> a -> b
$
            forall a. RealTime -> RealTime -> [a] -> [(RealTime, a)]
ControlUtil.distribute RealTime
start RealTime
end (forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Y
vals)

c_bpm :: Derive.Generator Derive.Control
c_bpm :: Generator Control
c_bpm = forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 CallName
"bpm" forall a. Monoid a => a
mempty
    Doc
"Set a tempo value for the given bpm, which is just (/60)."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call (forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"bpm" Doc
"")
    forall a b. (a -> b) -> a -> b
$ \Y
val PassedArgs Control
args -> do
        RealTime
pos <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Control
args
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall {k} (kind :: k). RealTime -> Y -> Signal kind
Signal.from_sample RealTime
pos (Y
val forall a. Fractional a => a -> a -> a
/ Y
60)

c_neighbor :: Derive.Generator Derive.Control
c_neighbor :: Generator Control
c_neighbor = forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 CallName
"neighbor" forall a. Monoid a => a
mempty
    (Doc
"Emit a slide from a value to 0 in absolute time. This is the control\
    \ equivalent of the neighbor pitch call."
    ) 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" (Y
1 :: Double) Doc
"Start at 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
"time" (RealTime -> DefaultReal
Typecheck.real RealTime
0.1) Doc
"Time taken to get to 0."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Curve
ControlUtil.curve_env
    ) forall a b. (a -> b) -> a -> b
$ \(Y
neighbor, Typecheck.DefaultReal Duration
time, Curve
curve) PassedArgs Control
args -> do
        (RealTime
start, RealTime
end) <- forall t d.
Time t =>
PassedArgs d -> t -> Deriver (RealTime, RealTime)
Call.duration_from_start PassedArgs Control
args Duration
time
        Curve -> RealTime -> Y -> RealTime -> Y -> Deriver Control
ControlUtil.make_segment Curve
curve RealTime
start Y
neighbor RealTime
end Y
0

c_up :: Derive.Generator Derive.Control
c_up :: Generator Control
c_up = forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 CallName
"u" Tags
Tags.prev
    Doc
"Ascend at the given speed until the value reaches a limit or 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
<$> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"speed" (Y
1 :: Double) Doc
"Ascend this amount per second."
    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
"limit" (forall a. Maybe a
Nothing :: Maybe Double) Doc
"Stop at this value."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe Y)
ControlUtil.from_env
    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
EnvKey.control_gt_0 Bool
False
        Doc
"Whether or not to limit to 1 by default."
    ) forall a b. (a -> b) -> a -> b
$ \(Y
speed, Maybe Y
limit, Maybe Y
from, Bool
gt0) PassedArgs Control
args ->
        PassedArgs Control
-> Maybe Y -> Maybe Y -> Maybe Y -> Y -> Deriver Control
make_slope PassedArgs Control
args forall a. Maybe a
Nothing
            (if Bool
gt0 then Maybe Y
limit else forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Y
1 Maybe Y
limit)
            Maybe Y
from Y
speed

c_down :: Derive.Generator Derive.Control
c_down :: Generator Control
c_down = forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 CallName
"d" Tags
Tags.prev
    Doc
"Descend at the given speed until the value reaches a limit or 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
<$> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"speed" (Y
1 :: Double) Doc
"Descend this amount per second."
    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
"limit" (Y
0 :: Double) Doc
"Stop at this value."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe Y)
ControlUtil.from_env
    ) forall a b. (a -> b) -> a -> b
$ \(Y
speed, Y
limit, Maybe Y
from) PassedArgs Control
args ->
        PassedArgs Control
-> Maybe Y -> Maybe Y -> Maybe Y -> Y -> Deriver Control
make_slope PassedArgs Control
args (forall a. a -> Maybe a
Just Y
limit) forall a. Maybe a
Nothing Maybe Y
from (-Y
speed)

c_down_from :: Derive.Generator Derive.Control
c_down_from :: Generator Control
c_down_from = forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 CallName
"df" forall a. Monoid a => a
mempty
    Doc
"Drop from a certain value. This is like `d` with `from`, but more\
    \ convenient to write."
    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
"from" (Y
1 :: Double) Doc
"Start at 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
"speed" (Y
1 :: Double) Doc
"Descend this amount per second."
    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
"limit" (Y
0 :: Double) Doc
"Stop at this value."
    ) forall a b. (a -> b) -> a -> b
$ \(Y
from, Y
speed, Y
limit) PassedArgs Control
args ->
        PassedArgs Control
-> Maybe Y -> Maybe Y -> Maybe Y -> Y -> Deriver Control
make_slope PassedArgs Control
args (forall a. a -> Maybe a
Just Y
limit) forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just Y
from) (-Y
speed)

c_up_from :: Derive.Generator Derive.Control
c_up_from :: Generator Control
c_up_from = forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 CallName
"uf" forall a. Monoid a => a
mempty Doc
"Like df, but up."
    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
"from" (Y
0 :: Double) Doc
"Start at 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
"speed" (Y
1 :: Double) Doc
"Ascend this amount per second."
    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
"limit" (Y
1 :: Double) Doc
"Stop at this value."
    ) forall a b. (a -> b) -> a -> b
$ \(Y
from, Y
speed, Y
limit) PassedArgs Control
args ->
        PassedArgs Control
-> Maybe Y -> Maybe Y -> Maybe Y -> Y -> Deriver Control
make_slope PassedArgs Control
args (forall a. a -> Maybe a
Just Y
limit) forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just Y
from) Y
speed

make_slope :: Derive.ControlArgs -> Maybe Signal.Y -> Maybe Signal.Y
    -> Maybe Signal.Y -> Double -> Derive.Deriver Signal.Control
make_slope :: PassedArgs Control
-> Maybe Y -> Maybe Y -> Maybe Y -> Y -> Deriver Control
make_slope PassedArgs Control
args Maybe Y
low Maybe Y
high Maybe Y
maybe_from Y
slope =
    case Maybe Y
maybe_from forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Y -> PassedArgs Control -> Maybe Y
ControlUtil.prev_val Maybe Y
maybe_from PassedArgs Control
args of
        Maybe Y
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
        Just Y
from -> do
            (RealTime
start, RealTime
end) <- forall a. PassedArgs a -> Deriver (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
$ Maybe Y -> Maybe Y -> Y -> Y -> RealTime -> RealTime -> Control
ControlUtil.slope_to_limit Maybe Y
low Maybe Y
high Y
from Y
slope RealTime
start RealTime
end

c_pedal :: Derive.Generator Derive.Control
c_pedal :: Generator Control
c_pedal = forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 CallName
"pedal" forall a. Monoid a => a
mempty
    (Doc
"Unlike most control events, this uses a duration. Set the control to\
    \ the given value for the event's duration, and reset to the old\
    \ value afterwards."
    ) 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
"val" (Y
1 :: Double) Doc
"Set to this value."
    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
"dur" EnvironDefault
Sig.Prefixed (Y
0.05 :: Double)
        Doc
"Use this duration if the event duration is 0."
    ) forall a b. (a -> b) -> a -> b
$ \(Y
val, RealTime
dur) PassedArgs Control
args -> do
        (RealTime
start, RealTime
end) <- forall a. PassedArgs a -> Deriver (RealTime, RealTime)
Args.real_range PassedArgs Control
args
        RealTime
end <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if RealTime
start forall a. Eq a => a -> a -> Bool
== RealTime
end then RealTime
end forall a. Num a => a -> a -> a
+ RealTime
dur else RealTime
end
        let prev :: Y
prev = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Y
0 forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ PassedArgs Control -> Maybe (RealTime, Y)
Args.prev_control PassedArgs Control
args
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall {k} (kind :: k). [(RealTime, Y)] -> Signal kind
Signal.from_pairs [(RealTime
start, Y
val), (RealTime
end, Y
val), (RealTime
end, Y
prev)]

c_swell :: Derive.Generator Derive.Control
c_swell :: Generator Control
c_swell = forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 CallName
"swell" forall a. Monoid a => a
mempty
    Doc
"Start at the given value, interpolate to a peak, then back to the\
    \ original value. Uses duration."
    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
"val" Doc
"Start 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
"peak" (Y
1 :: Double) Doc
"Interpolate to 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
"bias" (Y
0.5 :: Double)
        Doc
"0 puts the peak at the start, 1 at the end."
    ) forall a b. (a -> b) -> a -> b
$ \(Y
val, Y
peak, Y
bias) PassedArgs Control
args -> do
        (RealTime
start, RealTime
end) <- forall a. PassedArgs a -> Deriver (RealTime, RealTime)
Args.real_range PassedArgs Control
args
        let middle :: RealTime
middle = forall a. Ord a => a -> a -> a -> a
Num.clamp RealTime
start RealTime
end forall a b. (a -> b) -> a -> b
$
                forall a. (Eq a, Num a) => a -> a -> a -> a
Num.scale RealTime
start RealTime
end (Y -> RealTime
RealTime.seconds Y
bias)
        RealTime
srate <- Deriver RealTime
Call.get_srate
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ RealTime -> Curve -> [(RealTime, Y)] -> Control
ControlUtil.breakpoints RealTime
srate Curve
ControlUtil.Linear
            [(RealTime
start, Y
val), (RealTime
middle, Y
peak), (RealTime
end, Y
val)]

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