Update contributors.

[lilypond.git] / scm / part-combiner.scm

diff --git a/scm/part-combiner.scm b/scm/part-combiner.scm
index 2a95e2083bbe5331734a30382ba4abbbbffd945e..279123222ba2dbff58f9054e06494c026f9a2c1c 100644 (file)
--- a/scm/part-combiner.scm
+++ b/scm/part-combiner.scm
@@ -1,6 +1,6 @@
 ;;;; This file is part of LilyPond, the GNU music typesetter.
 ;;;;
 ;;;; This file is part of LilyPond, the GNU music typesetter.
 ;;;;

-;;;; Copyright (C) 2004--2010 Han-Wen Nienhuys <hanwen@xs4all.nl>
+;;;; Copyright (C) 2004--2012 Han-Wen Nienhuys <hanwen@xs4all.nl>

 ;;;;
 ;;;; LilyPond is free software: you can redistribute it and/or modify
 ;;;; it under the terms of the GNU General Public License as published by
 ;;;;
 ;;;; LilyPond is free software: you can redistribute it and/or modify
 ;;;; it under the terms of the GNU General Public License as published by


@@ -20,7 +20,7 @@
 
 (define-class <Voice-state> ()
   (event-list #:init-value '() #:accessor events #:init-keyword #:events)
 
 (define-class <Voice-state> ()
   (event-list #:init-value '() #:accessor events #:init-keyword #:events)

-  (when-moment #:accessor when #:init-keyword #:when)
+  (when-moment #:accessor moment #:init-keyword #:moment)

   (tuning #:accessor tuning #:init-keyword #:tuning)
   (split-index #:accessor split-index)
   (vector-index)
   (tuning #:accessor tuning #:init-keyword #:tuning)
   (split-index #:accessor split-index)
   (vector-index)


@@ -32,7 +32,7 @@
   (spanner-state #:init-value '() #:accessor span-state))
 
 (define-method (write (x <Voice-state> ) file)
   (spanner-state #:init-value '() #:accessor span-state))
 
 (define-method (write (x <Voice-state> ) file)

-  (display (when x) file)
+  (display (moment x) file)

   (display " evs = " file)
   (display (events x) file)
   (display " active = " file)
   (display " evs = " file)
   (display (events x) file)
   (display " active = " file)


@@ -41,7 +41,7 @@
 
 (define-method (note-events (vs <Voice-state>))
   (define (f? x)
 
 (define-method (note-events (vs <Voice-state>))
   (define (f? x)

-    (equal? (ly:event-property x 'class) 'note-event))
+    (ly:in-event-class? x 'note-event))

   (filter f? (events vs)))
 
 (define-method (previous-voice-state (vs <Voice-state>))
   (filter f? (events vs)))
 
 (define-method (previous-voice-state (vs <Voice-state>))


@@ -58,7 +58,7 @@
   (configuration #:init-value '() #:accessor configuration)
   ;; Allow overriding split configuration, takes precedence over configuration
   (forced-configuration #:init-value #f #:accessor forced-configuration)
   (configuration #:init-value '() #:accessor configuration)
   ;; Allow overriding split configuration, takes precedence over configuration
   (forced-configuration #:init-value #f #:accessor forced-configuration)

-  (when-moment #:accessor when #:init-keyword #:when)
+  (when-moment #:accessor moment #:init-keyword #:moment)

   ;; voice-states are states starting with the Split-state or later
   ;;
   (is #:init-keyword #:voice-states #:accessor voice-states)
   ;; voice-states are states starting with the Split-state or later
   ;;
   (is #:init-keyword #:voice-states #:accessor voice-states)


@@ -66,7 +66,7 @@
 
 
 (define-method (write (x <Split-state> ) f)
 
 
 (define-method (write (x <Split-state> ) f)

-  (display (when x) f)
+  (display (moment x) f)

   (display " = " f)
   (display (configuration x) f)
   (if (synced? x)
   (display " = " f)
   (display (configuration x) f)
   (if (synced? x)


@@ -83,7 +83,7 @@
 (define (make-voice-states evl)
   (let ((vec (list->vector (map (lambda (v)
                                  (make <Voice-state>
 (define (make-voice-states evl)
   (let ((vec (list->vector (map (lambda (v)
                                  (make <Voice-state>

-                                   #:when (caar v)
+                                   #:moment (caar v)

                                    #:tuning (cdar v)
                                    #:events (map car (cdr v))))
                                evl))))
                                    #:tuning (cdar v)
                                    #:events (map car (cdr v))))
                                evl))))


@@ -100,15 +100,15 @@ Voice-state objects
   (define (helper ss-idx ss-list idx1 idx2)
     (let* ((state1 (if (< idx1 (vector-length vs1)) (vector-ref vs1 idx1) #f))
           (state2 (if (< idx2 (vector-length vs2)) (vector-ref vs2 idx2) #f))
   (define (helper ss-idx ss-list idx1 idx2)
     (let* ((state1 (if (< idx1 (vector-length vs1)) (vector-ref vs1 idx1) #f))
           (state2 (if (< idx2 (vector-length vs2)) (vector-ref vs2 idx2) #f))

-          (min (cond ((and state1 state2) (moment-min (when state1) (when state2)))
-                     (state1 (when state1))
-                     (state2 (when state2))
+          (min (cond ((and state1 state2) (moment-min (moment state1) (moment state2)))
+                     (state1 (moment state1))
+                     (state2 (moment state2))

                      (else #f)))
                      (else #f)))

-          (inc1 (if (and state1 (equal? min (when state1))) 1 0))
-          (inc2 (if (and state2 (equal? min (when state2))) 1 0))
+          (inc1 (if (and state1 (equal? min (moment state1))) 1 0))
+          (inc2 (if (and state2 (equal? min (moment state2))) 1 0))

           (ss-object (if min
                          (make <Split-state>
           (ss-object (if min
                          (make <Split-state>

-                           #:when min
+                           #:moment min

                            #:voice-states (cons state1 state2)
                            #:synced (= inc1 inc2))
                          #f)))
                            #:voice-states (cons state1 state2)
                            #:synced (= inc1 inc2))
                          #f)))


@@ -130,30 +130,30 @@ Voice-state objects
     "Analyse EVS at INDEX, given state ACTIVE."
 
     (define (analyse-tie-start active ev)
     "Analyse EVS at INDEX, given state ACTIVE."
 
     (define (analyse-tie-start active ev)

-      (if (equal? (ly:event-property ev 'class) 'tie-event)
+      (if (ly:in-event-class? ev 'tie-event)

          (acons 'tie (split-index (vector-ref voice-state-vec index))
                 active)
          active))
 
     (define (analyse-tie-end active ev)
          (acons 'tie (split-index (vector-ref voice-state-vec index))
                 active)
          active))
 
     (define (analyse-tie-end active ev)

-      (if (equal? (ly:event-property ev 'class) 'note-event)
+      (if (ly:in-event-class? ev 'note-event)

          (assoc-remove! active 'tie)
          active))
 
     (define (analyse-absdyn-end active ev)
          (assoc-remove! active 'tie)
          active))
 
     (define (analyse-absdyn-end active ev)

-      (if (or (equal? (ly:event-property ev 'class) 'absolute-dynamic-event)
-             (and (equal? (ly:event-property ev 'class) 'crescendo-event)
+      (if (or (ly:in-event-class? ev 'absolute-dynamic-event)
+             (and (ly:in-event-class? ev 'span-dynamic-event)

                   (equal? STOP (ly:event-property ev 'span-direction))))
          (assoc-remove! (assoc-remove! active 'cresc) 'decr)
          active))
 
     (define (active<? a b)
       (cond ((symbol<? (car a) (car b)) #t)
                   (equal? STOP (ly:event-property ev 'span-direction))))
          (assoc-remove! (assoc-remove! active 'cresc) 'decr)
          active))
 
     (define (active<? a b)
       (cond ((symbol<? (car a) (car b)) #t)

-           ((symbol<? (car b) (car b)) #f)
+           ((symbol<? (car b) (car a)) #f)

            (else (< (cdr a) (cdr b)))))
 
     (define (analyse-span-event active ev)
            (else (< (cdr a) (cdr b)))))
 
     (define (analyse-span-event active ev)

-      (let* ((name (ly:event-property ev 'class))
+      (let* ((name (car (ly:event-property ev 'class)))

             (key (cond ((equal? name 'slur-event) 'slur)
                        ((equal? name 'phrasing-slur-event) 'tie)
                        ((equal? name 'beam-event) 'beam)
             (key (cond ((equal? name 'slur-event) 'slur)
                        ((equal? name 'phrasing-slur-event) 'tie)
                        ((equal? name 'beam-event) 'beam)


@@ -200,8 +200,9 @@ Voice-state objects
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (define-public (recording-group-emulate music odef)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (define-public (recording-group-emulate music odef)

-  "Interprets music according to odef, but stores all events in a chronological
-list, similar to the Recording_group_engraver in 2.8 and earlier"
+  "Interpret @var{music} according to @var{odef}, but store all events
+in a chronological list, similar to the @code{Recording_group_engraver} in
+LilyPond version 2.8 and earlier."

   (let*
      ((context-list '())
       (now-mom (ly:make-moment 0 0))
   (let*
      ((context-list '())
       (now-mom (ly:make-moment 0 0))


@@ -242,7 +243,7 @@ list, similar to the Recording_group_engraver in 2.8 and earlier"
     (ly:interpret-music-expression (make-non-relative-music music) global)
     context-list))
 
     (ly:interpret-music-expression (make-non-relative-music music) global)
     context-list))
 

-(define-public (make-part-combine-music parser music-list)
+(define-public (make-part-combine-music parser music-list direction)

   (let* ((m (make-music 'PartCombineMusic))
         (m1 (make-non-relative-music (context-spec-music (first music-list) 'Voice "one")))
         (m2  (make-non-relative-music  (context-spec-music (second music-list) 'Voice "two")))
   (let* ((m (make-music 'PartCombineMusic))
         (m1 (make-non-relative-music (context-spec-music (first music-list) 'Voice "one")))
         (m2  (make-non-relative-music  (context-spec-music (second music-list) 'Voice "two")))


@@ -251,6 +252,7 @@ list, similar to the Recording_group_engraver in 2.8 and earlier"
         (evs1 (recording-group-emulate m1 listener)))
 
     (set! (ly:music-property m 'elements) (list m1 m2))
         (evs1 (recording-group-emulate m1 listener)))
 
     (set! (ly:music-property m 'elements) (list m1 m2))

+    (set! (ly:music-property m 'direction) direction)

     (set! (ly:music-property m 'split-list)
          (if (and (assoc "one" evs1) (assoc "two" evs2))
              (determine-split-list (reverse! (assoc-get "one" evs1) '())
     (set! (ly:music-property m 'split-list)
          (if (and (assoc "one" evs1) (assoc "two" evs2))
              (determine-split-list (reverse! (assoc-get "one" evs1) '())


@@ -259,7 +261,7 @@ list, similar to the Recording_group_engraver in 2.8 and earlier"
     m))
 
 (define-public (determine-split-list evl1 evl2)
     m))
 
 (define-public (determine-split-list evl1 evl2)

-  "EVL1 and EVL2 should be ascending"
+  "@var{evl1} and @var{evl2} should be ascending."

   (let* ((pc-debug #f)
         (chord-threshold 8)
         (voice-state-vec1 (make-voice-states evl1))
   (let* ((pc-debug #f)
         (chord-threshold 8)
         (voice-state-vec1 (make-voice-states evl1))


@@ -400,7 +402,7 @@ Only set if not set previously.
                         (new-active1 (span-state vs1))
                         (new-active2 (span-state vs2)))
                     (if #f ; debug
                         (new-active1 (span-state vs1))
                         (new-active2 (span-state vs2)))
                     (if #f ; debug

-                        (display (list (when now-state) result-idx
+                        (display (list (moment now-state) result-idx

                                        active1 "->" new-active1
                                        active2 "->" new-active2
                                        "\n")))
                                        active1 "->" new-active1
                                        active2 "->" new-active2
                                        "\n")))


@@ -457,12 +459,12 @@ Only set if not set previously.
       (define (current-voice-state now-state voice-num)
        (define vs ((if (= 1 voice-num) car cdr)
                    (voice-states now-state)))
       (define (current-voice-state now-state voice-num)
        (define vs ((if (= 1 voice-num) car cdr)
                    (voice-states now-state)))

-       (if (or (not vs) (equal? (when now-state) (when vs)))
+       (if (or (not vs) (equal? (moment now-state) (moment vs)))

            vs
            (previous-voice-state vs)))
 
       (define (try-solo type start-idx current-idx)
            vs
            (previous-voice-state vs)))
 
       (define (try-solo type start-idx current-idx)

-       "Find a maximum stretch that can be marked as solo. Only set
+       "Find a maximum stretch that can be marked as solo.  Only set

 the mark when there are no spanners active.
 
       return next idx to analyse.
 the mark when there are no spanners active.
 
       return next idx to analyse.


@@ -473,7 +475,7 @@ the mark when there are no spanners active.
                   (silent-state (current-voice-state now-state (if (equal? type 'solo1) 2 1)))
                   (silent-notes (if silent-state (note-events silent-state) '()))
                   (solo-notes (if solo-state (note-events solo-state) '())))
                   (silent-state (current-voice-state now-state (if (equal? type 'solo1) 2 1)))
                   (silent-notes (if silent-state (note-events silent-state) '()))
                   (solo-notes (if solo-state (note-events solo-state) '())))

-             ;; (display (list "trying " type " at "  (when now-state) solo-state silent-state  "\n"))
+             ;; (display (list "trying " type " at "  (moment now-state) solo-state silent-state        "\n"))

              (cond ((not (equal? (configuration now-state) 'apart))
                     current-idx)
                    ((> (length silent-notes) 0) start-idx)
              (cond ((not (equal? (configuration now-state) 'apart))
                     current-idx)
                    ((> (length silent-notes) 0) start-idx)


@@ -497,7 +499,7 @@ the mark when there are no spanners active.
            start-idx))
 
       (define (analyse-moment result-idx)
            start-idx))
 
       (define (analyse-moment result-idx)

-       "Analyse 'apart starting at RESULT-IDX. Return next index. "
+       "Analyse 'apart starting at RESULT-IDX.  Return next index."

        (let* ((now-state (vector-ref result result-idx))
               (vs1 (current-voice-state now-state 1))
               (vs2 (current-voice-state now-state 2))
        (let* ((now-state (vector-ref result result-idx))
               (vs1 (current-voice-state now-state 1))
               (vs2 (current-voice-state now-state 2))


@@ -507,18 +509,18 @@ the mark when there are no spanners active.
               (notes2 (if vs2 (note-events vs2) '()))
               (n1 (length notes1))
               (n2 (length notes2)))
               (notes2 (if vs2 (note-events vs2) '()))
               (n1 (length notes1))
               (n2 (length notes2)))

-         ;; (display (list "analyzing step " result-idx "  moment " (when now-state) vs1 vs2  "\n"))
+         ;; (display (list "analyzing step " result-idx "  moment " (moment now-state) vs1 vs2  "\n"))

          (max
           ;; we should always increase.
           (cond ((and (= n1 0) (= n2 0))
                  (put 'apart-silence)
                  (1+ result-idx))
                 ((and (= n2 0)
          (max
           ;; we should always increase.
           (cond ((and (= n1 0) (= n2 0))
                  (put 'apart-silence)
                  (1+ result-idx))
                 ((and (= n2 0)

-                      (equal? (when vs1) (when now-state))
+                      (equal? (moment vs1) (moment now-state))

                       (null? (previous-span-state vs1)))
                  (try-solo 'solo1 result-idx result-idx))
                 ((and (= n1 0)
                       (null? (previous-span-state vs1)))
                  (try-solo 'solo1 result-idx result-idx))
                 ((and (= n1 0)

-                      (equal? (when vs2) (when now-state))
+                      (equal? (moment vs2) (moment now-state))

                       (null? (previous-span-state vs2)))
                  (try-solo 'solo2 result-idx result-idx))
 
                       (null? (previous-span-state vs2)))
                  (try-solo 'solo2 result-idx result-idx))
 


@@ -559,7 +561,7 @@ the mark when there are no spanners active.
     ;; (display result)
     (set! result (map
                  ;; forced-configuration overrides, if it is set
     ;; (display result)
     (set! result (map
                  ;; forced-configuration overrides, if it is set

-                 (lambda (x) (cons (when x) (or (forced-configuration x) (configuration x))))
+                 (lambda (x) (cons (moment x) (or (forced-configuration x) (configuration x))))

                  (vector->list result)))
     (if #f ;; pc-debug
         (display result))
                  (vector->list result)))
     (if #f ;; pc-debug
         (display result))


@@ -570,10 +572,27 @@ the mark when there are no spanners active.
 
 (define-public (add-quotable parser name mus)
   (let* ((tab (eval 'musicQuotes (current-module)))
 
 (define-public (add-quotable parser name mus)
   (let* ((tab (eval 'musicQuotes (current-module)))

-        (context-list (recording-group-emulate (context-spec-music mus 'Voice)
-                                               (ly:parser-lookup parser 'partCombineListener))))
-    (if (pair? context-list)
-       (hash-set! tab name
-                  ;; cdr : skip name string
-                  (list->vector (reverse! (cdar context-list)
-                                          '()))))))
+         (voicename (get-next-unique-voice-name))
+         ;; recording-group-emulate returns an assoc list (reversed!), so
+         ;; hand it a proper unique context name and extract that key:
+         (ctx-spec (context-spec-music mus 'Voice voicename))
+         (listener (ly:parser-lookup parser 'partCombineListener))
+         (context-list (reverse (recording-group-emulate ctx-spec listener)))
+         (raw-voice (assoc voicename context-list))
+         (quote-contents (if (pair? raw-voice) (cdr raw-voice) '())))
+
+    ;; If the context-specced quoted music does not contain anything, try to
+    ;; use the first child, i.e. the next in context-list after voicename
+    ;; That's the case e.g. for \addQuote "x" \relative c \new Voice {...}
+    (if (null? quote-contents)
+        (let find-non-empty ((current-tail (member raw-voice context-list)))
+          ;; if voice has contents, use them, otherwise check next ctx
+          (cond ((null? current-tail) #f)
+                ((and (pair? (car current-tail))
+                      (pair? (cdar current-tail)))
+                 (set! quote-contents (cdar current-tail)))
+                (else (find-non-empty (cdr current-tail))))))
+
+    (if (not (null? quote-contents))
+        (hash-set! tab name (list->vector (reverse! quote-contents '())))
+        (ly:music-warning mus (ly:format (_ "quoted music `~a' is empty") name)))))