From ae2db5b21bf232f5145f3a3e091689c8fc7247e9 Mon Sep 17 00:00:00 2001 From: David Kastrup Date: Sat, 28 Apr 2012 13:00:46 +0200 Subject: [PATCH] Make EventClass hierarchy a property of Global context --- input/regression/scheme-text-spanner.ly | 33 +++++++++++++++------ lily/context-scheme.cc | 12 ++++++++ lily/context.cc | 15 ++++++++-- lily/engraver.cc | 2 +- lily/global-context.cc | 7 +++++ lily/include/context.hh | 7 +++++ lily/include/music.hh | 3 +- lily/music.cc | 11 ++++--- lily/part-combine-iterator.cc | 19 ++++++------- lily/rhythmic-music-iterator.cc | 2 +- ly/engraver-init.ly | 1 + ly/performer-init.ly | 1 + scm/define-context-properties.scm | 1 + scm/define-event-classes.scm | 38 ++++--------------------- scm/document-music.scm | 6 ++-- 15 files changed, 93 insertions(+), 65 deletions(-) diff --git a/input/regression/scheme-text-spanner.ly b/input/regression/scheme-text-spanner.ly index c0204d55c7..00cf863bd6 100644 --- a/input/regression/scheme-text-spanner.ly +++ b/input/regression/scheme-text-spanner.ly @@ -6,11 +6,27 @@ and grob creation methods to create a fully functional text spanner in scheme." } -#(define-event-class 'scheme-text-span-event - '(scheme-text-span-event - span-event - music-event - StreamEvent)) +#(define my-grob-descriptions '()) + +#(define my-event-classes (ly:make-context-mod)) + +defineEventClass = +#(define-void-function (parser location class parent) + (symbol? symbol?) + (ly:add-context-mod + my-event-classes + `(apply + ,(lambda (context class parent) + (ly:context-set-property! + context + 'EventClasses + (event-class-cons + class + parent + (ly:context-property context 'EventClasses '())))) + ,class ,parent))) + +\defineEventClass #'scheme-text-span-event #'span-event #(define (add-grob-definition grob-name grob-entry) (let* ((meta-entry (assoc-get 'meta grob-entry)) @@ -33,9 +49,9 @@ in scheme." (set! meta-entry (assoc-set! meta-entry 'interfaces ifaces-entry)) (set! grob-entry (assoc-set! grob-entry 'meta meta-entry)) - (set! all-grob-descriptions + (set! my-grob-descriptions (cons (cons grob-name grob-entry) - all-grob-descriptions)))) + my-grob-descriptions)))) #(add-grob-definition 'SchemeTextSpanner @@ -181,7 +197,8 @@ schemeTextSpannerEnd = \layout { \context { \Global - \grobdescriptions #all-grob-descriptions + \grobdescriptions #my-grob-descriptions + #my-event-classes } \context { \Voice diff --git a/lily/context-scheme.cc b/lily/context-scheme.cc index f58a793ed4..4f3818ecd8 100644 --- a/lily/context-scheme.cc +++ b/lily/context-scheme.cc @@ -211,3 +211,15 @@ LY_DEFINE (ly_context_events_below, "ly:context-events-below", Context *ctx = unsmob_context (context); return ctx->events_below ()->self_scm (); } + +LY_DEFINE (ly_make_event_class, "ly:make-event-class", + 2, 0, 0, (SCM context, SCM type), + "Make an event class (a list of types) from the given @var{type}" + " within the global context containing @var{context}.") +{ + LY_ASSERT_SMOB (Context, context, 1); + LY_ASSERT_TYPE (ly_is_symbol, type, 2); + + Context *ctx = unsmob_context (context); + return ctx->make_event_class (type); +} diff --git a/lily/context.cc b/lily/context.cc index 0551b3b702..4d949e8379 100644 --- a/lily/context.cc +++ b/lily/context.cc @@ -91,6 +91,7 @@ Context::Context () definition_mods_ = SCM_EOL; event_source_ = 0; events_below_ = 0; + ancestor_lookup_ = SCM_UNDEFINED; smobify_self (); @@ -452,9 +453,7 @@ be called from any other place than the send_stream_event macro. void Context::internal_send_stream_event (SCM type, Input *origin, SCM props[]) { - Stream_event *e = new Stream_event - (scm_call_1 (ly_lily_module_constant ("ly:make-event-class"), type), - origin); + Stream_event *e = new Stream_event (make_event_class (type), origin); for (int i = 0; props[i]; i += 2) { e->set_property (props[i], props[i + 1]); @@ -595,6 +594,14 @@ Context::get_score_context () const return 0; } +SCM +Context::make_event_class (SCM event_type) +{ + if (SCM_UNBNDP (ancestor_lookup_)) + ancestor_lookup_ = get_global_context ()->ancestor_lookup_; + return scm_hashq_ref (ancestor_lookup_, event_type, SCM_EOL); +} + Output_def * Context::get_output_def () const { @@ -663,6 +670,8 @@ Context::mark_smob (SCM sm) if (me->events_below_) scm_gc_mark (me->events_below_->self_scm ()); + scm_gc_mark (me->ancestor_lookup_); + return me->properties_scm_; } diff --git a/lily/engraver.cc b/lily/engraver.cc index b8bf1234c0..db1303d63c 100644 --- a/lily/engraver.cc +++ b/lily/engraver.cc @@ -53,7 +53,7 @@ Engraver::make_grob_info (Grob *e, SCM cause) /* TODO: Remove Music code when it's no longer needed */ if (Music *m = unsmob_music (cause)) { - cause = m->to_event ()->unprotect (); + cause = m->to_event (context ())->unprotect (); } if (e->get_property ("cause") == SCM_EOL && (unsmob_stream_event (cause) || unsmob_grob (cause))) diff --git a/lily/global-context.cc b/lily/global-context.cc index 9a4d4c51ff..3384133f35 100644 --- a/lily/global-context.cc +++ b/lily/global-context.cc @@ -51,6 +51,13 @@ Global_context::Global_context (Output_def *o) programming_error ("no `Global' context found"); else globaldef->apply_default_property_operations (this); + + SCM p = get_property ("EventClasses"); + + ancestor_lookup_ = scm_make_hash_table (scm_length (p)); + for (;scm_is_pair (p); p = scm_cdr (p)) + scm_hashq_set_x (ancestor_lookup_, scm_caar (p), scm_car (p)); + accepts_list_ = scm_list_1 (ly_symbol2scm ("Score")); } diff --git a/lily/include/context.hh b/lily/include/context.hh index 6a9e59358c..5543235c25 100644 --- a/lily/include/context.hh +++ b/lily/include/context.hh @@ -117,6 +117,13 @@ public: virtual Moment now_mom () const; virtual Context *get_default_interpreter (string context_id = ""); + // It would make some sense to have the following just available in + // a global context. It would be decidedly tricky, however, to have + // it initialized before the constructor of its Context base class + // was able to trigger garbage collection. + SCM ancestor_lookup_; + SCM make_event_class (SCM); + bool is_alias (SCM) const; void add_alias (SCM); void add_context (Context *trans); diff --git a/lily/include/music.hh b/lily/include/music.hh index 83cc5ff4c3..b0f4837104 100644 --- a/lily/include/music.hh +++ b/lily/include/music.hh @@ -24,6 +24,7 @@ #include "moment.hh" #include "pitch.hh" #include "prob.hh" +#include "context.hh" #define is_mus_type(x) internal_is_music_type (ly_symbol2scm (x)) @@ -39,7 +40,7 @@ public: bool internal_is_music_type (SCM) const; - Stream_event *to_event () const; + Stream_event *to_event (Context *) const; DECLARE_SCHEME_CALLBACK (relative_callback, (SCM, SCM)); Pitch to_relative_octave (Pitch); diff --git a/lily/music.cc b/lily/music.cc index e96e83d59f..cc814c074b 100644 --- a/lily/music.cc +++ b/lily/music.cc @@ -271,7 +271,7 @@ Music::origin () const ES TODO: This method should probably be reworked or junked. */ Stream_event * -Music::to_event () const +Music::to_event (Context *c) const { SCM class_name = ly_camel_case_2_lisp_identifier (get_property ("name")); @@ -279,9 +279,8 @@ Music::to_event () const if (!internal_is_music_type (class_name)) programming_error ("Not a music type"); - Stream_event *e = new Stream_event - (scm_call_1 (ly_lily_module_constant ("ly:make-event-class"), class_name), - mutable_property_alist_); + Stream_event *e = new Stream_event (c->make_event_class (class_name), + mutable_property_alist_); Moment length = get_length (); if (length.to_bool ()) e->set_property ("length", length.smobbed_copy ()); @@ -294,7 +293,7 @@ Music::to_event () const for (; scm_is_pair (art_mus); art_mus = scm_cdr (art_mus)) { Music *m = unsmob_music (scm_car (art_mus)); - art_ev = scm_cons (m->to_event ()->unprotect (), art_ev); + art_ev = scm_cons (m->to_event (c)->unprotect (), art_ev); } e->set_property ("articulations", scm_reverse_x (art_ev, SCM_EOL)); } @@ -311,7 +310,7 @@ Music::to_event () const void Music::send_to_context (Context *c) { - Stream_event *ev = to_event (); + Stream_event *ev = to_event (c); c->event_source ()->broadcast (ev); ev->unprotect (); } diff --git a/lily/part-combine-iterator.cc b/lily/part-combine-iterator.cc index e7bece69cb..06449fb5dc 100644 --- a/lily/part-combine-iterator.cc +++ b/lily/part-combine-iterator.cc @@ -224,8 +224,8 @@ Part_combine_iterator::kill_mmrest (int in) if (!mmrest_event_) { mmrest_event_ = new Stream_event - (scm_call_1 (ly_lily_module_constant ("ly:make-event-class"), - ly_symbol2scm ("multi-measure-rest-event"))); + (handles_[in].get_context ()->make_event_class + (ly_symbol2scm ("multi-measure-rest-event"))); mmrest_event_->set_property ("duration", SCM_EOL); mmrest_event_->unprotect (); } @@ -256,16 +256,15 @@ Part_combine_iterator::unisono (bool silent) if (playing_state_ != UNISONO && newstate == UNISONO) { + Context *out = (last_playing_ == SOLO2 ? second_iter_ : first_iter_) + ->get_outlet (); if (!unisono_event_) { unisono_event_ = new Stream_event - (scm_call_1 (ly_lily_module_constant ("ly:make-event-class"), - ly_symbol2scm ("unisono-event"))); + (out->make_event_class (ly_symbol2scm ("unisono-event"))); unisono_event_->unprotect (); } - Context *out = (last_playing_ == SOLO2 ? second_iter_ : first_iter_) - ->get_outlet (); out->event_source ()->broadcast (unisono_event_); playing_state_ = UNISONO; } @@ -291,8 +290,8 @@ Part_combine_iterator::solo1 () if (!solo_one_event_) { solo_one_event_ = new Stream_event - (scm_call_1 (ly_lily_module_constant ("ly:make-event-class"), - ly_symbol2scm ("solo-one-event"))); + (first_iter_->get_outlet ()->make_event_class + (ly_symbol2scm ("solo-one-event"))); solo_one_event_->unprotect (); } @@ -318,8 +317,8 @@ Part_combine_iterator::solo2 () if (!solo_two_event_) { solo_two_event_ = new Stream_event - (scm_call_1 (ly_lily_module_constant ("ly:make-event-class"), - ly_symbol2scm ("solo-two-event"))); + (second_iter_->get_outlet ()->make_event_class + (ly_symbol2scm ("solo-two-event"))); solo_two_event_->unprotect (); } diff --git a/lily/rhythmic-music-iterator.cc b/lily/rhythmic-music-iterator.cc index 3a91d9d7cb..951c145ec8 100644 --- a/lily/rhythmic-music-iterator.cc +++ b/lily/rhythmic-music-iterator.cc @@ -47,7 +47,7 @@ Rhythmic_music_iterator::process (Moment m) descend_to_bottom_context (); Context *c = get_outlet (); - Stream_event *ev = get_music ()->to_event (); + Stream_event *ev = get_music ()->to_event (c); SCM arts = ev->get_property ("articulations"); if (scm_is_pair (arts)) diff --git a/ly/engraver-init.ly b/ly/engraver-init.ly index dbc8dbea56..6e8210b9c1 100644 --- a/ly/engraver-init.ly +++ b/ly/engraver-init.ly @@ -26,6 +26,7 @@ \defaultchild "Score" \description "Hard coded entry point for LilyPond. Cannot be tuned." \grobdescriptions #all-grob-descriptions + EventClasses = #all-event-classes } \context { diff --git a/ly/performer-init.ly b/ly/performer-init.ly index 98ae0ceb8f..0ad1e2964e 100644 --- a/ly/performer-init.ly +++ b/ly/performer-init.ly @@ -35,6 +35,7 @@ \name Global \accepts Score \description "Hard coded entry point for LilyPond. Cannot be tuned." + EventClasses = #all-event-classes } \context { diff --git a/scm/define-context-properties.scm b/scm/define-context-properties.scm index 15c717ffd1..59baec69ad 100644 --- a/scm/define-context-properties.scm +++ b/scm/define-context-properties.scm @@ -583,6 +583,7 @@ are described in @rinternals{bar-line-interface}.") (apply translator-property-description x)) `( + (EventClasses ,cheap-list? "The initial list of event classes.") (associatedVoiceContext ,ly:context? "The context object of the @code{Voice} that has the melody for this @code{Lyrics}.") diff --git a/scm/define-event-classes.scm b/scm/define-event-classes.scm index 51709463db..e093337091 100644 --- a/scm/define-event-classes.scm +++ b/scm/define-event-classes.scm @@ -72,47 +72,19 @@ (acons elt lineage alist)) classlist class)))) -(define all-event-classes - (fold (lambda (elt classlist) - (event-class-cons (cdr elt) (car elt) classlist)) - '() event-classes)) - -;; Maps event-class to a list of ancestors (inclusive) -(define-public ancestor-lookup - (let ((h (make-hash-table (length all-event-classes)))) - (for-each (lambda (ent) (hashq-set! h (car ent) ent)) - all-event-classes) - h)) - - ;; Each class will be defined as ;; (class parent grandparent .. ) ;; so that (eq? (cdr class) parent) holds. -(define-public (define-event-class leaf heritage) - (cond - ((not (eq? leaf (car heritage))) - (ly:warning (_ "All classes must be the last in their matrilineal line."))) - ((not (equal? (cdr heritage) - (list-head (hashq-ref ancestor-lookup (cadr heritage) '()) - (length (cdr heritage))))) - (ly:warning (_ "All classes must have a well-defined pedigree in the existing class hierarchy."))) - (else (hashq-set! ancestor-lookup - leaf - (cons leaf - (hashq-ref ancestor-lookup - (cadr heritage) - '()))))) - *unspecified*) - -;; TODO: Allow entering more complex classes, by taking unions. -(define-public (ly:make-event-class leaf) - (hashq-ref ancestor-lookup leaf)) - (define-public (ly:in-event-class? ev cl) "Does event @var{ev} belong to event class @var{cl}?" (memq cl (ly:event-property ev 'class))) +(define-public all-event-classes + (fold (lambda (elt classlist) + (event-class-cons (cdr elt) (car elt) classlist)) + '() event-classes)) + ;; does this exist in guile already? (define (map-tree f t) (cond diff --git a/scm/document-music.scm b/scm/document-music.scm index c9bb9f011b..7d7e2a9942 100644 --- a/scm/document-music.scm +++ b/scm/document-music.scm @@ -16,6 +16,8 @@ ;;;; You should have received a copy of the GNU General Public License ;;;; along with LilyPond. If not, see . +(define doc-context (ly:make-global-context $defaultlayout)) + (define (music-props-doc) (make #:name "Music properties" @@ -31,7 +33,7 @@ (define music-types->names (make-hash-table 61)) (filter-map (lambda (entry) (let* ((class (ly:camel-case->lisp-identifier (car entry))) - (classes (ly:make-event-class class))) + (classes (ly:make-event-class doc-context class))) (if classes (map (lambda (cl) @@ -88,7 +90,7 @@ (let* ((namesym (car obj)) (props (cdr obj)) (class (ly:camel-case->lisp-identifier namesym)) - (classes (ly:make-event-class class)) + (classes (ly:make-event-class doc-context class)) (accept-list (if classes (human-listify (map ref-ify -- 2.39.5