-- 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 -- | Calls for Carnatic gamakam. module Derive.C.India.Gamakam2 where import qualified Control.Monad.State.Strict as Monad.State import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Text as Text import qualified Util.Doc as Doc import qualified Util.Lists as Lists import qualified Util.Pretty as Pretty import qualified Derive.Args as Args import qualified Derive.C.Prelude.Trill as Trill import qualified Derive.Call as Call import qualified Derive.Call.ControlUtil as ControlUtil import qualified Derive.Call.Module as Module import qualified Derive.Call.PitchUtil as PitchUtil import qualified Derive.Call.Sub as Sub import qualified Derive.Call.Tags as Tags import qualified Derive.Controls as Controls import qualified Derive.Derive as Derive import qualified Derive.DeriveT as DeriveT import qualified Derive.Deriver.Internal as Internal import qualified Derive.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.Score as Score import qualified Derive.ScoreT as ScoreT import qualified Derive.ShowVal as ShowVal import qualified Derive.Sig as Sig import qualified Derive.Stream as Stream import qualified Derive.Typecheck as Typecheck import qualified Perform.RealTime as RealTime import qualified Perform.Signal as Signal import qualified Ui.Event as Event import Global import Types module_ :: Module.Module module_ :: Module module_ = Module "india" forall a. Semigroup a => a -> a -> a <> Module "gamakam2" -- | Calls in these modules are meant to be used via the sequence call, so they -- are only in scope under the relevant phase. begin_module, middle_module, end_module :: Module.Module begin_module :: Module begin_module = Module module_ forall a. Semigroup a => a -> a -> a <> Module "begin" middle_module :: Module middle_module = Module module_ forall a. Semigroup a => a -> a -> a <> Module "middle" end_module :: Module end_module = Module module_ forall a. Semigroup a => a -> a -> a <> Module "end" library :: Library.Library library :: Library library = forall a. Monoid a => [a] -> a mconcat [ forall call. ToLibrary (Generator call) => [(Symbol, Generator call)] -> Library Library.generators [(Symbol "@", Generator Note c_sequence)] , forall call. ToLibrary (Transformer call) => [(Symbol, Transformer call)] -> Library Library.transformers [ (Symbol "@", Transformer Note c_sequence_transform) , (Symbol "sahitya", forall a. Taggable a => Transformer a c_sahitya) ] -- Pitch , forall call. ToLibrary (Generator call) => [(Symbol, Generator call)] -> Library Library.generators forall a b. (a -> b) -> a -> b $ forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat [ [(Symbol, Generator Pitch)] begin_calls , [(Symbol, Generator Pitch)] begin_aliases , [(Symbol, Generator Pitch)] middle_calls , [(Symbol, Generator Pitch)] middle_aliases , [(Symbol, Generator Pitch)] end_calls , [(Symbol, Generator Pitch)] end_aliases ] ] begin_calls :: [(Expr.Symbol, Derive.Generator Derive.Pitch)] begin_calls :: [(Symbol, Generator Pitch)] begin_calls = [ (Symbol "set-pitch", Generator Pitch c_set_pitch) , (Symbol "flat-start", Generator Pitch c_flat_start) , (Symbol "cur", PitchFrom -> Fade -> Generator Pitch c_from PitchFrom PitchFromCurrent Fade NoFade) , (Symbol "cur<", PitchFrom -> Fade -> Generator Pitch c_from PitchFrom PitchFromCurrent Fade Fade) , (Symbol "prev", PitchFrom -> Fade -> Generator Pitch c_from PitchFrom PitchFromPrev Fade NoFade) , (Symbol "prev<", PitchFrom -> Fade -> Generator Pitch c_from PitchFrom PitchFromPrev Fade Fade) , (Symbol "jaru", Bool -> Generator Pitch c_jaru Bool False) , (Symbol "jaru0", Bool -> Generator Pitch c_jaru Bool True) , (Symbol "fade-in", Bool -> Generator Pitch c_fade Bool True) ] -- | I don't want to take up short names for the whole track scope, but within -- a sequence call it seems reasonable. In addition, I know if it's a begin or -- end call, and use the same name for logically similar things. begin_aliases :: [(Expr.Symbol, Derive.Generator Derive.Pitch)] begin_aliases :: [(Symbol, Generator Pitch)] begin_aliases = forall a b. (a -> b) -> [a] -> [b] map (forall (p :: * -> * -> *) b c a. Bifunctor p => (b -> c) -> p a b -> p a c second (forall f. Module -> Call f -> Call f Derive.set_module Module begin_module)) [ (Symbol "-", Generator Pitch c_flat_start) , (Symbol "c", PitchFrom -> Fade -> Generator Pitch c_from PitchFrom PitchFromCurrent Fade NoFade) , (Symbol "c<", PitchFrom -> Fade -> Generator Pitch c_from PitchFrom PitchFromCurrent Fade Fade) , (Symbol "p", PitchFrom -> Fade -> Generator Pitch c_from PitchFrom PitchFromPrev Fade NoFade) , (Symbol "p<", PitchFrom -> Fade -> Generator Pitch c_from PitchFrom PitchFromPrev Fade Fade) , (Symbol "J", Bool -> Generator Pitch c_jaru Bool False) , (Symbol "j", Bool -> Generator Pitch c_jaru Bool True) , (Symbol fade_in_call, Bool -> Generator Pitch c_fade Bool True) ] middle_calls :: [(Expr.Symbol, Derive.Generator Derive.Pitch)] middle_calls :: [(Symbol, Generator Pitch)] middle_calls = (Symbol "flat", Generator Pitch c_flat) forall a. a -> [a] -> [a] : forall call. Text -> (Maybe Direction -> call) -> [(Symbol, call)] kampita_variations Text "kam" (Doc -> KampitaArgs -> Maybe Direction -> Generator Pitch c_kampita Doc "" KampitaArgs neighbor) forall a. [a] -> [a] -> [a] ++ forall call. Text -> (Maybe Direction -> call) -> [(Symbol, call)] kampita_variations Text "kam2" (Doc -> KampitaArgs -> Maybe Direction -> Generator Pitch c_kampita Doc "" KampitaArgs Kampita2) forall a. [a] -> [a] -> [a] ++ forall call. Text -> (Maybe Direction -> call) -> [(Symbol, call)] kampita_variations Text "nkam" (Doc -> KampitaArgs -> Maybe Direction -> Generator Pitch c_nkampita Doc "" KampitaArgs neighbor) forall a. [a] -> [a] -> [a] ++ forall call. Text -> (Maybe Direction -> call) -> [(Symbol, call)] kampita_variations Text "nkam2" (Doc -> KampitaArgs -> Maybe Direction -> Generator Pitch c_nkampita Doc "" KampitaArgs Kampita2) where neighbor :: KampitaArgs neighbor = Double -> KampitaArgs Kampita1 Double 0 kampita_variations :: Text -> (Maybe Trill.Direction -> call) -> [(Expr.Symbol, call)] kampita_variations :: forall call. Text -> (Maybe Direction -> call) -> [(Symbol, call)] kampita_variations Text name Maybe Direction -> call call = [ (Text -> Symbol Expr.Symbol forall a b. (a -> b) -> a -> b $ Text name forall a. Semigroup a => a -> a -> a <> Maybe Direction -> Text Trill.direction_affix Maybe Direction end, Maybe Direction -> call call Maybe Direction end) | Maybe Direction end <- [Maybe Direction] dirs ] where dirs :: [Maybe Direction] dirs = [forall a. Maybe a Nothing, forall a. a -> Maybe a Just Direction Trill.Low, forall a. a -> Maybe a Just Direction Trill.High] middle_aliases :: [(Expr.Symbol, Derive.Generator Derive.Pitch)] middle_aliases :: [(Symbol, Generator Pitch)] middle_aliases = forall a b. (a -> b) -> [a] -> [b] map (forall (p :: * -> * -> *) b c a. Bifunctor p => (b -> c) -> p a b -> p a c second (forall f. Module -> Call f -> Call f Derive.set_module Module middle_module)) forall a b. (a -> b) -> a -> b $ forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat forall a b. (a -> b) -> a -> b $ [ (Symbol "-", Generator Pitch c_flat) ] forall a. a -> [a] -> [a] : [ forall {a}. (Semigroup a, IsString a) => a -> KampitaArgs -> Maybe Direction -> [(a, Generator Pitch)] hardcoded Symbol "o^" (Double -> Double -> KampitaArgs Kampita0 Double 1 Double 0) (forall a. a -> Maybe a Just Direction Trill.High) , forall {a}. (Semigroup a, IsString a) => a -> KampitaArgs -> Maybe Direction -> [(a, Generator Pitch)] hardcoded Symbol "o_" (Double -> Double -> KampitaArgs Kampita0 (-Double 1) Double 0) (forall a. a -> Maybe a Just Direction Trill.Low) , forall {a}. (Semigroup a, IsString a) => a -> KampitaArgs -> Maybe Direction -> [(a, Generator Pitch)] hardcoded Symbol "o*" (Double -> Double -> KampitaArgs Kampita0 (-Double 1) Double 1) (forall a. a -> Maybe a Just Direction Trill.Low) , forall call. Text -> Text -> [(Symbol, call)] -> [(Symbol, call)] alias_prefix Text "k" Text "kam" [(Symbol, Generator Pitch)] middle_calls , forall call. Text -> Text -> [(Symbol, call)] -> [(Symbol, call)] alias_prefix Text "nk" Text "nkam" [(Symbol, Generator Pitch)] middle_calls ] where hardcoded :: a -> KampitaArgs -> Maybe Direction -> [(a, Generator Pitch)] hardcoded a name KampitaArgs arg Maybe Direction dir = [ (a name, Doc -> KampitaArgs -> Maybe Direction -> Generator Pitch c_kampita Doc doc KampitaArgs arg Maybe Direction dir) , (a "n" forall a. Semigroup a => a -> a -> a <> a name, Doc -> KampitaArgs -> Maybe Direction -> Generator Pitch c_nkampita Doc doc KampitaArgs arg Maybe Direction dir) ] doc :: Doc doc = Text -> Doc Doc.Doc forall a b. (a -> b) -> a -> b $ [Text] -> Text Text.unlines [ Text "These are hardcoded `k` variants:" , Text "`o^` touches the swaram from above, like `k2^ 1 0`." , Text "`o_` touches the swaram from below, like `k2_ -1 0`." , Text "`o*` avoids the swaram, like `k2_ -1 1`." ] alias_prefix :: Text -> Text -> [(Expr.Symbol, call)] -> [(Expr.Symbol, call)] alias_prefix :: forall call. Text -> Text -> [(Symbol, call)] -> [(Symbol, call)] alias_prefix Text from Text to [(Symbol, call)] calls = do (Expr.Symbol Text name, call call) <- [(Symbol, call)] calls Just Text rest <- [Text -> Text -> Maybe Text Text.stripPrefix Text to Text name] forall (m :: * -> *) a. Monad m => a -> m a return (Text -> Symbol Expr.Symbol (Text from forall a. Semigroup a => a -> a -> a <> Text rest), call call) end_calls :: [(Expr.Symbol, Derive.Generator Derive.Pitch)] end_calls :: [(Symbol, Generator Pitch)] end_calls = [ (Symbol "flat-end", Generator Pitch c_flat_end) , (Symbol "to", Fade -> Generator Pitch c_to Fade NoFade) , (Symbol "to>", Fade -> Generator Pitch c_to Fade Fade) , (Symbol "fade-out", Bool -> Generator Pitch c_fade Bool False) ] end_aliases :: [(Expr.Symbol, Derive.Generator Derive.Pitch)] end_aliases :: [(Symbol, Generator Pitch)] end_aliases = forall a b. (a -> b) -> [a] -> [b] map (forall (p :: * -> * -> *) b c a. Bifunctor p => (b -> c) -> p a b -> p a c second (forall f. Module -> Call f -> Call f Derive.set_module Module end_module)) [ (Symbol "-", Generator Pitch c_flat_end) , (Symbol "t", Fade -> Generator Pitch c_to Fade NoFade) , (Symbol "t>", Fade -> Generator Pitch c_to Fade Fade) , (Symbol fade_out_call, Bool -> Generator Pitch c_fade Bool False) ] -- | Special behaviour documented in 'sequence_doc'. fade_out_call :: Expr.Symbol fade_out_call :: Symbol fade_out_call = Symbol "->" -- The leading dash makes these parse as symbols. -- | Unlike 'fade_out_call', this doesn't need special treatment. fade_in_call :: Expr.Symbol fade_in_call :: Symbol fade_in_call = Symbol "-<" -- * sequence c_sequence :: Derive.Generator Derive.Note c_sequence :: Generator Note c_sequence = forall d. Module -> CallName -> Tags -> Doc -> WithArgDoc (GeneratorF d) -> Generator d Derive.generator Module module_ CallName "sequence" forall a. Monoid a => a mempty Doc sequence_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 (ArgName -> Doc -> Parser [Val] Sig.many_vals ArgName "arg" Doc "Expressions separated by `;`.") forall a b. (a -> b) -> a -> b $ \[Val] _ -> forall d. (PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver Sub.inverting forall a b. (a -> b) -> a -> b $ \PassedArgs Note args -> forall a. PassedArgs Note -> Deriver a -> Deriver a with_sequence PassedArgs Note args (forall d. PassedArgs d -> NoteDeriver Call.placed_note PassedArgs Note args) c_sequence_transform :: Derive.Transformer Derive.Note c_sequence_transform :: Transformer Note c_sequence_transform = forall d. Module -> CallName -> Tags -> Doc -> WithArgDoc (TransformerF d) -> Transformer d Derive.transformer Module module_ CallName "sequence" forall a. Monoid a => a mempty Doc sequence_doc forall a b. (a -> b) -> a -> b $ forall y a d. Taggable y => Parser a -> (a -> Transformer y d) -> WithArgDoc (Transformer y d) Sig.callt (ArgName -> Doc -> Parser [Val] Sig.many_vals ArgName "arg" Doc "Expressions separated by `;`.") forall a b. (a -> b) -> a -> b $ \[Val] _ -> forall a. PassedArgs Note -> Deriver a -> Deriver a with_sequence sequence_doc :: Doc.Doc sequence_doc :: Doc sequence_doc = Doc "Sequence several pitch calls. Calls are divided into\ \ `begin ; middle1 ; middle2; ... ; end` phases. Calls are pitch\ \ generators, and are sequenced such that the middle calls stretch\ \ based on the duration of the note. The " forall a. Semigroup a => a -> a -> a <> Module -> Doc doc Module begin_module forall a. Semigroup a => a -> a -> a <> Doc ", " forall a. Semigroup a => a -> a -> a <> Module -> Doc doc Module middle_module forall a. Semigroup a => a -> a -> a <> Doc ", and " forall a. Semigroup a => a -> a -> a <> Module -> Doc doc Module end_module forall a. Semigroup a => a -> a -> a <> Doc " modules are\ \ in scope during the begin, middle, and end phases. All calls\ \ below the " forall a. Semigroup a => a -> a -> a <> Module -> Doc doc Module module_ forall a. Semigroup a => a -> a -> a <> Doc " module are designed for\ \ sequencing. This just means they emit samples at the beginning and end\ \ of their range, so the sequence call knows their extent. Normal pitch\ \ calls may not do that.\ \\nThere's a special hack for the " forall a. Semigroup a => a -> a -> a <> forall a. ShowVal a => a -> Doc ShowVal.doc Symbol fade_in_call forall a. Semigroup a => a -> a -> a <> Doc " and " forall a. Semigroup a => a -> a -> a <> forall a. ShowVal a => a -> Doc ShowVal.doc Symbol fade_out_call forall a. Semigroup a => a -> a -> a <> Doc " calls: they have 0\ \ duration, but are overlaid with their neighbors. This is so you can fade\ \ in or out without having to flatten the pitch." where doc :: Module -> Doc doc = forall a. Pretty a => a -> Doc Doc.pretty with_sequence :: Derive.PassedArgs Score.Event -> Derive.Deriver a -> Derive.Deriver a with_sequence :: forall a. PassedArgs Note -> Deriver a -> Deriver a with_sequence PassedArgs Note args Deriver a deriver = do let (Expr begin, [Expr] middle, Maybe Expr end) = [Val] -> (Expr, [Expr], Maybe Expr) parse_sequence (forall val. PassedArgs val -> [Val] Derive.passed_vals PassedArgs Note args) (Pitch pitch, [ControlMod] mods) <- Context Pitch -> (ScoreTime, ScoreTime) -> Expr -> [Expr] -> Maybe Expr -> Deriver (Pitch, [ControlMod]) sequence_calls (Context Note -> Context Pitch pitch_context (forall a. PassedArgs a -> Context a Args.context PassedArgs Note args)) (forall a. PassedArgs a -> (ScoreTime, ScoreTime) Args.range PassedArgs Note args) Expr begin [Expr] middle Maybe Expr end RealTime end_time <- forall a. Time a => a -> Deriver RealTime Derive.real forall a b. (a -> b) -> a -> b $ forall a. PassedArgs a -> ScoreTime Args.next PassedArgs Note args forall a. Pitch -> Deriver a -> Deriver a Derive.with_pitch Pitch pitch forall a b. (a -> b) -> a -> b $ forall a. [ControlMod] -> RealTime -> Deriver a -> Deriver a Derive.with_control_mods [ControlMod] mods RealTime end_time Deriver a deriver pitch_context :: Derive.Context Score.Event -> Derive.Context Derive.Pitch pitch_context :: Context Note -> Context Pitch pitch_context Context Note ctx = Context Note ctx { ctx_prev_val :: Maybe Pitch Derive.ctx_prev_val = Note -> Pitch Score.event_pitch forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall val. Context val -> Maybe val Derive.ctx_prev_val Context Note ctx } type Signals = (PSignal.PSignal, [Derive.ControlMod]) {- Awkward things: - I set call duration with the event (start, dur) instead of warp, so I have to modify the event rather than use Derive.place. - I deduce the duration of a call by seeing what signal it returns rather that having some special call mode, so these calls need to emit samples at their start and end. Actually, just end for begin and middle calls, and start for end calls. - Prev val is manually passed from one call to the next, so if I don't have TrackEval.derive_track handling that for me, I have to do it myself, and be careful to not pass it for the speculative evaluation of the end call. -} {- | I assume that start and end calls have a fixed duration and don't stretch to fill the given space, though they will shrink if necessary. So I evaluate start and end to get their durations, and fit the middle calls into the remaining space, evenly divided. Actually, there's a circular problem in that I don't know how long the middle section can be until I know how long the end call is, but the end call likely relies on 'Derive.ctx_prev_val', so it has to be evaluated after the middle. So I evaluate the end twice, once before the middle to find out its length, and again after evaluating the middle to get the pitch right. I considered a specially calling mode where calls could return their desired duration rather than a signal, but it seems much simpler to just have them do that by returning the signal itself and measuring that. A possibly useful extension would be to allow middle calls to be shorter than their allotted time, for instance a trill might want to complete a cycle and allow a @flat@ call to take up remaining space. I could put the requested time in @Derive.real 1@ and the hard limit in @Args.next@, but that wouldn't allow time before the call to stretch, only time after. But I could indicate stretchiness with a special tag on the call. -} sequence_calls :: Derive.Context Derive.Pitch -> (ScoreTime, ScoreTime) -> Expr -> [Expr] -> Maybe Expr -> Derive.Deriver Signals sequence_calls :: Context Pitch -> (ScoreTime, ScoreTime) -> Expr -> [Expr] -> Maybe Expr -> Deriver (Pitch, [ControlMod]) sequence_calls Context Pitch ctx (ScoreTime start, ScoreTime end) Expr begin [Expr] middles Maybe Expr maybe_end = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap forall a b. (a, b) -> a fst forall a b. (a -> b) -> a -> b $ forall a b c. (a -> b -> c) -> b -> a -> c flip forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s) Monad.State.runStateT Context Pitch ctx forall a b. (a -> b) -> a -> b $ do (Pitch begin_pitch, [ControlMod] begin_mods) <- Module -> ScoreTime -> ScoreTime -> Expr -> StateT (Context Pitch) (Deriver State Error) (Pitch, [ControlMod]) eval Module begin_module ScoreTime start ScoreTime end Expr begin ScoreTime middle_start <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift forall a b. (a -> b) -> a -> b $ ScoreTime -> Pitch -> Deriver ScoreTime signal_end ScoreTime start Pitch begin_pitch -- This is a test eval of 'end', just to see how long it is. The -- middle isn't evaluated yet, so it doesn't have the right -- ctx_prev_val. (Pitch test_end_pitch, [ControlMod] _) <- forall a. SequenceM a -> SequenceM a detached forall a b. (a -> b) -> a -> b $ forall {a}. (a -> StateT (Context Pitch) (Deriver State Error) (Pitch, [ControlMod])) -> Maybe a -> StateT (Context Pitch) (Deriver State Error) (Pitch, [ControlMod]) maybe_eval (Module -> ScoreTime -> ScoreTime -> Expr -> StateT (Context Pitch) (Deriver State Error) (Pitch, [ControlMod]) eval Module end_module ScoreTime middle_start ScoreTime end) Maybe Expr maybe_end ScoreTime end_start <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift forall a b. (a -> b) -> a -> b $ ScoreTime -> Pitch -> Deriver ScoreTime signal_start ScoreTime end Pitch test_end_pitch (Pitch middle_pitch, [ControlMod] middle_mods) <- ScoreTime -> ScoreTime -> [Expr] -> StateT (Context Pitch) (Deriver State Error) (Pitch, [ControlMod]) sequence_middles ScoreTime middle_start ScoreTime end_start [Expr] middles (Pitch end_pitch, [ControlMod] end_mods) <- forall {a}. (a -> StateT (Context Pitch) (Deriver State Error) (Pitch, [ControlMod])) -> Maybe a -> StateT (Context Pitch) (Deriver State Error) (Pitch, [ControlMod]) maybe_eval (ScoreTime -> ScoreTime -> ScoreTime -> Expr -> StateT (Context Pitch) (Deriver State Error) (Pitch, [ControlMod]) eval_end ScoreTime start ScoreTime end_start ScoreTime end) Maybe Expr maybe_end forall (m :: * -> *) a. Monad m => a -> m a return (Pitch begin_pitch forall a. Semigroup a => a -> a -> a <> Pitch middle_pitch forall a. Semigroup a => a -> a -> a <> Pitch end_pitch, [ControlMod] begin_mods forall a. Semigroup a => a -> a -> a <> [ControlMod] middle_mods forall a. Semigroup a => a -> a -> a <> [ControlMod] end_mods) where maybe_eval :: (a -> StateT (Context Pitch) (Deriver State Error) (Pitch, [ControlMod])) -> Maybe a -> StateT (Context Pitch) (Deriver State Error) (Pitch, [ControlMod]) maybe_eval = forall b a. b -> (a -> b) -> Maybe a -> b maybe (forall (m :: * -> *) a. Monad m => a -> m a return (forall a. Monoid a => a mempty, forall a. Monoid a => a mempty)) -- | Special behaviour for the @fade-out@ call, as documented in 'sequence_doc'. eval_end :: ScoreTime -> ScoreTime -> ScoreTime -> Expr -> SequenceM Signals eval_end :: ScoreTime -> ScoreTime -> ScoreTime -> Expr -> StateT (Context Pitch) (Deriver State Error) (Pitch, [ControlMod]) eval_end ScoreTime sequence_start ScoreTime start ScoreTime end Expr expr = case Expr expr of EvaluatedExpr Symbol call [Val] _ | Symbol call forall a. Eq a => a -> a -> Bool == Symbol fade_out_call -> Module -> ScoreTime -> ScoreTime -> Expr -> StateT (Context Pitch) (Deriver State Error) (Pitch, [ControlMod]) eval Module end_module ScoreTime sequence_start ScoreTime end Expr expr Expr _ -> Module -> ScoreTime -> ScoreTime -> Expr -> StateT (Context Pitch) (Deriver State Error) (Pitch, [ControlMod]) eval Module end_module ScoreTime start ScoreTime end Expr expr -- | I need to thread Derive.ctx_prev_val from each call in the sequence. type SequenceM = Monad.State.StateT (Derive.Context Derive.Pitch) Derive.Deriver detached :: SequenceM a -> SequenceM a detached :: forall a. SequenceM a -> SequenceM a detached SequenceM a m = do Context Pitch st <- forall s (m :: * -> *). MonadState s m => m s Monad.State.get a val <- SequenceM a m forall s (m :: * -> *). MonadState s m => s -> m () Monad.State.put Context Pitch st forall (m :: * -> *) a. Monad m => a -> m a return a val -- | Give each middle call an even division of the time left. The call can -- use less time if it wishes, and the remaining time will be divided among -- the remaining middle calls. It shouldn't use more time, because then it -- could overlap with the end call, or go past the end of the note. sequence_middles :: ScoreTime -> ScoreTime -> [Expr] -> SequenceM Signals sequence_middles :: ScoreTime -> ScoreTime -> [Expr] -> StateT (Context Pitch) (Deriver State Error) (Pitch, [ControlMod]) sequence_middles ScoreTime _ ScoreTime _ [] = forall (m :: * -> *) a. Monad m => a -> m a return (forall a. Monoid a => a mempty, forall a. Monoid a => a mempty) sequence_middles ScoreTime start ScoreTime end [Expr] _ | ScoreTime start forall a. Ord a => a -> a -> Bool >= ScoreTime end = forall (m :: * -> *) a. Monad m => a -> m a return (forall a. Monoid a => a mempty, forall a. Monoid a => a mempty) sequence_middles ScoreTime start ScoreTime end (Expr expr:[Expr] exprs) = do let dur :: ScoreTime dur = (ScoreTime end forall a. Num a => a -> a -> a - ScoreTime start) 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 [Expr] exprs forall a. Num a => a -> a -> a + Int 1) (Pitch pitch, [ControlMod] mods) <- Module -> ScoreTime -> ScoreTime -> Expr -> StateT (Context Pitch) (Deriver State Error) (Pitch, [ControlMod]) eval Module middle_module ScoreTime start (ScoreTime start forall a. Num a => a -> a -> a + ScoreTime dur) Expr expr ScoreTime sig_end <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift forall a b. (a -> b) -> a -> b $ ScoreTime -> Pitch -> Deriver ScoreTime signal_end ScoreTime start Pitch pitch (Pitch pitch_rest, [ControlMod] mods_rest) <- ScoreTime -> ScoreTime -> [Expr] -> StateT (Context Pitch) (Deriver State Error) (Pitch, [ControlMod]) sequence_middles ScoreTime sig_end ScoreTime end [Expr] exprs forall (m :: * -> *) a. Monad m => a -> m a return (Pitch pitch forall a. Semigroup a => a -> a -> a <> Pitch pitch_rest, [ControlMod] mods forall a. Semigroup a => a -> a -> a <> [ControlMod] mods_rest) signal_start :: ScoreTime -> PSignal.PSignal -> Derive.Deriver ScoreTime signal_start :: ScoreTime -> Pitch -> Deriver ScoreTime signal_start ScoreTime deflt = forall b a. b -> (a -> b) -> Maybe a -> b maybe (forall (m :: * -> *) a. Monad m => a -> m a return ScoreTime deflt) (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) forall b c a. (b -> c) -> (a -> b) -> a -> c . Pitch -> Maybe (RealTime, RawPitch Untransposed_) PSignal.head signal_end :: ScoreTime -> PSignal.PSignal -> Derive.Deriver ScoreTime signal_end :: ScoreTime -> Pitch -> Deriver ScoreTime signal_end ScoreTime deflt = forall b a. b -> (a -> b) -> Maybe a -> b maybe (forall (m :: * -> *) a. Monad m => a -> m a return ScoreTime deflt) (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) forall b c a. (b -> c) -> (a -> b) -> a -> c . Pitch -> Maybe (RealTime, RawPitch Untransposed_) PSignal.last eval :: Module.Module -> ScoreTime -> ScoreTime -> Expr -> SequenceM Signals eval :: Module -> ScoreTime -> ScoreTime -> Expr -> StateT (Context Pitch) (Deriver State Error) (Pitch, [ControlMod]) eval Module module_ ScoreTime start ScoreTime end Expr expr = do Context Pitch ctx <- forall s (m :: * -> *). MonadState s m => m s Monad.State.get (Stream Pitch result, [ControlMod] cmods) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift forall a b. (a -> b) -> a -> b $ forall a. Deriver a -> Deriver (a, [ControlMod]) with_empty_collect forall a b. (a -> b) -> a -> b $ forall a. Bool -> Module -> Deriver a -> Deriver a Derive.with_imported Bool True Module module_ forall a b. (a -> b) -> a -> b $ forall d. CallableExpr d => Context d -> Expr -> Deriver (Stream d) eval_expr (forall d. ScoreTime -> ScoreTime -> Context d -> Context d place_event ScoreTime start (ScoreTime end forall a. Num a => a -> a -> a - ScoreTime start) Context Pitch ctx) Expr expr Pitch signal <- forall a. Monoid a => [a] -> a mconcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (m :: * -> *) a. LogMonad m => Stream a -> m [a] Stream.write_logs Stream Pitch result forall (f :: * -> *). Applicative f => Bool -> f () -> f () unless (Pitch -> Bool PSignal.null Pitch signal) forall a b. (a -> b) -> a -> b $ forall s (m :: * -> *). MonadState s m => s -> m () Monad.State.put forall a b. (a -> b) -> a -> b $ Context Pitch ctx { ctx_prev_val :: Maybe Pitch Derive.ctx_prev_val = forall a. a -> Maybe a Just Pitch signal } forall (m :: * -> *) a. Monad m => a -> m a return (Pitch signal, [ControlMod] cmods) place_event :: ScoreTime -> ScoreTime -> Derive.Context d -> Derive.Context d place_event :: forall d. ScoreTime -> ScoreTime -> Context d -> Context d place_event ScoreTime start ScoreTime dur Context d ctx = Context d ctx { ctx_event :: Event Derive.ctx_event = ScoreTime -> ScoreTime -> Event -> Event Event.place ScoreTime start ScoreTime dur (forall val. Context val -> Event Derive.ctx_event Context d ctx) } eval_expr :: Derive.CallableExpr d => Derive.Context d -> Expr -> Derive.Deriver (Stream.Stream d) eval_expr :: forall d. CallableExpr d => Context d -> Expr -> Deriver (Stream d) eval_expr Context d ctx (QuotedExpr Expr expr) = forall d. CallableExpr d => Context d -> Expr -> Deriver (Stream d) Eval.eval_toplevel Context d ctx Expr expr eval_expr Context d ctx (EvaluatedExpr Symbol sym [Val] args) = do Generator d call <- forall d. Callable (Generator d) => Symbol -> Deriver (Generator d) Eval.get_generator Symbol sym forall d. Context d -> Generator d -> [Val] -> Deriver (Stream d) Eval.apply_generator Context d ctx Generator d call [Val] args with_empty_collect :: Derive.Deriver a -> Derive.Deriver (a, [Derive.ControlMod]) with_empty_collect :: forall a. Deriver a -> Deriver (a, [ControlMod]) with_empty_collect = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (forall (p :: * -> * -> *) b c a. Bifunctor p => (b -> c) -> p a b -> p a c second Collect -> [ControlMod] Derive.collect_control_mods) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Deriver a -> Deriver (a, Collect) Internal.local_collect -- ** parse data Expr = -- | This is a call which was embedded in the argument list of the sequence -- call, so its arguments have already been evaluated. EvaluatedExpr Expr.Symbol [DeriveT.Val] -- | A call and its arguments can be protected from evaluation by quoting -- it. This is also necessary to use a transformer, since @;@ has higher -- precedence than @|@ (actually it's just a value, not an operator). | QuotedExpr !DeriveT.Expr deriving Int -> Expr -> ShowS [Expr] -> ShowS Expr -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Expr] -> ShowS $cshowList :: [Expr] -> ShowS show :: Expr -> String $cshow :: Expr -> String showsPrec :: Int -> Expr -> ShowS $cshowsPrec :: Int -> Expr -> ShowS Show instance Pretty Expr where format :: Expr -> Doc format (EvaluatedExpr Symbol sym [Val] vals) = (Doc "(" forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Doc Pretty.format Symbol sym) Doc -> Doc -> Doc Pretty.<+> (forall a. Pretty a => a -> Doc Pretty.format [Val] vals forall a. Semigroup a => a -> a -> a <> Doc ")") format (QuotedExpr Expr quoted) = Text -> Doc Pretty.text forall a b. (a -> b) -> a -> b $ forall a. ShowVal a => a -> Text ShowVal.show_val Expr quoted -- | Parse the sequence call's arguments and substitute aliases. If there is -- no begin, @set-pitch@ will be added, and if there is no middle, @-@ will be -- added. This is so that if there is just an end call, there will still be -- a signal from the beginning of the note. -- -- The positions are inferred according to the number of sections: -- -- > ; middle1; -- > begin1; middle2 -- > begin1; middle2; middle3; ...; end_n parse_sequence :: [DeriveT.Val] -> (Expr, [Expr], Maybe Expr) parse_sequence :: [Val] -> (Expr, [Expr], Maybe Expr) parse_sequence [Val] exprs = (Maybe [Val], [[Val]], Maybe [Val]) -> (Expr, [Expr], Maybe Expr) postproc forall a b. (a -> b) -> a -> b $ case forall a. (a -> a) -> [a] -> [a] Lists.mapTail (forall a. Int -> [a] -> [a] drop Int 1) forall a b. (a -> b) -> a -> b $ forall a. (a -> Bool) -> [a] -> [[a]] Lists.splitBefore Val -> Bool is_separator [Val] exprs of [] -> (forall a. Maybe a Nothing, [], forall a. Maybe a Nothing) [Val] begin : [[Val]] rest -> case forall a. [a] -> [a] reverse [[Val]] rest of [[Val] middle] -> (forall a. a -> Maybe a Just [Val] begin, [[Val] middle], forall a. Maybe a Nothing) [Val] end : [[Val]] middle -> (forall a. a -> Maybe a Just [Val] begin, forall a. [a] -> [a] reverse [[Val]] middle, forall a. a -> Maybe a Just [Val] end) [] -> (forall a. a -> Maybe a Just [Val] begin, [], forall a. Maybe a Nothing) where postproc :: (Maybe [Val], [[Val]], Maybe [Val]) -> (Expr, [Expr], Maybe Expr) postproc (Maybe [Val] begin, [[Val]] middles, Maybe [Val] end) = ( forall a. a -> Maybe a -> a fromMaybe (Symbol -> [Val] -> Expr EvaluatedExpr Symbol "set-pitch" []) forall a b. (a -> b) -> a -> b $ [Val] -> Maybe Expr to_expr forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< Maybe [Val] begin , [Expr] -> [Expr] add_hold forall a b. (a -> b) -> a -> b $ forall a b. (a -> Maybe b) -> [a] -> [b] mapMaybe [Val] -> Maybe Expr to_expr [[Val]] middles , [Val] -> Maybe Expr to_expr forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< Maybe [Val] end ) add_hold :: [Expr] -> [Expr] add_hold [] = [Symbol -> [Val] -> Expr EvaluatedExpr Symbol "-" []] add_hold [Expr] xs = [Expr] xs to_expr :: [Val] -> Maybe Expr to_expr [] = forall a. Maybe a Nothing to_expr (Val call : [Val] args) = forall a. a -> Maybe a Just forall a b. (a -> b) -> a -> b $ case Val call of DeriveT.VQuoted (DeriveT.Quoted Expr expr) -> Expr -> Expr QuotedExpr Expr expr DeriveT.VStr (Expr.Str Text sym) -> Symbol -> [Val] -> Expr EvaluatedExpr (Text -> Symbol Expr.Symbol Text sym) [Val] args Val _ -> Symbol -> [Val] -> Expr EvaluatedExpr (Text -> Symbol Expr.Symbol (forall a. ShowVal a => a -> Text ShowVal.show_val Val call)) [Val] args is_separator :: Val -> Bool is_separator Val DeriveT.VSeparator = Bool True is_separator Val _ = Bool False -- * start c_flat_start :: Derive.Generator Derive.Pitch c_flat_start :: Generator Pitch c_flat_start = forall d. CallName -> Tags -> Doc -> WithArgDoc (PassedArgs d -> Deriver d) -> Call (GeneratorFunc d) generator1 CallName "flat-start" forall a. Monoid a => a mempty Doc "Emit a flat pitch for the given duration." 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 "pitch" (forall a. Maybe a Nothing :: Maybe Sig.Dummy) Doc "Emit this pitch, or continue the previous pitch if not given." forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> forall a deflt. (Typecheck a, ToVal deflt) => ArgName -> deflt -> Doc -> Parser a Sig.defaulted ArgName "time" (RealTime -> DefaultReal Typecheck.real RealTime 0.15) Doc "Pitch lasts for this duration." ) forall a b. (a -> b) -> a -> b $ \(Maybe PitchOrTranspose maybe_pitch, Typecheck.DefaultReal Duration time) PassedArgs Pitch args -> do RealTime start <- forall a. PassedArgs a -> Deriver RealTime Args.real_start PassedArgs Pitch args RealTime end <- forall a. RealTime -> Duration -> PassedArgs a -> Deriver RealTime get_end RealTime start Duration time PassedArgs Pitch args RawPitch Untransposed_ pitch <- Maybe PitchOrTranspose -> RawPitch Untransposed_ -> RawPitch Untransposed_ optional_pitch Maybe PitchOrTranspose maybe_pitch forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> RealTime -> Deriver State Error (RawPitch Untransposed_) Call.get_pitch RealTime start forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ [(RealTime, RawPitch Untransposed_)] -> Pitch PSignal.from_pairs [(RealTime start, RawPitch Untransposed_ pitch), (RealTime end, RawPitch Untransposed_ pitch)] c_set_pitch :: Derive.Generator Derive.Pitch c_set_pitch :: Generator Pitch c_set_pitch = forall d. CallName -> Tags -> Doc -> WithArgDoc (PassedArgs d -> Deriver d) -> Call (GeneratorFunc d) generator1 CallName "set-pitch" forall a. Monoid a => a mempty Doc "Emit the current pitch.\ \ Sequence pitch calls normally use the previous pitch, and this is an\ \ implicit begin call so a sequence missing a begin doesn't inherit the\ \ previous pitch." forall a b. (a -> b) -> a -> b $ forall y d. Taggable y => Generator y d -> WithArgDoc (Generator y d) Sig.call0 forall a b. (a -> b) -> a -> b $ \PassedArgs Pitch args -> do RealTime start <- forall a. PassedArgs a -> Deriver RealTime Args.real_start PassedArgs Pitch args RawPitch Untransposed_ pitch <- RealTime -> Deriver State Error (RawPitch Untransposed_) Call.get_pitch RealTime start forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ RealTime -> RawPitch Untransposed_ -> Pitch PSignal.from_sample RealTime start RawPitch Untransposed_ pitch data PitchFrom = PitchFromPrev | PitchFromCurrent deriving (PitchFrom -> PitchFrom -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: PitchFrom -> PitchFrom -> Bool $c/= :: PitchFrom -> PitchFrom -> Bool == :: PitchFrom -> PitchFrom -> Bool $c== :: PitchFrom -> PitchFrom -> Bool Eq, Int -> PitchFrom -> ShowS [PitchFrom] -> ShowS PitchFrom -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [PitchFrom] -> ShowS $cshowList :: [PitchFrom] -> ShowS show :: PitchFrom -> String $cshow :: PitchFrom -> String showsPrec :: Int -> PitchFrom -> ShowS $cshowsPrec :: Int -> PitchFrom -> ShowS Show) data Fade = Fade | NoFade deriving (Fade -> Fade -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Fade -> Fade -> Bool $c/= :: Fade -> Fade -> Bool == :: Fade -> Fade -> Bool $c== :: Fade -> Fade -> Bool Eq, Int -> Fade -> ShowS [Fade] -> ShowS Fade -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Fade] -> ShowS $cshowList :: [Fade] -> ShowS show :: Fade -> String $cshow :: Fade -> String showsPrec :: Int -> Fade -> ShowS $cshowsPrec :: Int -> Fade -> ShowS Show) c_from :: PitchFrom -> Fade -> Derive.Generator Derive.Pitch c_from :: PitchFrom -> Fade -> Generator Pitch c_from PitchFrom pitch_from Fade fade = forall d. CallName -> Tags -> Doc -> WithArgDoc (PassedArgs d -> Deriver d) -> Call (GeneratorFunc d) generator1 CallName "from" forall a. Monoid a => a mempty (case PitchFrom pitch_from of PitchFrom PitchFromPrev -> Doc "Come for the previous pitch, and possibly fade in." PitchFrom PitchFromCurrent -> Doc "Come from a pitch, and possibly fade in.") 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 <$> case PitchFrom pitch_from of PitchFrom PitchFromPrev -> forall (f :: * -> *) a. Applicative f => a -> f a pure forall a. Maybe a Nothing PitchFrom PitchFromCurrent -> forall a deflt. (Typecheck a, ToVal deflt) => ArgName -> deflt -> Doc -> Parser a Sig.defaulted ArgName "from" (forall a. Maybe a Nothing :: Maybe Sig.Dummy) Doc "Come from this pitch, or the previous one." 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 "transition" DefaultReal default_transition Doc "Time to destination." 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" (forall a. Maybe a Nothing :: Maybe Sig.Dummy) Doc "Go to this pitch, or the current one." forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser Curve ControlUtil.curve_env ) forall a b. (a -> b) -> a -> b $ \(Maybe PitchOrTranspose from_pitch, Typecheck.DefaultReal Duration time, Maybe PitchOrTranspose maybe_to_pitch, Curve curve) PassedArgs Pitch args -> do RealTime start <- forall a. PassedArgs a -> Deriver RealTime Args.real_start PassedArgs Pitch args RealTime end <- forall a. RealTime -> Duration -> PassedArgs a -> Deriver RealTime get_end RealTime start Duration time PassedArgs Pitch args RawPitch Untransposed_ to_pitch <- Maybe PitchOrTranspose -> RawPitch Untransposed_ -> RawPitch Untransposed_ optional_pitch Maybe PitchOrTranspose maybe_to_pitch forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> RealTime -> Deriver State Error (RawPitch Untransposed_) Call.get_pitch RealTime start let from :: RawPitch Untransposed_ from = PassedArgs Pitch -> RawPitch Untransposed_ -> Maybe PitchOrTranspose -> RawPitch Untransposed_ resolve_pitch PassedArgs Pitch args RawPitch Untransposed_ to_pitch Maybe PitchOrTranspose from_pitch case Fade fade of Fade Fade -> RealTime -> Control -> Deriver State Error () ControlUtil.multiply_dyn RealTime end forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< Curve -> RealTime -> Double -> RealTime -> Double -> Deriver Control ControlUtil.make_segment Curve ControlUtil.Linear RealTime start Double 0 RealTime end Double 1 Fade NoFade -> forall (m :: * -> *) a. Monad m => a -> m a return () Curve -> RealTime -> RawPitch Untransposed_ -> RealTime -> RawPitch Untransposed_ -> Deriver Pitch PitchUtil.make_segment Curve curve RealTime start RawPitch Untransposed_ from RealTime end RawPitch Untransposed_ to_pitch -- | Get the end time, given a start and a duration. Don't go beyond the -- maximum, which is the event's duration, if given explicitly, or the next -- event if it's 0. get_end :: RealTime -> DeriveT.Duration -> Derive.PassedArgs a -> Derive.Deriver RealTime get_end :: forall a. RealTime -> Duration -> PassedArgs a -> Deriver RealTime get_end RealTime start Duration dur PassedArgs a args = do RealTime time_end <- (RealTime start +) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall t1 t2. (Time t1, Time t2) => t1 -> t2 -> Deriver RealTime Call.real_duration RealTime start Duration dur RealTime max_end <- if forall a. PassedArgs a -> ScoreTime Args.duration PassedArgs a args forall a. Eq a => a -> a -> Bool == ScoreTime 0 then forall a. Time a => a -> Deriver RealTime Derive.real forall a b. (a -> b) -> a -> b $ forall a. PassedArgs a -> ScoreTime Args.next PassedArgs a args else forall a. PassedArgs a -> Deriver RealTime Args.real_end PassedArgs a args forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a. Ord a => a -> a -> a min RealTime time_end RealTime max_end {- Reliance on the underlying pitch is awkward. E.g. jaru and p go to 0, but sometimes the hold is at -1 or something. This also leads to kam not being able to assume the base. Maybe there should be a generic way to transpose the base pitch. Or set the middle: > j 1 2; -1; p> -- Jaru 1 2 to -1, hold -1, then to 0 > j 1 2; k^ -1 1; p> -- Jaru 1 2, kam -1 1, to 0 So maybe the 'from' calls need to know what the first middle pitch is, so they can go to it. Or kam can start with the previous pitch, just like hold does: > j 1 2 -1; - ; p> -- Jaru 1 2 to -1, hold -1, then to 0 > j 1 2 -1; k^ 0 2; p> -- Jaru 1 2, kam -1 1, to 0 Since it starts with 0 I can omit: > j 1 2 -1; k^ 2; p> -- Jaru 1 2, kam -1 1, to 0 I think it doesn't read as nicely because each call depends on the previous one, and 'j' needs an extra arg. On the other hand, how is 'start' supposed to know the starting pitch of 'middle', especially when 'middle' may want to rely on the previous pitch? I guess the two approaches are incompatible. So to do it that way, I'd need to make middle calls not rely on prev_pitch, do a speculative middle eval, and communicate next pitch to the 'begin' call via an env var or something. Seems too complicated. -} c_jaru :: Bool -> Derive.Generator Derive.Pitch c_jaru :: Bool -> Generator Pitch c_jaru Bool append_zero = forall d. CallName -> Tags -> Doc -> WithArgDoc (PassedArgs d -> Deriver d) -> Call (GeneratorFunc d) generator1 CallName "jaru" forall a. Monoid a => a mempty Doc "This is a series of grace notes whose pitches are relative to the\ \ base pitch. The 0 variant appends a 0 on the 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 (NonEmpty a) Sig.many1 ArgName "interval" Doc "Intervals from base pitch." forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> forall a deflt. (Typecheck a, ToVal deflt) => ArgName -> EnvironDefault -> deflt -> Doc -> Parser a Sig.environ ArgName "time" EnvironDefault Sig.Both DefaultReal default_transition Doc "Time for each note." -- TODO This should also be a Duration forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> forall a deflt. (Typecheck a, ToVal deflt) => ArgName -> EnvironDefault -> deflt -> Doc -> Parser a Sig.environ ArgName "transition" EnvironDefault Sig.Both (forall a. Maybe a Nothing :: Maybe Sig.Dummy) Doc "Time for each slide, defaults to `time`." forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser Curve ControlUtil.curve_env ) forall a b. (a -> b) -> a -> b $ \(NonEmpty DefaultDiatonic intervals, Typecheck.DefaultReal Duration time_, Maybe RealTime maybe_transition, Curve curve) PassedArgs Pitch args -> do RealTime start <- forall a. PassedArgs a -> Deriver RealTime Args.real_start PassedArgs Pitch args -- Adjust time per note based on the available duration. -- Since transitions can start at 0 and end at the end, I'm dividing -- the duration into intervals-1 parts. let len :: Int len = forall a. NonEmpty a -> Int NonEmpty.length NonEmpty DefaultDiatonic intervals forall a. Num a => a -> a -> a - Int 1 RealTime end <- forall a. RealTime -> Duration -> PassedArgs a -> Deriver RealTime get_end RealTime start (Duration -> Double -> Duration DeriveT.multiply_duration Duration time_ (forall a b. (Integral a, Num b) => a -> b fromIntegral Int len)) PassedArgs Pitch args let time :: RealTime time = (RealTime end forall a. Num a => a -> a -> a - RealTime start) forall a. Fractional a => a -> a -> a / forall a b. (Integral a, Num b) => a -> b fromIntegral Int len RawPitch Untransposed_ pitch <- RealTime -> Deriver State Error (RawPitch Untransposed_) Call.get_pitch RealTime start RealTime srate <- Deriver RealTime Call.get_srate (NonEmpty Double intervals, Control control) <- NonEmpty DefaultDiatonic -> Deriver State Error (NonEmpty Double, Control) parse NonEmpty DefaultDiatonic intervals let transition :: RealTime transition = forall a. a -> Maybe a -> a fromMaybe RealTime time Maybe RealTime maybe_transition let sig :: Control sig = Curve -> RealTime -> RealTime -> RealTime -> RealTime -> [Double] -> Control jaru Curve curve RealTime srate RealTime start RealTime time RealTime transition forall a b. (a -> b) -> a -> b $ forall a. NonEmpty a -> [a] NonEmpty.toList NonEmpty Double intervals forall a. [a] -> [a] -> [a] ++ if Bool append_zero then [Double 0] else [] forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ Control -> Typed Control -> Pitch -> Pitch PSignal.apply_control Control control (forall a. a -> Typed a ScoreT.untyped Control sig) forall a b. (a -> b) -> a -> b $ RealTime -> RawPitch Untransposed_ -> Pitch PSignal.from_sample RealTime start RawPitch Untransposed_ pitch where parse :: NonEmpty DefaultDiatonic -> Deriver State Error (NonEmpty Double, Control) parse NonEmpty DefaultDiatonic intervals | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool all (forall a. Eq a => a -> a -> Bool ==Control control) [Control] controls = forall (m :: * -> *) a. Monad m => a -> m a return (NonEmpty Double xs, Control control) | Bool otherwise = forall a. HasCallStack => Text -> Deriver a Derive.throw Text "all intervals must have the same type" where (NonEmpty Double xs, Control control :| [Control] controls) = forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b) NonEmpty.unzip forall a b. (a -> b) -> a -> b $ forall a b. (a -> b) -> NonEmpty a -> NonEmpty b NonEmpty.map (Transpose -> (Double, Control) Controls.transpose_control forall b c a. (b -> c) -> (a -> b) -> a -> c . DefaultDiatonic -> Transpose Typecheck.default_diatonic) NonEmpty DefaultDiatonic intervals jaru :: ControlUtil.Curve -> RealTime -> RealTime -> RealTime -> RealTime -> [Signal.Y] -> Signal.Control jaru :: Curve -> RealTime -> RealTime -> RealTime -> RealTime -> [Double] -> Control jaru Curve curve RealTime srate RealTime start RealTime time RealTime transition [Double] intervals = Curve -> RealTime -> RealTime -> [(RealTime, Double)] -> Control ControlUtil.smooth_absolute Curve curve RealTime srate (-RealTime transition) forall a b. (a -> b) -> a -> b $ forall a b. [a] -> [b] -> [(a, b)] zip (forall a. Num a => a -> a -> [a] Lists.range_ RealTime start RealTime time) [Double] intervals -- * middle c_flat :: Derive.Generator Derive.Pitch c_flat :: Generator Pitch c_flat = forall d. CallName -> Tags -> Doc -> WithArgDoc (PassedArgs d -> Deriver d) -> Call (GeneratorFunc d) generator1 CallName "flat" forall a. Monoid a => a mempty Doc "Emit a flat pitch." forall a b. (a -> b) -> a -> b $ forall y a d. Taggable y => Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d) Sig.call (forall a deflt. (Typecheck a, ToVal deflt) => ArgName -> deflt -> Doc -> Parser a Sig.defaulted ArgName "pitch" (forall a. Maybe a Nothing :: Maybe Sig.Dummy) Doc "Emit this pitch, or continue the previous pitch if not given.") forall a b. (a -> b) -> a -> b $ \Maybe PitchOrTranspose maybe_pitch PassedArgs Pitch args -> do RealTime start <- forall a. PassedArgs a -> Deriver RealTime Args.real_start PassedArgs Pitch args RealTime end <- forall a. PassedArgs a -> Deriver RealTime Args.real_end PassedArgs Pitch args RawPitch Untransposed_ pitch <- case Maybe PitchOrTranspose maybe_pitch of Maybe PitchOrTranspose Nothing -> RealTime -> PassedArgs Pitch -> Deriver State Error (RawPitch Untransposed_) prev_pitch RealTime start PassedArgs Pitch args Just PitchOrTranspose transpose -> do RawPitch Untransposed_ pitch <- RealTime -> Deriver State Error (RawPitch Untransposed_) Call.get_pitch RealTime start forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ RawPitch Untransposed_ -> PitchOrTranspose -> RawPitch Untransposed_ PitchUtil.resolve_pitch_transpose RawPitch Untransposed_ pitch PitchOrTranspose transpose forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ [(RealTime, RawPitch Untransposed_)] -> Pitch PSignal.from_pairs [(RealTime start, RawPitch Untransposed_ pitch), (RealTime end, RawPitch Untransposed_ pitch)] -- ** kampita data KampitaArgs = -- | Both interval arguments are hardcoded. Kampita0 !Signal.Y !Signal.Y -- | The starting pitch is hardcoded. | Kampita1 !Signal.Y -- | Both arguments must be provided. | Kampita2 deriving (Int -> KampitaArgs -> ShowS [KampitaArgs] -> ShowS KampitaArgs -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [KampitaArgs] -> ShowS $cshowList :: [KampitaArgs] -> ShowS show :: KampitaArgs -> String $cshow :: KampitaArgs -> String showsPrec :: Int -> KampitaArgs -> ShowS $cshowsPrec :: Int -> KampitaArgs -> ShowS Show) c_kampita:: Doc.Doc -> KampitaArgs -> Maybe Trill.Direction -> Derive.Generator Derive.Pitch c_kampita :: Doc -> KampitaArgs -> Maybe Direction -> Generator Pitch c_kampita Doc doc KampitaArgs kam_args Maybe Direction end_dir = forall d. CallName -> Tags -> Doc -> WithArgDoc (PassedArgs d -> Deriver d) -> Call (GeneratorFunc d) generator1 CallName "kam" forall a. Monoid a => a mempty (Doc "This is a kind of trill, but its interval defaults to NNs,\ \ and transitions between the notes are smooth. It's intended for\ \ the vocal microtonal trills common in Carnatic music." forall a. Semigroup a => a -> a -> a <> if Doc doc forall a. Eq a => a -> a -> Bool == Doc "" then Doc "" else Doc "\n" forall a. Semigroup a => a -> a -> a <> Doc doc) forall a b. (a -> b) -> a -> b $ forall y a d. Taggable y => Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d) Sig.call ((,,,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> KampitaArgs -> Parser (NnTransposeFunctionT, NnTransposeFunctionT) kampita_pitch_args KampitaArgs kam_args 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" (Double 6 :: Double) Doc "Alternate pitches at this speed." forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser (RealTime, Duration, Double, Adjust) kampita_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser Curve ControlUtil.curve_env ) forall a b. (a -> b) -> a -> b $ \((NnTransposeFunctionT, NnTransposeFunctionT) pitches, RealTimeFunctionT speed, (RealTime transition, Duration hold, Double lilt, Adjust adjust), Curve curve) PassedArgs Pitch args -> do ((Function, Function) pitches, Control control) <- KampitaArgs -> (NnTransposeFunctionT, NnTransposeFunctionT) -> Deriver ((Function, Function), Control) resolve_pitches KampitaArgs kam_args (NnTransposeFunctionT, NnTransposeFunctionT) pitches RealTime start <- forall a. PassedArgs a -> Deriver RealTime Args.real_start PassedArgs Pitch args let even :: Maybe Bool even = RealTime -> (Function, Function) -> Maybe Direction -> Maybe Bool end_wants_even_transitions RealTime start (Function, Function) pitches Maybe Direction end_dir Control transpose <- Curve -> Maybe Bool -> Adjust -> (Function, Function) -> RealTimeFunctionT -> RealTime -> Duration -> Double -> (ScoreTime, ScoreTime) -> Deriver Control kampita_transpose Curve curve Maybe Bool even Adjust adjust (Function, Function) pitches RealTimeFunctionT speed RealTime transition Duration hold Double lilt (forall a. PassedArgs a -> (ScoreTime, ScoreTime) Args.range PassedArgs Pitch args) RealTime -> PassedArgs Pitch -> Control -> Control -> Deriver Pitch kampita RealTime start PassedArgs Pitch args Control control Control transpose c_nkampita :: Doc.Doc -> KampitaArgs -> Maybe Trill.Direction -> Derive.Generator Derive.Pitch c_nkampita :: Doc -> KampitaArgs -> Maybe Direction -> Generator Pitch c_nkampita Doc doc KampitaArgs kam_args Maybe Direction end_dir = forall d. CallName -> Tags -> Doc -> WithArgDoc (PassedArgs d -> Deriver d) -> Call (GeneratorFunc d) generator1 CallName "nkam" forall a. Monoid a => a mempty (Doc "`kam` with a set number of cycles. The speed adjusts to fit the cycles in\ \ before the next event." forall a. Semigroup a => a -> a -> a <> if Doc doc forall a. Eq a => a -> a -> Bool == Doc "" then Doc "" else Doc "\n" forall a. Semigroup a => a -> a -> a <> Doc doc) forall a b. (a -> b) -> a -> b $ forall y a d. Taggable y => Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d) Sig.call ((,,,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (forall a. Positive a -> a Typecheck.positive 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 "cycles" (Double 1 :: Double) Doc "Number of cycles.") forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> KampitaArgs -> Parser (NnTransposeFunctionT, NnTransposeFunctionT) kampita_pitch_args KampitaArgs kam_args forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser (RealTime, Duration, Double, Adjust) kampita_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser Curve ControlUtil.curve_env ) forall a b. (a -> b) -> a -> b $ \(Double cycles, (NnTransposeFunctionT, NnTransposeFunctionT) pitches, (RealTime transition, Duration hold, Double lilt, Adjust adjust), Curve curve) PassedArgs Pitch args -> do ((Function, Function) pitches, Control control) <- KampitaArgs -> (NnTransposeFunctionT, NnTransposeFunctionT) -> Deriver ((Function, Function), Control) resolve_pitches KampitaArgs kam_args (NnTransposeFunctionT, NnTransposeFunctionT) pitches (RealTime start, RealTime end) <- forall a. PassedArgs a -> Deriver (RealTime, RealTime) Args.real_range_or_next PassedArgs Pitch args let even :: Maybe Bool even = RealTime -> (Function, Function) -> Maybe Direction -> Maybe Bool end_wants_even_transitions RealTime start (Function, Function) pitches Maybe Direction end_dir -- 1 cycle means a complete cycle, which is 3 transitions, but -- 'end_dir' may reduce the number of transitions, to a minimum of 2, -- which winds up sounding like a single transition: [0, 1]. let num_transitions :: Double num_transitions = Double cycles forall a. Num a => a -> a -> a * Double 2 forall a. Num a => a -> a -> a + if Maybe Bool even forall a. Eq a => a -> a -> Bool == forall a. a -> Maybe a Just Bool True then Double 0 else Double 1 let speed :: RealTimeFunctionT speed = TimeT -> Function -> RealTimeFunctionT Typecheck.RealTimeFunctionT TimeT ScoreT.TReal (forall a b. a -> b -> a const forall a b. (a -> b) -> a -> b $ (Double num_transitions forall a. Num a => a -> a -> a - Double 1) forall a. Fractional a => a -> a -> a / Function RealTime.to_seconds (RealTime end forall a. Num a => a -> a -> a - RealTime start)) Control transpose <- Curve -> Maybe Bool -> Adjust -> (Function, Function) -> RealTimeFunctionT -> RealTime -> Duration -> Double -> (ScoreTime, ScoreTime) -> Deriver Control kampita_transpose Curve curve Maybe Bool even Adjust adjust (Function, Function) pitches RealTimeFunctionT speed RealTime transition Duration hold Double lilt (forall a. PassedArgs a -> (ScoreTime, ScoreTime) Args.range PassedArgs Pitch args) RealTime -> PassedArgs Pitch -> Control -> Control -> Deriver Pitch kampita RealTime start PassedArgs Pitch args Control control Control transpose -- ** implementation resolve_pitches :: KampitaArgs -> (Typecheck.NnTransposeFunctionT, Typecheck.NnTransposeFunctionT) -> Derive.Deriver ((ScoreT.Function, ScoreT.Function), ScoreT.Control) resolve_pitches :: KampitaArgs -> (NnTransposeFunctionT, NnTransposeFunctionT) -> Deriver ((Function, Function), Control) resolve_pitches KampitaArgs kam_args ( Typecheck.NnTransposeFunctionT TransposeT ttype1 Function pitch1 , Typecheck.NnTransposeFunctionT TransposeT ttype2 Function pitch2) = do let control1 :: Control control1 = TransposeT -> Control Typecheck.transpose_control TransposeT ttype1 let control2 :: Control control2 = TransposeT -> Control Typecheck.transpose_control TransposeT ttype2 let two_pitches :: Bool two_pitches = case KampitaArgs kam_args of KampitaArgs Kampita2 -> Bool False KampitaArgs _ -> Bool True forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (Bool two_pitches Bool -> Bool -> Bool && Control control1 forall a. Eq a => a -> a -> Bool /= Control control2) forall a b. (a -> b) -> a -> b $ forall a. HasCallStack => Text -> Deriver a Derive.throw forall a b. (a -> b) -> a -> b $ Text "pitch1 and pitch2 signals should have the same type: " forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty Control control1 forall a. Semigroup a => a -> a -> a <> Text " /= " forall a. Semigroup a => a -> a -> a <> forall a. Pretty a => a -> Text pretty Control control2 forall (m :: * -> *) a. Monad m => a -> m a return ((Function pitch1, Function pitch2), Control control1) kampita_pitch_args :: KampitaArgs -> Sig.Parser (Typecheck.NnTransposeFunctionT, Typecheck.NnTransposeFunctionT) kampita_pitch_args :: KampitaArgs -> Parser (NnTransposeFunctionT, NnTransposeFunctionT) kampita_pitch_args KampitaArgs kam_args = case KampitaArgs kam_args of Kampita0 Double p1 Double p2 -> (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (f :: * -> *) a. Applicative f => a -> f a pure (Double -> NnTransposeFunctionT control Double p1) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> forall (f :: * -> *) a. Applicative f => a -> f a pure (Double -> NnTransposeFunctionT control Double p2) Kampita1 Double p1 -> (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (f :: * -> *) a. Applicative f => a -> f a pure (Double -> NnTransposeFunctionT control Double p1) 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 "neighbor" (Double 1 :: Double) Doc "Alternate with a pitch at this interval." KampitaArgs Kampita2 -> (,) 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 "pitch1" (Double 0 :: Double) Doc "First interval." 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 "pitch2" (Double 1 :: Double) Doc "Second interval." where control :: Double -> NnTransposeFunctionT control Double val = TransposeT -> Function -> NnTransposeFunctionT Typecheck.NnTransposeFunctionT TransposeT ScoreT.TNn (forall a b. a -> b -> a const Double val) kampita_env :: Sig.Parser (RealTime, DeriveT.Duration, Double, Trill.Adjust) kampita_env :: Parser (RealTime, Duration, Double, Adjust) kampita_env = (,,,) 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.defaulted_env ArgName "transition" EnvironDefault Sig.Both RealTime default_transition_ Doc "Time for each slide." forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser Duration Trill.hold_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser Double lilt_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Parser Adjust Trill.adjust_env where lilt_env :: Sig.Parser Double lilt_env :: Parser Double lilt_env = forall a deflt. (Typecheck a, ToVal deflt) => ArgName -> EnvironDefault -> deflt -> Doc -> Parser a Sig.environ ArgName "lilt" EnvironDefault Sig.Prefixed (Double 0 :: Double) Doc "Lilt is a horizontal bias to the vibrato. A lilt of 1 would place\ \ each neighbor on top of the following unison, while -1 would place\ \ it on the previous one. So it should range from -1 < lilt < 1." default_transition :: Typecheck.DefaultReal default_transition :: DefaultReal default_transition = RealTime -> DefaultReal Typecheck.real RealTime default_transition_ default_transition_ :: RealTime default_transition_ :: RealTime default_transition_ = RealTime 0.12 kampita :: RealTime -> Derive.PitchArgs -> ScoreT.Control -> Signal.Control -> Derive.Deriver PSignal.PSignal kampita :: RealTime -> PassedArgs Pitch -> Control -> Control -> Deriver Pitch kampita RealTime start PassedArgs Pitch args Control control Control transpose = do RawPitch Untransposed_ pitch <- RealTime -> PassedArgs Pitch -> Deriver State Error (RawPitch Untransposed_) prev_pitch RealTime start PassedArgs Pitch args forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ Control -> Typed Control -> Pitch -> Pitch PSignal.apply_control Control control (forall a. a -> Typed a ScoreT.untyped Control transpose) forall a b. (a -> b) -> a -> b $ RealTime -> RawPitch Untransposed_ -> Pitch PSignal.from_sample RealTime start RawPitch Untransposed_ pitch -- | You don't think there are too many arguments, do you? kampita_transpose :: ControlUtil.Curve -> Maybe Bool -> Trill.Adjust -> (ScoreT.Function, ScoreT.Function) -> Typecheck.RealTimeFunctionT -> RealTime -> DeriveT.Duration -> Double -> (ScoreTime, ScoreTime) -> Derive.Deriver Signal.Control kampita_transpose :: Curve -> Maybe Bool -> Adjust -> (Function, Function) -> RealTimeFunctionT -> RealTime -> Duration -> Double -> (ScoreTime, ScoreTime) -> Deriver Control kampita_transpose Curve curve Maybe Bool even Adjust adjust (Function pitch1, Function pitch2) RealTimeFunctionT speed RealTime transition Duration hold Double lilt (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 Curve -> RealTime -> Function -> Function -> [RealTime] -> Deriver Control smooth_trill Curve curve (-RealTime transition) Function pitch1 Function pitch2 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< Maybe Bool -> Adjust -> Double -> ScoreTime -> RealTimeFunctionT -> (ScoreTime, ScoreTime) -> Deriver [RealTime] trill_transitions Maybe Bool even Adjust adjust Double lilt ScoreTime hold RealTimeFunctionT speed (ScoreTime start, ScoreTime end) smooth_trill :: ControlUtil.Curve -> RealTime -> ScoreT.Function -> ScoreT.Function -> [RealTime] -> Derive.Deriver Signal.Control smooth_trill :: Curve -> RealTime -> Function -> Function -> [RealTime] -> Deriver Control smooth_trill Curve curve RealTime time Function val1 Function val2 [RealTime] transitions = do RealTime srate <- Deriver RealTime Call.get_srate forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ Curve -> RealTime -> RealTime -> [(RealTime, Double)] -> Control ControlUtil.smooth_absolute Curve curve RealTime srate RealTime time forall a b. (a -> b) -> a -> b $ Function -> Function -> [RealTime] -> [(RealTime, Double)] trill_from_transitions Function val1 Function val2 [RealTime] transitions -- | Make a trill signal from a list of transition times. trill_from_transitions :: ScoreT.Function -> ScoreT.Function -> [RealTime] -> [(RealTime, Signal.Y)] trill_from_transitions :: Function -> Function -> [RealTime] -> [(RealTime, Double)] trill_from_transitions Function val1 Function val2 [RealTime] transitions = [(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])] trill_transitions :: Maybe Bool -> Trill.Adjust -> Double -> ScoreTime -> Typecheck.RealTimeFunctionT -> (ScoreTime, ScoreTime) -> Derive.Deriver [RealTime] trill_transitions :: Maybe Bool -> Adjust -> Double -> ScoreTime -> RealTimeFunctionT -> (ScoreTime, ScoreTime) -> Deriver [RealTime] trill_transitions Maybe Bool even Adjust adjust Double bias ScoreTime hold RealTimeFunctionT speed (ScoreTime, ScoreTime) start_end = Config -> ScoreTime -> Maybe Bool -> (ScoreTime, ScoreTime) -> Deriver [RealTime] Trill.adjusted_transitions Config config ScoreTime hold Maybe Bool even (ScoreTime, ScoreTime) start_end where config :: Config config = Trill.Config { _start_dir :: Maybe Direction _start_dir = forall a. Maybe a Nothing , _end_dir :: Maybe Direction _end_dir = forall a. Maybe a Nothing , _adjust :: Adjust _adjust = Adjust adjust , _hold :: Duration _hold = ScoreTime -> Duration DeriveT.ScoreDuration ScoreTime 0 , _speed :: RealTimeFunctionT _speed = RealTimeFunctionT speed , _bias :: Double _bias = Double bias -- 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. , _include_end :: Bool _include_end = Bool True } end_wants_even_transitions :: RealTime -> (ScoreT.Function, ScoreT.Function) -> Maybe Trill.Direction -> Maybe Bool end_wants_even_transitions :: RealTime -> (Function, Function) -> Maybe Direction -> Maybe Bool end_wants_even_transitions RealTime start (Function pitch1, Function pitch2) Maybe Direction dir = case Maybe Direction dir of Maybe Direction Nothing -> forall a. Maybe a Nothing Just Direction Trill.Low -> forall a. a -> Maybe a Just (Bool -> Bool not Bool pitch1_low) Just Direction Trill.High -> forall a. a -> Maybe a Just Bool pitch1_low where pitch1_low :: Bool pitch1_low = Function pitch1 RealTime start forall a. Ord a => a -> a -> Bool <= Function pitch2 RealTime start -- * end c_flat_end :: Derive.Generator Derive.Pitch c_flat_end :: Generator Pitch c_flat_end = forall d. CallName -> Tags -> Doc -> WithArgDoc (PassedArgs d -> Deriver d) -> Call (GeneratorFunc d) generator1 CallName "flat-end" forall a. Monoid a => a mempty Doc "Emit a flat pitch for the given duration." 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 "pitch" (forall a. Maybe a Nothing :: Maybe Sig.Dummy) Doc "Emit this pitch, or continue the previous pitch if not given." forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> forall a deflt. (Typecheck a, ToVal deflt) => ArgName -> deflt -> Doc -> Parser a Sig.defaulted ArgName "time" (RealTime -> DefaultReal Typecheck.real RealTime 0.15) Doc "Pitch lasts for this duration." ) forall a b. (a -> b) -> a -> b $ \(Maybe PitchOrTranspose maybe_pitch, Typecheck.DefaultReal Duration time) PassedArgs Pitch args -> do (RealTime start, RealTime end) <- forall a. PassedArgs a -> Deriver (RealTime, RealTime) Args.real_range PassedArgs Pitch args RealTime start <- RealTime -> RealTime -> Duration -> Deriver RealTime align_to_end RealTime start RealTime end Duration time RawPitch Untransposed_ pitch <- Maybe PitchOrTranspose -> RawPitch Untransposed_ -> RawPitch Untransposed_ optional_pitch Maybe PitchOrTranspose maybe_pitch forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> RealTime -> PassedArgs Pitch -> Deriver State Error (RawPitch Untransposed_) prev_pitch RealTime start PassedArgs Pitch args forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ [(RealTime, RawPitch Untransposed_)] -> Pitch PSignal.from_pairs [(RealTime start, RawPitch Untransposed_ pitch), (RealTime end, RawPitch Untransposed_ pitch)] c_to :: Fade -> Derive.Generator Derive.Pitch c_to :: Fade -> Generator Pitch c_to Fade fade = forall d. CallName -> Tags -> Doc -> WithArgDoc (PassedArgs d -> Deriver d) -> Call (GeneratorFunc d) generator1 CallName "to" forall a. Monoid a => a mempty Doc "Go to a pitch, and possibly fade out." 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 "pitch" Doc "Go to this pitch or interval." 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 "transition" DefaultReal default_transition Doc "Time to destination pitch." ) forall a b. (a -> b) -> a -> b $ \(PitchOrTranspose to_pitch, Typecheck.DefaultReal Duration time) PassedArgs Pitch args -> do (RealTime start, RealTime end) <- forall a. PassedArgs a -> Deriver (RealTime, RealTime) Args.real_range PassedArgs Pitch args RealTime start <- RealTime -> RealTime -> Duration -> Deriver RealTime align_to_end RealTime start RealTime end Duration time RawPitch Untransposed_ pitch <- RealTime -> PassedArgs Pitch -> Deriver State Error (RawPitch Untransposed_) prev_pitch RealTime start PassedArgs Pitch args case Fade fade of Fade Fade -> RealTime -> Control -> Deriver State Error () ControlUtil.multiply_dyn RealTime end forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< Curve -> RealTime -> Double -> RealTime -> Double -> Deriver Control ControlUtil.make_segment Curve ControlUtil.Linear RealTime start Double 1 RealTime end Double 0 Fade NoFade -> forall (m :: * -> *) a. Monad m => a -> m a return () Curve -> RealTime -> RawPitch Untransposed_ -> RealTime -> RawPitch Untransposed_ -> Deriver Pitch PitchUtil.make_segment Curve ControlUtil.Linear RealTime start RawPitch Untransposed_ pitch RealTime end (RawPitch Untransposed_ -> PitchOrTranspose -> RawPitch Untransposed_ PitchUtil.resolve_pitch_transpose RawPitch Untransposed_ pitch PitchOrTranspose to_pitch) c_fade :: Bool -> Derive.Generator Derive.Pitch c_fade :: Bool -> Generator Pitch c_fade Bool fade_in = forall d. CallName -> Tags -> Doc -> WithArgDoc (PassedArgs d -> Deriver d) -> Call (GeneratorFunc d) generator1 CallName "fade" forall a. Monoid a => a mempty ((if Bool fade_in then Doc "Fade in." else Doc "Fade out.") forall a. Semigroup a => a -> a -> a <> Doc " This will overlap with the pitch part of the " forall a. Semigroup a => a -> a -> a <> (if Bool fade_in then Doc "next" else Doc "previous") forall a. Semigroup a => a -> a -> a <> Doc " call." ) forall a b. (a -> b) -> a -> b $ forall y a d. Taggable y => Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d) Sig.call (forall a deflt. (Typecheck a, ToVal deflt) => ArgName -> deflt -> Doc -> Parser a Sig.defaulted ArgName "time" (RealTime -> DefaultReal Typecheck.real RealTime 0.15) Doc "Time to fade.") forall a b. (a -> b) -> a -> b $ \(Typecheck.DefaultReal Duration time) PassedArgs Pitch args -> do (RealTime start, RealTime end) <- forall a. PassedArgs a -> Deriver (RealTime, RealTime) Args.real_range PassedArgs Pitch args (RealTime start, RealTime end) <- if Bool fade_in then (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (m :: * -> *) a. Monad m => a -> m a return RealTime start forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> forall a. RealTime -> Duration -> PassedArgs a -> Deriver RealTime get_end RealTime start Duration time PassedArgs Pitch args else (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> RealTime -> RealTime -> Duration -> Deriver RealTime align_to_end RealTime start RealTime end Duration time forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> forall (m :: * -> *) a. Monad m => a -> m a return RealTime end RealTime -> Control -> Deriver State Error () ControlUtil.multiply_dyn RealTime end forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< Curve -> RealTime -> Double -> RealTime -> Double -> Deriver Control ControlUtil.make_segment Curve ControlUtil.Linear RealTime start Double 1 RealTime end Double 0 forall (m :: * -> *) a. Monad m => a -> m a return forall a. Monoid a => a mempty -- | Subtract the duration from the given end time, but don't go past the -- start. align_to_end :: RealTime -> RealTime -> DeriveT.Duration -> Derive.Deriver RealTime align_to_end :: RealTime -> RealTime -> Duration -> Deriver RealTime align_to_end RealTime start RealTime end Duration dur = do RealTime dur <- forall a. Ord a => a -> a -> a min (RealTime end forall a. Num a => a -> a -> a - RealTime start) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall t1 t2. (Time t1, Time t2) => t1 -> t2 -> Deriver RealTime Call.real_duration RealTime start Duration dur forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ RealTime end forall a. Num a => a -> a -> a - RealTime dur -- * misc c_sahitya :: Derive.Taggable a => Derive.Transformer a c_sahitya :: forall a. Taggable a => Transformer a c_sahitya = forall d. Module -> CallName -> Tags -> Doc -> WithArgDoc (TransformerF d) -> Transformer d Derive.transformer Module module_ CallName "sahitya" forall a. Monoid a => a mempty Doc "Ignore the transformed deriver. Put this on a track to ignore its\ \ contents, and put in sahitya." forall a b. (a -> b) -> a -> b $ forall y d. Taggable y => Transformer y d -> WithArgDoc (Transformer y d) Sig.call0t forall a b. (a -> b) -> a -> b $ \PassedArgs a _args Deriver (Stream a) _deriver -> forall (m :: * -> *) a. Monad m => a -> m a return forall a. Stream a Stream.empty -- * util -- | This defaults to the note's base pitch, in case this call is the first -- one. Also, the end call is called before the middle calls to find out how -- long it is. prev_pitch :: RealTime -> Derive.PitchArgs -> Derive.Deriver PSignal.Pitch prev_pitch :: RealTime -> PassedArgs Pitch -> Deriver State Error (RawPitch Untransposed_) prev_pitch RealTime start PassedArgs Pitch args = case PassedArgs Pitch -> Maybe (RealTime, RawPitch Untransposed_) Args.prev_pitch PassedArgs Pitch args of Maybe (RealTime, RawPitch Untransposed_) Nothing -> RealTime -> Deriver State Error (RawPitch Untransposed_) Call.get_pitch RealTime start Just (RealTime _, RawPitch Untransposed_ pitch) -> forall (m :: * -> *) a. Monad m => a -> m a return RawPitch Untransposed_ pitch resolve_pitch :: Derive.PitchArgs -> PSignal.Pitch -> Maybe PitchUtil.PitchOrTranspose -> PSignal.Pitch resolve_pitch :: PassedArgs Pitch -> RawPitch Untransposed_ -> Maybe PitchOrTranspose -> RawPitch Untransposed_ resolve_pitch PassedArgs Pitch args RawPitch Untransposed_ this_pitch Maybe PitchOrTranspose maybe_pitch = case Maybe PitchOrTranspose maybe_pitch of Maybe PitchOrTranspose Nothing -> case PassedArgs Pitch -> Maybe (RealTime, RawPitch Untransposed_) Args.prev_pitch PassedArgs Pitch args of Maybe (RealTime, RawPitch Untransposed_) Nothing -> RawPitch Untransposed_ this_pitch Just (RealTime _, RawPitch Untransposed_ prev) -> RawPitch Untransposed_ prev Just (Left RawPitch Untransposed_ pitch) -> RawPitch Untransposed_ pitch Just (Right Transpose transpose) -> forall a. Transpose -> RawPitch a -> RawPitch a Pitches.transpose Transpose transpose RawPitch Untransposed_ this_pitch -- | A number of calls take an optional pitch, and default to either -- the current or previous pitch. optional_pitch :: Maybe PitchUtil.PitchOrTranspose -> PSignal.Pitch -> PSignal.Pitch optional_pitch :: Maybe PitchOrTranspose -> RawPitch Untransposed_ -> RawPitch Untransposed_ optional_pitch Maybe PitchOrTranspose maybe_pitch RawPitch Untransposed_ current_pitch = forall b a. b -> (a -> b) -> Maybe a -> b maybe RawPitch Untransposed_ current_pitch (RawPitch Untransposed_ -> PitchOrTranspose -> RawPitch Untransposed_ PitchUtil.resolve_pitch_transpose RawPitch Untransposed_ current_pitch) Maybe PitchOrTranspose maybe_pitch generator1 :: Derive.CallName -> Tags.Tags -> Doc.Doc -> Derive.WithArgDoc (Derive.PassedArgs d -> Derive.Deriver d) -> Derive.Call (Derive.GeneratorFunc d) generator1 :: forall d. CallName -> Tags -> Doc -> WithArgDoc (PassedArgs d -> Deriver d) -> Call (GeneratorFunc d) generator1 = forall d. Module -> CallName -> Tags -> Doc -> WithArgDoc (PassedArgs d -> Deriver d) -> Generator d Derive.generator1 Module module_