-- 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 -- | Utilities that emit 'PSignal.PSignal's. module Derive.Call.PitchUtil where import qualified Util.Doc as Doc import qualified Util.Num as Num import qualified Util.Seq as Seq import qualified Derive.Args as Args import qualified Derive.Call as Call import qualified Derive.Call.ControlUtil as ControlUtil import Derive.Call.ControlUtil (Curve, SRate) import qualified Derive.Call.Module as Module import qualified Derive.Call.Tags as Tags import qualified Derive.Derive as Derive import qualified Derive.DeriveT as DeriveT import qualified Derive.Expr as Expr import qualified Derive.PSignal as PSignal import qualified Derive.Pitches as Pitches import qualified Derive.Sig as Sig import qualified Perform.Pitch as Pitch import qualified Perform.RealTime as RealTime import Global import Types type PitchOrTranspose = Either PSignal.Pitch Pitch.Transpose resolve_pitch_transpose :: PSignal.Pitch -> PitchOrTranspose -> PSignal.Pitch resolve_pitch_transpose :: Pitch -> PitchOrTranspose -> Pitch resolve_pitch_transpose Pitch pitch = (Pitch -> Pitch) -> (Transpose -> Pitch) -> PitchOrTranspose -> Pitch forall a c b. (a -> c) -> (b -> c) -> Either a b -> c either Pitch -> Pitch forall a. a -> a id ((Transpose -> Pitch -> Pitch) -> Pitch -> Transpose -> Pitch forall a b c. (a -> b -> c) -> b -> a -> c flip Transpose -> Pitch -> Pitch forall a. Transpose -> RawPitch a -> RawPitch a Pitches.transpose Pitch pitch) -- * interpolator call interpolator_call :: Text -> ControlUtil.CurveD -> ControlUtil.InterpolatorTime Derive.Pitch -> Derive.Generator Derive.Pitch interpolator_call :: Text -> CurveD -> InterpolatorTime PSignal -> Generator PSignal interpolator_call Text name_suffix (ControlUtil.CurveD Text name Parser arg get_arg arg -> Curve curve) InterpolatorTime PSignal interpolator_time = Module -> CallName -> Tags -> Doc -> WithArgDoc (PassedArgs PSignal -> Deriver PSignal) -> Generator PSignal 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 PSignal -> Deriver PSignal) -> Generator PSignal) -> WithArgDoc (PassedArgs PSignal -> Deriver PSignal) -> Generator PSignal forall a b. (a -> b) -> a -> b $ Parser (PitchOrTranspose, Duration, arg, Maybe Pitch) -> ((PitchOrTranspose, Duration, arg, Maybe Pitch) -> PassedArgs PSignal -> Deriver PSignal) -> WithArgDoc (PassedArgs PSignal -> Deriver PSignal) forall y a d. Taggable y => Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d) Sig.call ((,,,) (PitchOrTranspose -> Duration -> arg -> Maybe Pitch -> (PitchOrTranspose, Duration, arg, Maybe Pitch)) -> Parser PitchOrTranspose -> Parser (Duration -> arg -> Maybe Pitch -> (PitchOrTranspose, Duration, arg, Maybe Pitch)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Parser PitchOrTranspose pitch_arg Parser (Duration -> arg -> Maybe Pitch -> (PitchOrTranspose, Duration, arg, Maybe Pitch)) -> Parser Duration -> Parser (arg -> Maybe Pitch -> (PitchOrTranspose, Duration, arg, Maybe Pitch)) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> (Parser Duration -> Parser Duration) -> ((GetTime PSignal, Text) -> Parser Duration) -> InterpolatorTime PSignal -> 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 PSignal, Text) -> Parser Duration forall a b. a -> b -> a const (Parser Duration -> (GetTime PSignal, Text) -> Parser Duration) -> Parser Duration -> (GetTime PSignal, 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 PSignal interpolator_time Parser (arg -> Maybe Pitch -> (PitchOrTranspose, Duration, arg, Maybe Pitch)) -> Parser arg -> Parser (Maybe Pitch -> (PitchOrTranspose, Duration, arg, Maybe Pitch)) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser arg get_arg Parser (Maybe Pitch -> (PitchOrTranspose, Duration, arg, Maybe Pitch)) -> Parser (Maybe Pitch) -> Parser (PitchOrTranspose, Duration, arg, Maybe Pitch) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser (Maybe Pitch) from_env ) (((PitchOrTranspose, Duration, arg, Maybe Pitch) -> PassedArgs PSignal -> Deriver PSignal) -> WithArgDoc (PassedArgs PSignal -> Deriver PSignal)) -> ((PitchOrTranspose, Duration, arg, Maybe Pitch) -> PassedArgs PSignal -> Deriver PSignal) -> WithArgDoc (PassedArgs PSignal -> Deriver PSignal) forall a b. (a -> b) -> a -> b $ \(PitchOrTranspose to, Duration time, arg curve_arg, Maybe Pitch from) PassedArgs PSignal args -> do Duration time <- if PassedArgs PSignal -> TrackTime forall a. PassedArgs a -> TrackTime Args.duration PassedArgs PSignal args TrackTime -> TrackTime -> Bool forall a. Eq a => a -> a -> Bool == TrackTime 0 then case InterpolatorTime PSignal interpolator_time of Left Parser Duration _ -> Duration -> Deriver State Error Duration forall (m :: * -> *) a. Monad m => a -> m a return Duration time Right (GetTime PSignal get_time, Text _) -> GetTime PSignal get_time PassedArgs PSignal 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 PSignal -> Deriver State Error RealTime forall a. PassedArgs a -> Deriver State Error RealTime Args.real_duration PassedArgs PSignal args (RealTime start, RealTime end) <- PassedArgs PSignal -> Duration -> Deriver (RealTime, RealTime) forall t d. Time t => PassedArgs d -> t -> Deriver (RealTime, RealTime) Call.duration_from_start PassedArgs PSignal args Duration time Curve -> RealTime -> Maybe Pitch -> RealTime -> PitchOrTranspose -> Deriver PSignal 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 Pitch -> PassedArgs PSignal -> Maybe Pitch prev_val Maybe Pitch from PassedArgs PSignal args) (RealTime -> RealTime -> RealTime forall a. Ord a => a -> a -> a max RealTime start RealTime end) PitchOrTranspose 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 PSignal, Text) -> Text) -> InterpolatorTime PSignal -> 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 PSignal, Text) -> Text) -> (GetTime PSignal, Text) -> Text forall b c a. (b -> c) -> (a -> b) -> a -> c . (GetTime PSignal, Text) -> Text forall a b. (a, b) -> b snd) InterpolatorTime PSignal interpolator_time -- The only difference between this and ControlUtil.interpolator_call is -- the 'interpolate' call and 'pitch_arg'. pitch_arg :: Sig.Parser PitchOrTranspose pitch_arg :: Parser PitchOrTranspose pitch_arg = ArgName -> Doc -> Parser PitchOrTranspose forall a. Typecheck a => ArgName -> Doc -> Parser a Sig.required ArgName "pitch" Doc "Destination pitch, or a transposition from the previous one." -- | Use this for calls that start from the previous value, to give a way -- to override that behaviour. from_env :: Sig.Parser (Maybe PSignal.Pitch) from_env :: Parser (Maybe Pitch) from_env = ArgName -> EnvironDefault -> Maybe Pitch -> Doc -> Parser (Maybe Pitch) forall a. (Typecheck a, ShowVal a) => ArgName -> EnvironDefault -> a -> Doc -> Parser a Sig.environ ArgName "from" EnvironDefault Sig.Both Maybe Pitch forall a. Maybe a Nothing Doc "Start from this pitch. If unset, use the previous pitch." prev_val :: Maybe PSignal.Pitch -> Derive.PitchArgs -> Maybe PSignal.Pitch prev_val :: Maybe Pitch -> PassedArgs PSignal -> Maybe Pitch prev_val Maybe Pitch from PassedArgs PSignal args = Maybe Pitch from Maybe Pitch -> Maybe Pitch -> Maybe Pitch forall (f :: * -> *) a. Alternative f => f a -> f a -> f a <|> ((RealTime, Pitch) -> Pitch forall a b. (a, b) -> b snd ((RealTime, Pitch) -> Pitch) -> Maybe (RealTime, Pitch) -> Maybe Pitch forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> PassedArgs PSignal -> Maybe (RealTime, Pitch) Args.prev_pitch PassedArgs PSignal args) -- | Pitch version of 'ControlUtil.interpolator_variations'. interpolator_variations :: [(Expr.Symbol, Derive.Generator Derive.Pitch)] interpolator_variations :: [(Symbol, Generator PSignal)] interpolator_variations = [[(Symbol, Generator PSignal)]] -> [(Symbol, Generator PSignal)] forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat [ (Text -> CurveD -> InterpolatorTime PSignal -> Generator PSignal) -> Symbol -> CurveD -> [(Symbol, Generator PSignal)] forall a call. Taggable a => (Text -> CurveD -> InterpolatorTime a -> call) -> Symbol -> CurveD -> [(Symbol, call)] ControlUtil.interpolator_variations_ Text -> CurveD -> InterpolatorTime PSignal -> Generator PSignal interpolator_call Symbol sym CurveD curve | (Symbol sym, CurveD curve) <- [(Symbol, CurveD)] ControlUtil.standard_curves ] -- * interpolate -- | Make a curve segment from the previous value, if there was one. make_segment_from :: Curve -> RealTime -> Maybe PSignal.Pitch -> RealTime -> PitchOrTranspose -> Derive.Deriver PSignal.PSignal make_segment_from :: Curve -> RealTime -> Maybe Pitch -> RealTime -> PitchOrTranspose -> Deriver PSignal make_segment_from Curve curve RealTime start Maybe Pitch maybe_from RealTime end PitchOrTranspose to = case Maybe Pitch maybe_from of Maybe Pitch Nothing -> PSignal -> Deriver PSignal forall (m :: * -> *) a. Monad m => a -> m a return (PSignal -> Deriver PSignal) -> PSignal -> Deriver PSignal forall a b. (a -> b) -> a -> b $ case PitchOrTranspose to of Left Pitch to -> RealTime -> Pitch -> PSignal PSignal.from_sample RealTime start Pitch to Right Transpose _ -> PSignal forall a. Monoid a => a mempty Just Pitch from -> Curve -> RealTime -> Pitch -> RealTime -> Pitch -> Deriver PSignal make_segment Curve curve RealTime start Pitch from RealTime end (Pitch -> PitchOrTranspose -> Pitch resolve_pitch_transpose Pitch from PitchOrTranspose to) make_segment :: Curve -> RealTime -> PSignal.Pitch -> RealTime -> PSignal.Pitch -> Derive.Deriver PSignal.PSignal make_segment :: Curve -> RealTime -> Pitch -> RealTime -> Pitch -> Deriver PSignal make_segment Curve curve RealTime x1 Pitch y1 RealTime x2 Pitch y2 = do RealTime srate <- Deriver State Error RealTime Call.get_srate PSignal -> Deriver PSignal forall (m :: * -> *) a. Monad m => a -> m a return (PSignal -> Deriver PSignal) -> PSignal -> Deriver PSignal forall a b. (a -> b) -> a -> b $ RealTime -> Curve -> RealTime -> Pitch -> RealTime -> Pitch -> PSignal segment RealTime srate Curve curve RealTime x1 Pitch y1 RealTime x2 Pitch y2 type Interpolate = RealTime -> PSignal.Pitch -> RealTime -> PSignal.Pitch -- ^ start -> starty -> end -> endy -> PSignal.PSignal -- | Interpolate between the given points. -- TODO(polymorphic-signals) same as ControlUtil.segment, well except Eq use segment :: SRate -> Curve -> RealTime -> PSignal.Pitch -> RealTime -> PSignal.Pitch -> PSignal.PSignal segment :: RealTime -> Curve -> RealTime -> Pitch -> RealTime -> Pitch -> PSignal segment RealTime srate Curve curve RealTime x1 Pitch y1 RealTime x2 Pitch y2 | RealTime x1 RealTime -> RealTime -> Bool forall a. Ord a => a -> a -> Bool > RealTime x2 = PSignal forall a. Monoid a => a mempty -- if x1 == x2 I still need to make a vertical segment -- I can't optimize y1==y2, which means flat breakpoints on a nonlinear -- curve get redundant samples. | Bool otherwise = case Curve curve of Curve ControlUtil.Linear -> [(RealTime, Pitch)] -> PSignal PSignal.from_pairs [(RealTime x1, Pitch y1), (RealTime x2, Pitch y2)] ControlUtil.Function Double -> Double curvef -> [(RealTime, Pitch)] -> PSignal PSignal.from_pairs ([(RealTime, Pitch)] -> PSignal) -> [(RealTime, Pitch)] -> PSignal forall a b. (a -> b) -> a -> b $ (RealTime -> (RealTime, Pitch)) -> [RealTime] -> [(RealTime, Pitch)] forall a b. (a -> b) -> [a] -> [b] map ((Double -> Double) -> RealTime -> (RealTime, Pitch) make Double -> Double curvef) ([RealTime] -> [(RealTime, Pitch)]) -> [RealTime] -> [(RealTime, Pitch)] 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 :: (Double -> Double) -> RealTime -> (RealTime, Pitch) make Double -> Double 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, Pitch y2) | Bool otherwise = (RealTime x, (Double -> Double) -> RealTime -> Pitch y_at Double -> Double curvef RealTime x) y_at :: (Double -> Double) -> RealTime -> Pitch y_at Double -> Double curvef = Pitch -> Pitch -> Double -> Pitch Pitches.interpolated Pitch y1 Pitch y2 (Double -> Pitch) -> (RealTime -> Double) -> RealTime -> Pitch forall b c a. (b -> c) -> (a -> b) -> a -> c . Double -> Double curvef (Double -> Double) -> (RealTime -> Double) -> RealTime -> Double forall b c a. (b -> c) -> (a -> b) -> a -> c . Double -> Double -> Double -> Double forall a. (Eq a, Fractional a) => a -> a -> a -> a Num.normalize (RealTime -> Double secs RealTime x1) (RealTime -> Double secs RealTime x2) (Double -> Double) -> (RealTime -> Double) -> RealTime -> Double forall b c a. (b -> c) -> (a -> b) -> a -> c . RealTime -> Double secs where secs :: RealTime -> Double secs = RealTime -> Double RealTime.to_seconds -- * breakpoints -- | Create line segments between the given breakpoints. breakpoints :: SRate -> Curve -> [(RealTime, PSignal.Pitch)] -> PSignal.PSignal breakpoints :: RealTime -> Curve -> [(RealTime, Pitch)] -> PSignal breakpoints RealTime _ Curve ControlUtil.Linear = [(RealTime, Pitch)] -> PSignal PSignal.from_pairs breakpoints RealTime srate Curve curve = (RealTime -> Pitch -> PSignal) -> (RealTime -> Pitch -> RealTime -> Pitch -> PSignal) -> [(RealTime, Pitch)] -> PSignal forall sig y. Monoid sig => (RealTime -> y -> sig) -> (RealTime -> y -> RealTime -> y -> sig) -> [(RealTime, y)] -> sig ControlUtil.signal_breakpoints RealTime -> Pitch -> PSignal PSignal.from_sample (RealTime -> Curve -> RealTime -> Pitch -> RealTime -> Pitch -> PSignal segment RealTime srate Curve curve)