in scheme."
}
-#(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-event-class 'scheme-text-span-event
+ '(scheme-text-span-event
+ span-event
+ music-event
+ StreamEvent))
#(define (add-grob-definition grob-name grob-entry)
(let* ((meta-entry (assoc-get 'meta grob-entry))
(set! meta-entry (assoc-set! meta-entry 'interfaces
ifaces-entry))
(set! grob-entry (assoc-set! grob-entry 'meta meta-entry))
- (set! my-grob-descriptions
+ (set! all-grob-descriptions
(cons (cons grob-name grob-entry)
- my-grob-descriptions))))
+ all-grob-descriptions))))
#(add-grob-definition
'SchemeTextSpanner
\layout {
\context {
\Global
- \grobdescriptions #my-grob-descriptions
- #my-event-classes
+ \grobdescriptions #all-grob-descriptions
}
\context {
\Voice
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);
-}
definition_mods_ = SCM_EOL;
event_source_ = 0;
events_below_ = 0;
- ancestor_lookup_ = SCM_UNDEFINED;
smobify_self ();
void
Context::internal_send_stream_event (SCM type, Input *origin, SCM props[])
{
- Stream_event *e = new Stream_event (make_event_class (type), origin);
+ Stream_event *e = new Stream_event
+ (scm_call_1 (ly_lily_module_constant ("ly:make-event-class"), type),
+ origin);
for (int i = 0; props[i]; i += 2)
{
e->set_property (props[i], props[i + 1]);
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
{
if (me->events_below_)
scm_gc_mark (me->events_below_->self_scm ());
- scm_gc_mark (me->ancestor_lookup_);
-
return me->properties_scm_;
}
/* TODO: Remove Music code when it's no longer needed */
if (Music *m = unsmob_music (cause))
{
- cause = m->to_event (context ())->unprotect ();
+ cause = m->to_event ()->unprotect ();
}
if (e->get_property ("cause") == SCM_EOL
&& (unsmob_stream_event (cause) || unsmob_grob (cause)))
return;
}
- footnotify (info.grob (), mus->to_event (context ())->unprotect ());
+ footnotify (info.grob (), mus->to_event ()->unprotect ());
// This grob has exhausted its footnote
info.grob ()->set_property ("footnote-music", SCM_EOL);
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));
-
default_child_ = ly_symbol2scm ("Score");
accepts_list_ = scm_list_1 (default_child_);
}
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);
#include "moment.hh"
#include "pitch.hh"
#include "prob.hh"
-#include "context.hh"
#define is_mus_type(x) internal_is_music_type (ly_symbol2scm (x))
bool internal_is_music_type (SCM) const;
- Stream_event *to_event (Context *) const;
+ Stream_event *to_event () const;
DECLARE_SCHEME_CALLBACK (relative_callback, (SCM, SCM));
Pitch to_relative_octave (Pitch);
ES TODO: This method should probably be reworked or junked.
*/
Stream_event *
-Music::to_event (Context *c) const
+Music::to_event () const
{
SCM class_name = ly_camel_case_2_lisp_identifier (get_property ("name"));
if (!internal_is_music_type (class_name))
programming_error ("Not a music type");
- Stream_event *e = new Stream_event (c->make_event_class (class_name),
- mutable_property_alist_);
+ Stream_event *e = new Stream_event
+ (scm_call_1 (ly_lily_module_constant ("ly:make-event-class"), class_name),
+ mutable_property_alist_);
Moment length = get_length ();
if (length.to_bool ())
e->set_property ("length", length.smobbed_copy ());
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 (c)->unprotect (), art_ev);
+ art_ev = scm_cons (m->to_event ()->unprotect (), art_ev);
}
e->set_property ("articulations", scm_reverse_x (art_ev, SCM_EOL));
}
void
Music::send_to_context (Context *c)
{
- Stream_event *ev = to_event (c);
+ Stream_event *ev = to_event ();
c->event_source ()->broadcast (ev);
ev->unprotect ();
}
if (!mmrest_event_)
{
mmrest_event_ = new Stream_event
- (handles_[in].get_context ()->make_event_class
- (ly_symbol2scm ("multi-measure-rest-event")));
+ (scm_call_1 (ly_lily_module_constant ("ly:make-event-class"),
+ ly_symbol2scm ("multi-measure-rest-event")));
mmrest_event_->set_property ("duration", SCM_EOL);
mmrest_event_->unprotect ();
}
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
- (out->make_event_class (ly_symbol2scm ("unisono-event")));
+ (scm_call_1 (ly_lily_module_constant ("ly: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;
}
if (!solo_one_event_)
{
solo_one_event_ = new Stream_event
- (first_iter_->get_outlet ()->make_event_class
- (ly_symbol2scm ("solo-one-event")));
+ (scm_call_1 (ly_lily_module_constant ("ly:make-event-class"),
+ ly_symbol2scm ("solo-one-event")));
solo_one_event_->unprotect ();
}
if (!solo_two_event_)
{
solo_two_event_ = new Stream_event
- (second_iter_->get_outlet ()->make_event_class
- (ly_symbol2scm ("solo-two-event")));
+ (scm_call_1 (ly_lily_module_constant ("ly:make-event-class"),
+ ly_symbol2scm ("solo-two-event")));
solo_two_event_->unprotect ();
}
descend_to_bottom_context ();
Context *c = get_outlet ();
- Stream_event *ev = get_music ()->to_event (c);
+ Stream_event *ev = get_music ()->to_event ();
SCM arts = ev->get_property ("articulations");
if (scm_is_pair (arts))
\defaultchild "Score"
\description "Hard coded entry point for LilyPond. Cannot be tuned."
\grobdescriptions #all-grob-descriptions
- EventClasses = #all-event-classes
}
\context {
\accepts Score
\defaultchild Score
\description "Hard coded entry point for LilyPond. Cannot be tuned."
- EventClasses = #all-event-classes
}
\context {
(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}.")
(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
;;;; You should have received a copy of the GNU General Public License
;;;; along with LilyPond. If not, see <http://www.gnu.org/licenses/>.
-(define doc-context (ly:make-global-context $defaultlayout))
-
(define (music-props-doc)
(make <texi-node>
#:name "Music properties"
(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 doc-context class)))
+ (classes (ly:make-event-class class)))
(if classes
(map
(lambda (cl)
(let* ((namesym (car obj))
(props (cdr obj))
(class (ly:camel-case->lisp-identifier namesym))
- (classes (ly:make-event-class doc-context class))
+ (classes (ly:make-event-class class))
(accept-list (if classes
(human-listify
(map ref-ify
projects / lilypond.git / commitdiff