scm/define-event-classes.scm

   1 ;;;; stream-event-classes.scm -- define the tree of stream-event classes.
   2 ;;;;
   3 ;;;;  source file of the GNU LilyPond music typesetter
   4 ;;;;
   5 ;;;; (c) 2005-2006 Erik Sandberg <mandolaerik@gmail.com>
   6
   7
   8 (use-modules (srfi srfi-1))
   9
  10 ;; Event class hierarchy. Each line is on the form ((List of children) . Parent)
  11 (define event-classes
  12   '(((StreamEvent) . '())
  13     ((RemoveContext ChangeParent Override Revert UnsetProperty
  14       SetProperty MusicEvent OldMusicEvent CreateContext Prepare
  15       OneTimeStep Finish) . StreamEvent)
  16     ((arpeggio-event
  17       beam-event note-event absolute-dynamic-event
  18       key-change-event lyric-event pedal-event slur-event tie-event
  19       metronome-change-event span-dynamic-event)
  20      . MusicEvent)
  21     ((decrescendo-event crescendo-event) . span-dynamic-event)
  22     ((sostenuto-event sustain-event una-corda-event) . pedal-event)
  23     ((Announcement) . '())
  24     ((AnnounceNewContext) . Announcement)
  25     ))
  26
  27 ;; Maps event-class to a list of ancestors (inclusive)
  28 ;; TODO: use resizable hash
  29 (define ancestor-lookup (make-hash-table 1))
  30
  31 ;; Each class will be defined as
  32 ;; (class parent grandparent .. )
  33 ;; so that (eq? (cdr class) parent) holds.
  34 (for-each
  35  (lambda (rel)
  36    (for-each
  37     (lambda (type)
  38       (hashq-set! ancestor-lookup type (cons type (hashq-ref ancestor-lookup (cdr rel) '())))) ;; `(define ,type (cons ',type ,(cdr rel)))))
  39     (car rel)))
  40  event-classes)
  41
  42 ;; TODO: Allow entering more complex classes, by taking unions.
  43 (define-public (ly:make-event-class leaf)
  44  (hashq-ref ancestor-lookup leaf))
  45 ;; (primitive-eval leaf))
  46
  47 (defmacro-public make-stream-event (expr)
  48   (Stream_event::undump (primitive-eval (list 'quasiquote expr))))
  49
  50 (define* (simplify e)
  51   (cond
  52    ;; Special case for lists reduces stack consumption.
  53    ((list? e) (map simplify e))
  54    ((pair? e) (cons (simplify (car e))
  55                     (simplify (cdr e))))
  56    ((ly:stream-event? e)
  57     (list 'unquote `(make-stream-event ,(simplify (Stream_event::dump e)))))
  58    ((ly:music? e)
  59     (list 'unquote (music->make-music e)))
  60    ((ly:moment? e)
  61     (list 'unquote `(ly:make-moment
  62                      ,(ly:moment-main-numerator e)
  63                      ,(ly:moment-main-denominator e)
  64                      . ,(if (eq? 0 (ly:moment-grace-numerator e))
  65                             '()
  66                             (list (ly:moment-grace-numerator e)
  67                                   (ly:moment-grace-denominator e))))))
  68    ((ly:duration? e)
  69     (list 'unquote `(ly:make-duration
  70                      ,(ly:duration-log e)
  71                      ,(ly:duration-dot-count e)
  72                      ,(car (ly:duration-factor e))
  73                      ,(cdr (ly:duration-factor e)))))
  74    ((ly:pitch? e)
  75     (list 'unquote `(ly:make-pitch
  76                      ,(ly:pitch-octave e)
  77                      ,(ly:pitch-notename e)
  78                      ,(ly:pitch-alteration e))))
  79    ((ly:input-location? e)
  80     (list 'unquote '(ly:dummy-input-location)))
  81    (#t e)))
  82
  83 (define-public (ly:simplify-scheme e)
  84   (list 'quasiquote (simplify e))
  85 )
  86
  87 ; used by lily/dispatcher.cc
  88 (define-public (car< a b) (< (car a) (car b)))