X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fdefine-event-classes.scm;h=dd6405a73e657984b842e4f7b384dc4051e45292;hb=e5f1f0e94c271d556bbcb77e565a6a70cbda2584;hp=9b00af992bdcea207a372c733ca1e3e9adb9055a;hpb=07f7ea94c774c7b746a0e7b703bc4a709b73eabf;p=lilypond.git

diff --git a/scm/define-event-classes.scm b/scm/define-event-classes.scm
index 9b00af992b..dd6405a73e 100644
--- a/scm/define-event-classes.scm
+++ b/scm/define-event-classes.scm
@@ -22,10 +22,10 @@
 (define event-classes
   '((() . (StreamEvent))
     (StreamEvent .
-		 (RemoveContext
-		  ChangeParent Override Revert UnsetProperty SetProperty
-		  music-event OldMusicEvent CreateContext Prepare
-		  OneTimeStep Finish))
+                 (RemoveContext
+                  ChangeParent Override Revert UnsetProperty SetProperty
+                  music-event OldMusicEvent CreateContext Prepare
+                  OneTimeStep Finish))
     (music-event . (annotate-output-event
                     footnote-event arpeggio-event breathing-event
                     extender-event span-event rhythmic-event dynamic-event
@@ -57,9 +57,9 @@
     (pedal-event . (sostenuto-event sustain-event una-corda-event))
     (rhythmic-event . (lyric-event
                        melodic-event multi-measure-rest-event
-		       double-percent-event percent-event
-		       repeat-slash-event rest-event
-		       skip-event bass-figure-event))
+                       double-percent-event percent-event
+                       repeat-slash-event rest-event
+                       skip-event bass-figure-event))
     (melodic-event . (cluster-note-event note-event))
     (() . (Announcement))
     (Announcement . (AnnounceNewContext))
@@ -68,29 +68,59 @@
 (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 '())))
+        (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))))
+        (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 (length all-event-classes)))
+
+(define (ancestor-lookup-initialize)
+  (hash-clear! ancestor-lookup)
+  (for-each (lambda (ent) (hashq-set! ancestor-lookup (car ent) ent))
+            all-event-classes))
+
+(ancestor-lookup-initialize)
+(call-after-session ancestor-lookup-initialize)
 
 ;; Each class will be defined as
 ;; (class parent grandparent .. )
 ;; so that (eq? (cdr class) parent) holds.
 
+(define-public (define-event-class class parent)
+  "Defines a new event @code{class} derived from @code{parent}, a
+previously defined event class."
+  (let ((parentclass (ly:make-event-class parent)))
+    (cond
+     ((ly:make-event-class class)
+      (ly:error (_ "Cannot redefine event class `~S'") class))
+     ((not parentclass)
+      (ly:error (_ "Undefined parent event class `~S'" parentclass)))
+     (else
+      (hashq-set! ancestor-lookup
+                  class
+                  (cons class parentclass))))
+    *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
@@ -104,24 +134,24 @@
 (define (expand-event-tree root)
   (let ((children (assq root event-classes)))
     (if children
-	(cons root (map expand-event-tree (cdr children)))
-	root)))
+        (cons root (map expand-event-tree (cdr children)))
+        root)))
 
 ;; produce neater representation of music event tree.
 ;; TODO: switch to this representation for the event-classes list?
 (define music-event-tree (expand-event-tree 'music-event))
 (define (sort-tree t)
   (define (stringify el)
-	      (if (symbol? el)
-		  (symbol->string el)
-		  (symbol->string (first el))))
+    (if (symbol? el)
+        (symbol->string el)
+        (symbol->string (first el))))
   (if (list? t)
       (sort (map (lambda (el)
-		   (if (list? el)
-		       (cons (car el) (sort-tree (cdr el)))
-		       el))
-		 t)
-	    (lambda (a b) (string<? (stringify a) (stringify b))))
+                   (if (list? el)
+                       (cons (car el) (sort-tree (cdr el)))
+                       el))
+                 t)
+            (lambda (a b) (string<? (stringify a) (stringify b))))
       t))
 
 ;;(use-modules (ice-9 pretty-print))
@@ -135,29 +165,29 @@
    ;; Special case for lists reduces stack consumption.
    ((list? e) (map simplify e))
    ((pair? e) (cons (simplify (car e))
-		    (simplify (cdr e))))
+                    (simplify (cdr e))))
    ((ly:stream-event? e)
     (list 'unquote (list 'make-stream-event (simplify (Stream_event::dump e)))))
    ((ly:music? e)
     (list 'unquote (music->make-music e)))
    ((ly:moment? e)
     (list 'unquote `(ly:make-moment
-		     ,(ly:moment-main-numerator e)
-		     ,(ly:moment-main-denominator e)
-		     . ,(if (zero? (ly:moment-grace-numerator e))
-			    '()
-			    (list (ly:moment-grace-numerator e)
-				  (ly:moment-grace-denominator e))))))
+                     ,(ly:moment-main-numerator e)
+                     ,(ly:moment-main-denominator e)
+                     . ,(if (zero? (ly:moment-grace-numerator e))
+                            '()
+                            (list (ly:moment-grace-numerator e)
+                                  (ly:moment-grace-denominator e))))))
    ((ly:duration? e)
     (list 'unquote `(ly:make-duration
-		     ,(ly:duration-log e)
-		     ,(ly:duration-dot-count e)
-		     ,(ly:duration-scale))))
+                     ,(ly:duration-log e)
+                     ,(ly:duration-dot-count e)
+                     ,(ly:duration-scale))))
    ((ly:pitch? e)
     (list 'unquote `(ly:make-pitch
-		     ,(ly:pitch-octave e)
-		     ,(ly:pitch-notename e)
-		     ,(ly:pitch-alteration e))))
+                     ,(ly:pitch-octave e)
+                     ,(ly:pitch-notename e)
+                     ,(ly:pitch-alteration e))))
    ((ly:input-location? e)
     (list 'unquote '(ly:dummy-input-location)))
    (#t e)))