-- 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.Lists as Lists
import qualified Util.Num as Num
import qualified Util.Test.ApproxEq as ApproxEq

import qualified Derive.Args as Args
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.DeriveT as DeriveT
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", forall arg. Text -> Parser arg -> (arg -> Curve) -> CurveD
CurveD Text
"linear" (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 =
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Generator d
Derive.generator1 Module
Module.prelude (Text -> CallName
Derive.CallName (Text
name forall a. Semigroup a => a -> a -> a
<> Text
name_suffix))
        Tags
Tags.prev Doc
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
Sig.required ArgName
"to" Doc
"Destination value."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ RealTime -> Duration
DeriveT.RealDuration RealTime
0) InterpolatorTime Control
interpolator_time
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser arg
get_arg forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe Y)
from_env
    ) forall a b. (a -> b) -> a -> b
$ \(Y
to, Duration
time, arg
curve_arg, Maybe Y
from) PassedArgs Control
args -> do
        Duration
time <- if forall a. PassedArgs a -> ScoreTime
Args.duration PassedArgs Control
args forall a. Eq a => a -> a -> Bool
== ScoreTime
0
            then case InterpolatorTime Control
interpolator_time of
                Left Parser 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 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) <- 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)
            (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) (forall a. Ord a => a -> a -> a
max RealTime
start RealTime
end) Y
to
    where
    doc :: Doc
doc = Text -> Doc
Doc.Doc forall a b. (a -> b) -> a -> b
$ Text
"Interpolate from the previous value to the given one."
        forall a. Semigroup a => a -> a -> a
<> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const Text
"") ((Text
" "<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.environ ArgName
"from" EnvironDefault
Sig.Both (forall a. Maybe a
Nothing :: Maybe Sig.Dummy)
    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 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)

-- | 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 forall {a}.
Either a (PassedArgs a -> Deriver State Error Duration, Text)
prev)
    , (Text -> Symbol
mksym forall a b. (a -> b) -> a -> b
$ Text
sym forall a. Semigroup a => a -> a -> a
<> Text
"<<", Text -> CurveD -> InterpolatorTime a -> call
make Text
"-prev-const" CurveD
curve (forall a b. a -> Either a b
Left Parser Duration
prev_time_arg))
    , (Text -> Symbol
mksym forall a b. (a -> b) -> a -> b
$ Text
sym forall a. Semigroup a => a -> a -> a
<> Text
">", Text -> CurveD -> InterpolatorTime a -> call
make Text
"-next" CurveD
curve forall {a} {a}.
Either a (PassedArgs a -> Deriver State Error Duration, Text)
next)
    , (Text -> Symbol
mksym forall a b. (a -> b) -> a -> b
$ Text
sym forall a. Semigroup a => a -> a -> a
<> Text
">>", Text -> CurveD -> InterpolatorTime a -> call
make Text
"-next-const" CurveD
curve (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 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
default_interpolation_time
            Doc
"Time to reach destination."
    prev_time_arg :: Parser Duration
prev_time_arg = Duration -> Duration
invert forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
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 = forall a b. b -> Either a b
Right (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 = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ScoreTime -> Duration
DeriveT.ScoreDuration forall a b. (a -> b) -> a -> b
$
            forall a. PassedArgs a -> ScoreTime
Args.next PassedArgs a
args forall a. Num a => a -> a -> a
- forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs a
args
    prev :: Either a (PassedArgs a -> Deriver State Error Duration, Text)
prev = forall a b. b -> Either a b
Right (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 <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs a
args
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ RealTime -> Duration
DeriveT.RealDuration forall a b. (a -> b) -> a -> b
$ case 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 forall a. Num a => a -> a -> a
- RealTime
start

interpolator_variations :: [(Expr.Symbol, Derive.Generator Derive.Control)]
interpolator_variations :: [(Symbol, Generator Control)]
interpolator_variations = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ 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 = PFunction -> Curve
pf_to_curve forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.environ ArgName
"curve" EnvironDefault
Sig.Both PFunction
pf_linear Doc
"Curve function."

curve_arg :: Sig.Parser Curve
curve_arg :: Parser Curve
curve_arg = PFunction -> Curve
pf_to_curve 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
"curve" PFunction
pf_linear Doc
"Curve function."

pf_linear :: DeriveT.PFunction
pf_linear :: PFunction
pf_linear = Text -> Curve -> PFunction
curve_to_pf Text
"" Curve
Linear

-- | A PFunction 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.
pf_linear_name :: Text
pf_linear_name :: Text
pf_linear_name = Text
"curve-linear"

curve_time_env :: Sig.Parser (Curve, RealTime)
curve_time_env :: Parser (Curve, RealTime)
curve_time_env = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Curve
curve_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser RealTime
time
    where
    time :: Parser RealTime
time = forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.environ ArgName
"curve-time" EnvironDefault
Sig.Both (Int
0 :: Int) 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) =
    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
"curve-" forall a. Semigroup a => a -> a -> a
<> Text
name))
        Tags
Tags.curve
    (forall a. a -> Maybe a -> a
fromMaybe (Doc
"Interpolation function: " forall a. Semigroup a => a -> a -> a
<> Text -> Doc
Doc.Doc Text
name) Maybe Doc
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 Parser arg
get_arg forall a b. (a -> b) -> a -> b
$ \arg
arg PassedArgs Tagged
_args ->
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> Curve -> PFunction
curve_to_pf Text
name (arg -> Curve
curve arg
arg)

-- | Stuff a curve function into a PFunction.
curve_to_pf :: Text -> Curve -> DeriveT.PFunction
curve_to_pf :: Text -> Curve -> PFunction
curve_to_pf Text
name = \case
    Function Y -> Y
curvef -> DeriveT.PFunction
        { pf_name :: Text
pf_name = Text
name
        , pf_function :: TypedFunction
pf_function = forall a. a -> Typed a
ScoreT.untyped (Y -> Y
curvef forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealTime -> Y
RealTime.to_seconds)
        }
    Curve
Linear -> DeriveT.PFunction
        { pf_name :: Text
pf_name = Text
pf_linear_name
        , pf_function :: TypedFunction
pf_function = forall a. a -> Typed a
ScoreT.untyped RealTime -> Y
RealTime.to_seconds
        }

-- | Convert a PFunction back into a curve function.
pf_to_curve :: DeriveT.PFunction -> Curve
pf_to_curve :: PFunction -> Curve
pf_to_curve (DeriveT.PFunction Text
name TypedFunction
pf)
    | Text
name forall a. Eq a => a -> a -> Bool
== Text
pf_linear_name = Curve
Linear
    | Bool
otherwise = (Y -> Y) -> Curve
Function (forall a. Typed a -> a
ScoreT.val_of TypedFunction
pf 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 <- forall a. Time a => a -> Deriver RealTime
Derive.real ScoreTime
start
    RealTime
dur <- forall t1 t2. (Time t1, Time t2) => t1 -> t2 -> Deriver RealTime
Call.real_duration RealTime
start Duration
dur
    -- 0 is before, 1 is after.
    let offset :: RealTime
offset = RealTime
dur forall a. Num a => a -> a -> a
* Y -> RealTime
RealTime.seconds (Y
1 forall a. Num a => a -> a -> a
- Y
place)
    forall (m :: * -> *) a. Monad m => a -> m a
return (RealTime
start forall a. Num a => a -> a -> a
- RealTime
offset, RealTime
start forall a. Num a => a -> a -> a
+ RealTime
dur 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 -> 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
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 RealTime
Call.get_srate
    forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall a. Eq a => a -> a -> Bool
== RealTime
x2 Bool -> Bool -> Bool
&& Y
y1 forall a. Eq a => a -> a -> Bool
== Y
y2 = forall a. Monoid a => a
mempty
    -- If x1 == x2 I still need to make a vertical segment
    | Y
y1 forall a. Eq a => a -> a -> Bool
== Y
y2 = 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 -> forall {k} (kind :: k). [(RealTime, Y)] -> Signal kind
Signal.from_pairs [(RealTime
x1, Y
y1), (RealTime
x2, Y
y2)]
        Function Y -> Y
curvef -> forall {k} (kind :: k). [(RealTime, Y)] -> Signal kind
Signal.from_pairs forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ((Y -> Y) -> RealTime -> (RealTime, Y)
make Y -> Y
curvef) forall a b. (a -> b) -> a -> b
$
            forall a. (Num a, Ord a) => a -> a -> a -> [a]
Lists.rangeEnd RealTime
x1 RealTime
x2 (RealTime
1forall 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 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 =
    forall a. (Eq a, Num a) => a -> a -> a -> a
Num.scale Y
y1 Y
y2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Y -> Y
curvef forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Eq a, Fractional a) => a -> a -> a -> a
Num.normalize (RealTime -> Y
secs RealTime
x1) (RealTime -> Y
secs RealTime
x2) 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 forall a. Eq a => a -> a -> Bool
== Y
0 = forall {k} (kind :: k). RealTime -> Y -> Signal kind
Signal.from_sample RealTime
start Y
from
    | Just Y
limit <- if Y
slope forall a. Ord a => a -> a -> Bool
< Y
0 then Maybe Y
low else Maybe Y
high =
        let intercept :: RealTime
intercept = RealTime
start forall a. Num a => a -> a -> a
+ forall a. Ord a => a -> a -> a
max RealTime
0 (Y -> RealTime
RealTime.seconds ((Y
limitforall a. Num a => a -> a -> a
-Y
from) forall a. Fractional a => a -> a -> a
/ Y
slope))
        in if RealTime
intercept 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 forall a. Num a => a -> a -> a
+ RealTime -> Y
RealTime.to_seconds (RealTime
end forall a. Num a => a -> a -> a
- RealTime
start) forall a. Num a => a -> a -> a
* Y
slope

-- * exponential

exponential_curve :: CurveD
exponential_curve :: CurveD
exponential_curve = forall arg. Text -> Parser arg -> (arg -> Curve) -> CurveD
CurveD Text
"expon" Parser Y
args ((Y -> Y) -> Curve
Function forall b c a. (b -> c) -> (a -> b) -> a -> c
. Y -> Y -> Y
expon)
    where
    args :: Parser Y
args = forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"expon" (Y
2 :: Double) 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
xforall a. Floating a => a -> a -> a
**Y
exp
    where exp :: Y
exp = if Y
n forall a. Ord a => a -> a -> Bool
>= Y
0 then Y
n else Y
1 forall a. Fractional a => a -> a -> a
/ 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 forall a. Ord a => a -> a -> Bool
>= Y
1 = Y
1
    | Y
x forall a. Ord a => a -> a -> Bool
< Y
0.5 = Y -> Y -> Y
expon Y
a (Y
x forall a. Num a => a -> a -> a
* Y
2) forall a. Fractional a => a -> a -> a
/ Y
2
    | Bool
otherwise = Y -> Y -> Y
expon (-Y
b) ((Y
xforall a. Num a => a -> a -> a
-Y
0.5) forall a. Num a => a -> a -> a
* Y
2) forall a. Fractional a => a -> a -> a
/ Y
2 forall a. Num a => a -> a -> a
+ Y
0.5

-- * bezier

sigmoid_curve :: CurveD
sigmoid_curve :: CurveD
sigmoid_curve = 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 forall a b. (a -> b) -> a -> b
$ Y -> Y -> Y -> Y
sigmoid Y
w1 Y
w2
    args :: Parser (Y, Y)
args = (,)
        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
"w1" (Y
0.5 :: Double) Doc
"Start weight."
        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
"w2" (Y
0.5 :: Double) 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 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 forall a. Num a => a -> a -> a
+ Y
high) 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 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
1forall 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 =
    (forall {a}. Num a => a -> a -> a -> a -> a -> a
f Y
x1 Y
x2 Y
x3 Y
x4 Y
t, 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
1forall a. Num a => a -> a -> a
-a
t)forall a b. (Num a, Integral b) => a -> b -> a
^Integer
3 forall a. Num a => a -> a -> a
* a
p1 forall a. Num a => a -> a -> a
+ a
3forall a. Num a => a -> a -> a
*(a
1forall a. Num a => a -> a -> a
-a
t)forall a b. (Num a, Integral b) => a -> b -> a
^Integer
2forall a. Num a => a -> a -> a
*a
t forall a. Num a => a -> a -> a
* a
p2 forall a. Num a => a -> a -> a
+ a
3forall a. Num a => a -> a -> a
*(a
1forall a. Num a => a -> a -> a
-a
t)forall a. Num a => a -> a -> a
*a
tforall a b. (Num a, Integral b) => a -> b -> a
^Integer
2 forall a. Num a => a -> a -> a
* a
p3 forall a. Num a => a -> a -> a
+ a
tforall a b. (Num a, Integral b) => a -> b -> a
^Integer
3 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 = forall {k} (kind :: k). [(RealTime, Y)] -> Signal kind
Signal.from_pairs
breakpoints RealTime
srate Curve
curve =
    forall sig y.
Monoid sig =>
(RealTime -> y -> sig)
-> (RealTime -> y -> RealTime -> y -> sig)
-> [(RealTime, y)]
-> sig
signal_breakpoints 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 = forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap ((RealTime, y), Maybe (RealTime, y)) -> sig
line forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [(a, Maybe a)]
Lists.zipNext
    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]
_ -> [(forall a. (Eq a, Num a) => a -> a -> a -> a
Num.scale RealTime
start RealTime
end (RealTime
n forall a. Fractional a => a -> a -> a
/ (RealTime
len forall a. Num a => a -> a -> a
- RealTime
1)), a
x)
        | (RealTime
n, a
x) <- forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. Num a => a -> a -> [a]
Lists.range_ RealTime
0 RealTime
1) [a]
vals]
    where len :: RealTime
len = forall a b. (Integral a, Num b) => a -> b
fromIntegral (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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall y. RealTime -> [(RealTime, y)] -> [(RealTime, y)]
split_samples_absolute RealTime
time

-- | Smooth with 'split_samples_relative'.
smooth_relative :: Curve -> RealTime -> ScoreT.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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. Ord a => a -> a -> Bool
>= RealTime
0 = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a} {b} {b}.
(Maybe (a, b), (RealTime, b), Maybe (RealTime, b))
-> [(RealTime, b)]
split_prev forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [(Maybe a, a, Maybe a)]
Lists.zipNeighbors
    | Bool
otherwise = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {b} {b}.
((RealTime, b), Maybe (RealTime, b)) -> [(RealTime, b)]
split_next forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [(a, Maybe a)]
Lists.zipNext
    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) forall a. a -> [a] -> [a]
: if Bool
is_room then [(RealTime
x1 forall a. Num a => a -> a -> a
+ RealTime
time, b
y1)] else []
        where is_room :: Bool
is_room = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True ((RealTime
x1 forall a. Num a => a -> a -> a
+ RealTime
time <) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) forall a. a -> [a] -> [a]
: if RealTime
x2 forall a. Num a => a -> a -> a
+ RealTime
time forall a. Ord a => a -> a -> Bool
> RealTime
x1 then [(RealTime
x2 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 :: ScoreT.Function -> [(RealTime, y)]
    -> [(RealTime, y)]
split_samples_relative :: forall y. (RealTime -> Y) -> [(RealTime, y)] -> [(RealTime, y)]
split_samples_relative RealTime -> Y
time_at = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {b} {b}.
((RealTime, b), Maybe (RealTime, b)) -> [(RealTime, b)]
split forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [(a, Maybe a)]
Lists.zipNext
    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) forall a. a -> [a] -> [a]
: if RealTime
offset forall a. Eq a => a -> a -> Bool
== RealTime
0 then [] else [(RealTime
x1 forall a. Num a => a -> a -> a
+ RealTime
offset, b
y1)]
        where
        offset :: RealTime
offset = (RealTime
x2 forall a. Num a => a -> a -> a
- RealTime
x1) forall a. Num a => a -> a -> a
* (RealTime
1 forall a. Num a => a -> a -> a
- RealTime
time)
        time :: RealTime
time = Y -> RealTime
RealTime.seconds (forall a. Ord a => a -> a -> a -> a
Num.clamp Y
0 Y
1 (RealTime -> Y
time_at RealTime
x1))

-- * control mod

-- | 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 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
            [ if Y
identity forall a. Eq a => a -> a -> Bool
== Y
0 then forall a. Monoid a => a
mempty else forall {k} (kind :: k). Y -> Signal kind
Signal.constant Y
identity
            , Control
sig
            , 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_signal Control
control
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case forall a. Typed a -> a
ScoreT.val_of 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 forall a. Semigroup a => a -> a -> a
<> Control
sig forall a. Semigroup a => a -> a -> a
<> forall {k} (kind :: k). RealTime -> Signal kind -> Signal kind
Signal.clip_before RealTime
end Control
old
        Merger
Derive.Unset -> 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