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

-- | Transformers on control and pitch signals.
module Derive.C.Prelude.SignalTransform (
    library
    , slew_limiter
) where
import qualified Data.List as List
import qualified Data.List.NonEmpty as NonEmpty

import qualified Util.Lists as Lists
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.Speed as Speed
import qualified Derive.Call.Tags as Tags
import qualified Derive.Derive as Derive
import qualified Derive.Library as Library
import qualified Derive.PSignal as PSignal
import qualified Derive.ScoreT as ScoreT
import qualified Derive.ShowVal as ShowVal
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           Types


library :: Library.Library
library :: Library
library = forall a. Monoid a => [a] -> a
mconcat
    [ forall call.
ToLibrary (Transformer call) =>
[(Symbol, Transformer call)] -> Library
Library.transformers [(Symbol
"cf-sample", Transformer Note
c_cf_sample)]
    , forall call.
ToLibrary (Transformer call) =>
[(Symbol, Transformer call)] -> Library
Library.transformers [(Symbol
"sh", Transformer Pitch
c_sh_pitch)]
    , forall call.
ToLibrary (Transformer call) =>
[(Symbol, Transformer call)] -> Library
Library.transformers
        [ (Symbol
"quantize", Transformer Control
c_quantize)
        , (Symbol
"sh", Transformer Control
c_sh_control)
        , (Symbol
"slew", Transformer Control
c_slew)
        , (Symbol
"smooth", Transformer Control
c_smooth)
        , (Symbol
"->", Merge -> Transformer Control
c_redirect Merge
Derive.DefaultMerge)
        -- TODO should I set to 1 at start and end, like
        -- Control.multiply_signal?
        , (Symbol
"->+", Merge -> Transformer Control
c_redirect (Merger -> Merge
Derive.Merge Merger
Derive.merge_add))
        ]
    ]

-- * pitch

c_sh_pitch :: Derive.Transformer Derive.Pitch
c_sh_pitch :: Transformer Pitch
c_sh_pitch = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude CallName
"sh" forall a. Monoid a => a
mempty
    Doc
"Sample & hold. Hold values at the given speed."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Transformer y d) -> WithArgDoc (Transformer y d)
Sig.callt Parser RealTimeFunctionT
Speed.arg forall a b. (a -> b) -> a -> b
$ \RealTimeFunctionT
speed PassedArgs Pitch
_args Deriver (Stream Pitch)
deriver -> do
        (Pitch
sig, (RealTime
start, RealTime
end), [Msg]
logs) <- Deriver (Stream Pitch)
-> Deriver (Pitch, (RealTime, RealTime), [Msg])
Post.pitch_range Deriver (Stream Pitch)
deriver
        [RealTime]
starts <- forall t.
Time t =>
RealTimeFunctionT -> (t, t) -> Bool -> Deriver [RealTime]
Speed.starts RealTimeFunctionT
speed (RealTime
start, RealTime
end) Bool
True
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> [Msg] -> Stream a
Stream.from_event_logs ([RealTime] -> Pitch -> Pitch
sample_hold_pitch [RealTime]
starts Pitch
sig) [Msg]
logs

-- TODO(polymorphic-signals): this is the same as 'sample_hold_control'
sample_hold_pitch :: [RealTime] -> PSignal.PSignal -> PSignal.PSignal
sample_hold_pitch :: [RealTime] -> Pitch -> Pitch
sample_hold_pitch [RealTime]
points Pitch
sig = [(RealTime, Pitch)] -> Pitch
PSignal.from_pairs forall a b. (a -> b) -> a -> b
$ do
    (RealTime
x1, Maybe RealTime
n) <- forall a. [a] -> [(a, Maybe a)]
Lists.zipNext [RealTime]
points
    Just Pitch
y <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Pitch -> RealTime -> Maybe Pitch
PSignal.at Pitch
sig RealTime
x1
    RealTime
x <- RealTime
x1 forall a. a -> [a] -> [a]
: forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall a. a -> [a] -> [a]
:[]) Maybe RealTime
n
    forall (m :: * -> *) a. Monad m => a -> m a
return (RealTime
x, Pitch
y)


-- * control

c_sh_control :: Derive.Transformer Derive.Control
c_sh_control :: Transformer Control
c_sh_control = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude CallName
"sh" forall a. Monoid a => a
mempty
    Doc
"Sample & hold. Hold values at the given speed."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Transformer y d) -> WithArgDoc (Transformer y d)
Sig.callt Parser RealTimeFunctionT
Speed.arg forall a b. (a -> b) -> a -> b
$ \RealTimeFunctionT
speed PassedArgs Control
_args Deriver (Stream Control)
deriver -> do
        (Control
sig, (RealTime
start, RealTime
end), [Msg]
logs) <- Deriver (Stream Control)
-> Deriver (Control, (RealTime, RealTime), [Msg])
Post.control_range Deriver (Stream Control)
deriver
        [RealTime]
starts <- forall t.
Time t =>
RealTimeFunctionT -> (t, t) -> Bool -> Deriver [RealTime]
Speed.starts RealTimeFunctionT
speed (RealTime
start, RealTime
end) Bool
True
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> [Msg] -> Stream a
Stream.from_event_logs ([RealTime] -> Control -> Control
sample_hold_control [RealTime]
starts Control
sig) [Msg]
logs

sample_hold_control :: [RealTime] -> Signal.Control -> Signal.Control
sample_hold_control :: [RealTime] -> Control -> Control
sample_hold_control [RealTime]
points Control
sig = forall {k} (kind :: k). [(RealTime, Y)] -> Signal kind
Signal.from_pairs forall a b. (a -> b) -> a -> b
$ do
    (RealTime
x1, Maybe RealTime
n) <- forall a. [a] -> [(a, Maybe a)]
Lists.zipNext [RealTime]
points
    let y :: Y
y = forall {k} (kind :: k). Signal kind -> RealTime -> Y
Signal.at Control
sig RealTime
x1
    RealTime
x <- RealTime
x1 forall a. a -> [a] -> [a]
: forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall a. a -> [a] -> [a]
:[]) Maybe RealTime
n
    forall (m :: * -> *) a. Monad m => a -> m a
return (RealTime
x, Y
y)

c_quantize :: Derive.Transformer Derive.Control
c_quantize :: Transformer Control
c_quantize = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude CallName
"quantize" forall a. Monoid a => a
mempty
    Doc
"Quantize a control signal."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Transformer y d) -> WithArgDoc (Transformer y d)
Sig.callt (forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"val" Doc
"Quantize to multiples of this value.") forall a b. (a -> b) -> a -> b
$
    \Y
val PassedArgs Control
_args Deriver (Stream Control)
deriver -> do
        RealTime
srate <- Deriver RealTime
Call.get_srate
        forall sig.
Monoid sig =>
(sig -> sig) -> Deriver (Stream sig) -> Deriver (Stream sig)
Post.signal (RealTime -> Y -> Control -> Control
quantize RealTime
srate Y
val) Deriver (Stream Control)
deriver

-- This would need to change for linear segments: for each segment, find where
-- it crosses the threshold between multiples, draw flat segments at each one.
-- But it may be that I want to do a soft quantize, where I map through
-- a function which is attracted to the quantize points, and that will need
-- resampling anyway.  So I'll leave this as-is.
quantize :: RealTime -> Signal.Y -> Signal.Control -> Signal.Control
quantize :: RealTime -> Y -> Control -> Control
quantize RealTime
srate Y
val
    | Y
val forall a. Eq a => a -> a -> Bool
== Y
0 = forall a. a -> a
id
    | Bool
otherwise = forall {k} (kind :: k).
RealTime -> (Y -> Y) -> Signal kind -> Signal kind
Signal.map_y RealTime
srate
        (\Y
y -> forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a b. (RealFrac a, Integral b) => a -> b
round (Y
y forall a. Fractional a => a -> a -> a
/ Y
val)) forall a. Num a => a -> a -> a
* Y
val)

c_slew :: Derive.Transformer Derive.Control
c_slew :: Transformer Control
c_slew = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude CallName
"slew" forall a. Monoid a => a
mempty
    Doc
"Smooth a signal by interpolating such that it doesn't exceed the given\
    \ slope."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Transformer y d) -> WithArgDoc (Transformer y d)
Sig.callt (forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"slope" Doc
"Maximum allowed slope, per second.")
    forall a b. (a -> b) -> a -> b
$ \Y
slope PassedArgs Control
_args -> forall sig.
Monoid sig =>
(sig -> sig) -> Deriver (Stream sig) -> Deriver (Stream sig)
Post.signal (Y -> Control -> Control
slew_limiter Y
slope)

-- | Smooth the signal by not allowing the signal to change faster than the
-- given slope.
slew_limiter :: Signal.Y -> Signal.Control -> Signal.Control
slew_limiter :: Y -> Control -> Control
slew_limiter Y
max_slope =
    forall {k} (kind :: k). [(RealTime, Y)] -> Signal kind
Signal.from_pairs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL Maybe (RealTime, Y)
-> (RealTime, Y) -> (Maybe (RealTime, Y), (RealTime, Y))
limit forall a. Maybe a
Nothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (kind :: k). Signal kind -> [(RealTime, Y)]
Signal.to_pairs
    where
    limit :: Maybe (RealTime, Y)
-> (RealTime, Y) -> (Maybe (RealTime, Y), (RealTime, Y))
limit Maybe (RealTime, Y)
Nothing (RealTime
x, Y
y) = (forall a. a -> Maybe a
Just (RealTime
x, Y
y), (RealTime
x, Y
y))
    limit (Just (RealTime
x0, Y
y0)) (RealTime
x1, Y
y1)
        | forall a. Num a => a -> a
abs Y
slope forall a. Ord a => a -> a -> Bool
<= Y
max_slope = (forall a. a -> Maybe a
Just (RealTime
x1, Y
y1), (RealTime
x1, Y
y1))
        | Bool
otherwise = (forall a. a -> Maybe a
Just (RealTime
x1, Y
y), (RealTime
x1, Y
y))
        where
        y :: Y
y = Y
dx forall a. Num a => a -> a -> a
* Y
max_slope
        slope :: Y
slope = (Y
y1 forall a. Num a => a -> a -> a
- Y
y0) forall a. Fractional a => a -> a -> a
/ Y
dx
        dx :: Y
dx = RealTime -> Y
RealTime.to_seconds (RealTime
x1 forall a. Num a => a -> a -> a
- RealTime
x0)

-- TODO maybe a bit broken since signals are now usually continuous?
-- Fix it when necessary.
c_smooth :: Derive.Transformer Derive.Control
c_smooth :: Transformer Control
c_smooth = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude CallName
"smooth" forall a. Monoid a => a
mempty
    Doc
"Smooth a signal by interpolating between discontinuities."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Transformer y d) -> WithArgDoc (Transformer y d)
Sig.callt ((,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"time" Doc
"Amount of time to reach to the next sample.\
        \ If negative, it will end on the destination sample rather than\
        \ start on it. The time will be compressed if the samples are too\
        \ close, so unlike `slew`, this will always reach the samples in the\
        \ source."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Curve
ControlUtil.curve_arg
    ) forall a b. (a -> b) -> a -> b
$ \(Typecheck.DefaultReal Duration
time, Curve
curve) PassedArgs Control
args Deriver (Stream Control)
deriver -> do
        RealTime
srate <- Deriver RealTime
Call.get_srate
        RealTime
time <- forall t1 t2. (Time t1, Time t2) => t1 -> t2 -> Deriver RealTime
Call.real_duration (forall a. PassedArgs a -> TrackTime
Args.start PassedArgs Control
args) Duration
time
        forall sig.
Monoid sig =>
(sig -> sig) -> Deriver (Stream sig) -> Deriver (Stream sig)
Post.signal (Curve -> RealTime -> RealTime -> [(RealTime, Y)] -> Control
ControlUtil.smooth_absolute Curve
curve RealTime
srate RealTime
time
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Eq k => (a -> k) -> [a] -> [a]
Lists.dropInitialDups forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (kind :: k). Signal kind -> [(RealTime, Y)]
Signal.to_pairs) Deriver (Stream Control)
deriver

c_redirect :: Derive.Merge -> Derive.Transformer Derive.Control
c_redirect :: Merge -> Transformer Control
c_redirect Merge
merger =
    forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude CallName
"redirect" Tags
Tags.cmod
    (Doc
"Redirect a signal to another control, using the control modifier hack.\
    \ The control is combined with " forall a. Semigroup a => a -> a -> a
<> Merge -> Doc
merge_name Merge
merger forall a. Semigroup a => a -> a -> a
<> Doc
".")
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Transformer y d) -> WithArgDoc (Transformer y d)
Sig.callt (forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"control" Doc
"Redirect to this control.")
    forall a b. (a -> b) -> a -> b
$ \Control
control PassedArgs Control
_args Deriver (Stream Control)
deriver -> do
        (Control
sig, [Msg]
logs) <- forall sig.
Monoid sig =>
Deriver (Stream sig) -> Deriver (sig, [Msg])
Post.derive_signal Deriver (Stream Control)
deriver
        Merger
merger <- Merge -> Control -> Deriver Merger
Derive.resolve_merge Merge
merger Control
control
        Merger -> Control -> Control -> Deriver ()
Derive.modify_control Merger
merger Control
control Control
sig
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [Msg] -> Stream a
Stream.from_logs [Msg]
logs
    where
    merge_name :: Merge -> Doc
merge_name Merge
Derive.DefaultMerge = Doc
"the default merger for the control"
    merge_name (Derive.Merge Merger
merger) = forall a. ShowVal a => a -> Doc
ShowVal.doc Merger
merger

c_cf_sample :: Derive.Transformer Derive.Note
c_cf_sample :: Transformer Note
c_cf_sample = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude CallName
"cf-sample"
    Tags
Tags.control_function
    Doc
"Sample the given control functions and insert them as constants in the\
    \ control map. The default note call expects continuous signals, so it\
    \ takes slices out of the control map. This transfers control functions\
    \ to the control map, so you can e.g. use randomized controls."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Transformer y d) -> WithArgDoc (Transformer y d)
Sig.callt (forall a. Typecheck a => ArgName -> Doc -> Parser (NonEmpty a)
Sig.many1 ArgName
"control" Doc
"Sample these control functions.")
    forall a b. (a -> b) -> a -> b
$ \NonEmpty Control
controls PassedArgs Note
args Deriver (Stream Note)
deriver -> do
        RealTime
start <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Note
args
        [Maybe (Typed Y)]
vals <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b c. (a -> b -> c) -> b -> a -> c
flip Control -> RealTime -> Deriver (Maybe (Typed Y))
Derive.control_at RealTime
start) (forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Control
controls)
        forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Control -> Y -> Deriver a -> Deriver a
Call.with_constant) Deriver (Stream Note)
deriver
            [ (Control
c, forall a. Typed a -> a
ScoreT.val_of Typed Y
v)
            | (Control
c, Just Typed Y
v) <- forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Control
controls) [Maybe (Typed Y)]
vals
            ]