X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fmodal-transforms.scm;h=70c813e8e68d6721d53eb2ab7f125f9a22405c86;hb=HEAD;hp=2d604fc948d1e56d8358bd997663c213f8be5441;hpb=cf6201863b691be9b361049f76b80024e34b029b;p=lilypond.git

diff --git a/scm/modal-transforms.scm b/scm/modal-transforms.scm
index 2d604fc948..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 Ellis & Grant, Inc.
+;; Copyright (C) 2011--2015 Ellis & Grant, Inc.
 
 ;; Author: Michael Ellis <michael.f.ellis@gmail.com>
 
@@ -48,11 +48,11 @@ pitches as members of a scale.
 
      (else
       (list-ref scale
-		(modulo
-		 (+ (index pitch scale)
-		    (- (index to-pitch scale)
-		       (index from-pitch scale)))
-		 (length scale)))))))
+                (modulo
+                 (+ (index pitch scale)
+                    (- (index to-pitch scale)
+                       (index from-pitch scale)))
+                 (length scale)))))))
 
 (define (inverter-factory scale)
   "Returns an inverter for the specified @var{scale}.
@@ -81,11 +81,11 @@ arbitrary items and pitches as members of a scale.
 
      (else
       (list-ref scale
-		(modulo
-		 (+ (index to-pitch scale)
-		    (- (index around-pitch scale)
-		       (index pitch scale)))
-		 (length scale)))))))
+                (modulo
+                 (+ (index to-pitch scale)
+                    (- (index around-pitch scale)
+                       (index pitch scale)))
+                 (length scale)))))))
 
 (define (replicate-modify lis n mod-proc)
   "Apply @code{(mod-proc lis n)} to each element of a list and
@@ -112,48 +112,40 @@ a single pitch as its argument and return a new pitch.  These are
 LilyPond scheme pitches, e.g. @code{(ly:make-pitch 0 2 0)}
 "
   (let ((elements (ly:music-property music 'elements))
-	(element (ly:music-property music 'element))
-	(pitch (ly:music-property music 'pitch)))
+        (element (ly:music-property music 'element))
+        (pitch (ly:music-property music 'pitch)))
 
     (cond
      ((ly:pitch? pitch)
       (ly:music-set-property! music 'pitch (converter pitch)))
 
      ((pair? elements)
-      (map (lambda (x) (change-pitches x converter)) elements))
+      (for-each (lambda (x) (change-pitches x converter)) elements))
 
      ((ly:music? element)
       (change-pitches element converter)))))
 
 
-(define (extract-pitch-sequence music)
+(define (make-scale music)
   "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))
-	(pitch (ly:music-property music 'pitch)))
+        (element (ly:music-property music 'element))
+        (pitch (ly:music-property music 'pitch)))
 
     (cond
      ((ly:pitch? pitch)
-      pitch)
+      (list pitch))
 
      ((pair? elements)
-      (map
-       (lambda (x) (extract-pitch-sequence x))
-       elements))
+      (append-map make-scale elements))
 
      ((ly:music? element)
-      (extract-pitch-sequence element)))))
-
-(define (make-scale music)
-  "Convenience wrapper for extract-pitch-sequence."
-  (map car (extract-pitch-sequence music)))
-
+      (make-scale element)))))
 
 (define (make-extended-scale music)
   "Extend scale given by @var{music} by 5 octaves up and down."
@@ -164,10 +156,10 @@ Typically used to construct a scale for input to transposer-factory
     (lambda (lis n)
       (map
        (lambda (i)
-	 (ly:make-pitch
-	  (+ (- n 6) (ly:pitch-octave i))
-	  (ly:pitch-notename i)
-	  (ly:pitch-alteration i)))
+         (ly:make-pitch
+          (+ (- n 6) (ly:pitch-octave i))
+          (ly:pitch-notename i)
+          (ly:pitch-alteration i)))
        lis)))
 
   (let ((scale (make-scale music)))
@@ -191,40 +183,121 @@ 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)))
-
-    (map 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}
 and transposes from @var{around} to @var{to}."
   (let ((p (ly:music-property music 'pitch)))
     (if (ly:pitch? p)
-	(ly:music-set-property!
-	 music 'pitch
-	 (ly:pitch-transpose to (ly:pitch-diff around p))))
+        (ly:music-set-property!
+         music 'pitch
+         (ly:pitch-transpose to (ly:pitch-diff around p))))
     music))
 
 (define-public (music-invert around to music)
   "Applies pitch-invert to all pitches in @var{music}."
-     (music-map (lambda (x) (pitch-invert around to x)) music))
+  (music-map (lambda (x) (pitch-invert around to x)) music))