Define and use event-class-cons

[lilypond.git] / scm / define-event-classes.scm

diff --git a/scm/define-event-classes.scm b/scm/define-event-classes.scm
index fee440ad508f1924691f15d7e2e1e18e6eb20c78..f5a6cea5f01603f28080b606eef64c55079ef4cc 100644 (file)
--- a/scm/define-event-classes.scm
+++ b/scm/define-event-classes.scm
@@ -59,20 +59,35 @@
     (Announcement . (AnnounceNewContext))
     ))
 
+(define-public (event-class-cons class parent classlist)
+  (let ((lineage (assq parent classlist)))
+    (if (not lineage)
+       (begin
+         (if (not (null? parent))
+             (ly:warning (_ "unknown parent class `~a'") parent))
+         (set! lineage '())))
+    (if (symbol? class)
+       (acons class lineage classlist)
+       (fold (lambda (elt alist)
+               (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 ancestor-lookup (make-hash-table 11))
+(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.
-(for-each
- (lambda (rel)
-   (for-each
-    (lambda (type)
-      (hashq-set! ancestor-lookup type
-                 (cons type (hashq-ref ancestor-lookup (car rel) '()))))
-    (cdr rel)))
- event-classes)
 
 (define-public (define-event-class leaf heritage)
   (cond
@@ -96,7 +111,7 @@
 
 (define-public (ly:in-event-class? ev cl)
   "Does event @var{ev} belong to event class @var{cl}?"
-  (memq cl (ly:make-event-class (ly:event-property ev 'class))))
+  (memq cl (ly:event-property ev 'class)))
 
 ;; does this exist in guile already?
 (define (map-tree f t)