-- 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 -- | Postprocs that change note start and duration. module Derive.C.Post.Postproc ( library , Key , make_cancel , adjust_offset , cancel_strong_weak , group_and_cancel , infer_duration_merged ) where import qualified Data.List as List import qualified Data.Map.Strict as Map import qualified Data.Maybe as Maybe import qualified Util.Lists as Lists import qualified Util.Test.ApproxEq as ApproxEq import qualified Derive.C.Prelude.ControlFunction as ControlFunction import qualified Derive.C.Prelude.Equal as Equal import qualified Derive.C.Prelude.Note as Note import qualified Derive.Call.Make as Make import qualified Derive.Call.Module as Module import qualified Derive.Call.Post as Post import qualified Derive.Call.StaticMacro as StaticMacro import qualified Derive.Call.Tags as Tags import qualified Derive.Controls as Controls import qualified Derive.Derive as Derive import qualified Derive.Env as Env import qualified Derive.EnvKey as EnvKey import qualified Derive.Flags as Flags import qualified Derive.LEvent as LEvent import qualified Derive.Library as Library import qualified Derive.Score as Score import qualified Derive.ShowVal as ShowVal import qualified Derive.Sig as Sig import qualified Derive.Stream as Stream import qualified Perform.RealTime as RealTime import Global import Types library :: Library.Library library :: Library library = forall call. ToLibrary (Transformer call) => [(Symbol, Transformer call)] -> Library Library.transformers [ (Symbol "apply-start-offset", Transformer Note c_apply_start_offset) , (Symbol "cancel", Transformer Note c_cancel) , (Symbol "infer-negative", Transformer Note c_infer_negative) , (Symbol "randomize-start", Transformer Note c_randomize_start) , (Symbol "strong", Module -> CallName -> Doc -> Flags -> Transformer Note Make.add_flag Module module_ CallName "strong" Doc "Add the 'Derive.Flags.strong' flag, which will cancel coincident\ \ non-strong notes." Flags Flags.strong) , (Symbol "weak", Module -> CallName -> Doc -> Flags -> Transformer Note Make.add_flag Module module_ CallName "weak" Doc "Add the 'Derive.Flags.weak' flag, which will cause this to be\ \ cancelled by coincident non-weak notes." Flags Flags.weak) ] module_ :: Module.Module module_ :: Module module_ = Module Module.prelude -- * infer-negative c_infer_negative :: Derive.Transformer Derive.Note c_infer_negative :: Transformer Note c_infer_negative = forall d. Module -> CallName -> Tags -> Doc -> WithArgDoc (TransformerF d) -> Transformer d Derive.transformer Module module_ CallName "infer-negative" Tags Tags.postproc Doc "Infer durations for negative events, by instrument." 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 deflt. (Typecheck a, ToVal deflt) => ArgName -> deflt -> Doc -> Parser a Sig.defaulted ArgName "heuristic" (Text "note" :: Text) Doc "doc" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser RealTime final_duration_arg ) forall a b. (a -> b) -> a -> b $ \(Text heuristic, RealTime final_dur) PassedArgs Note _args Deriver (Stream Note) deriver -> do RealTime -> Stream Note -> Stream Note process <- forall a. Stack => Text -> Maybe a -> Deriver a Derive.require (Text "invalid heuristic: " forall a. Semigroup a => a -> a -> a <> Text heuristic) forall a b. (a -> b) -> a -> b $ forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup (Text heuristic :: Text) Map Text (RealTime -> Stream Note -> Stream Note) infer_heuristics RealTime -> Stream Note -> Stream Note process RealTime final_dur forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Deriver (Stream Note) deriver where infer_heuristics :: Map Text (RealTime -> Stream Note -> Stream Note) infer_heuristics = forall k a. Ord k => [(k, a)] -> Map k a Map.fromList [ (Text "hand", RealTime -> Stream Note -> Stream Note next_hand) , (Text "note", RealTime -> Stream Note -> Stream Note next_note) ] -- | Until the next note with the same hand. Suitable for gender barung. -- If the next event doesn't touch this one, stop at its (negative) start time. -- This is a bit weird conceptually but in practice seems to be useful for -- controlling duration. next_hand :: RealTime -> Stream.Stream Score.Event -> Stream.Stream Score.Event next_hand :: RealTime -> Stream Note -> Stream Note next_hand = forall key. Eq key => Key key -> (RealTime -> [Note] -> Maybe RealTime) -> RealTime -> Stream Note -> Stream Note infer_duration Note -> (Instrument, Maybe Text) Post.hand_key forall a b. (a -> b) -> a -> b $ \RealTime here [Note] nexts -> forall a. Num a => a -> a -> a subtract RealTime here forall b c a. (b -> c) -> (a -> b) -> a -> c . RealTime -> Note -> RealTime until RealTime here forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall a. [a] -> Maybe a Lists.head [Note] nexts where until :: RealTime -> Note -> RealTime until RealTime here Note next | Note -> RealTime Score.event_min Note next forall a. Ord a => a -> a -> Bool >= RealTime here forall a. Num a => a -> a -> a + RealTime threshold = Note -> RealTime Score.event_min Note next | Bool otherwise = Note -> RealTime Score.event_max Note next threshold :: RealTime threshold = RealTime 0.05 -- | Until the next note with the same instrument. Suitable for gender -- panerus. next_note :: RealTime -> Stream.Stream Score.Event -> Stream.Stream Score.Event next_note :: RealTime -> Stream Note -> Stream Note next_note = forall key. Eq key => Key key -> (RealTime -> [Note] -> Maybe RealTime) -> RealTime -> Stream Note -> Stream Note infer_duration Note -> Instrument Score.event_instrument forall a b. (a -> b) -> a -> b $ \RealTime here [Note] nexts -> forall a. Num a => a -> a -> a subtract RealTime here forall b c a. (b -> c) -> (a -> b) -> a -> c . Note -> RealTime start forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall a. [a] -> Maybe a Lists.head (forall a. (a -> Bool) -> [a] -> [a] dropWhile (\Note n -> Note -> RealTime start Note n forall a. Num a => a -> a -> a - RealTime here forall a. Ord a => a -> a -> Bool < RealTime threshold) [Note] nexts) where threshold :: RealTime threshold = RealTime 0.15 start :: Note -> RealTime start = Note -> RealTime Score.event_start infer_duration :: Eq key => Key key -> (RealTime -> [Score.Event] -> Maybe RealTime) -> RealTime -> Stream.Stream Score.Event -> Stream.Stream Score.Event infer_duration :: forall key. Eq key => Key key -> (RealTime -> [Note] -> Maybe RealTime) -> RealTime -> Stream Note -> Stream Note infer_duration Key key next_key RealTime -> [Note] -> Maybe RealTime infer RealTime final_dur = forall a b. (a -> b) -> Stream a -> Stream b Post.emap1_ (Note, [Note]) -> Note infer1 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 Key key next_key where infer1 :: (Note, [Note]) -> Note infer1 (Note event, [Note] nexts) | forall (t :: * -> *) a. Foldable t => t a -> Bool null [Note] nexts = RealTime -> Note -> Note Score.set_duration RealTime final_dur Note event | Note -> RealTime Score.event_duration Note event forall a. Ord a => a -> a -> Bool >= RealTime 0 = Note event | Bool otherwise = case RealTime -> [Note] -> Maybe RealTime infer (Note -> RealTime Score.event_start Note event) [Note] nexts of Maybe RealTime Nothing -> RealTime -> Note -> Note Score.set_duration RealTime final_dur Note event Just RealTime dur -> RealTime -> Note -> Note Score.set_duration RealTime dur Note event -- * cancel c_cancel :: Derive.Transformer Derive.Note c_cancel :: Transformer Note c_cancel = forall d. Module -> CallName -> Tags -> Doc -> WithArgDoc (TransformerF d) -> Transformer d Derive.transformer Module module_ CallName "cancel" Tags Tags.postproc Doc "Process the 'Derive.Flags.strong' and 'Derive.Flags.weak' flags.\ \ This will cause notes to be dropped." forall a b. (a -> b) -> a -> b $ forall key. Ord key => Cancel -> Key key -> WithArgDoc (Transformer Note (Stream Note)) make_cancel ((Note -> [Note] -> Note) -> Cancel cancel_strong_weak Note -> [Note] -> Note infer_duration_merged) Note -> (Instrument, Maybe Text) Post.hand_key -- | Given a set of coincident notes, return either an error, or merge them -- into a set of output notes. type Cancel = [Score.Event] -> Either Text [Score.Event] -- | The key identifies another event which is in the same voice. This could -- be 'Post.hand_key', but it could also match polos to sangsih, since they -- form a composite part. type Key key = Score.Event -> key make_cancel :: Ord key => Cancel -> Key key -> Derive.WithArgDoc (Derive.TransformerF Derive.Note) make_cancel :: forall key. Ord key => Cancel -> Key key -> WithArgDoc (Transformer Note (Stream Note)) make_cancel Cancel cancel Key key key = forall y a d. Taggable y => Parser a -> (a -> Transformer y d) -> WithArgDoc (Transformer y d) Sig.callt Parser RealTime final_duration_arg forall a b. (a -> b) -> a -> b $ \RealTime final_dur PassedArgs Note _args Deriver (Stream Note) deriver -> forall err a. Stack => (err -> Text) -> Either err a -> Deriver a Derive.require_right forall a. a -> a id forall b c a. (b -> c) -> (a -> b) -> a -> c . forall key. Ord key => Cancel -> Key key -> RealTime -> Stream Note -> Either Text (Stream Note) group_and_cancel Cancel cancel Key key key RealTime final_dur forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< Deriver (Stream Note) deriver final_duration_arg :: Sig.Parser RealTime final_duration_arg :: Parser RealTime final_duration_arg = forall a deflt. (Typecheck a, ToVal deflt) => ArgName -> EnvironDefault -> deflt -> Doc -> Parser a Sig.defaulted_env ArgName "final-duration" EnvironDefault Sig.Unprefixed (RealTime 1 :: RealTime) Doc "If there is no following note, infer this duration." group_and_cancel :: Ord key => Cancel -> Key key -> RealTime -> Events -> Either Text Events group_and_cancel :: forall key. Ord key => Cancel -> Key key -> RealTime -> Stream Note -> Either Text (Stream Note) group_and_cancel Cancel cancel Key key key RealTime final_dur = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (forall key. Eq key => Key key -> RealTime -> Stream Note -> Stream Note infer_duration_single Key key key RealTime final_dur forall b c a. (b -> c) -> (a -> b) -> a -> c . Stream Note -> Stream Note suppress_notes) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. ([a] -> Either Text [a]) -> [Either [LEvent a] [a]] -> Either Text (Stream a) merge_groups Cancel cancel forall b c a. (b -> c) -> (a -> b) -> a -> c . forall key. Ord key => (Note -> key) -> Stream Note -> [Either [LEvent Note] [Note]] group_coincident Key key key -- | Merge notes with 'Flags.strong' and 'Flags.weak'. The rules are that -- strong notes merge with weaker ones, in the order strong, normal, weak. -- -- Previously I considered multiple weaks or strongs ambiguous, but it turns -- out I get multiple strongs with two hand strokes at the end of a block, -- and I might as well allow the rest too, for simplicity. cancel_strong_weak :: (Score.Event -> [Score.Event] -> Score.Event) -> [Score.Event] -> Either Text [Score.Event] cancel_strong_weak :: (Note -> [Note] -> Note) -> Cancel cancel_strong_weak Note -> [Note] -> Note merge [Note] events = case [Note] -> ([Note], [Note], [Note]) partition [Note] events of (strongs :: [Note] strongs@(Note _:[Note] _), [Note] weaks, [Note] normals) -> forall a b. b -> Either a b Right [Note -> [Note] -> Note merge Note strong ([Note] normals forall a. [a] -> [a] -> [a] ++ [Note] weaks) | Note strong <- [Note] strongs] ([], [Note] weaks, normals :: [Note] normals@(Note _:[Note] _)) -> forall a b. b -> Either a b Right [Note -> [Note] -> Note merge Note normal [Note] weaks | Note normal <- [Note] normals] ([], [Note] weaks, []) -> forall a b. b -> Either a b Right [Note] weaks where partition :: [Note] -> ([Note], [Note], [Note]) partition = forall a. (a -> Bool) -> (a -> Bool) -> [a] -> ([a], [a], [a]) Lists.partition2 (Flags -> Note -> Bool Score.has_flags Flags Flags.strong) (Flags -> Note -> Bool Score.has_flags Flags Flags.weak) -- | Handle 'Flags.infer_duration' for notes merged together. This is the case -- where a final note replaces a coincident initial note. The strong note gets -- the duration of the longest weak notes, if there are any. If there are no -- weaks, then there are no coincedent notes to merge, so return the event -- unchanged so 'infer_duration_single' can handle it. infer_duration_merged :: Score.Event -> [Score.Event] -> Score.Event infer_duration_merged :: Note -> [Note] -> Note infer_duration_merged Note strong [Note] weaks = case forall a. Ord a => [a] -> Maybe a Lists.maximum (forall a b. (a -> b) -> [a] -> [b] map Note -> RealTime Score.event_end [Note] weaks) of Just RealTime end | Flags -> Note -> Bool Score.has_flags Flags Flags.infer_duration Note strong -> Stack => Text -> Note -> Note Score.add_log (Text "set duration to max of weak notes: " forall a. Semigroup a => a -> a -> a <> [Note] -> Text Score.short_events [Note] weaks) forall a b. (a -> b) -> a -> b $ Flags -> Note -> Note Score.remove_flags Flags Flags.infer_duration forall a b. (a -> b) -> a -> b $ RealTime -> Note -> Note Score.set_duration (RealTime end forall a. Num a => a -> a -> a - Note -> RealTime Score.event_start Note strong) Note strong Maybe RealTime _ -> Note strong -- | Handle 'Flags.infer_duration' for a note by itself. When there is no -- coincident note to replace, the duration extends to the start of the next -- matching event, according to the 'Key'. -- -- This actually finds the next matching event which starts later than this -- one. Normally notes of the same key are not expected to occur -- simultaneously, but may still do so, for example pasang parts which are -- normally considered a single voice but may still contain unison or kempyung. infer_duration_single :: Eq key => Key key -> RealTime -> Stream.Stream Score.Event -> Stream.Stream Score.Event infer_duration_single :: forall key. Eq key => Key key -> RealTime -> Stream Note -> Stream Note infer_duration_single Key key key RealTime final_dur = forall a b. (a -> b) -> Stream a -> Stream b Post.emap1_ forall {t :: * -> *}. Foldable t => (Note, t Note) -> Note infer 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 Key key key where infer :: (Note, t Note) -> Note infer (Note event, t Note _) | Bool -> Bool not (Flags -> Note -> Bool Score.has_flags Flags Flags.infer_duration Note event) = Note event infer (Note event, t Note nexts) = Flags -> Note -> Note Score.remove_flags Flags Flags.infer_duration forall a b. (a -> b) -> a -> b $ case Maybe Note next of Just Note next -> Stack => Text -> Note -> Note Score.add_log Text "set duration to next start" forall a b. (a -> b) -> a -> b $ RealTime -> Note -> Note set_end (Note -> RealTime Score.event_start Note next) Note event Maybe Note Nothing -> Stack => Text -> Note -> Note Score.add_log Text "set duration to final dur" forall a b. (a -> b) -> a -> b $ RealTime -> Note -> Note Score.set_duration RealTime final_dur Note event where next :: Maybe Note next = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a List.find ((forall a. Ord a => a -> a -> Bool > Note -> RealTime Score.event_start Note event) forall b c a. (b -> c) -> (a -> b) -> a -> c . Note -> RealTime Score.event_start) t Note nexts set_end :: RealTime -> Note -> Note set_end RealTime end Note event = RealTime -> Note -> Note Score.set_duration (RealTime end forall a. Num a => a -> a -> a - Note -> RealTime Score.event_start Note event) Note event merge_groups :: ([a] -> Either Text [a]) -> [Either [LEvent.LEvent a] [a]] -> Either Text (Stream.Stream a) merge_groups :: forall a. ([a] -> Either Text [a]) -> [Either [LEvent a] [a]] -> Either Text (Stream a) merge_groups [a] -> Either Text [a] merge = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap forall a. [LEvent a] -> Stream a Stream.from_sorted_list forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (m :: * -> *) b a. (Monad m, Monoid b) => (a -> m b) -> [a] -> m b concatMapM Either [LEvent a] [a] -> Either Text [LEvent a] go where go :: Either [LEvent a] [a] -> Either Text [LEvent a] go (Left [LEvent a] ungrouped) = forall a b. b -> Either a b Right [LEvent a] ungrouped go (Right []) = forall a b. b -> Either a b Right [] go (Right [a e]) = forall a b. b -> Either a b Right [forall a. a -> LEvent a LEvent.Event a e] go (Right [a] es) = forall a b. (a -> b) -> [a] -> [b] map forall a. a -> LEvent a LEvent.Event forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [a] -> Either Text [a] merge [a] es type Events = Stream.Stream Score.Event -- | Group events with the same start time. Events in Left are not grouped. group_coincident :: Ord key => (Score.Event -> key) -> Events -> [Either [LEvent.LEvent Score.Event] [Score.Event]] group_coincident :: forall key. Ord key => (Note -> key) -> Stream Note -> [Either [LEvent Note] [Note]] group_coincident Note -> key key = [LEvent Note] -> [Either [LEvent Note] [Note]] go forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Stream a -> [LEvent a] Stream.to_list where go :: [LEvent Note] -> [Either [LEvent Note] [Note]] go [] = [] go (log :: LEvent Note log@(LEvent.Log {}) : [LEvent Note] es) = forall a b. a -> Either a b Left [LEvent Note log] forall a. a -> [a] -> [a] : [LEvent Note] -> [Either [LEvent Note] [Note]] go [LEvent Note] es go (LEvent.Event Note e : [LEvent Note] es) = (if forall (t :: * -> *) a. Foldable t => t a -> Bool null [Msg] logs then forall a. a -> a id else (forall a b. a -> Either a b Left (forall a b. (a -> b) -> [a] -> [b] map forall a. Msg -> LEvent a LEvent.Log [Msg] logs) :)) forall a b. (a -> b) -> a -> b $ forall {a}. [Either a [Note]] groups forall a. [a] -> [a] -> [a] ++ [LEvent Note] -> [Either [LEvent Note] [Note]] go [LEvent Note] after where (([Note] during, [Msg] logs), [LEvent Note] after) = forall (p :: * -> * -> *) a b c. Bifunctor p => (a -> b) -> p a c -> p b c first forall d. [LEvent d] -> ([d], [Msg]) LEvent.partition forall a b. (a -> b) -> a -> b $ forall a. (a -> Bool) -> [a] -> ([a], [a]) span (forall d. (d -> Bool) -> LEvent d -> Bool LEvent.log_or forall a b. (a -> b) -> a -> b $ Note -> Note -> Bool same_start Note e) [LEvent Note] es -- [e] is going to be a common case, since most notes don't group. groups :: [Either a [Note]] groups = forall a b. (a -> b) -> [a] -> [b] map forall a b. b -> Either a b Right (forall key a. Ord key => (a -> key) -> [a] -> [[a]] Lists.groupSort Note -> key key (Note e forall a. a -> [a] -> [a] : [Note] during)) same_start :: Note -> Note -> Bool same_start Note e1 Note e2 = Note -> RealTime Score.event_start Note e1 RealTime -> RealTime -> Bool RealTime.== Note -> RealTime Score.event_start Note e2 -- | Filter out events that fall at and before the 'EnvKey.suppress_until' -- range of an event with the same (instrument, hand). Only events that don't -- have a suppress_until are suppressed. -- -- This is complicated by the fact that an event should suppress coincident -- events even if the supressor follows the suppressee in the list, so I have -- to look into the future for the greatest suppress_until. suppress_notes :: Stream.Stream Score.Event -> Stream.Stream Score.Event suppress_notes :: Stream Note -> Stream Note suppress_notes = forall a b. (a, b) -> b snd forall b c a. (b -> c) -> (a -> b) -> a -> c . forall state a. (state -> a -> (state, [Note])) -> state -> Stream a -> (state, Stream Note) Post.emap forall {a}. Ord a => Map a RealTime -> ([(a, Maybe RealTime, Note)], (a, Maybe RealTime, Note)) -> (Map a RealTime, [Note]) go forall k a. Map k a Map.empty forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. ([a] -> [b]) -> Stream a -> Stream (b, a) Stream.zip_on forall a. [a] -> [[a]] Post.nexts forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b c. ([a] -> [b]) -> ([a] -> [c]) -> Stream a -> Stream (b, c, a) Stream.zip3_on (forall a b. (a -> b) -> [a] -> [b] map Note -> (Instrument, Maybe Text) Post.hand_key) (forall a b. (a -> b) -> [a] -> [b] map Note -> Maybe RealTime get_suppress) where go :: Map a RealTime -> ([(a, Maybe RealTime, Note)], (a, Maybe RealTime, Note)) -> (Map a RealTime, [Note]) go Map a RealTime suppressed ([(a, Maybe RealTime, Note)] nexts, (a key, Maybe RealTime suppress, Note event)) = case Maybe RealTime suppress of Maybe RealTime Nothing -> (,) Map a RealTime suppressed forall a b. (a -> b) -> a -> b $ case Maybe RealTime suppress_until of Just RealTime until | RealTime until forall a. Ord a => a -> a -> Bool >= Note -> RealTime Score.event_start Note event forall a. Num a => a -> a -> a - RealTime RealTime.eta -> [] Maybe RealTime _ -> [Note event] Just RealTime until -> (forall k a. Ord k => k -> a -> Map k a -> Map k a Map.insert a key RealTime until Map a RealTime suppressed, [Note event]) where suppress_until :: Maybe RealTime suppress_until = forall a. Ord a => [a] -> Maybe a Lists.maximum forall a b. (a -> b) -> a -> b $ forall a. [Maybe a] -> [a] Maybe.catMaybes forall a b. (a -> b) -> a -> b $ (forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup a key Map a RealTime suppressed :) forall a b. (a -> b) -> a -> b $ forall a b. (a -> b) -> [a] -> [b] map forall {a} {b} {c}. (a, b, c) -> b suppress_of forall a b. (a -> b) -> a -> b $ forall a. (a -> Bool) -> [a] -> [a] takeWhile (Note -> Bool coincident forall b c a. (b -> c) -> (a -> b) -> a -> c . forall {a} {b} {c}. (a, b, c) -> c event_of) forall a b. (a -> b) -> a -> b $ forall a. (a -> Bool) -> [a] -> [a] filter ((forall a. Eq a => a -> a -> Bool ==a key) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall {a} {b} {c}. (a, b, c) -> a key_of) [(a, Maybe RealTime, Note)] nexts coincident :: Note -> Bool coincident Note e = Note -> RealTime Score.event_start Note e forall a. Ord a => a -> a -> Bool <= Note -> RealTime Score.event_start Note event forall a. Num a => a -> a -> a + RealTime RealTime.eta get_suppress :: Score.Event -> Maybe RealTime get_suppress :: Note -> Maybe RealTime get_suppress = forall a. Typecheck a => Text -> Environ -> Maybe a Env.maybe_val Text EnvKey.suppress_until forall b c a. (b -> c) -> (a -> b) -> a -> c . Note -> Environ Score.event_environ key_of :: (a, b, c) -> a key_of (a k, b _, c _) = a k suppress_of :: (a, b, c) -> b suppress_of (a _, b s, c _) = b s event_of :: (a, b, c) -> c event_of (a _, b _, c e) = c e -- * apply start offset c_randomize_start :: Derive.Transformer Derive.Note c_randomize_start :: Transformer Note c_randomize_start = forall a. Stack => Text -> Either Text a -> a StaticMacro.check Text "c_randomize_start" forall a b. (a -> b) -> a -> b $ forall d. CallableExpr d => Module -> CallName -> Tags -> Doc -> [Call (Transformer d)] -> Either Text (Transformer d) StaticMacro.transformer Module module_ CallName "randomize-start" Tags Tags.postproc Doc "" -- apply-start-offset | start-s = (cf-rnd-a+ $) [ forall call. call -> [Arg] -> Call call StaticMacro.Call Transformer Note c_apply_start_offset [] , forall call. call -> [Arg] -> Call call StaticMacro.Call forall d. CallableExpr d => Transformer d Equal.c_equal [ forall a. ToVal a => a -> Arg StaticMacro.literal (forall a. ShowVal a => a -> Text ShowVal.show_val Control Controls.start_s) , ValCall -> [Arg] -> Arg StaticMacro.call ((Y -> Y -> Y) -> ValCall ControlFunction.c_cf_rnd_around forall a. Num a => a -> a -> a (+)) [Arg StaticMacro.Var] ] ] {- | Previously I applied the @%start-s@ and @%start-t@ controls in the note generator, but I wound up with notes getting out of sync with their controls. Even if I apply the controls before inversion, it still doesn't work other calls, like say block calls, and I can't apply the controls before the block call -} c_apply_start_offset :: Derive.Transformer Derive.Note c_apply_start_offset :: Transformer Note c_apply_start_offset = forall d. Module -> CallName -> Tags -> Doc -> WithArgDoc (TransformerF d) -> Transformer d Derive.transformer Module module_ CallName "apply-start-offset" Tags Tags.postproc (Doc "Apply the " forall a. Semigroup a => a -> a -> a <> forall a. ShowVal a => a -> Doc ShowVal.doc Text EnvKey.start_offset_val forall a. Semigroup a => a -> a -> a <> Doc " env var.\ \ This is set by note deriver from the " forall a. Semigroup a => a -> a -> a <> forall a. ShowVal a => a -> Doc ShowVal.doc Control Controls.start_s forall a. Semigroup a => a -> a -> a <> Doc " and " forall a. Semigroup a => a -> a -> a <> forall a. ShowVal a => a -> Doc ShowVal.doc Control Controls.start_t forall a. Semigroup a => a -> a -> a <> Doc " controls, so if you want those\ \ controls to have an effect, you have to use this postproc." ) 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 deflt. (Typecheck a, ToVal deflt) => ArgName -> deflt -> Doc -> Parser a Sig.defaulted ArgName "min-duration" (forall a. Maybe a Nothing :: Maybe RealTime) Doc "If given, notes on the same hand\ \ won't be moved closer than this time. Otherwise, hand and\ \ instrument is ignored." ) forall a b. (a -> b) -> a -> b $ \Maybe RealTime min_dur PassedArgs Note _args Deriver (Stream Note) deriver -> Maybe RealTime -> Stream Note -> Stream Note apply_start_offset Maybe RealTime min_dur forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Deriver (Stream Note) deriver apply_start_offset :: Maybe RealTime -> Stream.Stream Score.Event -> Stream.Stream Score.Event apply_start_offset :: Maybe RealTime -> Stream Note -> Stream Note apply_start_offset Maybe RealTime maybe_min_dur = Stream (RealTime, Note) -> Stream Note apply_offset forall b c a. (b -> c) -> (a -> b) -> a -> c . Stream (RealTime, Note) -> Stream (RealTime, Note) tweak_offset forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. ([a] -> [b]) -> Stream a -> Stream (b, a) Stream.zip_on (forall a b. (a -> b) -> [a] -> [b] map Note -> RealTime offset_of) where tweak_offset :: Stream (RealTime, Note) -> Stream (RealTime, Note) tweak_offset = case Maybe RealTime maybe_min_dur of Maybe RealTime Nothing -> forall a. a -> a id Just RealTime min_dur -> forall a b. (a -> b) -> Stream a -> Stream b Post.emap1_ (RealTime -> (Maybe (RealTime, Note), (RealTime, Note), Maybe (RealTime, Note)) -> (RealTime, Note) tweak RealTime min_dur) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall key a. Eq key => (a -> key) -> Stream a -> Stream (Maybe a, a, Maybe a) Post.neighbors_by (Note -> (Instrument, Maybe Text) Post.hand_key forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a, b) -> b snd) tweak :: RealTime -> (Maybe (RealTime, Note), (RealTime, Note), Maybe (RealTime, Note)) -> (RealTime, Note) tweak RealTime min_dur (Maybe (RealTime, Note) prev, (RealTime offset, Note event), Maybe (RealTime, Note) next) = (RealTime new_offset, Note event) where new_offset :: RealTime new_offset = RealTime -> Maybe (RealTime, RealTime) -> Maybe (RealTime, RealTime) -> RealTime -> RealTime -> RealTime adjust_offset RealTime min_dur (forall {a}. (a, Note) -> (a, RealTime) extract forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Maybe (RealTime, Note) prev) (forall {a}. (a, Note) -> (a, RealTime) extract forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Maybe (RealTime, Note) next) RealTime offset (Note -> RealTime Score.event_start Note event) extract :: (a, Note) -> (a, RealTime) extract (a offset, Note event) = (a offset, Note -> RealTime Score.event_start Note event) apply_offset :: Stream (RealTime, Note) -> Stream Note apply_offset = forall a. (a -> Note) -> Stream a -> Stream Note Post.emap1_ord_ forall {a}. (a, (RealTime, Note), Maybe (RealTime, Note)) -> Note apply forall b c a. (b -> c) -> (a -> b) -> a -> c . forall key a. Eq key => (a -> key) -> Stream a -> Stream (Maybe a, a, Maybe a) Post.neighbors_by (Note -> (Instrument, Maybe Text) Post.hand_key forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a, b) -> b snd) apply :: (a, (RealTime, Note), Maybe (RealTime, Note)) -> Note apply (a _, (RealTime offset, Note event), Maybe (RealTime, Note) maybe_next) = Note -> Note set_dur forall a b. (a -> b) -> a -> b $ RealTime -> RealTime -> Note -> Note Score.move_start (forall a. a -> Maybe a -> a fromMaybe RealTime Note.min_duration Maybe RealTime maybe_min_dur) RealTime offset Note event where set_dur :: Note -> Note set_dur Note event = case Maybe (RealTime, Note) maybe_next of Maybe (RealTime, Note) Nothing -> Note event Just (RealTime next_offset, Note next) -> (RealTime -> RealTime) -> Note -> Note Score.duration (forall a b. a -> b -> a const RealTime dur) Note event where dur :: RealTime dur = RealTime -> RealTime -> Note -> RealTime adjust_duration (Note -> RealTime Score.event_start Note next) (Note -> RealTime Score.event_start Note next forall a. Num a => a -> a -> a + RealTime next_offset) Note event {- | Conceptually, all notes move together until they bump into each other. Or, they move without restriction, and then go to midway of the overlap. But the note's start is a hard lower or upper limit, so one note moving can never cause another note to move, it can just cause it to not move as much as it wanted. TODO actually "half of the overlap" is not the same as "all move together". For the latter, the overlap split depends on how far the note moved to get there. So instead of overlap/2 it's 'max 0 (overlap - n) / 2', where 'n' is the imbalance between their move offsets. TODO this is still broken if an offset causes an note to skip over another. But that should be stopped by the next event, right? -} adjust_offset :: RealTime -- ^ don't move notes any closer than this -> Maybe (RealTime, RealTime) -> Maybe (RealTime, RealTime) -> RealTime -> RealTime -> RealTime adjust_offset :: RealTime -> Maybe (RealTime, RealTime) -> Maybe (RealTime, RealTime) -> RealTime -> RealTime -> RealTime adjust_offset RealTime min_dur Maybe (RealTime, RealTime) prev Maybe (RealTime, RealTime) next RealTime offset RealTime start | RealTime offset forall a. Eq a => a -> a -> Bool == RealTime 0 = RealTime offset | RealTime offset forall a. Ord a => a -> a -> Bool > RealTime 0 = case Maybe (RealTime, RealTime) next of Maybe (RealTime, RealTime) Nothing -> RealTime offset -- 0 1 2 3 4 -- [----=+=> -- <-+-----| -- [---====+===)---> -- <---+---| -- [-------> ) -- |-------> Just (RealTime next_offset, RealTime next_start) | RealTime overlap forall a. Ord a => a -> a -> Bool <= RealTime 0 -> forall a. Ord a => a -> a -> a min (RealTime next_end forall a. Num a => a -> a -> a - RealTime min_dur) RealTime end forall a. Num a => a -> a -> a - RealTime start | Bool otherwise -> (RealTime end forall a. Num a => a -> a -> a - RealTime overlap forall a. Num a => a -> a -> a + RealTime overlap forall a. Fractional a => a -> a -> a / RealTime 2 forall a. Num a => a -> a -> a - RealTime min_dur) forall a. Num a => a -> a -> a - RealTime start where overlap :: RealTime overlap = RealTime end forall a. Num a => a -> a -> a - RealTime next_end end :: RealTime end = forall a. Ord a => a -> a -> a min (forall a. Ord a => a -> a -> a max RealTime next_start RealTime next_end) (RealTime start forall a. Num a => a -> a -> a + RealTime offset) next_end :: RealTime next_end = forall a. Ord a => a -> a -> a max RealTime start (RealTime next_start forall a. Num a => a -> a -> a + RealTime next_offset) | Bool otherwise = case Maybe (RealTime, RealTime) prev of Maybe (RealTime, RealTime) Nothing -> RealTime offset -- 0 1 2 3 4 -- <-------| -- ( <-------| Just (RealTime prev_offset, RealTime prev_start) -- If the prev_offset is positive, then it will have already given -- the min_dur space. | RealTime overlap forall a. Ord a => a -> a -> Bool <= RealTime 0 -> if RealTime prev_offset forall a. Ord a => a -> a -> Bool > RealTime 0 then RealTime offset else forall a. Ord a => a -> a -> a max (RealTime prev_end forall a. Num a => a -> a -> a + RealTime min_dur) RealTime end forall a. Num a => a -> a -> a - RealTime start | Bool otherwise -> (RealTime end forall a. Num a => a -> a -> a + RealTime overlap forall a. Num a => a -> a -> a - RealTime overlap forall a. Fractional a => a -> a -> a / RealTime 2) forall a. Num a => a -> a -> a - RealTime start where overlap :: RealTime overlap = RealTime prev_end forall a. Num a => a -> a -> a - RealTime end end :: RealTime end = forall a. Ord a => a -> a -> a max (forall a. Ord a => a -> a -> a min RealTime prev_start RealTime prev_end) (RealTime start forall a. Num a => a -> a -> a + RealTime offset) prev_end :: RealTime prev_end = forall a. Ord a => a -> a -> a min RealTime start (RealTime prev_start forall a. Num a => a -> a -> a + RealTime prev_offset) -- | Change the duration based on the movement of the next event. -- -- If the event end touches the next start, then adjust dur by next_offset. If -- it's less, then shorten but don't lengthen. If it overlaps the next note, -- then leave it alone. adjust_duration :: RealTime -> RealTime -> Score.Event -> RealTime adjust_duration :: RealTime -> RealTime -> Note -> RealTime adjust_duration RealTime next RealTime new_next Note event = forall a. Num a => a -> a -> a subtract (Note -> RealTime Score.event_start Note event) forall a b. (a -> b) -> a -> b $ case forall a. (ApproxEq a, Ord a) => Y -> a -> a -> Ordering ApproxEq.compare Y 0.001 RealTime end RealTime next of Ordering EQ -> RealTime new_next Ordering LT -> forall a. Ord a => a -> a -> a min RealTime new_next RealTime end Ordering GT -> RealTime end where end :: RealTime end = Note -> RealTime Score.event_end Note event offset_of :: Score.Event -> RealTime offset_of :: Note -> RealTime offset_of = forall a. a -> Maybe a -> a fromMaybe RealTime 0 forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Typecheck a => Text -> Environ -> Maybe a Env.maybe_val Text EnvKey.start_offset_val forall b c a. (b -> c) -> (a -> b) -> a -> c . Note -> Environ Score.event_environ