X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=ly%2Farticulate.ly;h=2b418cee7b265e13083e5aeec1eae4595ab61425;hb=5d84bfad4626892bcffd05adcced53c8a2329047;hp=5b7ab7234f3c2671c8b3721c64e87e21a5cc039d;hpb=98ac53591234404cd70c5eebd370a598ec74095b;p=lilypond.git

diff --git a/ly/articulate.ly b/ly/articulate.ly
index 5b7ab7234f..2b418cee7b 100644
--- a/ly/articulate.ly
+++ b/ly/articulate.ly
@@ -29,10 +29,10 @@
 % is much scope for improvement.
 
 % See: http://nicta.com.au/people/chubbp/articulate for additional
-
 % information about how the articulate function works.
 
 %%% Supported items:
+% Articulations on a single note (staccato, staccatissimo, portato, tenuto).
 % Slurs and phrasing slurs.
 % Ornaments (i.e. mordents, trills, turns).
 % Rallentando, accelerando, ritard and 'a tempo'.
@@ -41,20 +41,28 @@
 % Manual for a more detailed list of supported items.
 
 %%% Technical Details:
-% * Any note not under a slur or phrasing mark, and not marked with an
-% explicit articulation, is shortened by ac:normalFactor (default 7/8)
-% * Any note marked staccato is shortened by ac:staccatoFactor.
-% (default 1/2).
-% * Any note marked tenuto gets its full value.
-% * Appogiaturas are made to take half the value of the note following,
-% without taking dots into account (so in \appoggiatura c8 d2. the c
-% will take the time of a crotchet).
+% * Any note not under a slur or phrasing slur, and not marked with an
+%   explicit articulation, is shortened by ac:normalFactor (default 7/8).
+%   (Shortening a note means replacing the note with a note of a smaller
+%   duration, and a rest to make up for the difference between the durations
+%   of the original and the shortened note.)
+% * Notes marked with articulations are shortened by factors specific to the
+%   articulation as follows:
+%     staccato       not under a slur: ac:staccatoFactor (default 1/2)
+%                    under a slur: ac:portatoFactor (default 3/4)
+%     staccatissimo  ac:staccatissimoFactor (default 1/4)
+%     portato        ac:portatoFactor (default 3/4)
+%     tenuto         ac:tenutoFactor (default 1/1 - by default, notes marked
+%                                     tenuto are not shortened)
+% * Appoggiaturas are made to take half the value of the note following,
+%   without taking dots into account (so in \appoggiatura c8 d2. the c
+%   will take the time of a crotchet).
 % * Trills and turns are expanded. The algorithm tries to choose notes
-% within the time of the current tempo that lead to each twiddle being
-% around 1/8 seconds; this can be adjusted with the ac:maxTwiddleTime
-% variable.
+%   within the time of the current tempo that lead to each twiddle being
+%   around 1/8 seconds; this can be adjusted with the ac:maxTwiddleTime
+%   variable.
 % * Rall, poco rall and a tempo are observed. It'd be fairly trivial to
-% make accel. and stringendo and so on work too.
+%   make accel. and stringendo and so on work too.
 
 %
 %%%USAGE
@@ -92,7 +100,6 @@
 % * Cope with more ornaments/articulations.
 %    inverted-turns, etc.
 %   -- accent needs better control of dynamics.
-%   -- Articulations: mezzo-staccato, portato.
 %   -- Handling of generic ornaments (in lily, `\stopped'; in
 %               most early music:  ornament this note (trill, turn
 %               or mordent as the player wishes))
@@ -108,6 +115,13 @@
 % * accidentals for trills and turns
 
 % CHANGELOG
+%  * Heikki Tauriainen: handle also the \portato articulation (both as an
+%    explicit articulation, and as the articulation to use for slurred
+%    notes marked \staccato).
+%  * David Kastrup: remove redefinitions of \afterGrace and \appoggiatura
+%    and let their actions be performed when \articulate is called by
+%    recognizing and replacing LilyPond's default code for these constructs.
+%    Cf issue 4517 in LilyPond's tracker.
 %  * David Kastrup: basic 2.15.28 compatibility by using event-chord-wrap!
 %    This should really be done by rewriting the code more thoroughly.
 %  * From Iain Nicol: appoggiatura timings were out; add staccatissimo; fix
@@ -117,7 +131,9 @@
 %    how to do lookahead in scheme.
 %  * Also ignore explicit line breaks.
 %  * Add Mordents (reported by Patrick Karl)
-%
+%  * Thomas Morley: extend unfold-repeats to reflect the possibility to
+%    customize its effect to user-settable repeat-types. Here the most general
+%    setting is hard-coded, resulting in unchanged behaviour.
 
 \version "2.19.22"
 
@@ -135,6 +151,10 @@
 % How much to compress notes marked staccatissimo.
 #(define ac:staccatissimoFactor '(1 . 4))
 
+% Shortening factor for notes marked portato (or slurred notes marked
+% staccato).
+#(define ac:portatoFactor '(3 . 4))
+
 % And tenuto (if we ever implement time stealing, this should be >1.0)
 #(define ac:tenutoFactor '(1 . 1))
 
@@ -267,10 +287,10 @@
 #(define (ac:up note)
   (let* ((pitch (ly:music-property note 'pitch))
          (notename (ly:pitch-notename pitch))
-         (new-notename (if (eq? notename 6) 0 (+ 1 notename)))
+         (new-notename (if (eqv? notename 6) 0 (+ 1 notename)))
          (alterations (ly:music-property ac:current-key 'pitch-alist))
          (new-alteration (cdr (assq new-notename alterations)))
-         (new-octave (if (eq? new-notename 0) (+ 1 (ly:pitch-octave pitch))
+         (new-octave (if (eqv? new-notename 0) (+ 1 (ly:pitch-octave pitch))
                       (ly:pitch-octave pitch)))
        )
    (set! (ly:music-property note 'pitch)(ly:make-pitch new-octave new-notename new-alteration))))
@@ -280,10 +300,10 @@
 #(define (ac:down note)
   (begin  (let* ((pitch (ly:music-property note 'pitch))
          (notename (ly:pitch-notename pitch))
-         (new-notename (if (eq? notename 0) 6 (- notename 1)))
+         (new-notename (if (eqv? notename 0) 6 (- notename 1)))
          (alterations (ly:music-property ac:current-key 'pitch-alist))
          (new-alteration (cdr (assq new-notename alterations)))
-         (new-octave (if (eq? new-notename 6) (- (ly:pitch-octave pitch) 1)
+         (new-octave (if (eqv? new-notename 6) (- (ly:pitch-octave pitch) 1)
                       (ly:pitch-octave pitch)))
        )
    (set! (ly:music-property note 'pitch)(ly:make-pitch new-octave new-notename new-alteration))))
@@ -407,7 +427,7 @@
    (map (lambda (y) (ac:setduration y hemisemidur))
     (ly:music-property music 'elements))
    (set! uppernote (ly:music-deep-copy music))
-   (map (lambda (y) (ac:up y))
+   (map ac:up
     (filter
      (lambda (z) (eq? 'NoteEvent (ly:music-property z 'name)))
      (ly:music-property uppernote 'elements)))
@@ -520,12 +540,12 @@
         (make-music 'BarCheck))))
      (else
       m)))
-   (unfold-repeats music)))
+   (unfold-repeats '() music)))
 
 % If there's an articulation, use it.
-% If in a slur, use (1 . 1) instead.
+% If in a slur, use (1 . 1) instead (unless the note is marked staccato,
+% in which case use ac:portatoFactor).
 % Treat phrasing slurs as slurs, but allow explicit articulation.
-% (Maybe should treat staccato under a phrasing slur as mezzo-staccato?)
 %
 % Expect an EventChord.
 %
@@ -536,108 +556,114 @@
 %  ac:articulate-chord applies the actions to each NoteEvent in
 %               the EventChord.
 #(define (ac:getactions music)
-  (let  loop ((factor ac:normalFactor)
-              (newelements '())
-              (es (ly:music-property music 'elements))
-              (actions '()))
-   (if (null? es)
-    (begin
-     (set! (ly:music-property music 'elements) (reverse newelements))
-     (if
-      (not (any (lambda (m) (music-is-of-type? m 'rhythmic-event))
-                newelements))
-      actions
-      (append
-       (let ((st ac:stealForward))
-        (if (= st 0)
-         '()
-         (begin
-          (set! ac:stealForward 0)
-          (list 'steal st))))
+  (let ((at-end-of-slur #f))
+   (let  loop ((factor ac:normalFactor)
+               (newelements '())
+               (es (ly:music-property music 'elements))
+               (actions '()))
+    (if (null? es)
+     (begin
+      (set! (ly:music-property music 'elements) (reverse newelements))
+      (if
+       (not (any (lambda (m) (music-is-of-type? m 'rhythmic-event))
+                 newelements))
        actions
-       (cond
-        (ac:inTrill '(trill))
-        ((and (eq? factor ac:normalFactor) (or ac:inSlur ac:inPhrasingSlur))
-         (list 'articulation  '(1 . 1)))
-        (else (list 'articulation  factor))))))
-    ; else part
-    (let ((e (car es))
-          (tail (cdr es)))
-     (case (ly:music-property e 'name)
-
-      ((BeamEvent) ; throw away beam events, or they'll be duplicated by turn or trill
-       (loop factor newelements tail actions))
-
-      ((LineBreakEvent FingeringEvent MarkEvent BreathingEvent TieEvent SkipEvent RestEvent) ; pass through some events.
-       (loop (cons 1 1) (cons e newelements) tail actions))
-
-      ((ArticulationEvent)
-       (let ((articname (ly:music-property e 'articulation-type)))
-        ; TODO: add more here
+       (append
+        (let ((st ac:stealForward))
+         (if (= st 0)
+          '()
+          (begin
+           (set! ac:stealForward 0)
+           (list 'steal st))))
+        actions
         (cond
-         ((string= articname "staccato")
-          (loop ac:staccatoFactor newelements tail actions))
-         ((string= articname "staccatissimo")
-          (loop ac:staccatissimoFactor newelements tail actions))
-         ((string= articname "tenuto")
-          (loop ac:tenutoFactor newelements tail actions))
-         ((string= articname "mordent")
-          (loop (cons 1 1) newelements tail (cons 'mordent actions)))
-         ((string= articname "prall")
-          (loop (cons 1 1) newelements tail (cons 'prall actions)))
-         ((string= articname "trill")
-          (loop (cons 1 1) newelements tail (cons 'trill actions)))
-         ((string= articname "turn")
-          (loop (cons 1 1) newelements tail (cons 'turn actions)))
-         (else (loop factor (cons e newelements) tail actions)))))
-
-      ((TextScriptEvent)
-       (let ((t (ly:music-property e 'text)))
-        (if (not (string? t))
-         (loop factor (cons e newelements) tail actions)
-         (begin
-          (cond
-           ((or
-             (string= t "rall")
-             (string= t "Rall")
-             (string= t "rit.")
-             (string= t "rall."))
-            (loop factor (cons e newelements) tail (cons 'rall actions)))
-           ((or
-             (string= t "accelerando")
-             (string= t "accel")
-             (string= t "accel."))
-            (loop factor (cons e newelements) tail (cons 'accel actions)))
-           ((or
-             (string= t "poco accel."))
-            (loop factor (cons e newelements) tail (cons 'pocoAccel actions)))
-           ((or
-             (string= t "poco rall.")
-             (string= t "poco rit."))
-            (loop factor (cons e newelements) tail (cons 'pocoRall actions)))
-           ((or (string= t "a tempo")
-             (string= t "tempo I"))
-          (loop factor (cons e newelements) tail (cons 'aTempo actions)))
-           (else (loop factor (cons e newelements) tail actions)))))))
-
-      ((SlurEvent)
-       (let ((direction (ly:music-property e 'span-direction)))
-        (set! ac:inSlur (eq? direction -1))
-        (loop factor newelements tail actions)))
-
-      ((TrillSpanEvent)
-       (let ((direction (ly:music-property e 'span-direction)))
-        (set! ac:inTrill (eq? direction -1))
-        (if ac:inTrill
-         (loop factor newelements tail (cons 'trill actions))
-         (loop factor (cons e newelements) tail actions))))
-
-      ((PhrasingSlurEvent)
-       (let ((direction (ly:music-property e 'span-direction)))
-        (set! ac:inPhrasingSlur (eq? direction -1))
-        (loop factor newelements tail actions)))
-
-      (else (loop factor (cons e newelements) tail actions)))))))
+         (ac:inTrill '(trill))
+         ((and (eq? factor ac:normalFactor) (or ac:inSlur ac:inPhrasingSlur))
+          (list 'articulation  '(1 . 1)))
+         ((and (eq? factor ac:staccatoFactor) (or ac:inSlur at-end-of-slur))
+          (list 'articulation ac:portatoFactor))
+         (else (list 'articulation  factor))))))
+     ; else part
+     (let ((e (car es))
+           (tail (cdr es)))
+      (case (ly:music-property e 'name)
+
+       ((BeamEvent) ; throw away beam events, or they'll be duplicated by turn or trill
+        (loop factor newelements tail actions))
+
+       ((LineBreakEvent FingeringEvent MarkEvent BreathingEvent TieEvent SkipEvent RestEvent) ; pass through some events.
+        (loop (cons 1 1) (cons e newelements) tail actions))
+
+       ((ArticulationEvent)
+        (let ((articname (ly:music-property e 'articulation-type)))
+         ; TODO: add more here
+         (cond
+          ((string= articname "staccato")
+           (loop ac:staccatoFactor newelements tail actions))
+          ((string= articname "staccatissimo")
+           (loop ac:staccatissimoFactor newelements tail actions))
+          ((string= articname "portato")
+           (loop ac:portatoFactor newelements tail actions))
+          ((string= articname "tenuto")
+           (loop ac:tenutoFactor newelements tail actions))
+          ((string= articname "mordent")
+           (loop (cons 1 1) newelements tail (cons 'mordent actions)))
+          ((string= articname "prall")
+           (loop (cons 1 1) newelements tail (cons 'prall actions)))
+          ((string= articname "trill")
+           (loop (cons 1 1) newelements tail (cons 'trill actions)))
+          ((string= articname "turn")
+           (loop (cons 1 1) newelements tail (cons 'turn actions)))
+          (else (loop factor (cons e newelements) tail actions)))))
+
+       ((TextScriptEvent)
+        (let ((t (ly:music-property e 'text)))
+         (if (not (string? t))
+          (loop factor (cons e newelements) tail actions)
+          (begin
+           (cond
+            ((or
+              (string= t "rall")
+              (string= t "Rall")
+              (string= t "rit.")
+              (string= t "rall."))
+             (loop factor (cons e newelements) tail (cons 'rall actions)))
+            ((or
+              (string= t "accelerando")
+              (string= t "accel")
+              (string= t "accel."))
+             (loop factor (cons e newelements) tail (cons 'accel actions)))
+            ((or
+              (string= t "poco accel."))
+             (loop factor (cons e newelements) tail (cons 'pocoAccel actions)))
+            ((or
+              (string= t "poco rall.")
+              (string= t "poco rit."))
+             (loop factor (cons e newelements) tail (cons 'pocoRall actions)))
+            ((or (string= t "a tempo")
+              (string= t "tempo I"))
+           (loop factor (cons e newelements) tail (cons 'aTempo actions)))
+            (else (loop factor (cons e newelements) tail actions)))))))
+
+       ((SlurEvent)
+        (let ((direction (ly:music-property e 'span-direction)))
+         (set! ac:inSlur (eqv? direction -1))
+         (set! at-end-of-slur (eqv? direction 1))
+         (loop factor newelements tail actions)))
+
+       ((TrillSpanEvent)
+        (let ((direction (ly:music-property e 'span-direction)))
+         (set! ac:inTrill (eqv? direction -1))
+         (if ac:inTrill
+          (loop factor newelements tail (cons 'trill actions))
+          (loop factor (cons e newelements) tail actions))))
+
+       ((PhrasingSlurEvent)
+        (let ((direction (ly:music-property e 'span-direction)))
+         (set! ac:inPhrasingSlur (eqv? direction -1))
+         (loop factor newelements tail actions)))
+
+       (else (loop factor (cons e newelements) tail actions))))))))
 
 
 
@@ -666,7 +692,7 @@
           (len (ly:duration-log ac:currentDuration))
           (dots (ly:duration-dot-count ac:currentDuration)))
 
-         (if (not (eq? num denom))
+         (if (not (eqv? num denom))
           (make-sequential-music
            (list (ac:to128 music)
            (make-music 'EventChord 'elements
@@ -740,11 +766,11 @@
           (ly:music-property abovenote 'elements))
          (map (lambda (y) (ac:setduration y gracedur))
           (ly:music-property abovenoteTwo 'elements))
-         (map (lambda (y) (ac:up y))
+         (map ac:up
           (filter
            (lambda (z) (eq? 'NoteEvent (ly:music-property z 'name)))
            (ly:music-property abovenote 'elements)))
-         (map (lambda (y) (ac:up y))
+         (map ac:up
           (filter
            (lambda (z) (eq? 'NoteEvent (ly:music-property z 'name)))
            (ly:music-property abovenoteTwo 'elements)))
@@ -764,7 +790,7 @@
           (ly:music-property gracenote 'elements))
          (map (lambda (y) (ac:setduration y gracedur))
                (ly:music-property belownote 'elements))
-         (map (lambda (y) (ac:down y))
+         (map ac:down
           (filter
            (lambda (z) (eq? 'NoteEvent (ly:music-property z 'name)))
            (ly:music-property belownote 'elements)))
@@ -788,11 +814,11 @@
                  (below (ly:music-deep-copy music))
                  (newmusic (make-sequential-music (list above music below music))))
            (begin
-            (map (lambda (y) (ac:down y))
+            (map ac:down
              (filter
               (lambda (z) (eq? 'NoteEvent (ly:music-property z 'name)))
               (ly:music-property below 'elements)))
-            (map (lambda (y) (ac:up y))
+            (map ac:up
              (filter
               (lambda (z) (eq? 'NoteEvent (ly:music-property z 'name)))
               (ly:music-property above 'elements)))
@@ -878,7 +904,7 @@ articulate = #(define-music-function (music)
                 (lambda ()
                  (music-map
                   ac:articulate-chord
-                  (ac:unfoldMusic (event-chord-wrap! music (*parser*)))))
+                  (ac:startup-replacements music)))
                 (lambda ()
                  (or (= ac:stealForward 0)
                   (begin
@@ -886,16 +912,81 @@ articulate = #(define-music-function (music)
                    (set! ac:stealForward 0)))
                  (set! ac:eventsBackward '()))))
 
+#(define (ac:startup-replacements music)
+   (fold (lambda (f m) (f m))
+	 music
+	 (list
+	  event-chord-wrap!
+	  ac:replace-aftergrace
+	  ac:replace-appoggiatura
+	  ac:unfoldMusic)))
+
+#(define (ac:replace-aftergrace music)
+   (map-some-music
+    (lambda (expr)
+      (with-music-match
+       (expr (music 'SimultaneousMusic
+		    elements (?before-grace
+			      (music 'SequentialMusic
+				     elements ((music 'SkipMusic)
+					       (music 'GraceMusic
+						      element ?grace))))))
+       (ac:aftergrace ?before-grace ?grace)))
+    music))
+
+#(define (ac:replace-appoggiatura music)
+   ;; appoggiature are ugly to deal with since they require a main
+   ;; note following them.  We only try dealing with this followership
+   ;; in sequential music
+   (map-some-music
+    (lambda (m)
+      (if (eq? 'SequentialMusic (ly:music-property m 'name))
+	  (pair-for-each
+	   (lambda (elts)
+	     (let ((expr (car elts))
+		   (main (and (pair? (cdr elts)) (cadr elts))))
+	       (and main
+		    ;;stolen from define-music-display-methods
+		    (with-music-match
+		     (expr (music
+			    'GraceMusic
+			    element (music
+				     'SequentialMusic
+				     elements (?start
+					       ?music
+					       ?stop))))
+		     ;; we check whether ?start and ?stop look like
+		     ;; startAppoggiaturaMusic stopAppoggiaturaMusic
+		     (and (with-music-match (?start (music
+						     'SequentialMusic
+						     elements ((music
+								'EventChord
+								elements
+								((music
+								  'SlurEvent
+								  span-direction START))))))
+					    #t)
+			  (with-music-match (?stop (music
+						    'SequentialMusic
+						    elements ((music
+							       'EventChord
+							       elements
+							       ((music
+								 'SlurEvent
+								 span-direction STOP))))))
+					    #t)
+			  (let* ((app (ac:appoggiatura ?music main))
+				 (apps (ly:music-property app 'elements)))
+			    (set-car! elts (car apps))
+			    (set-car! (cdr elts) (cadr apps))
+			    #f))))))
+	   (ly:music-property m 'elements)))
+      #f)
+    music))
 
 % Override \afterGrace to be in terms of audio, not spacing.
 % Special handling for a gruppetto after a trill.
-afterGrace =
-#(define-music-function
-  (main grace)
-  (ly:music? ly:music?)
-
-  (set! main (event-chord-wrap! main (*parser*)))
-  (set! grace (event-chord-wrap! grace (*parser*)))
+#(define (ac:aftergrace main grace)
   (let*
    ((main-length (ly:music-length main))
     (grace-orig-length (ly:music-length grace))
@@ -917,16 +1008,12 @@ afterGrace =
 % or 1/3 if the note is dotted (i.e., half the undotted equivalent time)
 % Somewhere around the end of the 19th, start of 20th century the rules
 % changed, but my main interest is early music.
-appoggiatura =
-#(define-music-function (grace main)
-  (ly:music? ly:music?)
-  (set! grace (event-chord-wrap! grace (*parser*)))
-  (set! main (event-chord-wrap! main (*parser*)))
+#(define (ac:appoggiatura grace main)
   (let* ((maindur (ly:music-length main))
          (grace-orig-len (ly:music-length grace))
          (main-orig-len (ly:music-length main))
          (numerator (ly:moment-main-numerator maindur))
-         (factor (if (eq? (remainder numerator 3) 0)
+         (factor (if (eqv? (remainder numerator 3) 0)
                   (ly:make-moment 1/3) (ly:make-moment 1/2))))
    (ly:music-compress grace
     (ly:moment-mul factor (ly:moment-div main-orig-len grace-orig-len)))
@@ -939,4 +1026,3 @@ appoggiatura =
      (append (ly:music-property main 'elements)
       (list (make-music 'SlurEvent 'span-direction 1))))
      (make-sequential-music (list grace main))))
-