X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fmodal-transforms.scm;h=70c813e8e68d6721d53eb2ab7f125f9a22405c86;hb=HEAD;hp=3e31f660e4e7e10fdd3a6a40cf14f3dce7d0b3a8;hpb=99b6f3aa3558b01c9d4158b19a1f1794c534f89c;p=lilypond.git diff --git a/scm/modal-transforms.scm b/scm/modal-transforms.scm index 3e31f660e4..70c813e8e6 100644 --- a/scm/modal-transforms.scm +++ b/scm/modal-transforms.scm @@ -1,6 +1,6 @@ ;;; modal-transforms.scm --- Modal transposition, inversion, and retrograde. -;; Copyright (C) 2011--2014 Ellis & Grant, Inc. +;; Copyright (C) 2011--2015 Ellis & Grant, Inc. ;; Author: Michael Ellis @@ -130,9 +130,8 @@ LilyPond scheme pitches, e.g. @code{(ly:make-pitch 0 2 0)} "Recurse through @var{music}, extracting pitches. Returns a list of pitch objects, e.g @code{'((ly:make-pitch 0 2 0) (ly:make-pitch 0 4 0) ... )} -Typically used to construct a scale for input to transposer-factory -(see). -" +Typically used to construct a scale for input to +@code{transposer-factory}." (let ((elements (ly:music-property music 'elements)) (element (ly:music-property music 'element)) @@ -143,9 +142,7 @@ Typically used to construct a scale for input to transposer-factory (list pitch)) ((pair? elements) - (append-map - (lambda (x) (make-scale x)) - elements)) + (append-map make-scale elements)) ((ly:music? element) (make-scale element))))) @@ -186,29 +183,110 @@ Typically used to construct a scale for input to transposer-factory (define-public (retrograde-music music) "Returns @var{music} in retrograde (reversed) order." - ;; Copied from LSR #105 and renamed. ;; Included here to allow this module to provide a complete set of ;; common formal operations on motives, i.e transposition, ;; inversion and retrograding. - (let* ((elements (ly:music-property music 'elements)) - (reversed (reverse elements)) - (element (ly:music-property music 'element)) - (span-dir (ly:music-property music 'span-direction))) - - (ly:music-set-property! music 'elements reversed) - - (if (ly:music? element) - (ly:music-set-property! - music 'element - (retrograde-music element))) - - (if (ly:dir? span-dir) - (ly:music-set-property! music 'span-direction (- span-dir))) - - (for-each retrograde-music reversed) - - music)) + (define (reverse-span! m) + ;; invert direction of two-sided spanners + (let ((spd (ly:music-property m 'span-direction))) + (if (ly:dir? spd) + (begin + (set! (ly:music-property m 'span-direction) (- spd)) + (case (ly:music-property m 'name) + ((CrescendoEvent) + (make-music 'DecrescendoEvent m)) + ((DecrescendoEvent) + (make-music 'CrescendoEvent m)) + (else m))) + m))) + + ;; carryover is a possible list of tie events, the loop returns any + ;; such trailing list from the given expression + (define (loop m carryover) + (define (filter-ties! m carryover field) + (let ((vals (ly:music-property m field))) + (if (pair? vals) + (call-with-values + (lambda () + (partition! (music-type-predicate + '(tie-event glissando-event)) vals)) + (lambda (ties no-ties) + (set! (ly:music-property m field) + (append! (map! reverse-span! no-ties) carryover)) + ties)) + (begin + (if (pair? carryover) + (set! (ly:music-property m field) carryover)) + '())))) + + ;; The reversal will let some prefatory material stay in front of + ;; the following element. Most prominently single + ;; overrides/reverts/sets/unsets and applyContext. This does not + ;; change the position of a clef (which will generally be useless + ;; after retrograding) but it does not jumble the clef change + ;; command internals. Also, stuff like \once\override stays at + ;; the affected element. + + (define (prefatory? m) + (or ((music-type-predicate + '(apply-context apply-output-event layout-instruction-event)) m) + (and + (music-is-of-type? m 'music-wrapper-music) + (prefatory? (ly:music-property m 'element))))) + + (define (musiclistreverse lst) + (let loop ((lst lst) (res '()) (zeros '())) + (cond ((null? lst) (reverse! zeros res)) + ((prefatory? (car lst)) + (loop (cdr lst) res (cons (car lst) zeros))) + (else + (loop (cdr lst) (reverse! zeros (cons (car lst) res)) '()))))) + + (cond ((music-is-of-type? m 'event-chord) + (let* ((chord-ties + (append! + (filter-ties! m carryover 'elements) + ;; articulations on an event-chord do not occur + ;; "naturally" but are supported when user-generated + ;; elsewhere, so we treat them properly + (filter-ties! m '() 'articulations))) + ;; in-chord ties are converted to per-chord ties. + ;; This is less than optimal but pretty much the + ;; best we can hope to achieve with this approach. + (element-ties + (append-map! + (lambda (m) (filter-ties! m '() 'articulations)) + (ly:music-property m 'elements)))) + (append! chord-ties element-ties))) + + ((music-is-of-type? m 'rhythmic-event) + (filter-ties! m carryover 'articulations)) + + ;; The following is hardly correct but tieing inside of + ;; <<...>> is really beyond our pay grade. + ((music-is-of-type? m 'simultaneous-music) + (append-map! (lambda (m) (loop m (ly:music-deep-copy carryover))) + (ly:music-property m 'elements))) + (else + (let ((elt (ly:music-property m 'element)) + (elts (ly:music-property m 'elements))) + (let ((res + (fold loop + (if (ly:music? elt) (loop elt carryover) carryover) + elts))) + (if (ly:music? elt) + (set! (ly:music-property m 'element) + (reverse-span! elt))) + (if (pair? elts) + (set! (ly:music-property m 'elements) + (map! reverse-span! (musiclistreverse elts)))) + (append! res (filter-ties! m '() 'articulations))))))) + (let ((dangling (loop music '()))) + (for-each + (lambda (t) (ly:music-warning t (_ "Dangling tie in \\retrograde"))) + dangling)) + music) (define-public (pitch-invert around to music) "If @var{music} is a single pitch, inverts it about @var{around}