-- 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 {- | Various kinds of trills. Trills want to generate an integral number of cycles. For the purpose of counting integral cycles, trills count the end (either the end of the event, or the start of the next event). This is different than other control calls, which tend to omit the end point, expecting that the next call will place a sample there. This is so that a trill can end on an off note if it exactly fits into its allotted space, otherwise a 16th note trill in a quarter note would degenerate into a mordent. Various flavors of trills: - Trill cycles depend on real duration of note. Cycle durations are given in real time. - As above, but durations are given in score time. - Number of trill cycles given as argument, and note stretches normally. - Sung style vibrato in a sine wave rather than a square wave. - Trill that simply adds an attribute, instrument will handle it. The generic 'tr' symbol can be bound to whichever variant is locally appropriate. It's easy to think of more variants of trills: hold the starting note briefly, hold the final note briefly, inject a little randomness, smooth the pitch curve by a variable amount, or variants that cover the range between trill and vibrato, etc. One can also imagine dynamic effects. Instead of trying to provide a million functions here or a few with a million parameters, it should be relatively easy to reuse the functions in here to write a specific kind of trill for the particular piece. -} module Derive.C.Prelude.Trill ( library , c_note_trill, c_tremolo_generator , hold_env, tremolo_starts_curve -- * transitions , trill_transitions, adjusted_transitions -- * types , Config(..) , Direction(..), direction_affix , AbsoluteMode(..) , Adjust(..), adjust_env , get_trill_control_smooth -- testing , full_notes, chord_tremolo, get_trill_control, xcut_control ) where import qualified Data.List as List import qualified Data.Maybe as Maybe import qualified Util.Doc as Doc import qualified Util.Lists as Lists import qualified Util.Num as Num import qualified Derive.Args as Args import qualified Derive.Attrs as Attrs import qualified Derive.Call as Call import qualified Derive.Call.ControlUtil as ControlUtil import qualified Derive.Call.Ly as Ly import qualified Derive.Call.Module as Module import qualified Derive.Call.Speed as Speed import qualified Derive.Call.Sub as Sub import qualified Derive.Call.SubT as SubT import qualified Derive.Call.Tags as Tags import qualified Derive.Derive as Derive import qualified Derive.DeriveT as DeriveT import qualified Derive.EnvKey as EnvKey import qualified Derive.Eval as Eval import qualified Derive.Expr as Expr import qualified Derive.Library as Library import qualified Derive.PSignal as PSignal import qualified Derive.Pitches as Pitches import qualified Derive.Scale as Scale import qualified Derive.Scale.Theory as Theory import qualified Derive.Scale.Twelve as Twelve import qualified Derive.ScoreT as ScoreT import qualified Derive.ShowVal as ShowVal import qualified Derive.Sig as Sig import qualified Derive.Typecheck as Typecheck import qualified Perform.Lilypond.Constants as Constants import qualified Perform.Lilypond.Convert as Lilypond.Convert import qualified Perform.Lilypond.Types as Types import qualified Perform.Pitch as Pitch import qualified Perform.RealTime as RealTime import qualified Perform.Signal as Signal import qualified Ui.ScoreTime as ScoreTime import Global import Types library :: Library.Library library :: Library library = forall a. Monoid a => [a] -> a mconcat -- Note [ forall {call}. ToLibrary (Generator call) => Text -> (Maybe Direction -> Maybe Direction -> Generator call) -> Library make_trills Text "tr" (Bool -> Maybe Direction -> Maybe Direction -> Generator Note c_note_trill Bool False) , forall call. ToLibrary (Generator call) => [(Symbol, Generator call)] -> Library Library.generators [(Symbol "trem", Maybe ([Attributes], Attributes) -> Generator Note c_tremolo_generator forall a. Maybe a Nothing)] , forall call. ToLibrary (Transformer call) => [(Symbol, Transformer call)] -> Library Library.transformers [(Symbol "trem", Transformer Note c_tremolo_transformer)] -- Pitch , forall {call}. ToLibrary (Generator call) => Text -> (Maybe Direction -> Maybe Direction -> Generator call) -> Library make_trills Text "tr" Maybe Direction -> Maybe Direction -> Generator PSignal c_pitch_trill , forall {call}. ToLibrary (Generator call) => Text -> (Maybe Direction -> Maybe Direction -> Generator call) -> Library make_trills Text "trs" Maybe Direction -> Maybe Direction -> Generator PSignal c_pitch_trill_smooth , forall call. ToLibrary (Generator call) => [(Symbol, Generator call)] -> Library Library.generators [ (Symbol "xcut", Bool -> Generator PSignal c_xcut_pitch Bool False) , (Symbol "xcut-h", Bool -> Generator PSignal c_xcut_pitch Bool True) ] -- Control , forall {call}. ToLibrary (Generator call) => Text -> (Maybe Direction -> Maybe Direction -> Generator call) -> Library make_trills Text "tr" Maybe Direction -> Maybe Direction -> Generator Control c_control_trill , forall {call}. ToLibrary (Generator call) => Text -> (Maybe Direction -> Maybe Direction -> Generator call) -> Library make_trills Text "trs" Maybe Direction -> Maybe Direction -> Generator Control c_control_trill_smooth , forall call. ToLibrary (Generator call) => [(Symbol, Generator call)] -> Library Library.generators forall a b. (a -> b) -> a -> b $ [ (Symbol "saw", Generator Control c_saw) , (Symbol "sine", SineMode -> Generator Control c_sine SineMode Bipolar) , (Symbol "sine+", SineMode -> Generator Control c_sine SineMode Positive) , (Symbol "sine-", SineMode -> Generator Control c_sine SineMode Negative) , (Symbol "xcut", Bool -> Generator Control c_xcut_control Bool False) , (Symbol "xcut-h", Bool -> Generator Control c_xcut_control Bool True) ] ] where make_trills :: Text -> (Maybe Direction -> Maybe Direction -> Generator call) -> Library make_trills Text prefix Maybe Direction -> Maybe Direction -> Generator call make = forall call. ToLibrary (Generator call) => [(Symbol, Generator call)] -> Library Library.generators [(Symbol name, Maybe Direction -> Maybe Direction -> Generator call make Maybe Direction start Maybe Direction end) | (Symbol name, Maybe Direction start, Maybe Direction end) <- Text -> [(Symbol, Maybe Direction, Maybe Direction)] trill_variations Text prefix] -- * note calls c_note_trill :: Bool -> Maybe Direction -> Maybe Direction -> Derive.Generator Derive.Note c_note_trill :: Bool -> Maybe Direction -> Maybe Direction -> Generator Note c_note_trill Bool use_attributes Maybe Direction hardcoded_start Maybe Direction hardcoded_end = forall d. Module -> CallName -> Tags -> Doc -> WithArgDoc (GeneratorF d) -> Generator d Derive.generator Module Module.prelude CallName "tr" Tags Tags.ly (Doc "Generate a note with a trill.\ \\nUnlike a trill on a pitch track, this generates events for each\ \ note of the trill. This is more appropriate for fingered trills,\ \ or monophonic instruments that use legato to play slurred notes.\ \\nInstruments that support +trill attributes should enable the attributes\ \ version, which emits a single note with `+trill+half`, `+trill+whole`, or\ \ all the notes with `+trill`, depending on the interval." forall a. Semigroup a => a -> a -> a <> forall a. Maybe a -> Maybe a -> Doc direction_doc Maybe Direction hardcoded_start Maybe Direction hardcoded_end ) 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 Neighbor neighbor_arg forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Maybe Direction -> Maybe Direction -> Parser Config config_arg Maybe Direction hardcoded_start Maybe Direction hardcoded_end forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> forall a deflt. (Typecheck a, ToVal deflt) => Text -> deflt -> Doc -> Parser a Sig.environ_key Text "tr-style" TrillStyle Tr Doc "Notation variant: tr symbol, tr~, or tremolo." ) forall a b. (a -> b) -> a -> b $ \(Neighbor neighbor, Config config, TrillStyle style) -> forall d. (PassedArgs d -> Deriver (Stream Note)) -> PassedArgs d -> Deriver (Stream Note) Sub.inverting forall a b. (a -> b) -> a -> b $ \PassedArgs Note args -> forall a. Deriver a -> Deriver a -> Deriver a Ly.when_lilypond (forall a. TrillStyle -> PassedArgs a -> Neighbor -> Deriver (Stream Note) note_trill_ly TrillStyle style PassedArgs Note args Neighbor neighbor) (forall a. Bool -> Neighbor -> Config -> PassedArgs a -> Deriver (Stream Note) note_trill Bool use_attributes Neighbor neighbor Config config PassedArgs Note args) type Neighbor = Either Typecheck.DiatonicTransposeFunctionT PSignal.Pitch neighbor_arg :: Sig.Parser Neighbor neighbor_arg :: Parser Neighbor neighbor_arg = forall a deflt. (Typecheck a, ToVal deflt) => ArgName -> deflt -> Doc -> Parser a Sig.defaulted ArgName "neighbor" (forall a b. a -> Either a b Left Int 1 :: Either Int Sig.Dummy) Doc "Alternate with an interval or pitch." note_trill :: Bool -> Neighbor -> Config -> Derive.PassedArgs a -> Derive.NoteDeriver note_trill :: forall a. Bool -> Neighbor -> Config -> PassedArgs a -> Deriver (Stream Note) note_trill Bool use_attributes Neighbor neighbor Config config PassedArgs a args | Bool use_attributes = Neighbor -> ScoreTime -> Deriver (Maybe Attributes) trill_attributes Neighbor neighbor (forall a. PassedArgs a -> ScoreTime Args.start PassedArgs a args) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \case Just Attributes attr -> forall d. Attributes -> Deriver d -> Deriver d Call.add_attributes (Attributes Attrs.trill forall a. Semigroup a => a -> a -> a <> Attributes attr) (forall d. PassedArgs d -> Deriver (Stream Note) Call.placed_note PassedArgs a args) Maybe Attributes Nothing -> forall d. Attributes -> Deriver d -> Deriver d Call.add_attributes Attributes Attrs.trill Deriver (Stream Note) trill_notes | Bool otherwise = Deriver (Stream Note) trill_notes where trill_notes :: Deriver (Stream Note) trill_notes = do (Function neighbor, Control control) <- ScoreTime -> Neighbor -> Deriver (Function, Control) neighbor_to_function (forall a. PassedArgs a -> ScoreTime Args.start PassedArgs a args) Neighbor neighbor [(RealTime, Double)] transpose <- Config -> (ScoreTime, ScoreTime) -> Function -> Deriver [(RealTime, Double)] get_trill_control Config config (forall a. PassedArgs a -> (ScoreTime, ScoreTime) Args.range_or_next PassedArgs a args) Function neighbor [Event] -> Deriver (Stream Note) Sub.derive forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM (forall {a} {b} {b}. (Time a, Time b) => Control -> ((a, Double), Maybe (b, b)) -> Deriver State Error Event note Control control) (forall a. [a] -> [(a, Maybe a)] Lists.zipNext [(RealTime, Double)] transpose) note :: Control -> ((a, Double), Maybe (b, b)) -> Deriver State Error Event note Control control ((a x, Double transpose), Maybe (b, b) next) = do ScoreTime start <- forall a. Time a => a -> Deriver ScoreTime Derive.score a x let end :: ScoreTime end = forall a b. (a, b) -> b snd forall a b. (a -> b) -> a -> b $ forall a. PassedArgs a -> (ScoreTime, ScoreTime) Args.range PassedArgs a args ScoreTime next <- forall b a. b -> (a -> b) -> Maybe a -> b maybe (forall (m :: * -> *) a. Monad m => a -> m a return ScoreTime end) (forall a. Time a => a -> Deriver ScoreTime Derive.score forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a, b) -> a fst) Maybe (b, b) next forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a. ScoreTime -> ScoreTime -> a -> EventT a SubT.EventT ScoreTime start (ScoreTime nextforall a. Num a => a -> a -> a -ScoreTime start) forall a b. (a -> b) -> a -> b $ forall a. Control -> Double -> Deriver a -> Deriver a Call.add_constant Control control Double transpose Deriver (Stream Note) Call.note -- trill_notes = do -- neighbor <- neighbor_to_signal2 (Args.start args) neighbor -- (transpose, control) <- get_trill_control2 -- (Args.range_or_next args) start_dir end_dir adjust hold -- neighbor speed -- xs <- mapM (Derive.score . fst) transpose -- let end = snd $ Args.range args -- let notes = do -- (x, maybe_next) <- Lists.zipNext xs -- let next = fromMaybe end maybe_next -- return $ SubT.EventT x (next-x) Call.note -- Call.add_control control (ScoreT.untyped transpose) -- (Sub.derive notes) -- TODO this is an implementation that directly uses the neighbor pitch -- instead of the roundabout signal thing. But I still need the signal -- if it changes. Implement when I'm not in such a hurry. -- neighbor <- case neighbor of -- Right p -> return p -- Left control -> undefined -- let neighbor_low = False -- TODO -- (who_first, transitions) <- get_trill_transitions -- (Args.range_or_next args) start_dir end_dir -- adjust hold speed neighbor_low -- base <- Call.get_pitch_here args -- let pitches = cycle $ case who_first of -- Unison -> [base, neighbor] -- Neighbor -> [neighbor, base] -- transitions <- mapM Derive.score transitions -- Sub.derive $ do -- (pitch, (x, maybe_next)) <- -- zip pitches (Lists.zipNext transitions) -- let next = fromMaybe (snd (Args.range args)) maybe_next -- return $ SubT.EventT x (next-x) (Call.pitched_note pitch) neighbor_to_function :: ScoreTime -> Neighbor -> Derive.Deriver (ScoreT.Function, ScoreT.Control) neighbor_to_function :: ScoreTime -> Neighbor -> Deriver (Function, Control) neighbor_to_function ScoreTime _ (Left (Typecheck.DiatonicTransposeFunctionT TransposeT typ Function f)) = forall (m :: * -> *) a. Monad m => a -> m a return (Function f, TransposeT -> Control Typecheck.transpose_control TransposeT typ) neighbor_to_function ScoreTime start (Right Pitch neighbor) = do RealTime start <- forall a. Time a => a -> Deriver RealTime Derive.real ScoreTime start Pitch base <- RealTime -> Deriver Pitch Call.get_pitch RealTime start NoteNumber diff <- RealTime -> Pitch -> Pitch -> Deriver NoteNumber Call.nn_difference RealTime start Pitch neighbor Pitch base forall (m :: * -> *) a. Monad m => a -> m a return (forall a b. a -> b -> a const (forall a b. (Real a, Fractional b) => a -> b realToFrac NoteNumber diff), TransposeT -> Control Typecheck.transpose_control TransposeT ScoreT.TNn) trill_attributes :: Neighbor -> ScoreTime -> Derive.Deriver (Maybe Attrs.Attributes) trill_attributes :: Neighbor -> ScoreTime -> Deriver (Maybe Attributes) trill_attributes Neighbor neighbor ScoreTime start = do RealTime start <- forall a. Time a => a -> Deriver RealTime Derive.real ScoreTime start (Pitch pitch, Pitch neighbor) <- Neighbor -> RealTime -> Deriver (Pitch, Pitch) pitch_and_neighbor Neighbor neighbor RealTime start NoteNumber diff <- RealTime -> Pitch -> Pitch -> Deriver NoteNumber Call.nn_difference RealTime start Pitch neighbor Pitch pitch forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ if | NoteNumber -> NoteNumber -> Bool Pitch.nns_equal NoteNumber diff NoteNumber 1 -> forall a. a -> Maybe a Just Attributes Attrs.half | NoteNumber -> NoteNumber -> Bool Pitch.nns_equal NoteNumber diff NoteNumber 2 -> forall a. a -> Maybe a Just Attributes Attrs.whole | Bool otherwise -> forall a. Maybe a Nothing data TrillStyle = Tr | Span | Tremolo deriving (Int -> TrillStyle -> ShowS [TrillStyle] -> ShowS TrillStyle -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [TrillStyle] -> ShowS $cshowList :: [TrillStyle] -> ShowS show :: TrillStyle -> String $cshow :: TrillStyle -> String showsPrec :: Int -> TrillStyle -> ShowS $cshowsPrec :: Int -> TrillStyle -> ShowS Show, TrillStyle -> TrillStyle -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: TrillStyle -> TrillStyle -> Bool $c/= :: TrillStyle -> TrillStyle -> Bool == :: TrillStyle -> TrillStyle -> Bool $c== :: TrillStyle -> TrillStyle -> Bool Eq, Int -> TrillStyle TrillStyle -> Int TrillStyle -> [TrillStyle] TrillStyle -> TrillStyle TrillStyle -> TrillStyle -> [TrillStyle] TrillStyle -> TrillStyle -> TrillStyle -> [TrillStyle] forall a. (a -> a) -> (a -> a) -> (Int -> a) -> (a -> Int) -> (a -> [a]) -> (a -> a -> [a]) -> (a -> a -> [a]) -> (a -> a -> a -> [a]) -> Enum a enumFromThenTo :: TrillStyle -> TrillStyle -> TrillStyle -> [TrillStyle] $cenumFromThenTo :: TrillStyle -> TrillStyle -> TrillStyle -> [TrillStyle] enumFromTo :: TrillStyle -> TrillStyle -> [TrillStyle] $cenumFromTo :: TrillStyle -> TrillStyle -> [TrillStyle] enumFromThen :: TrillStyle -> TrillStyle -> [TrillStyle] $cenumFromThen :: TrillStyle -> TrillStyle -> [TrillStyle] enumFrom :: TrillStyle -> [TrillStyle] $cenumFrom :: TrillStyle -> [TrillStyle] fromEnum :: TrillStyle -> Int $cfromEnum :: TrillStyle -> Int toEnum :: Int -> TrillStyle $ctoEnum :: Int -> TrillStyle pred :: TrillStyle -> TrillStyle $cpred :: TrillStyle -> TrillStyle succ :: TrillStyle -> TrillStyle $csucc :: TrillStyle -> TrillStyle Enum, TrillStyle forall a. a -> a -> Bounded a maxBound :: TrillStyle $cmaxBound :: TrillStyle minBound :: TrillStyle $cminBound :: TrillStyle Bounded) instance Typecheck.Typecheck TrillStyle instance Typecheck.ToVal TrillStyle instance ShowVal.ShowVal TrillStyle note_trill_ly :: TrillStyle -> Derive.PassedArgs a -> Neighbor -> Derive.NoteDeriver note_trill_ly :: forall a. TrillStyle -> PassedArgs a -> Neighbor -> Deriver (Stream Note) note_trill_ly TrillStyle style PassedArgs a args Neighbor neighbor = do RealTime start <- forall a. PassedArgs a -> Deriver RealTime Args.real_start PassedArgs a args (Pitch pitch, Pitch neighbor) <- Neighbor -> RealTime -> Deriver (Pitch, Pitch) pitch_and_neighbor Neighbor neighbor RealTime start NoteNumber diff <- RealTime -> Pitch -> Pitch -> Deriver NoteNumber Call.nn_difference RealTime start Pitch neighbor Pitch pitch let tremolo :: Deriver (Stream Note) tremolo = Pitch -> Pitch -> ScoreTime -> ScoreTime -> Deriver (Stream Note) tremolo_trill_ly Pitch pitch Pitch neighbor (forall a. PassedArgs a -> ScoreTime Args.start PassedArgs a args) (forall a. PassedArgs a -> ScoreTime Args.duration PassedArgs a args) Environ env <- Deriver Environ Derive.get_environ let ly_pitch :: Deriver State Error Pitch ly_pitch = forall err a. HasCallStack => (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 . Environ -> Transposed -> Either Text Pitch Lilypond.Convert.pitch_to_lily Environ env forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< RealTime -> Pitch -> Deriver Transposed Derive.resolve_pitch RealTime start Pitch neighbor case TrillStyle style of TrillStyle _ | Bool -> Bool not (NoteNumber -> NoteNumber -> Bool Pitch.nns_equal NoteNumber diff NoteNumber 1) Bool -> Bool -> Bool && Bool -> Bool not (NoteNumber -> NoteNumber -> Bool Pitch.nns_equal NoteNumber diff NoteNumber 2) -> Deriver (Stream Note) tremolo TrillStyle Tremolo -> Deriver (Stream Note) tremolo TrillStyle Tr -> do npitch :: Pitch npitch@(Types.Pitch Int _ PitchClass _ Accidental acc) <- Deriver State Error Pitch ly_pitch Bool in_key <- Pitch -> Deriver Bool pitch_in_key Pitch npitch let code :: Text code = case Accidental acc of Accidental _ | Bool in_key -> Text "\\trill" Accidental Types.FlatFlat -> Text "^\\trFlatFlat" Accidental Types.Flat -> Text "^\\trFlat" Accidental Types.Natural -> Text "^\\trNatural" Accidental Types.Sharp -> Text "^\\trSharp" Accidental Types.SharpSharp -> Text "^\\trSharpSharp" -- TODO this should by Ly.note_append, but I can't put the \trFlat -- macros on a single pitch. Code -> Deriver (Stream Note) -> Deriver (Stream Note) Ly.add_first (Distribution -> Position CodePosition Ly.append Distribution Constants.All, Text code) (forall d. PassedArgs d -> Deriver (Stream Note) Call.placed_note PassedArgs a args) TrillStyle Span -> do Pitch npitch <- Deriver State Error Pitch ly_pitch Code -> Deriver (Stream Note) -> Deriver (Stream Note) Ly.add_first (Position CodePosition Ly.prepend, Text "\\pitchedTrill") forall a b. (a -> b) -> a -> b $ Code -> Deriver (Stream Note) -> Deriver (Stream Note) Ly.add_first (Distribution -> Position CodePosition Ly.append Distribution Constants.First, Text "\\startTrillSpan " forall a. Semigroup a => a -> a -> a <> forall a. ToLily a => a -> Text Types.to_lily Pitch npitch) forall a b. (a -> b) -> a -> b $ Code -> Deriver (Stream Note) -> Deriver (Stream Note) Ly.add_first (Distribution -> Position CodePosition Ly.append Distribution Constants.Last, Text "\\stopTrillSpan") forall a b. (a -> b) -> a -> b $ forall d. PassedArgs d -> Deriver (Stream Note) Call.placed_note PassedArgs a args pitch_in_key :: Types.Pitch -> Derive.Deriver Bool pitch_in_key :: Pitch -> Deriver Bool pitch_in_key Pitch ly_pitch = do Key key <- Deriver Key get_key forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ Key -> Degree -> Bool in_key Key key (Pitch -> Degree Pitch.pitch_degree (Pitch -> Pitch Types.to_pitch Pitch ly_pitch)) get_key :: Derive.Deriver Theory.Key get_key :: Deriver Key get_key = do Maybe Key maybe_key <- Deriver (Maybe Key) Call.lookup_key forall a. HasCallStack => Text -> Maybe a -> Deriver a Derive.require (Text "unrecognized key: " forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty Maybe Key maybe_key) forall a b. (a -> b) -> a -> b $ Maybe Key -> Maybe Key Twelve.lookup_key Maybe Key maybe_key in_key :: Theory.Key -> Pitch.Degree -> Bool in_key :: Key -> Degree -> Bool in_key Key key (Pitch.Degree Int pc Int acc) = Key -> Int -> Int Theory.accidentals_at_pc Key key Int pc forall a. Eq a => a -> a -> Bool == Int acc pitch_and_neighbor :: Neighbor -> RealTime -> Derive.Deriver (PSignal.Pitch, PSignal.Pitch) pitch_and_neighbor :: Neighbor -> RealTime -> Deriver (Pitch, Pitch) pitch_and_neighbor (Right Pitch neighbor) RealTime start = (, Pitch neighbor) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> RealTime -> Deriver Pitch Call.get_pitch RealTime start pitch_and_neighbor (Left (Typecheck.DiatonicTransposeFunctionT TransposeT typ Function f)) RealTime start = do Pitch base <- RealTime -> Deriver Pitch Call.get_pitch RealTime start let width :: Double width = Function f RealTime start case (TransposeT typ, Double width) of (TransposeT ScoreT.TChromatic, Double 1) -> (Pitch base,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (Transposed -> Deriver Pitch chromatic_neighbor forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< RealTime -> Pitch -> Deriver Transposed Derive.resolve_pitch RealTime start Pitch base) (TransposeT, Double) _ -> forall (m :: * -> *) a. Monad m => a -> m a return (Pitch base, forall a. Transpose -> RawPitch a -> RawPitch a Pitches.transpose (TransposeT -> Double -> Transpose Typecheck.to_transpose TransposeT typ Double width) Pitch base) -- | Given a pitch, find the enharmonic one chromatic step above it which is -- at pitch class + 1. This is because trills should alternate with the next -- pitch class, so c to d flat, not c to c#. chromatic_neighbor :: PSignal.Transposed -> Derive.Deriver PSignal.Pitch chromatic_neighbor :: Transposed -> Deriver Pitch chromatic_neighbor Transposed pitch = do -- TODO this is way too complicated (Note -> Maybe Pitch parse, Pitch -> Maybe Note unparse, Transposition -> Int -> Pitch -> Maybe Pitch transpose) <- Deriver (Note -> Maybe Pitch, Pitch -> Maybe Note, Transposition -> Int -> Pitch -> Maybe Pitch) Call.get_pitch_functions Pitch pitch <- forall a. (Note -> Maybe a) -> Transposed -> Deriver a Call.parse_pitch Note -> Maybe Pitch parse Transposed pitch Key key <- Deriver Key get_key Pitch neighbor <- forall a. HasCallStack => Text -> Maybe a -> Deriver a Derive.require Text "transpose" forall a b. (a -> b) -> a -> b $ Transposition -> Int -> Pitch -> Maybe Pitch transpose Transposition Scale.Chromatic Int 1 Pitch pitch Pitch neighbor <- forall a. HasCallStack => Text -> Maybe a -> Deriver a Derive.require Text "enharmonic" forall a b. (a -> b) -> a -> b $ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a List.find ((forall a. Eq a => a -> a -> Bool == Pitch -> Int Pitch.pitch_pc Pitch pitch forall a. Num a => a -> a -> a + Int 1) forall b c a. (b -> c) -> (a -> b) -> a -> c . Pitch -> Int Pitch.pitch_pc) forall a b. (a -> b) -> a -> b $ Layout -> Pitch -> [Pitch] Theory.enharmonics_of (Key -> Layout Theory.key_layout Key key) Pitch neighbor Note note <- forall a. HasCallStack => Text -> Maybe a -> Deriver a Derive.require Text "unparse" forall a b. (a -> b) -> a -> b $ Pitch -> Maybe Note unparse Pitch neighbor Scale scale <- Deriver Scale Call.get_scale forall a. Scale -> Note -> Deriver (RawPitch a) Eval.eval_note Scale scale Note note -- | Emit the magic events to trigger lilypond's tremolo processing. tremolo_trill_ly :: PSignal.Pitch -> PSignal.Pitch -> ScoreTime -> ScoreTime -> Derive.NoteDeriver tremolo_trill_ly :: Pitch -> Pitch -> ScoreTime -> ScoreTime -> Deriver (Stream Note) tremolo_trill_ly Pitch pitch1 Pitch pitch2 ScoreTime start ScoreTime dur = forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a Derive.place ScoreTime start ScoreTime dur forall a b. (a -> b) -> a -> b $ forall a. Monoid a => [a] -> a mconcat [ Code -> Deriver (Stream Note) -> Deriver (Stream Note) Ly.add_first (forall pos. Text -> Position pos Ly.SetEnviron Text Constants.v_tremolo, Text "") Deriver (Stream Note) Call.note , Pitch -> Deriver (Stream Note) Call.pitched_note Pitch pitch1 , Pitch -> Deriver (Stream Note) Call.pitched_note Pitch pitch2 ] c_tremolo_generator :: Maybe ([Attrs.Attributes], Attrs.Attributes) -> Derive.Generator Derive.Note c_tremolo_generator :: Maybe ([Attributes], Attributes) -> Generator Note c_tremolo_generator Maybe ([Attributes], Attributes) attrs_unless = forall d. Module -> CallName -> Tags -> Doc -> WithArgDoc (GeneratorF d) -> Generator d Derive.generator Module Module.prelude CallName "trem" Tags Tags.ly (Doc "Repeat a single note. Or, if there are sub-notes, alternate with each of\ \ the sub-notes in turn." forall a. Semigroup a => a -> a -> a <> case Maybe ([Attributes], Attributes) attrs_unless of Maybe ([Attributes], Attributes) Nothing -> Doc "" Just ([Attributes] unless, Attributes _) -> if Maybe ([Attributes], Attributes) attrs_unless forall a. Eq a => a -> a -> Bool == forall a. Maybe a Nothing then Doc "" else Doc "\nThis version just derives plain notes with the " forall a. Semigroup a => a -> a -> a <> forall a. ShowVal a => a -> Doc ShowVal.doc Attributes Attrs.trem forall a. Semigroup a => a -> a -> a <> Doc " attribute, unless any of these\ \ attributes are present: " forall a. Semigroup a => a -> a -> a <> forall a. ShowVal a => a -> Doc ShowVal.doc [Attributes] unless forall a. Semigroup a => a -> a -> a <> 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 ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Parser RealTimeFunctionT Speed.arg forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser Duration hold_env) forall a b. (a -> b) -> a -> b $ \(RealTimeFunctionT speed, Duration hold) PassedArgs Note args -> do [ScoreTime] starts <- Duration -> RealTimeFunctionT -> (ScoreTime, ScoreTime) -> Deriver [ScoreTime] tremolo_starts Duration hold RealTimeFunctionT speed (forall a. PassedArgs a -> (ScoreTime, ScoreTime) Args.range_or_next PassedArgs Note args) [[Event]] notes <- forall d. PassedArgs d -> Deriver [[Event]] Sub.sub_events PassedArgs Note args Attributes attrs <- Deriver Attributes Call.get_attributes let use_attrs :: Bool use_attrs = forall b a. b -> (a -> b) -> Maybe a -> b maybe Bool False (Bool -> Bool not forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool any (Attributes -> Attributes -> Bool Attrs.contain Attributes attrs)forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a, b) -> a fst) Maybe ([Attributes], Attributes) attrs_unless let trem_attrs :: Attributes trem_attrs = forall b a. b -> (a -> b) -> Maybe a -> b maybe forall a. Monoid a => a mempty forall a b. (a, b) -> b snd Maybe ([Attributes], Attributes) attrs_unless case forall a. (a -> Bool) -> [a] -> [a] filter (Bool -> Bool not forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: * -> *) a. Foldable t => t a -> Bool null) [[Event]] notes of [] -> forall d. PassedArgs d -> (PassedArgs d -> Deriver (Stream Note)) -> Deriver (Stream Note) Sub.inverting_args PassedArgs Note args forall a b. (a -> b) -> a -> b $ \PassedArgs Note args -> forall d. Code -> PassedArgs d -> Deriver (Stream Note) -> Deriver (Stream Note) Ly.note_code Code code PassedArgs Note args forall a b. (a -> b) -> a -> b $ if Bool use_attrs then forall d. Attributes -> Deriver d -> Deriver d Call.add_attributes Attributes Attrs.trem Deriver (Stream Note) Call.note else forall d. Attributes -> Deriver d -> Deriver d Call.add_attributes Attributes trem_attrs forall a b. (a -> b) -> a -> b $ [ScoreTime] -> [Deriver (Stream Note)] -> Deriver (Stream Note) simple_tremolo [ScoreTime] starts [Deriver (Stream Note) Call.note] [[Event]] notes -> forall d. Code -> PassedArgs d -> Deriver (Stream Note) -> Deriver (Stream Note) Ly.notes_code Code code PassedArgs Note args forall a b. (a -> b) -> a -> b $ if Bool use_attrs then forall d. Attributes -> Deriver d -> Deriver d Call.add_attributes Attributes Attrs.trem forall a b. (a -> b) -> a -> b $ [[Event]] -> Deriver (Stream Note) Sub.derive_tracks [[Event]] notes else forall d. Attributes -> Deriver d -> Deriver d Call.add_attributes Attributes trem_attrs forall a b. (a -> b) -> a -> b $ [Event] -> Deriver (Stream Note) Sub.derive forall a b. (a -> b) -> a -> b $ forall a. [ScoreTime] -> [[EventT a]] -> [EventT a] chord_tremolo [ScoreTime] starts [[Event]] notes where code :: Code code = (Distribution -> Position CodePosition Ly.append Distribution Constants.All, Text ":32") c_tremolo_transformer :: Derive.Transformer Derive.Note c_tremolo_transformer :: Transformer Note c_tremolo_transformer = forall d. Module -> CallName -> Tags -> Doc -> WithArgDoc (TransformerF d) -> Transformer d Derive.transformer Module Module.prelude CallName "trem" Tags Tags.subs Doc "Repeat the transformed note. The generator is creating the notes so it\ \ can set them to the appropriate duration, but this one has to stretch\ \ them to fit." 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 <$> Parser RealTimeFunctionT Speed.arg forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser Duration hold_env) forall a b. (a -> b) -> a -> b $ \(RealTimeFunctionT speed, Duration hold) PassedArgs Note args Deriver (Stream Note) deriver -> do [ScoreTime] starts <- Duration -> RealTimeFunctionT -> (ScoreTime, ScoreTime) -> Deriver [ScoreTime] tremolo_starts Duration hold RealTimeFunctionT speed (forall a. PassedArgs a -> (ScoreTime, ScoreTime) Args.range_or_next PassedArgs Note args) [ScoreTime] -> [Deriver (Stream Note)] -> Deriver (Stream Note) simple_tremolo [ScoreTime] starts [forall a b. PassedArgs a -> Deriver b -> Deriver b Args.normalized PassedArgs Note args Deriver (Stream Note) deriver] tremolo_starts :: DeriveT.Duration -> Typecheck.RealTimeFunctionT -> (ScoreTime, ScoreTime) -> Derive.Deriver [ScoreTime] -- ^ start time for each note, and one for the end of the last one tremolo_starts :: Duration -> RealTimeFunctionT -> (ScoreTime, ScoreTime) -> Deriver [ScoreTime] tremolo_starts Duration hold (Typecheck.RealTimeFunctionT TimeT ttype Function speed) (ScoreTime start, ScoreTime end) = do ScoreTime hold <- forall t1 t2. (Time t1, Time t2) => t1 -> t2 -> Deriver ScoreTime Call.score_duration ScoreTime start Duration hold (ScoreTime, ScoreTime) -> ScoreTime -> [ScoreTime] -> [ScoreTime] add_hold (ScoreTime start, ScoreTime end) ScoreTime hold forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> case TimeT ttype of TimeT ScoreT.TReal -> do RealTime start <- forall a. Time a => a -> Deriver RealTime Derive.real (ScoreTime start forall a. Num a => a -> a -> a + ScoreTime hold) RealTime end <- forall a. Time a => a -> Deriver RealTime Derive.real ScoreTime end forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM forall a. Time a => a -> Deriver ScoreTime Derive.score forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Ord a => a -> [a] -> [a] full_notes RealTime end forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< Function -> RealTime -> RealTime -> Deriver [RealTime] Speed.real_starts Function speed RealTime start RealTime end TimeT ScoreT.TScore -> do [ScoreTime] starts <- Function -> ScoreTime -> ScoreTime -> Deriver [ScoreTime] Speed.score_starts Function speed (ScoreTime start forall a. Num a => a -> a -> a + ScoreTime hold) ScoreTime end forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a. Ord a => a -> [a] -> [a] full_notes ScoreTime end [ScoreTime] starts -- | This is like 'tremolo_starts', but takes a start and end speed instead -- of a speed signal. In exchange, it can have start and end be different -- time types, which a signal can't express. Of course I could make the -- signal into duration and then do the reciprocal in the score as a val call, -- but that seems too complicated for tracklang. tremolo_starts_curve :: ControlUtil.CurveF -> DeriveT.Duration -> Speed.Speed -> Speed.Speed -> (ScoreTime, ScoreTime) -> Derive.Deriver [ScoreTime] -- ^ start time for each note, and one for the end of the last one tremolo_starts_curve :: CurveF -> Duration -> Speed -> Speed -> (ScoreTime, ScoreTime) -> Deriver [ScoreTime] tremolo_starts_curve CurveF curvef Duration hold Speed start_speed Speed end_speed (ScoreTime start, ScoreTime end) = do ScoreTime hold <- forall t1 t2. (Time t1, Time t2) => t1 -> t2 -> Deriver ScoreTime Call.score_duration ScoreTime start Duration hold (RealTime, RealTime) real_range <- (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall a. Time a => a -> Deriver RealTime Derive.real ScoreTime start forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> forall a. Time a => a -> Deriver RealTime Derive.real ScoreTime end ((ScoreTime, ScoreTime) -> ScoreTime -> [ScoreTime] -> [ScoreTime] add_hold (ScoreTime start, ScoreTime end) ScoreTime hold forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Ord a => a -> [a] -> [a] full_notes ScoreTime end <$>) forall a b. (a -> b) -> a -> b $ forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM forall a. Time a => a -> Deriver ScoreTime Derive.score forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< CurveF -> Speed -> Speed -> (RealTime, RealTime) -> Bool -> Deriver [RealTime] Speed.starts_curve CurveF curvef Speed start_speed Speed end_speed (RealTime, RealTime) real_range Bool include_end where include_end :: Bool include_end = Bool True -- because the end time is also included. -- | Add the hold time to the first tremolo note. add_hold :: (ScoreTime, ScoreTime) -> ScoreTime -> [ScoreTime] -> [ScoreTime] add_hold :: (ScoreTime, ScoreTime) -> ScoreTime -> [ScoreTime] -> [ScoreTime] add_hold (ScoreTime start, ScoreTime end) ScoreTime hold [ScoreTime] starts | ScoreTime hold forall a. Ord a => a -> a -> Bool >= ScoreTime end forall a. Num a => a -> a -> a - ScoreTime start = [ScoreTime start, ScoreTime end] | ScoreTime hold forall a. Ord a => a -> a -> Bool > ScoreTime 0 = ScoreTime start forall a. a -> [a] -> [a] : [ScoreTime] starts | Bool otherwise = [ScoreTime] starts -- | Alternate each note with the other notes within its range, in order from -- the lowest track to the highest. -- -- This doesn't restart the tremolo when a new note enters, if you want that -- you can have multiple tremolo events. chord_tremolo :: forall a. [ScoreTime] -> [[SubT.EventT a]] -> [SubT.EventT a] chord_tremolo :: forall a. [ScoreTime] -> [[EventT a]] -> [EventT a] chord_tremolo [ScoreTime] starts [[EventT a]] note_tracks = forall a. [Maybe a] -> [a] Maybe.catMaybes forall a b. (a -> b) -> a -> b $ forall a b. (a, b) -> b snd forall a b. (a -> b) -> a -> b $ forall (t :: * -> *) s a b. Traversable t => (s -> a -> (s, b)) -> s -> t a -> (s, t b) List.mapAccumL forall {a} {a}. Ord a => (a, [(a, EventT a)]) -> (ScoreTime, ScoreTime) -> ((a, [(a, EventT a)]), Maybe (EventT a)) emit (-Int 1, [(Int, EventT a)] by_track) forall a b. (a -> b) -> a -> b $ forall a b. [a] -> [b] -> [(a, b)] zip [ScoreTime] starts (forall a. Int -> [a] -> [a] drop Int 1 [ScoreTime] starts) where emit :: (a, [(a, EventT a)]) -> (ScoreTime, ScoreTime) -> ((a, [(a, EventT a)]), Maybe (EventT a)) emit (a last_tracknum, [(a, EventT a)] notes_) (ScoreTime pos, ScoreTime next_pos) = case Maybe (a, EventT a) chosen of Maybe (a, EventT a) Nothing -> ((a last_tracknum, [(a, EventT a)] notes), forall a. Maybe a Nothing) Just (a tracknum, EventT a note) -> ((a tracknum, [(a, EventT a)] notes), forall a. a -> Maybe a Just forall a b. (a -> b) -> a -> b $ forall a. ScoreTime -> ScoreTime -> a -> EventT a SubT.EventT ScoreTime pos (ScoreTime next_posforall a. Num a => a -> a -> a -ScoreTime pos) (forall a. EventT a -> a SubT._note EventT a note)) where chosen :: Maybe (a, EventT a) chosen = forall k a. Ord k => (a -> k) -> [a] -> Maybe a Lists.minimumOn forall a b. (a, b) -> a fst (forall a. (a -> Bool) -> [a] -> [a] filter ((forall a. Ord a => a -> a -> Bool >a last_tracknum) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a, b) -> a fst) [(a, EventT a)] overlapping) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a <|> forall k a. Ord k => (a -> k) -> [a] -> Maybe a Lists.minimumOn forall a b. (a, b) -> a fst [(a, EventT a)] overlapping overlapping :: [(a, EventT a)] overlapping = forall a. (a -> Bool) -> [a] -> [a] filter (forall a. ScoreTime -> EventT a -> Bool SubT.overlaps ScoreTime pos forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a, b) -> b snd) [(a, EventT a)] notes notes :: [(a, EventT a)] notes = forall a. (a -> Bool) -> [a] -> [a] dropWhile ((forall a. Ord a => a -> a -> Bool <=ScoreTime pos) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. EventT a -> ScoreTime SubT.end forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a, b) -> b snd) [(a, EventT a)] notes_ by_track :: [(TrackNum, SubT.EventT a)] by_track :: [(Int, EventT a)] by_track = forall k a. Ord k => (a -> k) -> [a] -> [a] Lists.sortOn (forall a. EventT a -> ScoreTime SubT.end forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a, b) -> b snd) [ (Int tracknum, EventT a event) | (Int tracknum, [EventT a] track) <- forall a b. [a] -> [b] -> [(a, b)] zip [Int 0..] [[EventT a]] note_tracks, EventT a event <- [EventT a] track ] -- | Just cycle the given notes. simple_tremolo :: [ScoreTime] -> [Derive.NoteDeriver] -> Derive.NoteDeriver simple_tremolo :: [ScoreTime] -> [Deriver (Stream Note)] -> Deriver (Stream Note) simple_tremolo [ScoreTime] starts [Deriver (Stream Note)] notes = [Event] -> Deriver (Stream Note) Sub.derive [ forall a. ScoreTime -> ScoreTime -> a -> EventT a SubT.EventT ScoreTime start (ScoreTime end forall a. Num a => a -> a -> a - ScoreTime start) Deriver (Stream Note) note | (ScoreTime start, ScoreTime end, Deriver (Stream Note) note) <- forall a b c. [a] -> [b] -> [c] -> [(a, b, c)] zip3 [ScoreTime] starts (forall a. Int -> [a] -> [a] drop Int 1 [ScoreTime] starts) forall a b. (a -> b) -> a -> b $ if forall (t :: * -> *) a. Foldable t => t a -> Bool null [Deriver (Stream Note)] notes then [] else forall a. [a] -> [a] cycle [Deriver (Stream Note)] notes ] -- | Given start times, return only ones whose full duration fits before the -- end time. This is the tremolo analog to 'full_cycles'. Unlike a trill, it -- emits both the starts and ends, and therefore the last sample will be at the -- end time, rather than before it. It should always emit an even number of -- elements. full_notes :: Ord a => a -> [a] -> [a] full_notes :: forall a. Ord a => a -> [a] -> [a] full_notes a end [a t] | a t forall a. Ord a => a -> a -> Bool < a end = [a t, a end] | Bool otherwise = [] full_notes a end [a] ts = [a] -> [a] go [a] ts where go :: [a] -> [a] go [] = [] go (a t1:[a] ts) = case [a] ts of a t2 : [a] _ | a t2 forall a. Ord a => a -> a -> Bool > a end -> [a end] | Bool otherwise -> a t1 forall a. a -> [a] -> [a] : [a] -> [a] go [a] ts [] -> [a end] -- This is surprisingly tricky. -- * pitch calls c_pitch_trill :: Maybe Direction -> Maybe Direction -> Derive.Generator Derive.Pitch c_pitch_trill :: Maybe Direction -> Maybe Direction -> Generator PSignal c_pitch_trill Maybe Direction hardcoded_start Maybe Direction hardcoded_end = forall d. Module -> CallName -> Tags -> Doc -> WithArgDoc (PassedArgs d -> Deriver d) -> Generator d Derive.generator1 Module Module.prelude CallName "tr" forall a. Monoid a => a mempty (Doc "Generate a pitch signal of alternating pitches." forall a. Semigroup a => a -> a -> a <> forall a. Maybe a -> Maybe a -> Doc direction_doc Maybe Direction hardcoded_start Maybe Direction hardcoded_end ) 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. Typecheck a => ArgName -> Doc -> Parser a Sig.required ArgName "note" Doc "Base pitch." forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser Neighbor neighbor_arg forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Maybe Direction -> Maybe Direction -> Parser Config config_arg Maybe Direction hardcoded_start Maybe Direction hardcoded_end forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser Curve ControlUtil.curve_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser Function transition_env ) forall a b. (a -> b) -> a -> b $ \(Pitch note, Neighbor neighbor, Config config, Curve curve, Function transition) PassedArgs PSignal args -> do (Function neighbor, Control control) <- ScoreTime -> Neighbor -> Deriver (Function, Control) neighbor_to_function (forall a. PassedArgs a -> ScoreTime Args.start PassedArgs PSignal args) Neighbor neighbor [(RealTime, Double)] transpose <- Config -> (ScoreTime, ScoreTime) -> Function -> Deriver [(RealTime, Double)] get_trill_control Config config (forall a. PassedArgs a -> (ScoreTime, ScoreTime) Args.range_or_next PassedArgs PSignal args) Function neighbor Control transpose <- Function -> Curve -> [(RealTime, Double)] -> Deriver Control smooth_trill Function transition Curve curve [(RealTime, Double)] transpose RealTime start <- forall a. PassedArgs a -> Deriver RealTime Args.real_start PassedArgs PSignal args forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ Control -> Typed Control -> PSignal -> PSignal PSignal.apply_control Control control (forall a. a -> Typed a ScoreT.untyped Control transpose) forall a b. (a -> b) -> a -> b $ RealTime -> Pitch -> PSignal PSignal.from_sample RealTime start Pitch note c_pitch_trill_smooth :: Maybe Direction -> Maybe Direction -> Derive.Generator Derive.Pitch c_pitch_trill_smooth :: Maybe Direction -> Maybe Direction -> Generator PSignal c_pitch_trill_smooth Maybe Direction hardcoded_start Maybe Direction hardcoded_end = forall d. Module -> CallName -> Tags -> Doc -> WithArgDoc (PassedArgs d -> Deriver d) -> Generator d Derive.generator1 Module Module.prelude CallName "trs" forall a. Monoid a => a mempty (Doc "Generate a pitch signal of alternating pitches. Like `tr`, but with\ \ defaults for smooth transitions." forall a. Semigroup a => a -> a -> a <> forall a. Maybe a -> Maybe a -> Doc direction_doc Maybe Direction hardcoded_start Maybe Direction hardcoded_end ) 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. Typecheck a => ArgName -> Doc -> Parser a Sig.required ArgName "note" Doc "Base pitch." forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser Neighbor neighbor_arg forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Maybe Direction -> Maybe Direction -> Parser Config config_arg Maybe Direction hardcoded_start Maybe Direction hardcoded_end ) forall a b. (a -> b) -> a -> b $ \(Pitch note, Neighbor neighbor, Config config) PassedArgs PSignal args -> do (Function neighbor, Control control) <- ScoreTime -> Neighbor -> Deriver (Function, Control) neighbor_to_function (forall a. PassedArgs a -> ScoreTime Args.start PassedArgs PSignal args) Neighbor neighbor Control transpose <- Config -> Curve -> (ScoreTime, ScoreTime) -> Function -> Deriver Control get_trill_control_smooth Config config Curve curve (forall a. PassedArgs a -> (ScoreTime, ScoreTime) Args.range_or_next PassedArgs PSignal args) Function neighbor RealTime start <- forall a. PassedArgs a -> Deriver RealTime Args.real_start PassedArgs PSignal args forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ Control -> Typed Control -> PSignal -> PSignal PSignal.apply_control Control control (forall a. a -> Typed a ScoreT.untyped Control transpose) forall a b. (a -> b) -> a -> b $ RealTime -> Pitch -> PSignal PSignal.from_sample RealTime start Pitch note where curve :: Curve curve = CurveF -> Curve ControlUtil.Function forall a b. (a -> b) -> a -> b $ Double -> Double -> CurveF ControlUtil.sigmoid Double 0.5 Double 0.5 c_xcut_pitch :: Bool -> Derive.Generator Derive.Pitch c_xcut_pitch :: Bool -> Generator PSignal c_xcut_pitch Bool hold = forall d. Module -> CallName -> Tags -> Doc -> WithArgDoc (PassedArgs d -> Deriver d) -> Generator d Derive.generator1 Module Module.prelude CallName "xcut" forall a. Monoid a => a mempty Doc "Cross-cut between two pitches. The `-h` variant holds the value at the\ \ beginning of each transition." 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. Typecheck a => ArgName -> Doc -> Parser a Sig.required ArgName "fst" Doc "First pitch." forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> forall a. Typecheck a => ArgName -> Doc -> Parser a Sig.required ArgName "snd" Doc "Second 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 Sig.defaulted ArgName "speed" (Int 14 :: Int) Doc "Speed." ) forall a b. (a -> b) -> a -> b $ \(PSignal xcut1, PSignal xcut2, RealTimeFunctionT speed) PassedArgs PSignal args -> do [RealTime] transitions <- forall t. Time t => RealTimeFunctionT -> (t, t) -> Bool -> Deriver [RealTime] Speed.starts RealTimeFunctionT speed (forall a. PassedArgs a -> (ScoreTime, ScoreTime) Args.range_or_next PassedArgs PSignal args) Bool False forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ Bool -> PSignal -> PSignal -> [RealTime] -> PSignal xcut_pitch Bool hold PSignal xcut1 PSignal xcut2 [RealTime] transitions xcut_pitch :: Bool -> PSignal.PSignal -> PSignal.PSignal -> [RealTime] -> PSignal.PSignal xcut_pitch :: Bool -> PSignal -> PSignal -> [RealTime] -> PSignal xcut_pitch Bool hold PSignal val1 PSignal val2 = forall a. Monoid a => [a] -> a mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map (PSignal, RealTime) -> PSignal slice forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. [a] -> [b] -> [(a, b)] zip (forall a. [a] -> [a] cycle [PSignal val1, PSignal val2]) where slice :: (PSignal, RealTime) -> PSignal slice (PSignal val, RealTime t) | Bool hold = forall b a. b -> (a -> b) -> Maybe a -> b maybe forall a. Monoid a => a mempty (RealTime -> Pitch -> PSignal PSignal.from_sample RealTime t) (PSignal -> RealTime -> Maybe Pitch PSignal.at PSignal val RealTime t) | Bool otherwise = RealTime -> PSignal -> PSignal PSignal.clip_before RealTime t PSignal val -- * control calls c_control_trill :: Maybe Direction -> Maybe Direction -> Derive.Generator Derive.Control c_control_trill :: Maybe Direction -> Maybe Direction -> Generator Control c_control_trill Maybe Direction hardcoded_start Maybe Direction hardcoded_end = forall d. Module -> CallName -> Tags -> Doc -> WithArgDoc (PassedArgs d -> Deriver d) -> Generator d Derive.generator1 Module Module.prelude CallName "tr" forall a. Monoid a => a mempty (Doc "The control version of the pitch trill. It generates a signal of values\ \ alternating with 0, which can be used as a transposition signal." forall a. Semigroup a => a -> a -> a <> forall a. Maybe a -> Maybe a -> Doc direction_doc Maybe Direction hardcoded_start Maybe Direction hardcoded_end ) 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 Sig.defaulted ArgName "neighbor" (Int 1 :: Int) Doc "Alternate with this value." forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Maybe Direction -> Maybe Direction -> Parser Config config_arg Maybe Direction hardcoded_start Maybe Direction hardcoded_end forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser Function transition_env ) forall a b. (a -> b) -> a -> b $ \(Function neighbor, Config config, Function transition) PassedArgs Control args -> do [(RealTime, Double)] transpose <- Config -> (ScoreTime, ScoreTime) -> Function -> Deriver [(RealTime, Double)] get_trill_control Config config (forall a. PassedArgs a -> (ScoreTime, ScoreTime) Args.range_or_next PassedArgs Control args) Function neighbor Function -> Curve -> [(RealTime, Double)] -> Deriver Control smooth_trill Function transition Curve ControlUtil.Linear [(RealTime, Double)] transpose c_control_trill_smooth :: Maybe Direction -> Maybe Direction -> Derive.Generator Derive.Control c_control_trill_smooth :: Maybe Direction -> Maybe Direction -> Generator Control c_control_trill_smooth Maybe Direction hardcoded_start Maybe Direction hardcoded_end = forall d. Module -> CallName -> Tags -> Doc -> WithArgDoc (PassedArgs d -> Deriver d) -> Generator d Derive.generator1 Module Module.prelude CallName "tr" forall a. Monoid a => a mempty (Doc "The control version of the pitch trill. It generates a signal of values\ \ alternating with 0, which can be used as a transposition signal." forall a. Semigroup a => a -> a -> a <> forall a. Maybe a -> Maybe a -> Doc direction_doc Maybe Direction hardcoded_start Maybe Direction hardcoded_end ) 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 Sig.defaulted ArgName "neighbor" (Int 1 :: Int) Doc "Alternate with this value." forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Maybe Direction -> Maybe Direction -> Parser Config config_arg Maybe Direction hardcoded_start Maybe Direction hardcoded_end ) forall a b. (a -> b) -> a -> b $ \(Function neighbor, Config config) PassedArgs Control args -> do Control transpose <- Config -> Curve -> (ScoreTime, ScoreTime) -> Function -> Deriver Control get_trill_control_smooth Config config Curve curve (forall a. PassedArgs a -> (ScoreTime, ScoreTime) Args.range_or_next PassedArgs Control args) Function neighbor forall (m :: * -> *) a. Monad m => a -> m a return Control transpose where curve :: Curve curve = CurveF -> Curve ControlUtil.Function forall a b. (a -> b) -> a -> b $ Double -> Double -> CurveF ControlUtil.sigmoid Double 0.5 Double 0.5 c_saw :: Derive.Generator Derive.Control c_saw :: Generator Control c_saw = forall d. Module -> CallName -> Tags -> Doc -> WithArgDoc (PassedArgs d -> Deriver d) -> Generator d Derive.generator1 Module Module.prelude CallName "saw" forall a. Monoid a => a mempty Doc "Emit a sawtooth. By default it has a downward slope, but you can make\ \ an upward slope by setting `from` and `to`." 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 RealTimeFunctionT Speed.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 "from" (Double 1 :: Double) Doc "Start from this value." 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 "to" (Double 0 :: Double) Doc "End at this value." ) forall a b. (a -> b) -> a -> b $ \(RealTimeFunctionT speed, Double from, Double to) PassedArgs Control args -> do [RealTime] starts <- forall t. Time t => RealTimeFunctionT -> (t, t) -> Bool -> Deriver [RealTime] Speed.starts RealTimeFunctionT speed (forall a. PassedArgs a -> (ScoreTime, ScoreTime) Args.range_or_next PassedArgs Control args) Bool True RealTime srate <- Deriver RealTime Call.get_srate forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ RealTime -> [RealTime] -> Double -> Double -> Control saw RealTime srate [RealTime] starts Double from Double to saw :: RealTime -> [RealTime] -> Double -> Double -> Signal.Control saw :: RealTime -> [RealTime] -> Double -> Double -> Control saw RealTime srate [RealTime] starts Double from Double to = forall a. Monoid a => [a] -> a mconcat forall a b. (a -> b) -> a -> b $ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c] zipWith RealTime -> RealTime -> Control saw [RealTime] starts (forall a. Int -> [a] -> [a] drop Int 1 [RealTime] starts) where saw :: RealTime -> RealTime -> Control saw RealTime t1 RealTime t2 = RealTime -> Curve -> RealTime -> Double -> RealTime -> Double -> Control ControlUtil.segment RealTime srate Curve ControlUtil.Linear RealTime t1 Double from RealTime t2 Double to -- ** sine data SineMode = Bipolar | Negative | Positive deriving (Int -> SineMode -> ShowS [SineMode] -> ShowS SineMode -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [SineMode] -> ShowS $cshowList :: [SineMode] -> ShowS show :: SineMode -> String $cshow :: SineMode -> String showsPrec :: Int -> SineMode -> ShowS $cshowsPrec :: Int -> SineMode -> ShowS Show) -- | This is probably not terribly convenient to use on its own, I should -- have some more specialized calls based on this. c_sine :: SineMode -> Derive.Generator Derive.Control c_sine :: SineMode -> Generator Control c_sine SineMode mode = forall d. Module -> CallName -> Tags -> Doc -> WithArgDoc (PassedArgs d -> Deriver d) -> Generator d Derive.generator1 Module Module.prelude CallName "sine" forall a. Monoid a => a mempty Doc "Emit a sine wave. The default version is centered on the `offset`,\ \ and the `+` and `-` variants are above and below it, respectively." 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 Sig.defaulted ArgName "speed" (RealTime 1 :: RealTime) Doc "Frequency." 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 "amp" (Double 1 :: Double) Doc "Amplitude, measured center to peak." 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 "offset" (Double 0 :: Double) Doc "Center point." ) forall a b. (a -> b) -> a -> b $ \(Typecheck.RealTimeFunctionT TimeT time_type Function speed, Double amp, Double offset) PassedArgs Control args -> do case TimeT time_type of TimeT ScoreT.TScore -> forall a. HasCallStack => Text -> Deriver a Derive.throw Text "RealTime signal required" TimeT _ -> forall (m :: * -> *) a. Monad m => a -> m a return () RealTime srate <- Deriver RealTime Call.get_srate let sign :: Double sign = case SineMode mode of SineMode Bipolar -> Double 0 SineMode Negative -> -Double amp SineMode Positive -> Double amp (RealTime start, RealTime end) <- forall a. PassedArgs a -> Deriver State Error (RealTime, RealTime) Args.real_range_or_next PassedArgs Control args forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall {k} (kind :: k). CurveF -> Signal kind -> Signal kind Signal.map_y_linear ((forall a. Num a => a -> a -> a +(Double offsetforall a. Num a => a -> a -> a +Double sign)) forall b c a. (b -> c) -> (a -> b) -> a -> c . (forall a. Num a => a -> a -> a *Double amp)) forall a b. (a -> b) -> a -> b $ RealTime -> RealTime -> RealTime -> Function -> Control sine RealTime srate RealTime start RealTime end Function speed sine :: RealTime -> RealTime -> RealTime -> ScoreT.Function -> Signal.Control sine :: RealTime -> RealTime -> RealTime -> Function -> Control sine RealTime srate RealTime start RealTime end Function freq_sig = forall {k} state (kind :: k). (state -> Maybe ((RealTime, Double), state)) -> state -> Signal kind Signal.unfoldr (RealTime, Double) -> Maybe ((RealTime, Double), (RealTime, Double)) go (RealTime start, Double 0) where go :: (RealTime, Double) -> Maybe ((RealTime, Double), (RealTime, Double)) go (RealTime pos, Double phase) | RealTime pos forall a. Ord a => a -> a -> Bool >= RealTime end = forall a. Maybe a Nothing | Bool otherwise = forall a. a -> Maybe a Just ((RealTime pos, forall a. Floating a => a -> a sin Double phase), (RealTime pos forall a. Num a => a -> a -> a + RealTime 1forall a. Fractional a => a -> a -> a /RealTime srate, Double next_phase)) where next_phase :: Double next_phase = Double phase forall a. Num a => a -> a -> a + Double 1 forall a. Fractional a => a -> a -> a / Function RealTime.to_seconds RealTime srate forall a. Num a => a -> a -> a * Double 2forall a. Num a => a -> a -> a *forall a. Floating a => a pi forall a. Num a => a -> a -> a * Function freq_sig RealTime pos -- ** xcut c_xcut_control :: Bool -> Derive.Generator Derive.Control c_xcut_control :: Bool -> Generator Control c_xcut_control Bool hold = forall d. Module -> CallName -> Tags -> Doc -> WithArgDoc (PassedArgs d -> Deriver d) -> Generator d Derive.generator1 Module Module.prelude CallName "xcut" forall a. Monoid a => a mempty Doc "Cross-cut between two signals. The `-h` variant holds the value at the\ \ beginning of each transition." 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 Sig.defaulted ArgName "fst" (Int 1 :: Int) Doc "First value." 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 "snd" (Int 0 :: Int) Doc "Second value." 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 "speed" (Int 14 :: Int) Doc "Speed." ) forall a b. (a -> b) -> a -> b $ \(Control xcut1, Control xcut2, RealTimeFunctionT speed) PassedArgs Control args -> do [RealTime] transitions <- forall t. Time t => RealTimeFunctionT -> (t, t) -> Bool -> Deriver [RealTime] Speed.starts RealTimeFunctionT speed (forall a. PassedArgs a -> (ScoreTime, ScoreTime) Args.range_or_next PassedArgs Control args) Bool False forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ Bool -> Control -> Control -> [RealTime] -> Control xcut_control Bool hold Control xcut1 Control xcut2 [RealTime] transitions -- TODO(polymorphic-signals) This is the same as 'xcut_pitch' xcut_control :: Bool -> Signal.Control -> Signal.Control -> [RealTime] -> Signal.Control xcut_control :: Bool -> Control -> Control -> [RealTime] -> Control xcut_control Bool hold Control val1 Control val2 = forall a. Monoid a => [a] -> a mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map forall {k} {kind :: k}. (Signal kind, RealTime) -> Signal kind slice forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. [a] -> [b] -> [(a, b)] zip (forall a. [a] -> [a] cycle [Control val1, Control val2]) where slice :: (Signal kind, RealTime) -> Signal kind slice (Signal kind val, RealTime t) | Bool hold = forall {k} (kind :: k). RealTime -> Double -> Signal kind Signal.from_sample RealTime t (forall {k} (kind :: k). Signal kind -> Function Signal.at Signal kind val RealTime t) | Bool otherwise = forall {k} (kind :: k). RealTime -> Signal kind -> Signal kind Signal.clip_before RealTime t Signal kind val -- * util trill_speed_arg :: Sig.Parser Typecheck.RealTimeFunctionT trill_speed_arg :: Parser RealTimeFunctionT trill_speed_arg = forall a deflt. (Typecheck a, ToVal deflt) => ArgName -> deflt -> Doc -> Parser a Sig.defaulted ArgName "speed" (Int 14 :: Int) Doc "Trill at this speed. If it's a RealTime, the value is the number of\ \ cycles per second, which will be unaffected by the tempo. If it's\ \ a ScoreTime, the value is the number of cycles per ScoreTime\ \ unit, and will stretch along with tempo changes. In either case,\ \ this will emit only whole notes, i.e. it will end sooner to avoid\ \ emitting a cut-off note at the end." -- | Whether the trill starts or ends on the high or low note. This is another -- way to express 'AbsoluteMode'. -- -- I had a lot of debate about whether I should use High and Low, or Unison and -- Neighbor. Unison-Neighbor is more convenient for the implementation but -- High-Low I think is more musically intuitive. data Direction = High | Low deriving (Direction forall a. a -> a -> Bounded a maxBound :: Direction $cmaxBound :: Direction minBound :: Direction $cminBound :: Direction Bounded, Direction -> Direction -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Direction -> Direction -> Bool $c/= :: Direction -> Direction -> Bool == :: Direction -> Direction -> Bool $c== :: Direction -> Direction -> Bool Eq, Int -> Direction Direction -> Int Direction -> [Direction] Direction -> Direction Direction -> Direction -> [Direction] Direction -> Direction -> Direction -> [Direction] forall a. (a -> a) -> (a -> a) -> (Int -> a) -> (a -> Int) -> (a -> [a]) -> (a -> a -> [a]) -> (a -> a -> [a]) -> (a -> a -> a -> [a]) -> Enum a enumFromThenTo :: Direction -> Direction -> Direction -> [Direction] $cenumFromThenTo :: Direction -> Direction -> Direction -> [Direction] enumFromTo :: Direction -> Direction -> [Direction] $cenumFromTo :: Direction -> Direction -> [Direction] enumFromThen :: Direction -> Direction -> [Direction] $cenumFromThen :: Direction -> Direction -> [Direction] enumFrom :: Direction -> [Direction] $cenumFrom :: Direction -> [Direction] fromEnum :: Direction -> Int $cfromEnum :: Direction -> Int toEnum :: Int -> Direction $ctoEnum :: Int -> Direction pred :: Direction -> Direction $cpred :: Direction -> Direction succ :: Direction -> Direction $csucc :: Direction -> Direction Enum, Int -> Direction -> ShowS [Direction] -> ShowS Direction -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Direction] -> ShowS $cshowList :: [Direction] -> ShowS show :: Direction -> String $cshow :: Direction -> String showsPrec :: Int -> Direction -> ShowS $cshowsPrec :: Int -> Direction -> ShowS Show) instance ShowVal.ShowVal Direction instance Typecheck.Typecheck Direction instance Typecheck.ToVal Direction -- | This is the like 'Direction', but in terms of the unison and neighbor -- pitches, instead of high and low. data AbsoluteMode = Unison | Neighbor deriving (AbsoluteMode forall a. a -> a -> Bounded a maxBound :: AbsoluteMode $cmaxBound :: AbsoluteMode minBound :: AbsoluteMode $cminBound :: AbsoluteMode Bounded, AbsoluteMode -> AbsoluteMode -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: AbsoluteMode -> AbsoluteMode -> Bool $c/= :: AbsoluteMode -> AbsoluteMode -> Bool == :: AbsoluteMode -> AbsoluteMode -> Bool $c== :: AbsoluteMode -> AbsoluteMode -> Bool Eq, Int -> AbsoluteMode AbsoluteMode -> Int AbsoluteMode -> [AbsoluteMode] AbsoluteMode -> AbsoluteMode AbsoluteMode -> AbsoluteMode -> [AbsoluteMode] AbsoluteMode -> AbsoluteMode -> AbsoluteMode -> [AbsoluteMode] forall a. (a -> a) -> (a -> a) -> (Int -> a) -> (a -> Int) -> (a -> [a]) -> (a -> a -> [a]) -> (a -> a -> [a]) -> (a -> a -> a -> [a]) -> Enum a enumFromThenTo :: AbsoluteMode -> AbsoluteMode -> AbsoluteMode -> [AbsoluteMode] $cenumFromThenTo :: AbsoluteMode -> AbsoluteMode -> AbsoluteMode -> [AbsoluteMode] enumFromTo :: AbsoluteMode -> AbsoluteMode -> [AbsoluteMode] $cenumFromTo :: AbsoluteMode -> AbsoluteMode -> [AbsoluteMode] enumFromThen :: AbsoluteMode -> AbsoluteMode -> [AbsoluteMode] $cenumFromThen :: AbsoluteMode -> AbsoluteMode -> [AbsoluteMode] enumFrom :: AbsoluteMode -> [AbsoluteMode] $cenumFrom :: AbsoluteMode -> [AbsoluteMode] fromEnum :: AbsoluteMode -> Int $cfromEnum :: AbsoluteMode -> Int toEnum :: Int -> AbsoluteMode $ctoEnum :: Int -> AbsoluteMode pred :: AbsoluteMode -> AbsoluteMode $cpred :: AbsoluteMode -> AbsoluteMode succ :: AbsoluteMode -> AbsoluteMode $csucc :: AbsoluteMode -> AbsoluteMode Enum, Int -> AbsoluteMode -> ShowS [AbsoluteMode] -> ShowS AbsoluteMode -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [AbsoluteMode] -> ShowS $cshowList :: [AbsoluteMode] -> ShowS show :: AbsoluteMode -> String $cshow :: AbsoluteMode -> String showsPrec :: Int -> AbsoluteMode -> ShowS $cshowsPrec :: Int -> AbsoluteMode -> ShowS Show) transition_env :: Sig.Parser ScoreT.Function transition_env :: Parser Function transition_env = forall a deflt. (Typecheck a, ToVal deflt) => ArgName -> EnvironDefault -> deflt -> Doc -> Parser a Sig.environ ArgName "tr-transition" EnvironDefault Sig.Unprefixed (Int 0 :: Int) Doc "Take this long to reach the neighbor, as a proportion of time available." -- | A bundle of standard configuration for trills. config_arg :: Maybe Direction -> Maybe Direction -> Sig.Parser Config config_arg :: Maybe Direction -> Maybe Direction -> Parser Config config_arg Maybe Direction start_dir Maybe Direction end_dir = RealTimeFunctionT -> Maybe Direction -> Maybe Direction -> Duration -> Adjust -> Double -> Bool -> Config Config forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Parser RealTimeFunctionT trill_speed_arg forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser (Maybe Direction) start forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser (Maybe Direction) end forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser Duration hold_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser Adjust adjust_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser Double bias forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> forall (f :: * -> *) a. Applicative f => a -> f a pure Bool False where start :: Parser (Maybe Direction) start = case Maybe Direction start_dir of Maybe Direction Nothing -> forall a deflt. (Typecheck a, ToVal deflt) => ArgName -> EnvironDefault -> deflt -> Doc -> Parser a Sig.environ ArgName "tr-start" EnvironDefault Sig.Unprefixed (forall a. Maybe a Nothing :: Maybe Direction) Doc "Which note the trill starts with. If not given, it will start\ \ the unison note, which means it may move up or down." Just Direction dir -> forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ forall a. a -> Maybe a Just Direction dir end :: Parser (Maybe Direction) end = case Maybe Direction end_dir of Maybe Direction Nothing -> forall a deflt. (Typecheck a, ToVal deflt) => ArgName -> EnvironDefault -> deflt -> Doc -> Parser a Sig.environ ArgName "tr-end" EnvironDefault Sig.Unprefixed (forall a. Maybe a Nothing :: Maybe Direction) Doc "Which note the trill ends with. If not given, it can end with\ \ either." Just Direction dir -> forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ forall a. a -> Maybe a Just Direction dir bias :: Parser Double bias = NormalizedBipolar -> Double Typecheck.normalized_bipolar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall a deflt. (Typecheck a, ToVal deflt) => ArgName -> EnvironDefault -> deflt -> Doc -> Parser a Sig.environ ArgName "tr-bias" EnvironDefault Sig.Unprefixed (Double -> NormalizedBipolar Typecheck.NormalizedBipolar Double 0) Doc "Offset every other transition by this amount." data Config = Config { -- | transition speed Config -> RealTimeFunctionT _speed :: !Typecheck.RealTimeFunctionT , Config -> Maybe Direction _start_dir :: !(Maybe Direction) , Config -> Maybe Direction _end_dir :: !(Maybe Direction) -- | extend the first transition by this amount , Config -> Duration _hold :: !DeriveT.Duration -- | how to fit the transitions into the time range , Config -> Adjust _adjust :: !Adjust -- | offset every other transition by this amount, from -1--1 , Config -> Double _bias :: !Double -- | include a transition at the end time , Config -> Bool _include_end :: !Bool } -- Its default is both prefixed and unprefixed so you can put in a tr-hold -- globally, and so you can have a short @hold=n |@ for a single call. hold_env :: Sig.Parser DeriveT.Duration hold_env :: Parser Duration hold_env = DefaultReal -> Duration Typecheck._real forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall a deflt. (Typecheck a, ToVal deflt) => ArgName -> EnvironDefault -> deflt -> Doc -> Parser a Sig.environ (Text -> ArgName Derive.ArgName Text EnvKey.hold) EnvironDefault Sig.Both (RealTime -> DefaultReal Typecheck.real RealTime 0) Doc "Time to hold the first note." trill_variations :: Text -> [(Expr.Symbol, Maybe Direction, Maybe Direction)] trill_variations :: Text -> [(Symbol, Maybe Direction, Maybe Direction)] trill_variations Text prefix = [ (Text -> Symbol Expr.Symbol forall a b. (a -> b) -> a -> b $ Text prefix forall a. Semigroup a => a -> a -> a <> (if Maybe Direction start forall a. Eq a => a -> a -> Bool == forall a. Maybe a Nothing Bool -> Bool -> Bool && Maybe Direction end forall a. Eq a => a -> a -> Bool /= forall a. Maybe a Nothing then Text "-" else Maybe Direction -> Text direction_affix Maybe Direction start) forall a. Semigroup a => a -> a -> a <> Maybe Direction -> Text direction_affix Maybe Direction end, Maybe Direction start, Maybe Direction end) | Maybe Direction start <- [Maybe Direction] dirs, Maybe Direction end <- [Maybe Direction] dirs ] where dirs :: [Maybe Direction] dirs = [forall a. Maybe a Nothing, forall a. a -> Maybe a Just Direction High, forall a. a -> Maybe a Just Direction Low] direction_affix :: Maybe Direction -> Text direction_affix :: Maybe Direction -> Text direction_affix Maybe Direction Nothing = Text "" direction_affix (Just Direction High) = Text "^" direction_affix (Just Direction Low) = Text "_" direction_doc :: Maybe a -> Maybe a -> Doc.Doc direction_doc :: forall a. Maybe a -> Maybe a -> Doc direction_doc Maybe a Nothing Maybe a Nothing = Doc "" direction_doc Maybe a _ Maybe a _ = Doc "\nA `^` suffix makes the trill starts on the higher value,\ \ while `_` makes it start on the lower value. A second suffix causes it\ \ to end on the higher or lower value, e.g. `^_` starts high and ends low.\ \ `-_` has start unspecified, and ends low.\ \ No suffix causes it to obey the settings in scope." -- | How to adjust an ornament to fulfill its 'Direction' restrictions. data Adjust = -- | Adjust by shortening the ornament. Shorten -- | Adjust by increasing the speed. | Stretch deriving (Adjust forall a. a -> a -> Bounded a maxBound :: Adjust $cmaxBound :: Adjust minBound :: Adjust $cminBound :: Adjust Bounded, Adjust -> Adjust -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Adjust -> Adjust -> Bool $c/= :: Adjust -> Adjust -> Bool == :: Adjust -> Adjust -> Bool $c== :: Adjust -> Adjust -> Bool Eq, Int -> Adjust Adjust -> Int Adjust -> [Adjust] Adjust -> Adjust Adjust -> Adjust -> [Adjust] Adjust -> Adjust -> Adjust -> [Adjust] forall a. (a -> a) -> (a -> a) -> (Int -> a) -> (a -> Int) -> (a -> [a]) -> (a -> a -> [a]) -> (a -> a -> [a]) -> (a -> a -> a -> [a]) -> Enum a enumFromThenTo :: Adjust -> Adjust -> Adjust -> [Adjust] $cenumFromThenTo :: Adjust -> Adjust -> Adjust -> [Adjust] enumFromTo :: Adjust -> Adjust -> [Adjust] $cenumFromTo :: Adjust -> Adjust -> [Adjust] enumFromThen :: Adjust -> Adjust -> [Adjust] $cenumFromThen :: Adjust -> Adjust -> [Adjust] enumFrom :: Adjust -> [Adjust] $cenumFrom :: Adjust -> [Adjust] fromEnum :: Adjust -> Int $cfromEnum :: Adjust -> Int toEnum :: Int -> Adjust $ctoEnum :: Int -> Adjust pred :: Adjust -> Adjust $cpred :: Adjust -> Adjust succ :: Adjust -> Adjust $csucc :: Adjust -> Adjust Enum, Int -> Adjust -> ShowS [Adjust] -> ShowS Adjust -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Adjust] -> ShowS $cshowList :: [Adjust] -> ShowS show :: Adjust -> String $cshow :: Adjust -> String showsPrec :: Int -> Adjust -> ShowS $cshowsPrec :: Int -> Adjust -> ShowS Show) instance ShowVal.ShowVal Adjust instance Typecheck.Typecheck Adjust instance Typecheck.ToVal Adjust adjust_env :: Sig.Parser Adjust adjust_env :: Parser Adjust adjust_env = forall a deflt. (Typecheck a, ToVal deflt) => ArgName -> EnvironDefault -> deflt -> Doc -> Parser a Sig.environ ArgName "adjust" EnvironDefault Sig.Both Adjust Shorten Doc "How to adjust a trill to fulfill its start and end pitch restrictions." -- ** transitions -- | A signal that alternates between the base and neighbor values. get_trill_control :: Config -> (ScoreTime, ScoreTime) -> ScoreT.Function -> Derive.Deriver [(RealTime, Signal.Y)] get_trill_control :: Config -> (ScoreTime, ScoreTime) -> Function -> Deriver [(RealTime, Double)] get_trill_control Config config (ScoreTime start, ScoreTime end) Function neighbor = do RealTime real_start <- forall a. Time a => a -> Deriver RealTime Derive.real ScoreTime start let neighbor_low :: Bool neighbor_low = Function neighbor RealTime real_start forall a. Ord a => a -> a -> Bool < Double 0 (AbsoluteMode who_first, [RealTime] transitions) <- Config -> (ScoreTime, ScoreTime) -> Bool -> Deriver (AbsoluteMode, [RealTime]) get_trill_transitions Config config (ScoreTime start, ScoreTime end) Bool neighbor_low let (Function val1, Function val2) = case AbsoluteMode who_first of AbsoluteMode Unison -> (forall a b. a -> b -> a const Double 0, Function neighbor) AbsoluteMode Neighbor -> (Function neighbor, forall a b. a -> b -> a const Double 0) forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ Function -> Function -> RealTime -> [RealTime] -> [(RealTime, Double)] trill_from_transitions Function val1 Function val2 RealTime real_start [RealTime] transitions -- | Like 'get_trill_control', but for a curved trill. get_trill_control_smooth :: Config -> ControlUtil.Curve -> (ScoreTime, ScoreTime) -> ScoreT.Function -> Derive.Deriver Signal.Control get_trill_control_smooth :: Config -> Curve -> (ScoreTime, ScoreTime) -> Function -> Deriver Control get_trill_control_smooth Config config Curve curve (ScoreTime, ScoreTime) range Function neighbor = do [(RealTime, Double)] transpose <- Config -> (ScoreTime, ScoreTime) -> Function -> Deriver [(RealTime, Double)] get_trill_control -- Trills usually omit the transition that coincides with the end -- because that would create a zero duration note. But these -- trills are smoothed and thus will still have a segment leading -- to the cut-off transition. (Config config { _include_end :: Bool _include_end = Bool True }) (ScoreTime, ScoreTime) range Function neighbor Control signal <- Function -> Curve -> [(RealTime, Double)] -> Deriver Control smooth_trill (forall a b. a -> b -> a const Double 1) Curve curve [(RealTime, Double)] transpose forall (m :: * -> *) a. Monad m => a -> m a return Control signal -- | The points in time where the trill should transition between pitches. get_trill_transitions :: Config -> (ScoreTime, ScoreTime) -> Bool -> Derive.Deriver (AbsoluteMode, [RealTime]) get_trill_transitions :: Config -> (ScoreTime, ScoreTime) -> Bool -> Deriver (AbsoluteMode, [RealTime]) get_trill_transitions Config config (ScoreTime start, ScoreTime end) Bool neighbor_low = do let (AbsoluteMode who_first, Maybe Bool even_transitions) = Bool -> Maybe Direction -> Maybe Direction -> (AbsoluteMode, Maybe Bool) convert_direction Bool neighbor_low (Config -> Maybe Direction _start_dir Config config) (Config -> Maybe Direction _end_dir Config config) ScoreTime hold <- forall t1 t2. (Time t1, Time t2) => t1 -> t2 -> Deriver ScoreTime Call.score_duration ScoreTime start (Config -> Duration _hold Config config) (AbsoluteMode who_first,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Config -> ScoreTime -> Maybe Bool -> (ScoreTime, ScoreTime) -> Deriver [RealTime] adjusted_transitions Config config ScoreTime 0 Maybe Bool even_transitions (ScoreTime start forall a. Num a => a -> a -> a + ScoreTime hold, ScoreTime end) -- | Resolve start and end Directions to the first and second trill notes. convert_direction :: Bool -> Maybe Direction -> Maybe Direction -> (AbsoluteMode, Maybe Bool) -- ^ Who starts the trill. The boolean indicates whether the transitions -- should be even to end on the expected end Direction, and Nothing if it -- doesn't matter. convert_direction :: Bool -> Maybe Direction -> Maybe Direction -> (AbsoluteMode, Maybe Bool) convert_direction Bool neighbor_low Maybe Direction start Maybe Direction end = (AbsoluteMode first, Maybe Bool even_transitions) where first :: AbsoluteMode first = case Maybe Direction start of Maybe Direction Nothing -> AbsoluteMode Unison Just Direction Low -> if Bool neighbor_low then AbsoluteMode Neighbor else AbsoluteMode Unison Just Direction High -> if Bool neighbor_low then AbsoluteMode Unison else AbsoluteMode Neighbor -- If I end Low, and neighbor is low, and I started with Unison, then val2 -- is low, so I want even transitions. Why is it so complicated just to -- get a trill to end high or low? first_low :: Bool first_low = case AbsoluteMode first of AbsoluteMode Unison -> Bool -> Bool not Bool neighbor_low AbsoluteMode Neighbor -> Bool neighbor_low even_transitions :: Maybe Bool even_transitions = case Maybe Direction end of Maybe Direction Nothing -> forall a. Maybe a Nothing Just Direction Low -> forall a. a -> Maybe a Just (Bool -> Bool not Bool first_low) Just Direction High -> forall a. a -> Maybe a Just Bool first_low -- | Turn transition times into a trill control. smooth_trill :: ScoreT.Function -- ^ time to take make the transition, -- where 0 is instant and 1 is all available time -> ControlUtil.Curve -> [(RealTime, Signal.Y)] -> Derive.Deriver Signal.Control smooth_trill :: Function -> Curve -> [(RealTime, Double)] -> Deriver Control smooth_trill Function time Curve curve [(RealTime, Double)] transitions = do RealTime srate <- Deriver RealTime Call.get_srate -- I used to optimize sig_function == const 0, but it probably doesn't make -- much difference. forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ Curve -> RealTime -> Function -> [(RealTime, Double)] -> Control ControlUtil.smooth_relative Curve curve RealTime srate Function time [(RealTime, Double)] transitions -- | Get trill transition times, adjusted for all the various fancy parameters -- that trills have. adjusted_transitions :: Config -> ScoreTime -> Maybe Bool -- ^ emit an even number of transitions, or Nothing for -- however many will fit -> (ScoreTime, ScoreTime) -> Derive.Deriver [RealTime] adjusted_transitions :: Config -> ScoreTime -> Maybe Bool -> (ScoreTime, ScoreTime) -> Deriver [RealTime] adjusted_transitions Config config ScoreTime hold Maybe Bool even (ScoreTime start, ScoreTime end) = do RealTime real_end <- forall a. Time a => a -> Deriver RealTime Derive.real ScoreTime end [RealTime] -> Deriver [RealTime] add_hold forall b c a. (b -> c) -> (a -> b) -> a -> c . Double -> [RealTime] -> [RealTime] add_bias (Config -> Double _bias Config config) forall b c a. (b -> c) -> (a -> b) -> a -> c . RealTime -> Adjust -> [RealTime] -> [RealTime] adjust_transitions RealTime real_end (Config -> Adjust _adjust Config config) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. [a] -> [a] trim forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< (ScoreTime, ScoreTime) -> Bool -> RealTimeFunctionT -> Deriver [RealTime] trill_transitions (ScoreTime start forall a. Num a => a -> a -> a + ScoreTime hold, ScoreTime end) (Config -> Bool _include_end Config config) (Config -> RealTimeFunctionT _speed Config config) where add_hold :: [RealTime] -> Deriver [RealTime] add_hold [RealTime] transitions | ScoreTime hold forall a. Ord a => a -> a -> Bool > ScoreTime 0 = (forall a. a -> [a] -> [a] : forall a. Int -> [a] -> [a] drop Int 1 [RealTime] transitions) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall a. Time a => a -> Deriver RealTime Derive.real ScoreTime start | Bool otherwise = forall (m :: * -> *) a. Monad m => a -> m a return [RealTime] transitions trim :: [a] -> [a] trim = case Maybe Bool even of Maybe Bool Nothing -> forall a. a -> a id Just Bool even -> if Bool even then forall a. [a] -> [a] take_even else forall a. [a] -> [a] take_odd take_even :: [a] -> [a] take_even (a x:a y:[a] zs) = a x forall a. a -> [a] -> [a] : a y forall a. a -> [a] -> [a] : [a] -> [a] take_even [a] zs take_even [a] _ = [] take_odd :: [a] -> [a] take_odd [a x, a _] = [a x] take_odd (a x:a y:[a] zs) = a x forall a. a -> [a] -> [a] : a y forall a. a -> [a] -> [a] : [a] -> [a] take_odd [a] zs take_odd [a] xs = [a] xs adjust_transitions :: RealTime -> Adjust -> [RealTime] -> [RealTime] adjust_transitions :: RealTime -> Adjust -> [RealTime] -> [RealTime] adjust_transitions RealTime _ Adjust Shorten [RealTime] ts = [RealTime] ts adjust_transitions RealTime end Adjust Stretch ts :: [RealTime] ts@(RealTime _:RealTime _:[RealTime] _) = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c] zipWith forall a. Num a => a -> a -> a (+) [RealTime] offsets [RealTime] ts where -- (_:_:_) above means both the last and division are safe. stretch :: RealTime stretch = forall a. Ord a => a -> a -> a max RealTime 0 (RealTime end forall a. Num a => a -> a -> a - forall a. [a] -> a last [RealTime] ts) forall a. Fractional a => a -> a -> a / forall a b. (Integral a, Num b) => a -> b fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Int length [RealTime] ts forall a. Num a => a -> a -> a - Int 1) offsets :: [RealTime] offsets = forall a. Num a => a -> a -> [a] Lists.range_ RealTime 0 RealTime stretch adjust_transitions RealTime _ Adjust Stretch [RealTime] ts = [RealTime] ts add_bias :: Double -> [RealTime] -> [RealTime] add_bias :: Double -> [RealTime] -> [RealTime] add_bias Double _ [] = [] add_bias Double bias (RealTime t:[RealTime] ts) | Double bias forall a. Eq a => a -> a -> Bool == Double 0 = RealTime t forall a. a -> [a] -> [a] : [RealTime] ts | Double bias forall a. Ord a => a -> a -> Bool > Double 0 = RealTime t forall a. a -> [a] -> [a] : forall {t}. (Eq t, Num t) => t -> [t] -> [t] positive (forall a. Ord a => a -> a -> a min RealTime 1 (Double -> RealTime RealTime.seconds Double bias)) [RealTime] ts | Bool otherwise = forall {t}. (Eq t, Num t) => t -> [t] -> [t] negative (forall a. Ord a => a -> a -> a min RealTime 1 (Double -> RealTime RealTime.seconds (forall a. Num a => a -> a abs Double bias))) (RealTime tforall a. a -> [a] -> [a] :[RealTime] ts) where positive :: t -> [t] -> [t] positive t bias (t x:t y:[t] zs) = forall a. (Eq a, Num a) => a -> a -> a -> a Num.scale t x t y t bias forall a. a -> [a] -> [a] : t y forall a. a -> [a] -> [a] : t -> [t] -> [t] positive t bias [t] zs positive t _ [t] xs = [t] xs negative :: t -> [t] -> [t] negative t bias (t x:t y:[t] zs) = t x forall a. a -> [a] -> [a] : forall a. (Eq a, Num a) => a -> a -> a -> a Num.scale t x t y t bias forall a. a -> [a] -> [a] : t -> [t] -> [t] negative t bias [t] zs negative t _ [t] xs = [t] xs -- | Make a trill signal from a list of transition times. It will alternate -- between values from the given Functions. trill_from_transitions :: ScoreT.Function -> ScoreT.Function -> RealTime -> [RealTime] -> [(RealTime, Signal.Y)] trill_from_transitions :: Function -> Function -> RealTime -> [RealTime] -> [(RealTime, Double)] trill_from_transitions Function val1 Function val2 RealTime start [RealTime] transitions = [(RealTime, Double)] initial forall a. [a] -> [a] -> [a] ++ [(RealTime x, Function sig RealTime x) | (RealTime x, Function sig) <- forall a b. [a] -> [b] -> [(a, b)] zip [RealTime] transitions (forall a. [a] -> [a] cycle [Function val1, Function val2])] where -- Hold might have push the first transition forward, so make a flat -- segment for it. initial :: [(RealTime, Double)] initial = case [RealTime] transitions of RealTime x : [RealTime] _ | RealTime start forall a. Ord a => a -> a -> Bool < RealTime x -> [(RealTime start, Function val1 RealTime start)] [RealTime] _ -> [] -- | Create trill transition points from a speed. trill_transitions :: (ScoreTime, ScoreTime) -> Bool -> Typecheck.RealTimeFunctionT -> Derive.Deriver [RealTime] trill_transitions :: (ScoreTime, ScoreTime) -> Bool -> RealTimeFunctionT -> Deriver [RealTime] trill_transitions (ScoreTime, ScoreTime) range Bool include_end (Typecheck.RealTimeFunctionT TimeT ttype Function speed) = case TimeT ttype of TimeT ScoreT.TReal -> (ScoreTime, ScoreTime) -> Bool -> Function -> Deriver [RealTime] real_transitions (ScoreTime, ScoreTime) range Bool include_end Function speed TimeT ScoreT.TScore -> (ScoreTime, ScoreTime) -> Bool -> Function -> Deriver [RealTime] score_transitions (ScoreTime, ScoreTime) range Bool include_end Function speed real_transitions :: (ScoreTime, ScoreTime) -> Bool -> ScoreT.Function -> Derive.Deriver [RealTime] real_transitions :: (ScoreTime, ScoreTime) -> Bool -> Function -> Deriver [RealTime] real_transitions (ScoreTime start, ScoreTime end) Bool include_end Function speed = do RealTime start <- forall a. Time a => a -> Deriver RealTime Derive.real ScoreTime start RealTime end <- forall a. Time a => a -> Deriver RealTime Derive.real ScoreTime end forall a. (Ord a, Num a) => a -> a -> Bool -> [a] -> [a] full_cycles RealTime RealTime.eta RealTime end Bool include_end forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Function -> RealTime -> RealTime -> Deriver [RealTime] Speed.real_starts Function speed RealTime start RealTime end score_transitions :: (ScoreTime, ScoreTime) -> Bool -> ScoreT.Function -> Derive.Deriver [RealTime] score_transitions :: (ScoreTime, ScoreTime) -> Bool -> Function -> Deriver [RealTime] score_transitions (ScoreTime start, ScoreTime end) Bool include_end Function speed = do [ScoreTime] all_transitions <- Function -> ScoreTime -> ScoreTime -> Deriver [ScoreTime] Speed.score_starts Function speed ScoreTime start ScoreTime end forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM forall a. Time a => a -> Deriver RealTime Derive.real forall a b. (a -> b) -> a -> b $ forall a. (Ord a, Num a) => a -> a -> Bool -> [a] -> [a] full_cycles ScoreTime ScoreTime.eta ScoreTime end Bool include_end [ScoreTime] all_transitions -- | Given a list of trill transition times, take only ones with a complete -- duration. Otherwise a trill can wind up with a short note at the end, which -- sounds funny. However it's ok if the note is slightly too short, as tends -- to happen with floating point. full_cycles :: (Ord a, Num a) => a -> a -> Bool -> [a] -> [a] full_cycles :: forall a. (Ord a, Num a) => a -> a -> Bool -> [a] -> [a] full_cycles a eta a end Bool include_end [a] vals | forall (t :: * -> *) a. Foldable t => t a -> Bool null [a] cycles = forall a. Int -> [a] -> [a] take Int 1 [a] vals | Bool otherwise = [a] cycles where cycles :: [a] cycles = [a] -> [a] go [a] vals go :: [a] -> [a] go (a x1 : [a] xs) = case [a] xs of a x2 : [a] _ | a x2 forall a. Ord a => a -> a -> Bool <= a end forall a. Num a => a -> a -> a + a eta -> a x1 forall a. a -> [a] -> [a] : [a] -> [a] go [a] xs [a] _ | Bool include_end Bool -> Bool -> Bool && a x1 forall a. Num a => a -> a -> a - a eta forall a. Ord a => a -> a -> Bool <= a end -> [a x1] [a] _ -> [] go [] = []