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

{-# LANGUAGE ExistentialQuantification #-}
-- | Utilities that emit 'Signal.Control's and 'Derive.ControlMod's.
module Derive.Call.ControlUtil where
import qualified Util.Doc as Doc
import qualified Util.Num as Num
import qualified Util.Seq as Seq
import qualified Util.Test.ApproxEq as ApproxEq

import qualified Derive.Args as Args
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Call as Call
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.Expr as Expr
import qualified Derive.ScoreT as ScoreT
import qualified Derive.Sig as Sig
import qualified Derive.Typecheck as Typecheck

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

import           Global
import           Types


-- | Sampling rate.
type SRate = RealTime

-- | Package up a curve name along with arguments.
data CurveD = forall arg. CurveD !Text !(Sig.Parser arg) !(arg -> Curve)

curve_name :: CurveD -> Text
curve_name :: CurveD -> Text
curve_name (CurveD Text
name Parser arg
_ arg -> Curve
_) = Text
name

data Curve = Function !(Double -> Double)
    -- | Signals can represent linear segments directly, so if I keep track of
    -- them, I can use the efficient direct representation.
    | Linear

-- | Interpolation function.  This maps 0--1 to the desired curve, which is
-- also normalized to 0--1.
type CurveF = Double -> Double

standard_curves :: [(Expr.Symbol, CurveD)]
standard_curves :: [(Symbol, CurveD)]
standard_curves =
    [ (Symbol
"i", Text -> Parser () -> (() -> Curve) -> CurveD
forall arg. Text -> Parser arg -> (arg -> Curve) -> CurveD
CurveD Text
"linear" (() -> Parser ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (\() -> Curve
Linear))
    , (Symbol
"e", CurveD
exponential_curve)
    , (Symbol
"s", CurveD
sigmoid_curve)
    ]

-- * interpolator call

-- | Left for an explicit time arg.  Right is for an implicit time, inferred
-- from the args, along with an extra bit of documentation to describe it.
type InterpolatorTime a =
    Either (Sig.Parser DeriveT.Duration) (GetTime a, Text)
type GetTime a = Derive.PassedArgs a -> Derive.Deriver DeriveT.Duration

interpolator_call :: Text -> CurveD
    -> InterpolatorTime Derive.Control -> Derive.Generator Derive.Control
interpolator_call :: Text -> CurveD -> InterpolatorTime Control -> Generator Control
interpolator_call Text
name_suffix (CurveD Text
name Parser arg
get_arg arg -> Curve
curve) InterpolatorTime Control
interpolator_time =
    Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Control -> Deriver Control)
-> Generator Control
forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Generator d
Derive.generator1 Module
Module.prelude (Text -> CallName
Derive.CallName (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name_suffix))
        Tags
Tags.prev Doc
doc
    (WithArgDoc (PassedArgs Control -> Deriver Control)
 -> Generator Control)
-> WithArgDoc (PassedArgs Control -> Deriver Control)
-> Generator Control
forall a b. (a -> b) -> a -> b
$ Parser (Y, Duration, arg, Maybe Y)
-> ((Y, Duration, arg, Maybe Y)
    -> PassedArgs Control -> Deriver Control)
-> WithArgDoc (PassedArgs Control -> Deriver Control)
forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,,,)
    (Y -> Duration -> arg -> Maybe Y -> (Y, Duration, arg, Maybe Y))
-> Parser Y
-> Parser
     (Duration -> arg -> Maybe Y -> (Y, Duration, arg, Maybe Y))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgName -> Doc -> Parser Y
forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"to" Doc
"Destination value."
    Parser (Duration -> arg -> Maybe Y -> (Y, Duration, arg, Maybe Y))
-> Parser Duration
-> Parser (arg -> Maybe Y -> (Y, Duration, arg, Maybe Y))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser Duration -> Parser Duration)
-> ((GetTime Control, Text) -> Parser Duration)
-> InterpolatorTime Control
-> Parser Duration
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Parser Duration -> Parser Duration
forall a. a -> a
id (Parser Duration -> (GetTime Control, Text) -> Parser Duration
forall a b. a -> b -> a
const (Parser Duration -> (GetTime Control, Text) -> Parser Duration)
-> Parser Duration -> (GetTime Control, Text) -> Parser Duration
forall a b. (a -> b) -> a -> b
$ Duration -> Parser Duration
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Duration -> Parser Duration) -> Duration -> Parser Duration
forall a b. (a -> b) -> a -> b
$ RealTime -> Duration
DeriveT.RealDuration RealTime
0) InterpolatorTime Control
interpolator_time
    Parser (arg -> Maybe Y -> (Y, Duration, arg, Maybe Y))
-> Parser arg -> Parser (Maybe Y -> (Y, Duration, arg, Maybe Y))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser arg
get_arg Parser (Maybe Y -> (Y, Duration, arg, Maybe Y))
-> Parser (Maybe Y) -> Parser (Y, Duration, arg, Maybe Y)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe Y)
from_env
    ) (((Y, Duration, arg, Maybe Y)
  -> PassedArgs Control -> Deriver Control)
 -> WithArgDoc (PassedArgs Control -> Deriver Control))
-> ((Y, Duration, arg, Maybe Y)
    -> PassedArgs Control -> Deriver Control)
-> WithArgDoc (PassedArgs Control -> Deriver Control)
forall a b. (a -> b) -> a -> b
$ \(Y
to, Duration
time, arg
curve_arg, Maybe Y
from) PassedArgs Control
args -> do
        Duration
time <- if PassedArgs Control -> ScoreTime
forall a. PassedArgs a -> ScoreTime
Args.duration PassedArgs Control
args ScoreTime -> ScoreTime -> Bool
forall a. Eq a => a -> a -> Bool
== ScoreTime
0
            then case InterpolatorTime Control
interpolator_time of
                Left Parser Duration
_ -> Duration -> Deriver State Error Duration
forall (m :: * -> *) a. Monad m => a -> m a
return Duration
time
                Right (GetTime Control
get_time, Text
_) -> GetTime Control
get_time PassedArgs Control
args
            else RealTime -> Duration
DeriveT.RealDuration (RealTime -> Duration)
-> Deriver State Error RealTime -> Deriver State Error Duration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PassedArgs Control -> Deriver State Error RealTime
forall a. PassedArgs a -> Deriver State Error RealTime
Args.real_duration PassedArgs Control
args
        (RealTime
start, RealTime
end) <- PassedArgs Control -> Duration -> Deriver (RealTime, RealTime)
forall t d.
Time t =>
PassedArgs d -> t -> Deriver (RealTime, RealTime)
Call.duration_from_start PassedArgs Control
args Duration
time
        Curve -> RealTime -> Maybe Y -> RealTime -> Y -> Deriver Control
make_segment_from (arg -> Curve
curve arg
curve_arg)
            (RealTime -> RealTime -> RealTime
forall a. Ord a => a -> a -> a
min RealTime
start RealTime
end) (Maybe Y -> PassedArgs Control -> Maybe Y
prev_val Maybe Y
from PassedArgs Control
args) (RealTime -> RealTime -> RealTime
forall a. Ord a => a -> a -> a
max RealTime
start RealTime
end) Y
to
    where
    doc :: Doc
doc = Text -> Doc
Doc.Doc (Text -> Doc) -> Text -> Doc
forall a b. (a -> b) -> a -> b
$ Text
"Interpolate from the previous value to the given one."
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Parser Duration -> Text)
-> ((GetTime Control, Text) -> Text)
-> InterpolatorTime Control
-> Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> Parser Duration -> Text
forall a b. a -> b -> a
const Text
"") ((Text
" "<>) (Text -> Text)
-> ((GetTime Control, Text) -> Text)
-> (GetTime Control, Text)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GetTime Control, Text) -> Text
forall a b. (a, b) -> b
snd) InterpolatorTime Control
interpolator_time

-- | Use this for calls that start from the previous value, to give a way
-- to override that behaviour.
from_env :: Sig.Parser (Maybe Signal.Y)
from_env :: Parser (Maybe Y)
from_env = ArgName -> EnvironDefault -> Maybe Y -> Doc -> Parser (Maybe Y)
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> EnvironDefault -> a -> Doc -> Parser a
Sig.environ ArgName
"from" EnvironDefault
Sig.Both Maybe Y
forall a. Maybe a
Nothing
    Doc
"Start from this value. If unset, use the previous value."

prev_val :: Maybe Signal.Y -> Derive.ControlArgs -> Maybe Signal.Y
prev_val :: Maybe Y -> PassedArgs Control -> Maybe Y
prev_val Maybe Y
from PassedArgs Control
args = Maybe Y
from Maybe Y -> Maybe Y -> Maybe Y
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((RealTime, Y) -> Y
forall a b. (a, b) -> b
snd ((RealTime, Y) -> Y) -> Maybe (RealTime, Y) -> Maybe Y
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PassedArgs Control -> Maybe (RealTime, Y)
Args.prev_control PassedArgs Control
args)

-- | Create the standard set of interpolator calls.  Generic so it can
-- be used by PitchUtil as well.
interpolator_variations_ :: Derive.Taggable a =>
    (Text -> CurveD -> InterpolatorTime a -> call)
    -> Expr.Symbol -> CurveD -> [(Expr.Symbol, call)]
interpolator_variations_ :: forall a call.
Taggable a =>
(Text -> CurveD -> InterpolatorTime a -> call)
-> Symbol -> CurveD -> [(Symbol, call)]
interpolator_variations_ Text -> CurveD -> InterpolatorTime a -> call
make (Expr.Symbol Text
sym) CurveD
curve =
    [ (Text -> Symbol
mksym Text
sym, Text -> CurveD -> InterpolatorTime a -> call
make Text
"" CurveD
curve InterpolatorTime a
forall {a}.
Either a (PassedArgs a -> Deriver State Error Duration, Text)
prev)
    , (Text -> Symbol
mksym (Text -> Symbol) -> Text -> Symbol
forall a b. (a -> b) -> a -> b
$ Text
sym Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"<<", Text -> CurveD -> InterpolatorTime a -> call
make Text
"-prev-const" CurveD
curve (Parser Duration -> InterpolatorTime a
forall a b. a -> Either a b
Left Parser Duration
prev_time_arg))
    , (Text -> Symbol
mksym (Text -> Symbol) -> Text -> Symbol
forall a b. (a -> b) -> a -> b
$ Text
sym Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
">", Text -> CurveD -> InterpolatorTime a -> call
make Text
"-next" CurveD
curve InterpolatorTime a
forall {a} {a}.
Either a (PassedArgs a -> Deriver State Error Duration, Text)
next)
    , (Text -> Symbol
mksym (Text -> Symbol) -> Text -> Symbol
forall a b. (a -> b) -> a -> b
$ Text
sym Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
">>", Text -> CurveD -> InterpolatorTime a -> call
make Text
"-next-const" CurveD
curve (Parser Duration -> InterpolatorTime a
forall a b. a -> Either a b
Left Parser Duration
next_time_arg))
    ]
    where
    mksym :: Text -> Symbol
mksym = Text -> Symbol
Expr.Symbol
    next_time_arg :: Parser Duration
next_time_arg = DefaultReal -> Duration
Typecheck._real (DefaultReal -> Duration) -> Parser DefaultReal -> Parser Duration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        ArgName -> DefaultReal -> Doc -> Parser DefaultReal
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> a -> Doc -> Parser a
Sig.defaulted ArgName
"time" DefaultReal
default_interpolation_time
            Doc
"Time to reach destination."
    prev_time_arg :: Parser Duration
prev_time_arg = Duration -> Duration
invert (Duration -> Duration)
-> (DefaultReal -> Duration) -> DefaultReal -> Duration
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DefaultReal -> Duration
Typecheck._real (DefaultReal -> Duration) -> Parser DefaultReal -> Parser Duration
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        ArgName -> DefaultReal -> Doc -> Parser DefaultReal
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> a -> Doc -> Parser a
Sig.defaulted ArgName
"time" DefaultReal
default_interpolation_time
            Doc
"Time to reach destination, starting before the event."
    invert :: Duration -> Duration
invert (DeriveT.RealDuration RealTime
t) = RealTime -> Duration
DeriveT.RealDuration (-RealTime
t)
    invert (DeriveT.ScoreDuration ScoreTime
t) = ScoreTime -> Duration
DeriveT.ScoreDuration (-ScoreTime
t)

    next :: Either a (PassedArgs a -> Deriver State Error Duration, Text)
next = (PassedArgs a -> Deriver State Error Duration, Text)
-> Either a (PassedArgs a -> Deriver State Error Duration, Text)
forall a b. b -> Either a b
Right (PassedArgs a -> Deriver State Error Duration
forall {m :: * -> *} {a}. Monad m => PassedArgs a -> m Duration
next, Text
"If the event's duration is 0, interpolate from this\
            \ event to the next.")
        where
        next :: PassedArgs a -> m Duration
next PassedArgs a
args = Duration -> m Duration
forall (m :: * -> *) a. Monad m => a -> m a
return (Duration -> m Duration) -> Duration -> m Duration
forall a b. (a -> b) -> a -> b
$ ScoreTime -> Duration
DeriveT.ScoreDuration (ScoreTime -> Duration) -> ScoreTime -> Duration
forall a b. (a -> b) -> a -> b
$
            PassedArgs a -> ScoreTime
forall a. PassedArgs a -> ScoreTime
Args.next PassedArgs a
args ScoreTime -> ScoreTime -> ScoreTime
forall a. Num a => a -> a -> a
- PassedArgs a -> ScoreTime
forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs a
args
    prev :: Either a (PassedArgs a -> Deriver State Error Duration, Text)
prev = (PassedArgs a -> Deriver State Error Duration, Text)
-> Either a (PassedArgs a -> Deriver State Error Duration, Text)
forall a b. b -> Either a b
Right (PassedArgs a -> Deriver State Error Duration
forall a.
Taggable a =>
PassedArgs a -> Deriver State Error Duration
get_prev_val,
        Text
"If the event's duration is 0, interpolate from the\
        \ previous event to this one.")

default_interpolation_time :: Typecheck.DefaultReal
default_interpolation_time :: DefaultReal
default_interpolation_time = RealTime -> DefaultReal
Typecheck.real RealTime
0.1

get_prev_val :: Derive.Taggable a => Derive.PassedArgs a
    -> Derive.Deriver DeriveT.Duration
get_prev_val :: forall a.
Taggable a =>
PassedArgs a -> Deriver State Error Duration
get_prev_val PassedArgs a
args = do
    RealTime
start <- PassedArgs a -> Deriver State Error RealTime
forall a. PassedArgs a -> Deriver State Error RealTime
Args.real_start PassedArgs a
args
    Duration -> Deriver State Error Duration
forall (m :: * -> *) a. Monad m => a -> m a
return (Duration -> Deriver State Error Duration)
-> Duration -> Deriver State Error Duration
forall a b. (a -> b) -> a -> b
$ RealTime -> Duration
DeriveT.RealDuration (RealTime -> Duration) -> RealTime -> Duration
forall a b. (a -> b) -> a -> b
$ case PassedArgs a -> Maybe RealTime
forall a. Taggable a => PassedArgs a -> Maybe RealTime
Args.prev_val_end PassedArgs a
args of
        -- It's likely the callee won't use the duration if there's no
        -- prev val.
        Maybe RealTime
Nothing -> RealTime
0
        Just RealTime
prev -> RealTime
prev RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
- RealTime
start

interpolator_variations :: [(Expr.Symbol, Derive.Generator Derive.Control)]
interpolator_variations :: [(Symbol, Generator Control)]
interpolator_variations = [[(Symbol, Generator Control)]] -> [(Symbol, Generator Control)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ (Text -> CurveD -> InterpolatorTime Control -> Generator Control)
-> Symbol -> CurveD -> [(Symbol, Generator Control)]
forall a call.
Taggable a =>
(Text -> CurveD -> InterpolatorTime a -> call)
-> Symbol -> CurveD -> [(Symbol, call)]
interpolator_variations_ Text -> CurveD -> InterpolatorTime Control -> Generator Control
interpolator_call Symbol
sym CurveD
curve
    | (Symbol
sym, CurveD
curve) <- [(Symbol, CurveD)]
standard_curves
    ]

-- * curve as argument

-- | For calls whose curve can be configured.
curve_env :: Sig.Parser Curve
curve_env :: Parser Curve
curve_env = ControlFunction -> Curve
cf_to_curve (ControlFunction -> Curve)
-> Parser ControlFunction -> Parser Curve
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    ArgName
-> EnvironDefault
-> ControlFunction
-> Doc
-> Parser ControlFunction
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> EnvironDefault -> a -> Doc -> Parser a
Sig.environ ArgName
"curve" EnvironDefault
Sig.Both ControlFunction
cf_linear Doc
"Curve function."

curve_arg :: Sig.Parser Curve
curve_arg :: Parser Curve
curve_arg = ControlFunction -> Curve
cf_to_curve (ControlFunction -> Curve)
-> Parser ControlFunction -> Parser Curve
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    ArgName -> ControlFunction -> Doc -> Parser ControlFunction
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> a -> Doc -> Parser a
Sig.defaulted ArgName
"curve" ControlFunction
cf_linear Doc
"Curve function."

cf_linear :: DeriveT.ControlFunction
cf_linear :: ControlFunction
cf_linear = Text -> Curve -> ControlFunction
curve_to_cf Text
"" Curve
Linear

-- | A ControlFunction is a generic function, so it can't retain the
-- distinction between Function and Linear.  So I use a grody hack and keep
-- the distinction in a special name.
cf_linear_name :: Text
cf_linear_name :: Text
cf_linear_name = Text
"cf-linear"

curve_time_env :: Sig.Parser (Curve, RealTime)
curve_time_env :: Parser (Curve, RealTime)
curve_time_env = (,) (Curve -> RealTime -> (Curve, RealTime))
-> Parser Curve -> Parser (RealTime -> (Curve, RealTime))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Curve
curve_env Parser (RealTime -> (Curve, RealTime))
-> Parser RealTime -> Parser (Curve, RealTime)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser RealTime
time
    where time :: Parser RealTime
time = ArgName -> EnvironDefault -> RealTime -> Doc -> Parser RealTime
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> EnvironDefault -> a -> Doc -> Parser a
Sig.environ ArgName
"curve-time" EnvironDefault
Sig.Both RealTime
0 Doc
"Curve transition time."

make_curve_call :: Maybe Doc.Doc -> CurveD -> Derive.ValCall
make_curve_call :: Maybe Doc -> CurveD -> ValCall
make_curve_call Maybe Doc
doc (CurveD Text
name Parser arg
get_arg arg -> Curve
curve) =
    Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver ControlFunction)
-> ValCall
forall a.
ToVal a =>
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
Derive.val_call Module
Module.prelude (Text -> CallName
Derive.CallName (Text
"cf-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name)) Tags
Tags.curve
    (Doc -> Maybe Doc -> Doc
forall a. a -> Maybe a -> a
fromMaybe (Doc
"Interpolation function: " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Text -> Doc
Doc.Doc Text
name) Maybe Doc
doc)
    (WithArgDoc (PassedArgs Tagged -> Deriver ControlFunction)
 -> ValCall)
-> WithArgDoc (PassedArgs Tagged -> Deriver ControlFunction)
-> ValCall
forall a b. (a -> b) -> a -> b
$ Parser arg
-> (arg -> PassedArgs Tagged -> Deriver ControlFunction)
-> WithArgDoc (PassedArgs Tagged -> Deriver ControlFunction)
forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call Parser arg
get_arg ((arg -> PassedArgs Tagged -> Deriver ControlFunction)
 -> WithArgDoc (PassedArgs Tagged -> Deriver ControlFunction))
-> (arg -> PassedArgs Tagged -> Deriver ControlFunction)
-> WithArgDoc (PassedArgs Tagged -> Deriver ControlFunction)
forall a b. (a -> b) -> a -> b
$ \arg
arg PassedArgs Tagged
_args ->
        ControlFunction -> Deriver ControlFunction
forall (m :: * -> *) a. Monad m => a -> m a
return (ControlFunction -> Deriver ControlFunction)
-> ControlFunction -> Deriver ControlFunction
forall a b. (a -> b) -> a -> b
$ Text -> Curve -> ControlFunction
curve_to_cf Text
name (arg -> Curve
curve arg
arg)

-- | Stuff a curve function into a ControlFunction.
curve_to_cf :: Text -> Curve -> DeriveT.ControlFunction
curve_to_cf :: Text -> Curve -> ControlFunction
curve_to_cf Text
name (Function Y -> Y
curvef) = Text
-> (Control -> Dynamic -> RealTime -> Typed Y) -> ControlFunction
DeriveT.ControlFunction Text
name ((Control -> Dynamic -> RealTime -> Typed Y) -> ControlFunction)
-> (Control -> Dynamic -> RealTime -> Typed Y) -> ControlFunction
forall a b. (a -> b) -> a -> b
$
    \Control
_ Dynamic
_ -> Y -> Typed Y
forall a. a -> Typed a
ScoreT.untyped (Y -> Typed Y) -> (RealTime -> Y) -> RealTime -> Typed Y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Y -> Y
curvef (Y -> Y) -> (RealTime -> Y) -> RealTime -> Y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealTime -> Y
RealTime.to_seconds
curve_to_cf Text
_ Curve
Linear = Text
-> (Control -> Dynamic -> RealTime -> Typed Y) -> ControlFunction
DeriveT.ControlFunction Text
cf_linear_name ((Control -> Dynamic -> RealTime -> Typed Y) -> ControlFunction)
-> (Control -> Dynamic -> RealTime -> Typed Y) -> ControlFunction
forall a b. (a -> b) -> a -> b
$
    \Control
_ Dynamic
_ -> Y -> Typed Y
forall a. a -> Typed a
ScoreT.untyped (Y -> Typed Y) -> (RealTime -> Y) -> RealTime -> Typed Y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealTime -> Y
RealTime.to_seconds

-- | Convert a ControlFunction back into a curve function.
cf_to_curve :: DeriveT.ControlFunction -> Curve
cf_to_curve :: ControlFunction -> Curve
cf_to_curve cf :: ControlFunction
cf@(DeriveT.ControlFunction Text
name Control -> Dynamic -> RealTime -> Typed Y
_)
    | Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
cf_linear_name = Curve
Linear
    | Bool
otherwise = (Y -> Y) -> Curve
Function ((Y -> Y) -> Curve) -> (Y -> Y) -> Curve
forall a b. (a -> b) -> a -> b
$ Typed Y -> Y
forall a. Typed a -> a
ScoreT.typed_val
        (Typed Y -> Y) -> (Y -> Typed Y) -> Y -> Y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ControlFunction -> Control -> Dynamic -> RealTime -> Typed Y
DeriveT.call_control_function ControlFunction
cf Control
Controls.null Dynamic
DeriveT.empty_dynamic
        (RealTime -> Typed Y) -> (Y -> RealTime) -> Y -> Typed Y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Y -> RealTime
RealTime.seconds

-- * interpolate

-- | Given a placement, start, and duration, return the range thus implied.
place_range :: Typecheck.Normalized -> ScoreTime -> DeriveT.Duration
    -> Derive.Deriver (RealTime, RealTime)
place_range :: Normalized -> ScoreTime -> Duration -> Deriver (RealTime, RealTime)
place_range (Typecheck.Normalized Y
place) ScoreTime
start Duration
dur = do
    RealTime
start <- ScoreTime -> Deriver State Error RealTime
forall a. Time a => a -> Deriver State Error RealTime
Derive.real ScoreTime
start
    RealTime
dur <- RealTime -> Duration -> Deriver State Error RealTime
forall t1 t2.
(Time t1, Time t2) =>
t1 -> t2 -> Deriver State Error RealTime
Call.real_duration RealTime
start Duration
dur
    -- 0 is before, 1 is after.
    let offset :: RealTime
offset = RealTime
dur RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
* Y -> RealTime
RealTime.seconds (Y
1 Y -> Y -> Y
forall a. Num a => a -> a -> a
- Y
place)
    (RealTime, RealTime) -> Deriver (RealTime, RealTime)
forall (m :: * -> *) a. Monad m => a -> m a
return (RealTime
start RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
- RealTime
offset, RealTime
start RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
+ RealTime
dur RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
- RealTime
offset)

-- | Make a curve segment from the previous value, if there was one.
make_segment_from :: Curve -> RealTime -> Maybe Signal.Y -> RealTime
    -> Signal.Y -> Derive.Deriver Signal.Control
make_segment_from :: Curve -> RealTime -> Maybe Y -> RealTime -> Y -> Deriver Control
make_segment_from Curve
curve RealTime
start Maybe Y
maybe_from RealTime
end Y
to = case Maybe Y
maybe_from of
    Maybe Y
Nothing -> Control -> Deriver Control
forall (m :: * -> *) a. Monad m => a -> m a
return (Control -> Deriver Control) -> Control -> Deriver Control
forall a b. (a -> b) -> a -> b
$ RealTime -> Y -> Control
forall {k} (kind :: k). RealTime -> Y -> Signal kind
Signal.from_sample RealTime
start Y
to
    Just Y
from -> Curve -> RealTime -> Y -> RealTime -> Y -> Deriver Control
make_segment Curve
curve RealTime
start Y
from RealTime
end Y
to

make_segment :: Curve -> RealTime -> Signal.Y -> RealTime
    -> Signal.Y -> Derive.Deriver Signal.Control
make_segment :: Curve -> RealTime -> Y -> RealTime -> Y -> Deriver Control
make_segment Curve
curve RealTime
x1 Y
y1 RealTime
x2 Y
y2 = do
    RealTime
srate <- Deriver State Error RealTime
Call.get_srate
    Control -> Deriver Control
forall (m :: * -> *) a. Monad m => a -> m a
return (Control -> Deriver Control) -> Control -> Deriver Control
forall a b. (a -> b) -> a -> b
$ RealTime -> Curve -> RealTime -> Y -> RealTime -> Y -> Control
segment RealTime
srate Curve
curve RealTime
x1 Y
y1 RealTime
x2 Y
y2

-- | Interpolate between the given points.
segment :: SRate -> Curve -> RealTime -> Signal.Y -> RealTime
    -> Signal.Y -> Signal.Control
segment :: RealTime -> Curve -> RealTime -> Y -> RealTime -> Y -> Control
segment RealTime
srate Curve
curve RealTime
x1 Y
y1 RealTime
x2 Y
y2
    | RealTime
x1 RealTime -> RealTime -> Bool
forall a. Eq a => a -> a -> Bool
== RealTime
x2 Bool -> Bool -> Bool
&& Y
y1 Y -> Y -> Bool
forall a. Eq a => a -> a -> Bool
== Y
y2 = Control
forall a. Monoid a => a
mempty
    -- If x1 == x2 I still need to make a vertical segment
    | Y
y1 Y -> Y -> Bool
forall a. Eq a => a -> a -> Bool
== Y
y2 = [(RealTime, Y)] -> Control
forall {k} (kind :: k). [(RealTime, Y)] -> Signal kind
Signal.from_pairs [(RealTime
x1, Y
y1), (RealTime
x2, Y
y2)]
    | Bool
otherwise = case Curve
curve of
        Curve
Linear -> [(RealTime, Y)] -> Control
forall {k} (kind :: k). [(RealTime, Y)] -> Signal kind
Signal.from_pairs [(RealTime
x1, Y
y1), (RealTime
x2, Y
y2)]
        Function Y -> Y
curvef -> [(RealTime, Y)] -> Control
forall {k} (kind :: k). [(RealTime, Y)] -> Signal kind
Signal.from_pairs ([(RealTime, Y)] -> Control) -> [(RealTime, Y)] -> Control
forall a b. (a -> b) -> a -> b
$ (RealTime -> (RealTime, Y)) -> [RealTime] -> [(RealTime, Y)]
forall a b. (a -> b) -> [a] -> [b]
map ((Y -> Y) -> RealTime -> (RealTime, Y)
make Y -> Y
curvef) ([RealTime] -> [(RealTime, Y)]) -> [RealTime] -> [(RealTime, Y)]
forall a b. (a -> b) -> a -> b
$
            RealTime -> RealTime -> RealTime -> [RealTime]
forall a. (Num a, Ord a) => a -> a -> a -> [a]
Seq.range_end RealTime
x1 RealTime
x2 (RealTime
1RealTime -> RealTime -> RealTime
forall a. Fractional a => a -> a -> a
/RealTime
srate)
    where
    make :: (Y -> Y) -> RealTime -> (RealTime, Y)
make Y -> Y
curvef RealTime
x
        -- Otherwise if x1==x2 then I get y1.
        | RealTime
x RealTime -> RealTime -> Bool
forall a. Ord a => a -> a -> Bool
>= RealTime
x2 = (RealTime
x2, Y
y2)
        | Bool
otherwise = (RealTime
x, (Y -> Y) -> RealTime -> Y -> RealTime -> Y -> RealTime -> Y
make_function Y -> Y
curvef RealTime
x1 Y
y1 RealTime
x2 Y
y2 RealTime
x)

make_function :: CurveF -> RealTime -> Signal.Y -> RealTime -> Signal.Y
    -> (RealTime -> Signal.Y)
make_function :: (Y -> Y) -> RealTime -> Y -> RealTime -> Y -> RealTime -> Y
make_function Y -> Y
curvef RealTime
x1 Y
y1 RealTime
x2 Y
y2 =
    Y -> Y -> Y -> Y
forall a. (Eq a, Num a) => a -> a -> a -> a
Num.scale Y
y1 Y
y2 (Y -> Y) -> (RealTime -> Y) -> RealTime -> Y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Y -> Y
curvef (Y -> Y) -> (RealTime -> Y) -> RealTime -> Y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Y -> Y -> Y -> Y
forall a. (Eq a, Fractional a) => a -> a -> a -> a
Num.normalize (RealTime -> Y
secs RealTime
x1) (RealTime -> Y
secs RealTime
x2) (Y -> Y) -> (RealTime -> Y) -> RealTime -> Y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealTime -> Y
secs
    where secs :: RealTime -> Y
secs = RealTime -> Y
RealTime.to_seconds

-- * slope

-- | Make a line with a certain slope, with optional lower and upper limits.
-- TODO I could support Curve but it would make the intercept more complicated.
slope_to_limit :: Maybe Signal.Y -> Maybe Signal.Y
    -> Signal.Y -> Double -> RealTime -> RealTime -> Signal.Control
slope_to_limit :: Maybe Y -> Maybe Y -> Y -> Y -> RealTime -> RealTime -> Control
slope_to_limit Maybe Y
low Maybe Y
high Y
from Y
slope RealTime
start RealTime
end
    | Y
slope Y -> Y -> Bool
forall a. Eq a => a -> a -> Bool
== Y
0 = RealTime -> Y -> Control
forall {k} (kind :: k). RealTime -> Y -> Signal kind
Signal.from_sample RealTime
start Y
from
    | Just Y
limit <- if Y
slope Y -> Y -> Bool
forall a. Ord a => a -> a -> Bool
< Y
0 then Maybe Y
low else Maybe Y
high =
        let intercept :: RealTime
intercept = RealTime
start RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
+ RealTime -> RealTime -> RealTime
forall a. Ord a => a -> a -> a
max RealTime
0 (Y -> RealTime
RealTime.seconds ((Y
limitY -> Y -> Y
forall a. Num a => a -> a -> a
-Y
from) Y -> Y -> Y
forall a. Fractional a => a -> a -> a
/ Y
slope))
        in if RealTime
intercept RealTime -> RealTime -> Bool
forall a. Ord a => a -> a -> Bool
< RealTime
end then RealTime -> Y -> Control
make RealTime
intercept Y
limit else RealTime -> Y -> Control
make RealTime
end Y
end_y
    | Bool
otherwise = RealTime -> Y -> Control
make RealTime
end Y
end_y
    where
    make :: RealTime -> Y -> Control
make = RealTime -> Curve -> RealTime -> Y -> RealTime -> Y -> Control
segment RealTime
srate Curve
Linear RealTime
start Y
from
    srate :: RealTime
srate = RealTime
1 -- not used for Linear
    end_y :: Y
end_y = Y
from Y -> Y -> Y
forall a. Num a => a -> a -> a
+ RealTime -> Y
RealTime.to_seconds (RealTime
end RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
- RealTime
start) Y -> Y -> Y
forall a. Num a => a -> a -> a
* Y
slope

-- * exponential

exponential_curve :: CurveD
exponential_curve :: CurveD
exponential_curve = Text -> Parser Y -> (Y -> Curve) -> CurveD
forall arg. Text -> Parser arg -> (arg -> Curve) -> CurveD
CurveD Text
"expon" Parser Y
args ((Y -> Y) -> Curve
Function ((Y -> Y) -> Curve) -> (Y -> Y -> Y) -> Y -> Curve
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Y -> Y -> Y
expon)
    where
    args :: Parser Y
args = ArgName -> Y -> Doc -> Parser Y
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> a -> Doc -> Parser a
Sig.defaulted ArgName
"expon" Y
2 Doc
exponential_doc

exponential_doc :: Doc.Doc
exponential_doc :: Doc
exponential_doc =
    Doc
"Slope of an exponential curve. Positive `n` is taken as `x^n`\
    \ and will generate a slowly departing and rapidly approaching\
    \ curve. Negative `-n` is taken as `x^1/n`, which will generate a\
    \ rapidly departing and slowly approaching curve."

-- | Negative exponents produce a curve that jumps from the \"starting point\"
-- which doesn't seem too useful, so so hijack the negatives as an easier way
-- to write 1/n.  That way n is smoothly departing, while -n is smoothly
-- approaching.
expon :: Double -> CurveF
expon :: Y -> Y -> Y
expon Y
n Y
x = Y
xY -> Y -> Y
forall a. Floating a => a -> a -> a
**Y
exp
    where exp :: Y
exp = if Y
n Y -> Y -> Bool
forall a. Ord a => a -> a -> Bool
>= Y
0 then Y
n else Y
1 Y -> Y -> Y
forall a. Fractional a => a -> a -> a
/ Y -> Y
forall a. Num a => a -> a
abs Y
n

-- | I could probably make a nicer curve of this general shape if I knew more
-- math.
expon2 :: Double -> Double -> CurveF
expon2 :: Y -> Y -> Y -> Y
expon2 Y
a Y
b Y
x
    | Y
x Y -> Y -> Bool
forall a. Ord a => a -> a -> Bool
>= Y
1 = Y
1
    | Y
x Y -> Y -> Bool
forall a. Ord a => a -> a -> Bool
< Y
0.5 = Y -> Y -> Y
expon Y
a (Y
x Y -> Y -> Y
forall a. Num a => a -> a -> a
* Y
2) Y -> Y -> Y
forall a. Fractional a => a -> a -> a
/ Y
2
    | Bool
otherwise = Y -> Y -> Y
expon (-Y
b) ((Y
xY -> Y -> Y
forall a. Num a => a -> a -> a
-Y
0.5) Y -> Y -> Y
forall a. Num a => a -> a -> a
* Y
2) Y -> Y -> Y
forall a. Fractional a => a -> a -> a
/ Y
2 Y -> Y -> Y
forall a. Num a => a -> a -> a
+ Y
0.5

-- * bezier

sigmoid_curve :: CurveD
sigmoid_curve :: CurveD
sigmoid_curve = Text -> Parser (Y, Y) -> ((Y, Y) -> Curve) -> CurveD
forall arg. Text -> Parser arg -> (arg -> Curve) -> CurveD
CurveD Text
"sigmoid" Parser (Y, Y)
args (Y, Y) -> Curve
curve
    where
    curve :: (Y, Y) -> Curve
curve (Y
w1, Y
w2) = (Y -> Y) -> Curve
Function ((Y -> Y) -> Curve) -> (Y -> Y) -> Curve
forall a b. (a -> b) -> a -> b
$ Y -> Y -> Y -> Y
sigmoid Y
w1 Y
w2
    args :: Parser (Y, Y)
args = (,)
        (Y -> Y -> (Y, Y)) -> Parser Y -> Parser (Y -> (Y, Y))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgName -> Y -> Doc -> Parser Y
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> a -> Doc -> Parser a
Sig.defaulted ArgName
"w1" Y
0.5 Doc
"Start weight."
        Parser (Y -> (Y, Y)) -> Parser Y -> Parser (Y, Y)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ArgName -> Y -> Doc -> Parser Y
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> a -> Doc -> Parser a
Sig.defaulted ArgName
"w2" Y
0.5 Doc
"End weight."

type Point = (Double, Double)

-- | As far as I can tell, there's no direct way to know what value to give to
-- the bezier function in order to get a specific @x@.  So I guess with binary
-- search.
-- https://youtu.be/aVwxzDHniEw?t=1119
guess_x :: (Double -> (Double, Double)) -> CurveF
guess_x :: (Y -> (Y, Y)) -> Y -> Y
guess_x Y -> (Y, Y)
f Y
x1 = Y -> Y -> Y
go Y
0 Y
1
    where
    go :: Y -> Y -> Y
go Y
low Y
high = case Y -> Y -> Y -> Ordering
forall a. (ApproxEq a, Ord a) => Y -> a -> a -> Ordering
ApproxEq.compare Y
threshold Y
x Y
x1 of
        Ordering
EQ -> Y
y
        Ordering
LT -> Y -> Y -> Y
go Y
mid Y
high
        Ordering
GT -> Y -> Y -> Y
go Y
low Y
mid
        where
        mid :: Y
mid = (Y
low Y -> Y -> Y
forall a. Num a => a -> a -> a
+ Y
high) Y -> Y -> Y
forall a. Fractional a => a -> a -> a
/ Y
2
        (Y
x, Y
y) = Y -> (Y, Y)
f Y
mid
    threshold :: Y
threshold = Y
0.00015

-- | Generate a sigmoid curve.  The first weight is the flatness at the start,
-- and the second is the flatness at the end.  Both should range from 0--1.
sigmoid :: Double -> Double -> CurveF
sigmoid :: Y -> Y -> Y -> Y
sigmoid Y
w1 Y
w2 = (Y -> (Y, Y)) -> Y -> Y
guess_x ((Y -> (Y, Y)) -> Y -> Y) -> (Y -> (Y, Y)) -> Y -> Y
forall a b. (a -> b) -> a -> b
$ (Y, Y) -> (Y, Y) -> (Y, Y) -> (Y, Y) -> Y -> (Y, Y)
bezier3 (Y
0, Y
0) (Y
w1, Y
0) (Y
1Y -> Y -> Y
forall a. Num a => a -> a -> a
-Y
w2, Y
1) (Y
1, Y
1)

-- | Cubic bezier curve.
bezier3 :: Point -> Point -> Point -> Point -> (Double -> Point)
bezier3 :: (Y, Y) -> (Y, Y) -> (Y, Y) -> (Y, Y) -> Y -> (Y, Y)
bezier3 (Y
x1, Y
y1) (Y
x2, Y
y2) (Y
x3, Y
y3) (Y
x4, Y
y4) Y
t =
    (Y -> Y -> Y -> Y -> Y -> Y
forall {a}. Num a => a -> a -> a -> a -> a -> a
f Y
x1 Y
x2 Y
x3 Y
x4 Y
t, Y -> Y -> Y -> Y -> Y -> Y
forall {a}. Num a => a -> a -> a -> a -> a -> a
f Y
y1 Y
y2 Y
y3 Y
y4 Y
t)
    where
    f :: a -> a -> a -> a -> a -> a
f a
p1 a
p2 a
p3 a
p4 a
t =
        (a
1a -> a -> a
forall a. Num a => a -> a -> a
-a
t)a -> Integer -> a
forall a b. (Num a, Integral b) => a -> b -> a
^Integer
3 a -> a -> a
forall a. Num a => a -> a -> a
* a
p1 a -> a -> a
forall a. Num a => a -> a -> a
+ a
3a -> a -> a
forall a. Num a => a -> a -> a
*(a
1a -> a -> a
forall a. Num a => a -> a -> a
-a
t)a -> Integer -> a
forall a b. (Num a, Integral b) => a -> b -> a
^Integer
2a -> a -> a
forall a. Num a => a -> a -> a
*a
t a -> a -> a
forall a. Num a => a -> a -> a
* a
p2 a -> a -> a
forall a. Num a => a -> a -> a
+ a
3a -> a -> a
forall a. Num a => a -> a -> a
*(a
1a -> a -> a
forall a. Num a => a -> a -> a
-a
t)a -> a -> a
forall a. Num a => a -> a -> a
*a
ta -> Integer -> a
forall a b. (Num a, Integral b) => a -> b -> a
^Integer
2 a -> a -> a
forall a. Num a => a -> a -> a
* a
p3 a -> a -> a
forall a. Num a => a -> a -> a
+ a
ta -> Integer -> a
forall a b. (Num a, Integral b) => a -> b -> a
^Integer
3 a -> a -> a
forall a. Num a => a -> a -> a
* a
p4

-- * breakpoints

-- | Create line segments between the given breakpoints.
breakpoints :: SRate -> Curve -> [(RealTime, Signal.Y)] -> Signal.Control
breakpoints :: RealTime -> Curve -> [(RealTime, Y)] -> Control
breakpoints RealTime
_srate Curve
Linear = [(RealTime, Y)] -> Control
forall {k} (kind :: k). [(RealTime, Y)] -> Signal kind
Signal.from_pairs
breakpoints RealTime
srate Curve
curve =
    (RealTime -> Y -> Control)
-> (RealTime -> Y -> RealTime -> Y -> Control)
-> [(RealTime, Y)]
-> Control
forall sig y.
Monoid sig =>
(RealTime -> y -> sig)
-> (RealTime -> y -> RealTime -> y -> sig)
-> [(RealTime, y)]
-> sig
signal_breakpoints RealTime -> Y -> Control
forall {k} (kind :: k). RealTime -> Y -> Signal kind
Signal.from_sample (RealTime -> Curve -> RealTime -> Y -> RealTime -> Y -> Control
segment RealTime
srate Curve
curve)

signal_breakpoints :: Monoid sig => (RealTime -> y -> sig)
    -> (RealTime -> y -> RealTime -> y -> sig) -> [(RealTime, y)] -> sig
signal_breakpoints :: forall sig y.
Monoid sig =>
(RealTime -> y -> sig)
-> (RealTime -> y -> RealTime -> y -> sig)
-> [(RealTime, y)]
-> sig
signal_breakpoints RealTime -> y -> sig
make_signal RealTime -> y -> RealTime -> y -> sig
make_segment = (((RealTime, y), Maybe (RealTime, y)) -> sig)
-> [((RealTime, y), Maybe (RealTime, y))] -> sig
forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap ((RealTime, y), Maybe (RealTime, y)) -> sig
line ([((RealTime, y), Maybe (RealTime, y))] -> sig)
-> ([(RealTime, y)] -> [((RealTime, y), Maybe (RealTime, y))])
-> [(RealTime, y)]
-> sig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(RealTime, y)] -> [((RealTime, y), Maybe (RealTime, y))]
forall a. [a] -> [(a, Maybe a)]
Seq.zip_next
    where
    line :: ((RealTime, y), Maybe (RealTime, y)) -> sig
line ((RealTime
x1, y
y1), Just (RealTime
x2, y
y2)) = RealTime -> y -> RealTime -> y -> sig
make_segment RealTime
x1 y
y1 RealTime
x2 y
y2
    line ((RealTime
x1, y
y2), Maybe (RealTime, y)
Nothing) = RealTime -> y -> sig
make_signal RealTime
x1 y
y2

-- | Distribute the values evenly over the given time range.
distribute :: RealTime -> RealTime -> [a] -> [(RealTime, a)]
distribute :: forall a. RealTime -> RealTime -> [a] -> [(RealTime, a)]
distribute RealTime
start RealTime
end [a]
vals = case [a]
vals of
    [] -> []
    [a
x] -> [(RealTime
start, a
x)]
    [a]
_ -> [(RealTime -> RealTime -> RealTime -> RealTime
forall a. (Eq a, Num a) => a -> a -> a -> a
Num.scale RealTime
start RealTime
end (RealTime
n RealTime -> RealTime -> RealTime
forall a. Fractional a => a -> a -> a
/ (RealTime
len RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
- RealTime
1)), a
x)
        | (RealTime
n, a
x) <- [RealTime] -> [a] -> [(RealTime, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip (RealTime -> RealTime -> [RealTime]
forall a. Num a => a -> a -> [a]
Seq.range_ RealTime
0 RealTime
1) [a]
vals]
    where len :: RealTime
len = Int -> RealTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
vals)

-- * smooth

-- | Use the function to create a segment between each point in the signal.
-- Smooth with 'split_samples_absolute'.
smooth_absolute :: Curve -> RealTime -> RealTime
    -- ^ If negative, each segment is from this much before the original sample
    -- until the sample.  If positive, it starts on the sample.  If samples are
    -- too close, the segments are shortened correspondingly.
    -> [(RealTime, Signal.Y)] -> Signal.Control
smooth_absolute :: Curve -> RealTime -> RealTime -> [(RealTime, Y)] -> Control
smooth_absolute Curve
curve RealTime
srate RealTime
time =
    RealTime -> Curve -> [(RealTime, Y)] -> Control
breakpoints RealTime
srate Curve
curve ([(RealTime, Y)] -> Control)
-> ([(RealTime, Y)] -> [(RealTime, Y)])
-> [(RealTime, Y)]
-> Control
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealTime -> [(RealTime, Y)] -> [(RealTime, Y)]
forall y. RealTime -> [(RealTime, y)] -> [(RealTime, y)]
split_samples_absolute RealTime
time

-- | Smooth with 'split_samples_relative'.
smooth_relative :: Curve -> RealTime -> Typecheck.Function
    -> [(RealTime, Signal.Y)] -> Signal.Control
smooth_relative :: Curve -> RealTime -> (RealTime -> Y) -> [(RealTime, Y)] -> Control
smooth_relative Curve
curve RealTime
srate RealTime -> Y
time_at =
    RealTime -> Curve -> [(RealTime, Y)] -> Control
breakpoints RealTime
srate Curve
curve ([(RealTime, Y)] -> Control)
-> ([(RealTime, Y)] -> [(RealTime, Y)])
-> [(RealTime, Y)]
-> Control
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RealTime -> Y) -> [(RealTime, Y)] -> [(RealTime, Y)]
forall y. (RealTime -> Y) -> [(RealTime, y)] -> [(RealTime, y)]
split_samples_relative RealTime -> Y
time_at

-- | Split apart samples to make a flat segment.
--
-- TODO if y=Pitch there's no Eq, so breakpoints winds up sampling flat
-- segments.  I could emit Maybe y where Nothing means same as previous.
--
-- > 0 1 2 3 4 5 6 7 8
-- > 0-------1-------0
-- > 0-----0=1-----1=0      time = -1
-- > 0-------0=1-----1=0    time = 1
split_samples_absolute :: RealTime -> [(RealTime, y)] -> [(RealTime, y)]
split_samples_absolute :: forall y. RealTime -> [(RealTime, y)] -> [(RealTime, y)]
split_samples_absolute RealTime
time
    | RealTime
time RealTime -> RealTime -> Bool
forall a. Ord a => a -> a -> Bool
>= RealTime
0 = ((Maybe (RealTime, y), (RealTime, y), Maybe (RealTime, y))
 -> [(RealTime, y)])
-> [(Maybe (RealTime, y), (RealTime, y), Maybe (RealTime, y))]
-> [(RealTime, y)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Maybe (RealTime, y), (RealTime, y), Maybe (RealTime, y))
-> [(RealTime, y)]
forall {a} {b} {b}.
(Maybe (a, b), (RealTime, b), Maybe (RealTime, b))
-> [(RealTime, b)]
split_prev ([(Maybe (RealTime, y), (RealTime, y), Maybe (RealTime, y))]
 -> [(RealTime, y)])
-> ([(RealTime, y)]
    -> [(Maybe (RealTime, y), (RealTime, y), Maybe (RealTime, y))])
-> [(RealTime, y)]
-> [(RealTime, y)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(RealTime, y)]
-> [(Maybe (RealTime, y), (RealTime, y), Maybe (RealTime, y))]
forall a. [a] -> [(Maybe a, a, Maybe a)]
Seq.zip_neighbors
    | Bool
otherwise = (((RealTime, y), Maybe (RealTime, y)) -> [(RealTime, y)])
-> [((RealTime, y), Maybe (RealTime, y))] -> [(RealTime, y)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((RealTime, y), Maybe (RealTime, y)) -> [(RealTime, y)]
forall {b} {b}.
((RealTime, b), Maybe (RealTime, b)) -> [(RealTime, b)]
split_next ([((RealTime, y), Maybe (RealTime, y))] -> [(RealTime, y)])
-> ([(RealTime, y)] -> [((RealTime, y), Maybe (RealTime, y))])
-> [(RealTime, y)]
-> [(RealTime, y)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(RealTime, y)] -> [((RealTime, y), Maybe (RealTime, y))]
forall a. [a] -> [(a, Maybe a)]
Seq.zip_next
    where
    split_prev :: (Maybe (a, b), (RealTime, b), Maybe (RealTime, b))
-> [(RealTime, b)]
split_prev (Maybe (a, b)
Nothing, (RealTime
x1, b
y1), Maybe (RealTime, b)
_) = [(RealTime
x1, b
y1)]
    split_prev (Just (a
_, b
y0), (RealTime
x1, b
y1), Maybe (RealTime, b)
next) =
        (RealTime
x1, b
y0) (RealTime, b) -> [(RealTime, b)] -> [(RealTime, b)]
forall a. a -> [a] -> [a]
: if Bool
is_room then [(RealTime
x1 RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
+ RealTime
time, b
y1)] else []
        where is_room :: Bool
is_room = Bool -> ((RealTime, b) -> Bool) -> Maybe (RealTime, b) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True ((RealTime
x1 RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
+ RealTime
time <) (RealTime -> Bool)
-> ((RealTime, b) -> RealTime) -> (RealTime, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RealTime, b) -> RealTime
forall a b. (a, b) -> a
fst) Maybe (RealTime, b)
next
    split_next :: ((RealTime, b), Maybe (RealTime, b)) -> [(RealTime, b)]
split_next ((RealTime
x1, b
y1), Maybe (RealTime, b)
Nothing) = [(RealTime
x1, b
y1)]
    split_next ((RealTime
x1, b
y1), Just (RealTime
x2, b
_)) =
        (RealTime
x1, b
y1) (RealTime, b) -> [(RealTime, b)] -> [(RealTime, b)]
forall a. a -> [a] -> [a]
: if RealTime
x2 RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
+ RealTime
time RealTime -> RealTime -> Bool
forall a. Ord a => a -> a -> Bool
> RealTime
x1 then [(RealTime
x2 RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
+ RealTime
time, b
y1)] else []

-- | Like 'smooth_absolute', but the transition time is a 0--1 proportion of the
-- available time, rather than an absolute time.  Also, the transition is
-- always before the destination sample, unlike absolute, where it's only
-- before for a negative transition time.  This is because I can't transition
-- after the sample, because the last sample has no next sample to take
-- a proportional time from!
--
-- > 0 1 2 3 4 5 6 7 8
-- > 0-------1-------0
-- > 0-----0=1-----1=0 time_at = const 0.25
split_samples_relative :: Typecheck.Function -> [(RealTime, y)]
    -> [(RealTime, y)]
split_samples_relative :: forall y. (RealTime -> Y) -> [(RealTime, y)] -> [(RealTime, y)]
split_samples_relative RealTime -> Y
time_at = (((RealTime, y), Maybe (RealTime, y)) -> [(RealTime, y)])
-> [((RealTime, y), Maybe (RealTime, y))] -> [(RealTime, y)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((RealTime, y), Maybe (RealTime, y)) -> [(RealTime, y)]
forall {b} {b}.
((RealTime, b), Maybe (RealTime, b)) -> [(RealTime, b)]
split ([((RealTime, y), Maybe (RealTime, y))] -> [(RealTime, y)])
-> ([(RealTime, y)] -> [((RealTime, y), Maybe (RealTime, y))])
-> [(RealTime, y)]
-> [(RealTime, y)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(RealTime, y)] -> [((RealTime, y), Maybe (RealTime, y))]
forall a. [a] -> [(a, Maybe a)]
Seq.zip_next
    where
    split :: ((RealTime, b), Maybe (RealTime, b)) -> [(RealTime, b)]
split ((RealTime
x1, b
y1), Maybe (RealTime, b)
Nothing) = [(RealTime
x1, b
y1)]
    split ((RealTime
x1, b
y1), Just (RealTime
x2, b
_)) =
        (RealTime
x1, b
y1) (RealTime, b) -> [(RealTime, b)] -> [(RealTime, b)]
forall a. a -> [a] -> [a]
: if RealTime
offset RealTime -> RealTime -> Bool
forall a. Eq a => a -> a -> Bool
== RealTime
0 then [] else [(RealTime
x1 RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
+ RealTime
offset, b
y1)]
        where
        offset :: RealTime
offset = (RealTime
x2 RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
- RealTime
x1) RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
* (RealTime
1 RealTime -> RealTime -> RealTime
forall a. Num a => a -> a -> a
- RealTime
time)
        time :: RealTime
time = Y -> RealTime
RealTime.seconds (Y -> Y -> Y -> Y
forall a. Ord a => a -> a -> a -> a
Num.clamp Y
0 Y
1 (RealTime -> Y
time_at RealTime
x1))

-- * control mod

modify :: ScoreT.Control -> RealTime -> Signal.Control -> Derive.Deriver ()
modify :: Control -> RealTime -> Control -> Deriver ()
modify = Merge -> Control -> RealTime -> Control -> Deriver ()
modify_with Merge
Derive.DefaultMerge

-- | Modify the signal only in the given range.
modify_with :: Derive.Merge -> ScoreT.Control -> RealTime
    -- ^ Where the modification should end.  I don't need a start time since
    -- signals already have an implicit start time.
    -> Signal.Control -> Derive.Deriver ()
modify_with :: Merge -> Control -> RealTime -> Control -> Deriver ()
modify_with Merge
merge Control
control RealTime
end Control
sig = do
    Merger
merger <- Merge -> Control -> Deriver Merger
Derive.resolve_merge Merge
merge Control
control
    -- Since signals are implicitly 0 before the first sample, I prepend
    -- a segment with the identity value, in case the identity isn't 0.
    Merger -> Control -> Control -> Deriver ()
Derive.modify_control Merger
merger Control
control (Control -> Deriver ()) -> Deriver Control -> Deriver ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< case Merger
merger of
        Derive.Merger Text
_ Control -> Control -> Control
_ Y
identity -> Control -> Deriver Control
forall (m :: * -> *) a. Monad m => a -> m a
return (Control -> Deriver Control) -> Control -> Deriver Control
forall a b. (a -> b) -> a -> b
$ [Control] -> Control
forall a. Monoid a => [a] -> a
mconcat
            [ if Y
identity Y -> Y -> Bool
forall a. Eq a => a -> a -> Bool
== Y
0 then Control
forall a. Monoid a => a
mempty else Y -> Control
forall {k} (kind :: k). Y -> Signal kind
Signal.constant Y
identity
            , Control
sig
            , RealTime -> Y -> Control
forall {k} (kind :: k). RealTime -> Y -> Signal kind
Signal.from_sample RealTime
end Y
identity
            ]
        Merger
Derive.Set -> do
            -- There's no identity for Set, so I have to slice the signal
            -- myself.
            Maybe (Typed Control)
maybe_old <- Control -> Deriver (Maybe (Typed Control))
Derive.lookup_control_signal Control
control
            Control -> Deriver Control
forall (m :: * -> *) a. Monad m => a -> m a
return (Control -> Deriver Control) -> Control -> Deriver Control
forall a b. (a -> b) -> a -> b
$ case Typed Control -> Control
forall a. Typed a -> a
ScoreT.typed_val (Typed Control -> Control)
-> Maybe (Typed Control) -> Maybe Control
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Typed Control)
maybe_old of
                Maybe Control
Nothing -> Control
sig
                Just Control
old -> Control
old Control -> Control -> Control
forall a. Semigroup a => a -> a -> a
<> Control
sig Control -> Control -> Control
forall a. Semigroup a => a -> a -> a
<> RealTime -> Control -> Control
forall {k} (kind :: k). RealTime -> Signal kind -> Signal kind
Signal.clip_before RealTime
end Control
old
        Merger
Derive.Unset -> Control -> Deriver Control
forall (m :: * -> *) a. Monad m => a -> m a
return Control
sig

multiply_dyn :: RealTime -> Signal.Control -> Derive.Deriver ()
multiply_dyn :: RealTime -> Control -> Deriver ()
multiply_dyn = Merge -> Control -> RealTime -> Control -> Deriver ()
modify_with (Merger -> Merge
Derive.Merge Merger
Derive.merge_mul) Control
Controls.dynamic