X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fdefine-event-classes.scm;h=8695bc5b78874801405a36288a8c5757e0679bfd;hb=HEAD;hp=fb790a591fd562d0fd4b85199a6daad9698f0fbe;hpb=44dd3acc534e7a534f846810b481c3f603eaa92e;p=lilypond.git

diff --git a/scm/define-event-classes.scm b/scm/define-event-classes.scm
index fb790a591f..8695bc5b78 100644
--- a/scm/define-event-classes.scm
+++ b/scm/define-event-classes.scm
@@ -1,6 +1,6 @@
 ;;;; This file is part of LilyPond, the GNU music typesetter.
 ;;;;
-;;;; Copyright (C) 2005--2012 Erik Sandberg <mandolaerik@gmail.com>
+;;;; Copyright (C) 2005--2015 Erik Sandberg <mandolaerik@gmail.com>
 ;;;;
 ;;;; LilyPond is free software: you can redistribute it and/or modify
 ;;;; it under the terms of the GNU General Public License as published by
@@ -25,19 +25,20 @@
                  (RemoveContext
                   ChangeParent Override Revert UnsetProperty SetProperty
                   music-event OldMusicEvent CreateContext Prepare
-                  OneTimeStep Finish))
+                  OneTimeStep Finish GraceChange))
     (music-event . (annotate-output-event
                     footnote-event arpeggio-event breathing-event
                     extender-event span-event rhythmic-event dynamic-event
                     break-event label-event percent-event key-change-event
                     string-number-event stroke-finger-event tie-event
-                    part-combine-event part-combine-force-event
+                    part-combine-event
                     beam-forbid-event script-event tempo-change-event
                     tremolo-event bend-after-event fingering-event
                     glissando-event harmonic-event hyphen-event
                     laissez-vibrer-event mark-event multi-measure-text-event
                     note-grouping-event pes-or-flexa-event repeat-tie-event
                     spacing-section-event layout-instruction-event
+                    time-signature-event
                     completize-extender-event break-span-event alternative-event))
 
     (layout-instruction-event . (apply-output-event))
@@ -78,19 +79,49 @@
                 (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
@@ -128,7 +159,7 @@
 ;;(pretty-print (cons (car music-event-tree) (sort-tree (cdr music-event-tree))))
 
 (defmacro-public make-stream-event (expr)
-  (Stream_event::undump (primitive-eval (list 'quasiquote expr))))
+  (ly:stream-event::undump (primitive-eval (list 'quasiquote expr))))
 
 (define* (simplify e)
   (cond
@@ -137,7 +168,7 @@
    ((pair? e) (cons (simplify (car e))
                     (simplify (cdr e))))
    ((ly:stream-event? e)
-    (list 'unquote (list 'make-stream-event (simplify (Stream_event::dump e)))))
+    (list 'unquote (list 'make-stream-event (simplify (ly:stream-event::dump e)))))
    ((ly:music? e)
     (list 'unquote (music->make-music e)))
    ((ly:moment? e)
@@ -152,7 +183,7 @@
     (list 'unquote `(ly:make-duration
                      ,(ly:duration-log e)
                      ,(ly:duration-dot-count e)
-                     ,(ly:duration-scale))))
+                     ,(ly:duration-scale e))))
    ((ly:pitch? e)
     (list 'unquote `(ly:make-pitch
                      ,(ly:pitch-octave e)