-- 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 -- | Ornaments for gender. The unique thing about gender technique is the -- delayed damping, so these calls deal with delayed damping. module Derive.C.Bali.Gender ( library, ngoret_variations , interval_arg, ngoret, c_realize_ngoret, realize_ngoret , weak, weak_call ) where import qualified Util.Log as Log import qualified Util.Lists as Lists import qualified Derive.Args as Args import qualified Derive.Call as Call import qualified Derive.Call.Module as Module import qualified Derive.Call.Post as Post 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.EnvKey as EnvKey import qualified Derive.Expr as Expr import qualified Derive.Flags as Flags import qualified Derive.Library as Library import qualified Derive.PSignal as PSignal import qualified Derive.Pitches as Pitches import qualified Derive.Score as Score 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.Pitch as Pitch import qualified Perform.Signal as Signal import Global import Types library :: Library.Library library :: Library library = forall a. Monoid a => [a] -> a mconcat [ forall call. ToLibrary (Generator call) => [(Symbol, Generator call)] -> Library Library.generators forall a b. (a -> b) -> a -> b $ ((Symbol "weak", Generator Note c_weak) forall a. a -> [a] -> [a] : forall call. (Parser (Maybe Transpose) -> call) -> [(Symbol, call)] ngoret_variations Parser (Maybe Transpose) -> Generator Note gender_ngoret) , forall call. ToLibrary (Transformer call) => [(Symbol, Transformer call)] -> Library Library.transformers [ (Symbol "realize-ngoret", Transformer Note c_realize_ngoret) , (Symbol "infer-damp-simple", Transformer Note c_infer_damp_simple) ] ] ngoret_variations :: (Sig.Parser (Maybe Pitch.Transpose) -> call) -> [(Expr.Symbol, call)] ngoret_variations :: forall call. (Parser (Maybe Transpose) -> call) -> [(Symbol, call)] ngoret_variations Parser (Maybe Transpose) -> call make = [ (Symbol "'", Parser (Maybe Transpose) -> call make forall a b. (a -> b) -> a -> b $ forall (f :: * -> *) a. Applicative f => a -> f a pure forall a. Maybe a Nothing) , (Symbol "'n", Parser (Maybe Transpose) -> call make forall a b. (a -> b) -> a -> b $ forall a. a -> Maybe a Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Parser Transpose interval_arg) , (Symbol "'^", Parser (Maybe Transpose) -> call make forall a b. (a -> b) -> a -> b $ forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ forall a. a -> Maybe a Just forall a b. (a -> b) -> a -> b $ Double -> Transpose Pitch.Diatonic (-Double 1)) , (Symbol "'-", Parser (Maybe Transpose) -> call make forall a b. (a -> b) -> a -> b $ forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ forall a. a -> Maybe a Just forall a b. (a -> b) -> a -> b $ Double -> Transpose Pitch.Diatonic Double 0) , (Symbol "'_", Parser (Maybe Transpose) -> call make forall a b. (a -> b) -> a -> b $ forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ forall a. a -> Maybe a Just forall a b. (a -> b) -> a -> b $ Double -> Transpose Pitch.Diatonic Double 1) ] module_ :: Module.Module module_ :: Module module_ = Module "bali" forall a. Semigroup a => a -> a -> a <> Module "gender" -- * ngoret gender_ngoret :: Sig.Parser (Maybe Pitch.Transpose) -> Derive.Generator Derive.Note gender_ngoret :: Parser (Maybe Transpose) -> Generator Note gender_ngoret = Module -> Bool -> Parser RealTimeFunction -> Parser (Maybe Transpose) -> Generator Note ngoret Module module_ Bool True Parser RealTimeFunction damp_arg where damp_arg :: Parser RealTimeFunction damp_arg = forall a deflt. (Typecheck a, ToVal deflt) => ArgName -> deflt -> Doc -> Parser a Sig.defaulted ArgName "damp" (RealTime 0.5 :: RealTime) Doc "Time that the grace note overlaps with this one. So the total\ \ duration is time+damp, though it will be clipped to the\ \ end of the current note." interval_arg :: Sig.Parser Pitch.Transpose interval_arg :: Parser Transpose interval_arg = DefaultDiatonic -> Transpose Typecheck.default_diatonic forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall a. Typecheck a => ArgName -> Doc -> Parser a Sig.required ArgName "interval" Doc "The grace note is this interval from the destination pitch." -- | Other instruments also have ngoret, but without gender's special damping -- behaviour. ngoret :: Module.Module -> Bool -- ^ Extend the previous note's duration to the end of the grace note. -> Sig.Parser Typecheck.RealTimeFunction -- ^ Time grace note overlaps with this one. -> Sig.Parser (Maybe Pitch.Transpose) -> Derive.Generator Derive.Note ngoret :: Module -> Bool -> Parser RealTimeFunction -> Parser (Maybe Transpose) -> Generator Note ngoret Module module_ Bool late_damping Parser RealTimeFunction damp_arg Parser (Maybe Transpose) interval_arg = forall d. Module -> CallName -> Tags -> Doc -> WithArgDoc (GeneratorF d) -> Generator d Derive.generator Module module_ CallName "ngoret" (Tags Tags.inst forall a. Semigroup a => a -> a -> a <> Tags Tags.ornament forall a. Semigroup a => a -> a -> a <> Tags Tags.requires_postproc) (Doc "Insert an intermediate grace note in the \"ngoret\" style.\ \ The grace note moves up for `'^`, down for `'_`, or is based\ \ on the previous note's pitch for `'`.\ \\nThis requires the `realize-ngoret` postproc." ) 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 <$> Parser (Maybe Transpose) interval_arg 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 "time" (Double 0.1 :: Double) Doc "Time between the grace note start and the main note. If there isn't\ \ enough room after the previous note, it will be halfway between\ \ the previous note and this one." forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser RealTimeFunction damp_arg 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 "dyn" (Double 0.75 :: Double) Doc "The grace note's dyn will be this multiplier of the current dyn." forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> forall a deflt. (Typecheck a, ToVal deflt) => ArgName -> EnvironDefault -> deflt -> Doc -> Parser a Sig.environ ArgName "damp-threshold" EnvironDefault Sig.Prefixed (Double 0.15 :: Double) Doc "A grace note with this much time will cause the previous note to be\ \ shortened to not overlap. Under the threshold, and the damping of\ \ the previous note will be delayed until the end of the grace note." ) forall a b. (a -> b) -> a -> b $ \(Maybe Transpose maybe_interval , Typecheck.RealTimeFunction RealTime -> Duration time , Typecheck.RealTimeFunction RealTime -> Duration damp , Double dyn_scale , RealTime damp_threshold ) PassedArgs Note args -> forall d. PassedArgs d -> (PassedArgs d -> Deriver State Error (Stream Note)) -> Deriver State Error (Stream Note) Sub.inverting_args PassedArgs Note args forall a b. (a -> b) -> a -> b $ \PassedArgs Note args -> do RealTime start <- forall a. PassedArgs a -> Deriver RealTime Args.real_start PassedArgs Note args RealTime time <- forall a. Time a => a -> Deriver RealTime Derive.real (RealTime -> Duration time RealTime start) RealTime damp <- forall a. Time a => a -> Deriver RealTime Derive.real (RealTime -> Duration damp RealTime start) Maybe (RawPitch Untransposed_) maybe_pitch <- case Maybe Transpose maybe_interval of Maybe Transpose Nothing -> forall (m :: * -> *) a. Monad m => a -> m a return forall a. Maybe a Nothing Just Transpose transpose -> forall a. a -> Maybe a Just forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Transpose -> RawPitch a -> RawPitch a Pitches.transpose Transpose transpose forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> RealTime -> Deriver (RawPitch Untransposed_) Call.get_pitch RealTime start Double dyn <- (forall a. Num a => a -> a -> a *Double dyn_scale) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> RealTime -> Deriver State Error Double Call.dynamic RealTime start ScoreTime grace_start <- forall a. Time a => a -> Deriver ScoreTime Derive.score (RealTime start forall a. Num a => a -> a -> a - RealTime time) -- If there isn't room for the grace note, use the midpoint between the -- prev note and this one. ScoreTime grace_start <- forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ case forall a. PassedArgs a -> Maybe ScoreTime Args.prev_start PassedArgs Note args of Maybe ScoreTime Nothing -> ScoreTime grace_start Just ScoreTime prev -> forall a. Ord a => a -> a -> a max ScoreTime grace_start forall a b. (a -> b) -> a -> b $ (ScoreTime prev forall a. Num a => a -> a -> a + forall a. PassedArgs a -> ScoreTime Args.start PassedArgs Note args) forall a. Fractional a => a -> a -> a / ScoreTime 2 RealTime real_grace_start <- forall a. Time a => a -> Deriver RealTime Derive.real ScoreTime grace_start let with_flags :: Deriver State Error (Stream Note) -> Deriver State Error (Stream Note) with_flags | Bool late_damping Bool -> Bool -> Bool && Bool prev_touches = Flags -> Deriver State Error (Stream Note) -> Deriver State Error (Stream Note) Call.add_flags forall a b. (a -> b) -> a -> b $ if RealTime start forall a. Num a => a -> a -> a - RealTime real_grace_start forall a. Ord a => a -> a -> Bool < RealTime damp_threshold then Flags extend_previous else Flags shorten_previous | Bool otherwise = forall a. a -> a id prev_touches :: Bool prev_touches = forall b a. b -> (a -> b) -> Maybe a -> b maybe Bool False (forall a. Ord a => a -> a -> Bool >= forall a. PassedArgs a -> ScoreTime Args.start PassedArgs Note args) (forall a. PassedArgs a -> Maybe ScoreTime Args.prev_end PassedArgs Note args) ScoreTime overlap <- forall t1 t2. (Time t1, Time t2) => t1 -> t2 -> Deriver ScoreTime Call.score_duration (forall a. PassedArgs a -> ScoreTime Args.start PassedArgs Note args) RealTime damp let grace_end :: ScoreTime grace_end = forall a. PassedArgs a -> ScoreTime Args.start PassedArgs Note args forall a. Num a => a -> a -> a + ScoreTime overlap grace_note :: Deriver State Error (Stream Note) grace_note = case Maybe (RawPitch Untransposed_) maybe_pitch of Maybe (RawPitch Untransposed_) Nothing -> Flags -> Deriver State Error (Stream Note) -> Deriver State Error (Stream Note) Call.add_flags Flags infer_pitch_flag Deriver State Error (Stream Note) Call.note Just RawPitch Untransposed_ pitch -> RawPitch Untransposed_ -> Deriver State Error (Stream Note) Call.pitched_note RawPitch Untransposed_ pitch forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a Derive.place ScoreTime grace_start (ScoreTime grace_end forall a. Num a => a -> a -> a - ScoreTime grace_start) (Deriver State Error (Stream Note) -> Deriver State Error (Stream Note) with_flags forall a b. (a -> b) -> a -> b $ forall a. Double -> Deriver a -> Deriver a Call.with_dynamic Double dyn Deriver State Error (Stream Note) grace_note) forall a. Semigroup a => a -> a -> a <> forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a Derive.place (forall a. PassedArgs a -> ScoreTime Args.start PassedArgs Note args) (forall a. PassedArgs a -> ScoreTime Args.duration PassedArgs Note args) Deriver State Error (Stream Note) Call.note -- ** realize c_realize_ngoret :: Derive.Transformer Derive.Note c_realize_ngoret :: Transformer Note c_realize_ngoret = forall d. Module -> CallName -> Tags -> Doc -> WithArgDoc (TransformerF d) -> Transformer d Derive.transformer Module module_ CallName "realize-ngoret" (Tags Tags.inst forall a. Semigroup a => a -> a -> a <> Tags Tags.postproc) (Doc "Realize pitches and positions emited by the `ngoret` call.\ \ This is necessary because it needs to know the positions and pitches\ \ of the previous and next notes, and those aren't necessarily available\ \ when evaluating the track. This call needs a " forall a. Semigroup a => a -> a -> a <> forall a. ShowVal a => a -> Doc ShowVal.doc Text EnvKey.hand forall a. Semigroup a => a -> a -> a <> Doc " envron to figure out which which note\ \ follows which." ) forall a b. (a -> b) -> a -> b $ forall y d. Taggable y => Transformer y d -> WithArgDoc (Transformer y d) Sig.call0t forall a b. (a -> b) -> a -> b $ \PassedArgs Note _ Deriver State Error (Stream Note) deriver -> Stream Note -> Deriver State Error (Stream Note) realize_ngoret forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< Deriver State Error (Stream Note) deriver realize_ngoret :: Stream.Stream Score.Event -> Derive.NoteDeriver realize_ngoret :: Stream Note -> Deriver State Error (Stream Note) realize_ngoret = forall (f :: * -> *) a b. Functor f => ([a] -> f [b]) -> Stream a -> f (Stream b) Post.apply_m forall a b. (a -> b) -> a -> b $ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap [[Note]] -> [Note] merge forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM [Note] -> Deriver State Error [Note] realize forall b c a. (b -> c) -> (a -> b) -> a -> c . forall key a. Ord key => (a -> key) -> [a] -> [[a]] Lists.groupSort Note -> (Instrument, Maybe Text) Post.hand_key where -- TODO do I want to ignore streams with irrelevant instruments? realize :: [Note] -> Deriver State Error [Note] realize = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (forall a b. (a -> b) -> [a] -> [b] map (forall a b c. (a -> b -> c) -> (a, b) -> c uncurry Note -> Maybe Note -> Note realize_damped) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. [a] -> [(a, Maybe a)] Lists.zipNext) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall {b}. (Maybe Note -> Note -> Maybe Note -> Either Text b) -> [Note] -> Deriver State Error [b] apply Maybe Note -> Note -> Maybe Note -> Either Text Note realize_infer_pitch apply :: (Maybe Note -> Note -> Maybe Note -> Either Text b) -> [Note] -> Deriver State Error [b] apply Maybe Note -> Note -> Maybe Note -> Either Text b f = forall (m :: * -> *) a b. Monad m => (a -> m (Maybe b)) -> [a] -> m [b] mapMaybeM (forall {t} {t} {a}. (t -> Note -> t -> Either Text a) -> (t, Note, t) -> Deriver State Error (Maybe a) apply1 Maybe Note -> Note -> Maybe Note -> Either Text b f) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. [a] -> [(Maybe a, a, Maybe a)] Lists.zipNeighbors where apply1 :: (t -> Note -> t -> Either Text a) -> (t, Note, t) -> Deriver State Error (Maybe a) apply1 t -> Note -> t -> Either Text a f (t prev, Note event, t next) = case t -> Note -> t -> Either Text a f t prev Note event t next of Right a event -> forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a. a -> Maybe a Just a event Left Text err -> do forall a. Note -> Deriver a -> Deriver a Derive.with_event_stack Note event forall a b. (a -> b) -> a -> b $ forall (m :: * -> *). (Stack, LogMonad m) => Text -> m () Log.warn Text err forall (m :: * -> *) a. Monad m => a -> m a return forall a. Maybe a Nothing merge :: [[Note]] -> [Note] merge = forall k a. Ord k => (a -> k) -> [[a]] -> [a] Lists.mergeLists Note -> RealTime Score.event_start realize_infer_pitch :: Maybe Score.Event -> Score.Event -> Maybe Score.Event -> Either Text Score.Event realize_infer_pitch :: Maybe Note -> Note -> Maybe Note -> Either Text Note realize_infer_pitch Maybe Note maybe_prev Note event Maybe Note maybe_next | Flags -> Note -> Bool Score.has_flags Flags infer_pitch_flag Note event = do Note prev <- forall {a} {b}. a -> Maybe b -> Either a b require Text "no previous event" Maybe Note maybe_prev Note next <- forall {a} {b}. a -> Maybe b -> Either a b require Text "no next event" Maybe Note maybe_next RawPitch Untransposed_ pitch <- forall (p :: * -> * -> *) a b c. Bifunctor p => (a -> b) -> p a c -> p b c first (Text "can't infer pitch: "<>) forall a b. (a -> b) -> a -> b $ Note -> Note -> Either Text (RawPitch Untransposed_) infer_pitch Note prev Note next -- Also make sure the grace note doesn't go past the end of the next -- note. let dur :: RealTime dur = forall a. Ord a => a -> a -> a min (Note -> RealTime Score.event_duration Note event) (Note -> RealTime Score.event_end Note next forall a. Num a => a -> a -> a - Note -> RealTime Score.event_start Note event) forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ Flags -> Note -> Note Score.remove_flags Flags infer_pitch_flag forall a b. (a -> b) -> a -> b $ RealTime -> Note -> Note Score.set_duration RealTime dur forall a b. (a -> b) -> a -> b $ Pitch -> Note -> Note Score.set_pitch (RawPitch Untransposed_ -> Pitch PSignal.constant RawPitch Untransposed_ pitch) Note event | Bool otherwise = forall (m :: * -> *) a. Monad m => a -> m a return Note event where require :: a -> Maybe b -> Either a b require a err = forall b a. b -> (a -> b) -> Maybe a -> b maybe (forall a b. a -> Either a b Left a err) forall (m :: * -> *) a. Monad m => a -> m a return realize_damped :: Score.Event -> Maybe Score.Event -> Score.Event realize_damped :: Note -> Maybe Note -> Note realize_damped Note event Maybe Note maybe_next = Flags -> Note -> Note Score.remove_flags (Flags extend_previous forall a. Semigroup a => a -> a -> a <> Flags shorten_previous) forall a b. (a -> b) -> a -> b $ forall b a. b -> (a -> b) -> Maybe a -> b maybe forall a. a -> a id Note -> Note -> Note set_dur Maybe Note maybe_next Note event where set_dur :: Note -> Note -> Note set_dur Note next | Flags -> Note -> Bool Score.has_flags Flags extend_previous Note next = RealTime -> Note -> Note Score.set_duration (Note -> RealTime Score.event_end Note next forall a. Num a => a -> a -> a - RealTime start) | Flags -> Note -> Bool Score.has_flags Flags shorten_previous Note next = RealTime -> Note -> Note Score.set_duration (Note -> RealTime Score.event_start Note next forall a. Num a => a -> a -> a - RealTime start) | Bool otherwise = forall a. a -> a id where start :: RealTime start = Note -> RealTime Score.event_start Note event infer_pitch :: Score.Event -> Score.Event -> Either Text PSignal.Pitch infer_pitch :: Note -> Note -> Either Text (RawPitch Untransposed_) infer_pitch Note prev Note next = do NoteNumber prev_nn <- forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a tryJust (Text "no prev nn: " forall a. Semigroup a => a -> a -> a <> Note -> Text Score.short_event Note prev) forall a b. (a -> b) -> a -> b $ Note -> Maybe NoteNumber Score.initial_nn Note prev NoteNumber next_nn <- forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a tryJust (Text "no next nn: " forall a. Semigroup a => a -> a -> a <> Note -> Text Score.short_event Note next) forall a b. (a -> b) -> a -> b $ Note -> Maybe NoteNumber Score.initial_nn Note next let steps :: Step steps | NoteNumber prev_nn forall a. Eq a => a -> a -> Bool == NoteNumber next_nn = Step 0 | NoteNumber prev_nn forall a. Ord a => a -> a -> Bool < NoteNumber next_nn = -Step 1 | Bool otherwise = Step 1 forall a. Step -> RawPitch a -> RawPitch a Pitches.transpose_d Step steps forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a tryJust (Text "no pitch at " forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty (Note -> RealTime Score.event_start Note next)) (RealTime -> Note -> Maybe (RawPitch Untransposed_) Score.pitch_at (Note -> RealTime Score.event_start Note next) Note next) -- | Mark events whose should have their pitch inferred from the previous and -- next events. infer_pitch_flag :: Flags.Flags infer_pitch_flag :: Flags infer_pitch_flag = Text -> Flags Flags.flag Text "infer-pitch" -- | Mark grace notes that were damped late, and whose previous event should be -- extended to be damped together. extend_previous :: Flags.Flags extend_previous :: Flags extend_previous = Text -> Flags Flags.flag Text "extend-previous-duration" -- | Mark grace notes that don't cause a late damp. The previous event's -- duration should be shortened to end where the grace note begins. shorten_previous :: Flags.Flags shorten_previous :: Flags shorten_previous = Text -> Flags Flags.flag Text "shorten-previous-duration" -- * weak c_weak :: Derive.Generator Derive.Note c_weak :: Generator Note c_weak = forall d. Module -> CallName -> Tags -> Doc -> WithArgDoc (GeneratorF d) -> Generator d Derive.generator Module module_ CallName "weak" Tags Tags.inst Doc "Weak notes are filler notes." 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 a deflt. (Typecheck a, ToVal deflt) => ArgName -> EnvironDefault -> deflt -> Doc -> Parser a Sig.defaulted_env ArgName "strength" EnvironDefault Derive.Unprefixed (Double 0.5 :: Double) Doc "From low strength to high, omit the note, then play it muted, and\ \ then play it open but softly." ) forall a b. (a -> b) -> a -> b $ \Double strength -> forall d. (PassedArgs d -> Deriver State Error (Stream Note)) -> PassedArgs d -> Deriver State Error (Stream Note) Sub.inverting (forall a. Double -> PassedArgs a -> Deriver State Error (Stream Note) weak Double strength) weak :: Signal.Y -> Derive.PassedArgs a -> Derive.NoteDeriver weak :: forall a. Double -> PassedArgs a -> Deriver State Error (Stream Note) weak Double strength PassedArgs a args = do -- This biases mute values to be lower, and 0 before it unmutes. let mute :: Double mute = forall a. Ord a => a -> a -> a max Double 0 forall a b. (a -> b) -> a -> b $ Double 1 forall a. Num a => a -> a -> a - (Double strength forall a. Num a => a -> a -> a + (Double 1 forall a. Num a => a -> a -> a - Double unmute_threshold)) if Double strength forall a. Ord a => a -> a -> Bool <= Double omit_threshold then forall a. Monoid a => a mempty else forall a. Control -> Double -> Deriver a -> Deriver a Call.with_constant Control Controls.mute Double mute forall a b. (a -> b) -> a -> b $ forall d. PassedArgs d -> Deriver State Error (Stream Note) Call.placed_note PassedArgs a args where omit_threshold :: Double omit_threshold = Double 0.25 unmute_threshold :: Double unmute_threshold = Double 0.75 weak_call :: Derive.PassedArgs a -> Derive.NoteDeriver weak_call :: forall d. PassedArgs d -> Deriver State Error (Stream Note) weak_call PassedArgs a args = do -- TODO This is nonstandard, because usually signals are resolved -- implicitly as arguments. But DUtil.zero_duration doesn't really plug -- into Sig.call. Maybe it should reapply `weak` instead of calling it -- directly? In any case, I think the result should be the same. Double strength <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (forall b a. b -> (a -> b) -> Maybe a -> b maybe Double 0.5 forall a. Typed a -> a ScoreT.val_of) forall a b. (a -> b) -> a -> b $ Control -> RealTime -> Deriver State Error (Maybe (Typed Double)) Derive.control_at Control "strength" forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< forall a. PassedArgs a -> Deriver RealTime Args.real_start PassedArgs a args forall a. Double -> PassedArgs a -> Deriver State Error (Stream Note) weak Double strength (forall a. ScoreTime -> PassedArgs a -> PassedArgs a Args.set_duration ScoreTime dur PassedArgs a args) where dur :: ScoreTime dur = 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 -- * im -- ** infer damp {- | Simple version: - Any note immediately followed by the same pitch gets its duration extended to the end of the last note with the same pitch. Fancy version: - All notes ring until explicitly damped. - A gap between notes in the same hand adds a damp. A pitch followed by a different one in the same hand adds a damp to the first. - The hand requires time to actually do the damp. Adjacent pitches by 1 or 2 can be simultaneous. Otherwise, you need a certain amount of time when that hand is not busy damping. -} c_infer_damp_simple :: Derive.Transformer Derive.Note c_infer_damp_simple :: Transformer Note c_infer_damp_simple = forall d. Module -> CallName -> Tags -> Doc -> WithArgDoc (TransformerF d) -> Transformer d Derive.transformer (Module module_ forall a. Semigroup a => a -> a -> a <> Module "im") CallName "infer-damp-simple" Tags Tags.postproc (Doc "Simple gender damping. Duration is extended if the next note on the same\ \ hand has the same pitch and the gap is < " forall a. Semigroup a => a -> a -> a <> forall a. ShowVal a => a -> Doc ShowVal.doc RealTime gap 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 "insts" Doc "Apply damping to these instruments.") forall a b. (a -> b) -> a -> b $ \[Instrument] insts PassedArgs Note _args -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap forall a b. (a -> b) -> a -> b $ forall a b. (a -> b) -> Stream a -> Stream b Post.emap1_ ([Instrument] -> (Note, [Note]) -> Note infer [Instrument] insts) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall key a. Eq key => (a -> key) -> Stream a -> Stream (a, [a]) Post.nexts_by Note -> (Instrument, Maybe Text) Post.hand_key where infer :: [Instrument] -> (Note, [Note]) -> Note infer [Instrument] insts = forall a event. (a -> event) -> (event -> Bool) -> (a -> event) -> a -> event Post.only forall a b. (a, b) -> a fst ([Instrument] -> Note -> Bool Post.has_instrument [Instrument] insts) forall a b. (a -> b) -> a -> b $ RealTime -> (Note, [Note]) -> Note infer_damp_simple RealTime gap -- Less than this much time before the next note of the same pitch means -- extend the duration. gap :: RealTime gap = RealTime 0.15 infer_damp_simple :: RealTime -> (Score.Event, [Score.Event]) -> Score.Event infer_damp_simple :: RealTime -> (Note, [Note]) -> Note infer_damp_simple RealTime gap (Note event, [Note] nexts) | Note -> RealTime Score.event_duration Note event forall a. Eq a => a -> a -> Bool /= RealTime 0 Bool -> Bool -> Bool && RealTime new_end forall a. Ord a => a -> a -> Bool > Note -> RealTime Score.event_end Note event = RealTime -> Note -> Note Score.set_duration (RealTime new_end forall a. Num a => a -> a -> a - Note -> RealTime Score.event_start Note event) Note event | Bool otherwise = Note event where new_end :: RealTime new_end = Note -> [Note] -> RealTime go Note event [Note] nexts go :: Note -> [Note] -> RealTime go Note prev (Note next:[Note] nexts) | Note -> RealTime Score.event_start Note next forall a. Num a => a -> a -> a - Note -> RealTime Score.event_end Note prev forall a. Ord a => a -> a -> Bool <= RealTime gap Bool -> Bool -> Bool && Note -> Maybe Note Score.initial_note Note prev forall a. Eq a => a -> a -> Bool == Note -> Maybe Note Score.initial_note Note next = Note -> [Note] -> RealTime go Note next [Note] nexts go Note prev [Note] _ = Note -> RealTime Score.event_end Note prev