X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fdefine-event-classes.scm;h=09dfbf79a34b39898a30e7b413166aea0f15d078;hb=5cc4e758f0d8b01600a39faced769883cca6995a;hp=539288b8439f34bcc0dc2be517e9b6f882b92e3a;hpb=c1d5bb448321d688185e0c6b798575d4c325ae80;p=lilypond.git diff --git a/scm/define-event-classes.scm b/scm/define-event-classes.scm index 539288b843..09dfbf79a3 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--2011 Erik Sandberg +;;;; Copyright (C) 2005--2012 Erik Sandberg ;;;; ;;;; 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,7 +25,7 @@ (RemoveContext ChangeParent Override Revert UnsetProperty SetProperty music-event OldMusicEvent CreateContext Prepare OneTimeStep Finish)) - (music-event . (annotate-output-event + (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 @@ -35,7 +35,8 @@ 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 completize-extender-event break-span-event)) + layout-instruction-event completize-extender-event break-span-event + alternative-event)) (layout-instruction-event . (apply-output-event)) (script-event . (articulation-event text-script-event)) @@ -43,57 +44,48 @@ (break-event . (line-break-event page-break-event page-turn-event)) (dynamic-event . (absolute-dynamic-event)) (span-event . (span-dynamic-event beam-event episema-event ligature-event - pedal-event phrasing-slur-event slur-event staff-span-event - text-span-event trill-span-event tremolo-span-event - tuplet-span-event)) + measure-counter-event pedal-event + phrasing-slur-event slur-event + staff-span-event text-span-event + trill-span-event tremolo-span-event + tuplet-span-event)) (span-dynamic-event . (decrescendo-event crescendo-event)) (break-span-event . (break-dynamic-span-event)) (pedal-event . (sostenuto-event sustain-event una-corda-event)) (rhythmic-event . (lyric-event melodic-event multi-measure-rest-event - percent-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)) )) -;; Maps event-class to a list of ancestors (inclusive) -(define ancestor-lookup (make-hash-table 11)) +(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)))) ;; 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 - ((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) - '())))))) - -;; 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:make-event-class (ly:event-property ev 'class)))) + (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) @@ -111,13 +103,6 @@ (cons root (map expand-event-tree (cdr children))) root))) -;; All leaf event classes that no translator listens to -;; directly. Avoids printing a warning. -(define unlistened-music-event-classes - '(harmonic-event line-break-event page-break-event page-turn-event label-event - solo-one-event solo-two-event skip-event unisono-event - part-combine-force-event break-dynamic-span-event)) - ;; 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)) @@ -138,22 +123,6 @@ ;;(use-modules (ice-9 pretty-print)) ;;(pretty-print (cons (car music-event-tree) (sort-tree (cdr music-event-tree)))) -;; check that the music event tree corresponds well with the set of -;; available translators; print warnings otherwise. -(map-tree (lambda (sym) - (if (and (symbol? sym) - (not (ly:is-listened-event-class sym)) - (not (assq sym event-classes)) - (not (memq sym unlistened-music-event-classes))) - (ly:programming-error (_ "event class ~A seems to be unused") sym))) - music-event-tree) - -(map (lambda (sym) - (if (not (pair? (ly:make-event-class sym))) - ;; should be programming-error - (ly:error (_ "translator listens to nonexisting event class ~A") sym))) - (ly:get-listened-event-classes)) - (defmacro-public make-stream-event (expr) (Stream_event::undump (primitive-eval (list 'quasiquote expr)))) @@ -179,8 +148,7 @@ (list 'unquote `(ly:make-duration ,(ly:duration-log e) ,(ly:duration-dot-count e) - ,(car (ly:duration-factor e)) - ,(cdr (ly:duration-factor e))))) + ,(ly:duration-scale)))) ((ly:pitch? e) (list 'unquote `(ly:make-pitch ,(ly:pitch-octave e)