-- 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 -- | Library of basic high level pitch calls. -- -- High level calls do something a little more abstract and \"musical\" -- than the low level calls in "Derive.Call.Prelude.Pitch". Generally they -- have complete-word names, while low level calls are just single letters. -- -- TODO this module has a dumb name. What would be better? module Derive.C.Prelude.PitchHigh (library) where import qualified Util.Doc as Doc import qualified Derive.Args as Args import qualified Derive.C.Prelude.Pitch as Call.Pitch import qualified Derive.Call as Call import qualified Derive.Call.ControlUtil as ControlUtil import qualified Derive.Call.Module as Module import qualified Derive.Call.PitchUtil as PitchUtil import qualified Derive.Call.Sub as Sub 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.Deriver.Internal as Internal import qualified Derive.Library as Library import qualified Derive.PSignal as PSignal import qualified Derive.Pitches as Pitches import qualified Derive.ScoreT as ScoreT import qualified Derive.Sig as Sig import Derive.Sig (defaulted) import qualified Derive.Typecheck as Typecheck import qualified Perform.Pitch as Pitch 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 "lift", Transformer Note c_lift_note) , (Symbol "drop", Transformer Note c_drop_note) , (Symbol "Lift", Transformer Note c_lift_note_start) , (Symbol "Drop", Transformer Note c_drop_note_start) ] , forall call. ToLibrary (Generator call) => [(Symbol, Generator call)] -> Library Library.generators [ (Symbol "drop", Generator PSignal c_drop) , (Symbol "lift", Generator PSignal c_lift) , (Symbol "ad", Generator PSignal c_approach_dyn) ] ] -- * note calls c_lift_note :: Derive.Transformer Derive.Note c_lift_note :: Transformer Note c_lift_note = CallName -> Doc -> PitchDirection -> Align -> Align -> Transformer Note make_note_fade CallName "lift" Doc "Raise pitch and drop `dyn` at the end of the note. Same as the `drop`\ \ note call, except it defaults to going up instead of down." PitchDirection PitchLift Align AlignEnd Align AlignStart c_drop_note :: Derive.Transformer Derive.Note c_drop_note :: Transformer Note c_drop_note = CallName -> Doc -> PitchDirection -> Align -> Align -> Transformer Note make_note_fade CallName "drop" Doc "Drop pitch and `dyn` at the end of the note." PitchDirection PitchDrop Align AlignEnd Align AlignStart c_lift_note_start :: Derive.Transformer Derive.Note c_lift_note_start :: Transformer Note c_lift_note_start = CallName -> Doc -> PitchDirection -> Align -> Align -> Transformer Note make_note_fade CallName "Lift" Doc "Attack the note from a lower neighbor. This is like the `n` pitch call,\ \ but it's a note call, and it fades in `dyn` at the same time." PitchDirection PitchDrop Align AlignStart Align AlignEnd -- The PitchDirection is reversed because a lift at the beginning of a note -- comes from below. Also, I align the pitch to the end of the fade -- for symmetry with 'drop' and 'lift', I'm not sure if it's actually more -- musically useful that way. c_drop_note_start :: Derive.Transformer Derive.Note c_drop_note_start :: Transformer Note c_drop_note_start = CallName -> Doc -> PitchDirection -> Align -> Align -> Transformer Note make_note_fade CallName "Drop" Doc "Like `Lift`, but attack the note from a higher neighbor." PitchDirection PitchLift Align AlignStart Align AlignEnd -- Like 'c_lift_note_start', the PitchDirection is reversed. make_note_fade :: Derive.CallName -> Doc.Doc -> PitchDirection -> Align -> Align -> Derive.Transformer Derive.Note make_note_fade :: CallName -> Doc -> PitchDirection -> Align -> Align -> Transformer Note make_note_fade CallName name Doc doc PitchDirection pitch_dir Align align Align align_fade = forall d. Module -> CallName -> Tags -> Doc -> WithArgDoc (TransformerF d) -> Transformer d Derive.transformer Module Module.prelude CallName name Tags Tags.under_invert Doc 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 Parser (Either Transpose Pitch, DefaultReal, Maybe DefaultReal, Curve) fade_args forall a b. (a -> b) -> a -> b $ \(Either Transpose Pitch interval, Typecheck.DefaultReal Duration time, Maybe DefaultReal maybe_fade, Curve curve) -> Transformer Note (Stream Note) -> Transformer Note (Stream Note) Sub.under_invert forall a b. (a -> b) -> a -> b $ \NoteArgs args NoteDeriver deriver -> do let fade :: Duration fade = case Maybe DefaultReal maybe_fade of Maybe DefaultReal Nothing -> Duration time Just (Typecheck.DefaultReal Duration t) -> Duration t ranges :: ((X, X), (X, X)) ranges@((X pitch_start, X _), (X, X) _) <- Align -> Align -> Duration -> Duration -> ScoreTime -> ScoreTime -> Deriver ((X, X), (X, X)) pitch_fade_ranges Align align Align align_fade Duration fade Duration time (forall a. PassedArgs a -> ScoreTime Args.start NoteArgs args) (forall a. PassedArgs a -> ScoreTime Args.end NoteArgs args) X -> Deriver (Maybe Pitch) Derive.pitch_at X pitch_start forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \case Maybe Pitch Nothing -> NoteDeriver deriver Just Pitch pitch -> do (PSignal slide, Control dyn) <- Align -> Curve -> Pitch -> PitchDirection -> Either Transpose Pitch -> ((X, X), (X, X)) -> Deriver (PSignal, Control) pitch_fade Align align Curve curve Pitch pitch PitchDirection pitch_dir Either Transpose Pitch interval ((X, X), (X, X)) ranges PSignal pitch_sig <- forall a. (Dynamic -> a) -> Deriver a Internal.get_dynamic Dynamic -> PSignal Derive.state_pitch let merged :: PSignal merged = case Align align of -- Since the initial slide has to override the base -- pitch, I can't just merge normally. Align AlignStart -> PSignal -> PSignal -> PSignal PSignal.prepend PSignal slide PSignal pitch_sig Align AlignEnd -> PSignal pitch_sig forall a. Semigroup a => a -> a -> a <> PSignal slide forall a. Control -> Typed Control -> Deriver a -> Deriver a Call.multiply_control Control Controls.dynamic (forall a. a -> Typed a ScoreT.untyped Control dyn) forall a b. (a -> b) -> a -> b $ forall a. PSignal -> Deriver a -> Deriver a Derive.with_pitch PSignal merged NoteDeriver deriver fade_args :: Sig.Parser (Either Pitch.Transpose PSignal.Pitch, Typecheck.DefaultReal, Maybe Typecheck.DefaultReal, ControlUtil.Curve) fade_args :: Parser (Either Transpose Pitch, DefaultReal, Maybe DefaultReal, Curve) fade_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 defaulted ArgName "interval" (forall a b. a -> Either a b Left (Y -> Transpose Pitch.Chromatic Y 7) :: Either Pitch.Transpose Sig.Dummy) Doc "Interval or destination pitch." 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 defaulted ArgName "time" (X -> DefaultReal Typecheck.real X 0.25) Doc "Time to the destination pitch." 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 defaulted ArgName "fade" (forall a. Maybe a Nothing :: Maybe Sig.Dummy) Doc "Time to fade from or to nothing. If the fade is longer than the pitch\ \ time, the pitch will finish moving before the dyn has faded out." forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser Curve ControlUtil.curve_env -- * pitch calls c_drop :: Derive.Generator Derive.Pitch c_drop :: Generator PSignal c_drop = CallName -> Doc -> PitchDirection -> Generator PSignal make_pitch_fade CallName "drop" Doc "Drop pitch and `dyn`." PitchDirection PitchDrop c_lift :: Derive.Generator Derive.Pitch c_lift :: Generator PSignal c_lift = CallName -> Doc -> PitchDirection -> Generator PSignal make_pitch_fade CallName "lift" Doc "Lift pitch and drop `dyn`. This is the same as `drop`, except that it\ \ defaults to going up instead of down." PitchDirection PitchLift make_pitch_fade :: Derive.CallName -> Doc.Doc -> PitchDirection -> Derive.Generator Derive.Pitch make_pitch_fade :: CallName -> Doc -> PitchDirection -> Generator PSignal make_pitch_fade CallName name Doc doc PitchDirection pitch_dir = forall d. Module -> CallName -> Tags -> Doc -> WithArgDoc (PassedArgs d -> Deriver d) -> Generator d Derive.generator1 Module Module.prelude CallName name Tags Tags.cmod 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 (Either Transpose Pitch, DefaultReal, Maybe DefaultReal, Curve) fade_args forall a b. (a -> b) -> a -> b $ \(Either Transpose Pitch interval, Typecheck.DefaultReal Duration time, Maybe DefaultReal maybe_fade, Curve curve) PassedArgs PSignal args -> do let fade :: Duration fade = case Maybe DefaultReal maybe_fade of Maybe DefaultReal Nothing -> Duration time Just (Typecheck.DefaultReal Duration t) -> Duration t case PassedArgs PSignal -> Maybe (X, Pitch) Args.prev_pitch PassedArgs PSignal args of Maybe (X, Pitch) Nothing -> forall (m :: * -> *) a. Monad m => a -> m a return forall a. Monoid a => a mempty Just (X _, Pitch prev_pitch) -> do (PSignal slide, Control dyn) <- Align -> Curve -> Pitch -> PitchDirection -> Either Transpose Pitch -> ((X, X), (X, X)) -> Deriver (PSignal, Control) pitch_fade Align AlignEnd Curve curve Pitch prev_pitch PitchDirection pitch_dir Either Transpose Pitch interval forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< Align -> Align -> Duration -> Duration -> ScoreTime -> ScoreTime -> Deriver ((X, X), (X, X)) pitch_fade_ranges Align AlignStart Align AlignStart Duration fade Duration time (forall a. PassedArgs a -> ScoreTime Args.start PassedArgs PSignal args) (forall a. PassedArgs a -> ScoreTime Args.start PassedArgs PSignal args) X next <- forall a. Time a => a -> Deriver X Derive.real (forall a. PassedArgs a -> ScoreTime Args.next PassedArgs PSignal args) X -> Control -> Deriver () ControlUtil.multiply_dyn X next Control dyn forall (m :: * -> *) a. Monad m => a -> m a return PSignal slide c_approach_dyn :: Derive.Generator Derive.Pitch c_approach_dyn :: Generator PSignal c_approach_dyn = forall d. Module -> CallName -> Tags -> Doc -> WithArgDoc (PassedArgs d -> Deriver d) -> Generator d Derive.generator1 Module Module.prelude CallName "approach-dyn" (Tags Tags.cmod forall a. Semigroup a => a -> a -> a <> Tags Tags.next) Doc "Like `approach`, slide to the next pitch, but also drop the `dyn`." 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 deflt. (Typecheck a, ToVal deflt) => ArgName -> deflt -> Doc -> Parser a defaulted ArgName "time" (X -> DefaultReal Typecheck.real X 0.2) Doc "Time to get to destination pitch and dyn." 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 defaulted ArgName "dyn" (Y 0.25 :: Double) Doc "Drop `dyn` by this factor." forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser Curve ControlUtil.curve_env ) forall a b. (a -> b) -> a -> b $ \(Typecheck.DefaultReal Duration time, Y dyn, Curve curve) PassedArgs PSignal args -> do (X start, X end) <- forall t d. Time t => PassedArgs d -> t -> Deriver (X, X) Call.duration_from_start PassedArgs PSignal args Duration time X -> Control -> Deriver () ControlUtil.multiply_dyn X end forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< Curve -> X -> Y -> X -> Y -> Deriver Control ControlUtil.make_segment Curve ControlUtil.Linear X start Y 1 X end Y dyn PassedArgs PSignal -> Curve -> X -> X -> Deriver PSignal Call.Pitch.approach PassedArgs PSignal args Curve curve X start X end -- * fade implementation data Align = AlignStart | AlignEnd deriving (Int -> Align -> ShowS [Align] -> ShowS Align -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Align] -> ShowS $cshowList :: [Align] -> ShowS show :: Align -> String $cshow :: Align -> String showsPrec :: Int -> Align -> ShowS $cshowsPrec :: Int -> Align -> ShowS Show) data PitchDirection = PitchDrop | PitchLift deriving (Int -> PitchDirection -> ShowS [PitchDirection] -> ShowS PitchDirection -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [PitchDirection] -> ShowS $cshowList :: [PitchDirection] -> ShowS show :: PitchDirection -> String $cshow :: PitchDirection -> String showsPrec :: Int -> PitchDirection -> ShowS $cshowsPrec :: Int -> PitchDirection -> ShowS Show) pitch_fade :: Align -> ControlUtil.Curve -> PSignal.Pitch -> PitchDirection -> Either Pitch.Transpose PSignal.Pitch -> ((RealTime, RealTime), (RealTime, RealTime)) -> Derive.Deriver (PSignal.PSignal, Signal.Control) pitch_fade :: Align -> Curve -> Pitch -> PitchDirection -> Either Transpose Pitch -> ((X, X), (X, X)) -> Deriver (PSignal, Control) pitch_fade Align align Curve curve Pitch pitch PitchDirection pitch_dir Either Transpose Pitch interval ((X pitch_start, X pitch_end), (X fade_start, X fade_end)) = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Align -> Curve -> X -> X -> X -> Pitch -> Either Transpose Pitch -> PitchDirection -> Deriver PSignal pitch_segment Align align Curve curve (forall a. Ord a => a -> a -> a min X pitch_start X fade_start) X pitch_start X pitch_end Pitch pitch Either Transpose Pitch interval PitchDirection pitch_dir forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Curve -> X -> Y -> X -> Y -> Deriver Control segment Curve ControlUtil.Linear X fade_start Y dyn1 X fade_end Y dyn2 where (Y dyn1, Y dyn2) = case Align align of Align AlignStart -> (Y 0, Y 1) Align AlignEnd -> (Y 1, Y 0) -- | Create envelope start and end times for pitch and fade as follows: -- -- @ -- -------- align align_fade -- ffff Start Start -- pp--> -- ffff Start End -- <-pp -- ffff End Start -- <pp-- -- ffff End End -- <--pp -- @ pitch_fade_ranges :: Align -> Align -> DeriveT.Duration -> DeriveT.Duration -> ScoreTime -> ScoreTime -> Derive.Deriver ((RealTime, RealTime), (RealTime, RealTime)) pitch_fade_ranges :: Align -> Align -> Duration -> Duration -> ScoreTime -> ScoreTime -> Deriver ((X, X), (X, X)) pitch_fade_ranges Align align Align align_fade Duration fade_time Duration pitch_time ScoreTime start ScoreTime end = do let dur_from :: ScoreTime dur_from = case Align align of Align AlignStart -> ScoreTime start Align AlignEnd -> ScoreTime end X fade_time <- forall t1 t2. (Time t1, Time t2) => t1 -> t2 -> Deriver X Call.real_duration ScoreTime dur_from Duration fade_time X pitch_time <- forall t1 t2. (Time t1, Time t2) => t1 -> t2 -> Deriver X Call.real_duration ScoreTime dur_from Duration pitch_time (X fade_start, X fade_end) <- case Align align of Align AlignStart -> (\X p -> (X p, X p forall a. Num a => a -> a -> a + X fade_time)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall a. Time a => a -> Deriver X Derive.real ScoreTime start Align AlignEnd -> (\X p -> (X p forall a. Num a => a -> a -> a - X fade_time, X p)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall a. Time a => a -> Deriver X Derive.real ScoreTime end let (X pitch_start, X pitch_end) = case Align align_fade of Align AlignStart -> -- Since there's no point doing anything after the fade is -- done, extend backwards if pitch is longer than fade. forall a. Ord a => a -> a -> a min (X fade_start, X fade_start forall a. Num a => a -> a -> a + X pitch_time) (X fade_end forall a. Num a => a -> a -> a - X pitch_time, X fade_end) Align AlignEnd -> forall a. Ord a => a -> a -> a max (X fade_end forall a. Num a => a -> a -> a - X pitch_time, X fade_end) (X fade_start, X fade_start forall a. Num a => a -> a -> a + X pitch_time) forall (m :: * -> *) a. Monad m => a -> m a return ((X pitch_start, X pitch_end), (X fade_start, X fade_end)) segment :: ControlUtil.Curve -> RealTime -> Signal.Y -> RealTime -> Signal.Y -> Derive.Deriver Signal.Control segment :: Curve -> X -> Y -> X -> Y -> Deriver Control segment Curve curve X x1 Y y1 X x2 Y y2 = do Control sig <- Curve -> X -> Y -> X -> Y -> Deriver Control ControlUtil.make_segment Curve curve X x1 Y y1 X x2 Y y2 -- TODO why do I need this leading sample? forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall {k} (kind :: k). X -> Y -> Signal kind Signal.from_sample X 0 Y y1 forall a. Semigroup a => a -> a -> a <> Control sig pitch_segment :: Align -> ControlUtil.Curve -> RealTime -- ^ start pitch at this time -> RealTime -- ^ start segment -> RealTime -- ^ end segment -> PSignal.Pitch -> Either Pitch.Transpose PSignal.Pitch -> PitchDirection -> Derive.Deriver PSignal.PSignal pitch_segment :: Align -> Curve -> X -> X -> X -> Pitch -> Either Transpose Pitch -> PitchDirection -> Deriver PSignal pitch_segment Align align Curve curve X start0 X start X end Pitch pitch Either Transpose Pitch interval PitchDirection pitch_dir = case Align align of -- If the pitch segment is at the start of the note, then I may need to -- override its base pitch with a flat segment. Align AlignStart -> (Pitch -> PSignal initial Pitch dest <>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Curve -> X -> Pitch -> X -> Pitch -> Deriver PSignal PitchUtil.make_segment Curve curve X start Pitch dest X end Pitch pitch Align AlignEnd -> Curve -> X -> Pitch -> X -> Pitch -> Deriver PSignal PitchUtil.make_segment Curve curve X start Pitch pitch X end Pitch dest where initial :: Pitch -> PSignal initial Pitch p = X -> Pitch -> PSignal PSignal.from_sample X start0 Pitch p dest :: Pitch dest = case Either Transpose Pitch interval of Left Transpose degrees -> forall a. Transpose -> RawPitch a -> RawPitch a Pitches.transpose (Transpose -> Transpose negate_interval Transpose degrees) Pitch pitch Right Pitch p -> Pitch p negate_interval :: Transpose -> Transpose negate_interval = case PitchDirection pitch_dir of PitchDirection PitchDrop -> (Y -> Y) -> Transpose -> Transpose Pitch.modify_transpose forall a. Num a => a -> a negate PitchDirection PitchLift -> forall a. a -> a id