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