Doc: simplify description of disabling beamExceptions (3094)

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

diff --git a/scm/part-combiner.scm b/scm/part-combiner.scm
index a444313f6617f1d385580e8cd76905b1041b8eb7..279123222ba2dbff58f9054e06494c026f9a2c1c 100644 (file)
--- a/scm/part-combiner.scm
+++ b/scm/part-combiner.scm
@@ -1,15 +1,26 @@
-;;;; part-combiner.scm -- Part combining, staff changes.
+;;;; This file is part of LilyPond, the GNU music typesetter.

 ;;;;
 ;;;;

-;;;;  source file of the GNU LilyPond music typesetter
-;;;; 
-;;;; (c) 2004--2006    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
+;;;; the Free Software Foundation, either version 3 of the License, or
+;;;; (at your option) any later version.
+;;;;
+;;;; LilyPond is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.

 
 ;; todo: figure out how to make module,
 ;; without breaking nested ly scopes
 
 (define-class <Voice-state> ()
   (event-list #:init-value '() #:accessor events #:init-keyword #:events)
 
 ;; todo: figure out how to make module,
 ;; without breaking nested ly scopes
 
 (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)


@@ -19,9 +30,9 @@
   ;; of (SYMBOL . RESULT-INDEX), which indicates where
   ;; said spanner was started.
   (spanner-state #:init-value '() #:accessor span-state))
   ;; of (SYMBOL . RESULT-INDEX), which indicates where
   ;; said spanner was started.
   (spanner-state #:init-value '() #:accessor span-state))

-  
+

 (define-method (write (x <Voice-state> ) file)
 (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)


@@ -30,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>))


@@ -43,16 +54,19 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (define-class <Split-state> ()
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (define-class <Split-state> ()

+  ;; The automatically determined split configuration

   (configuration #:init-value '() #:accessor configuration)
   (configuration #:init-value '() #:accessor configuration)

-  (when-moment #:accessor when #:init-keyword #:when)
+  ;; Allow overriding split configuration, takes precedence over configuration
+  (forced-configuration #:init-value #f #:accessor forced-configuration)
+  (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)
   (synced  #:init-keyword #:synced #:init-value         #f #:getter synced?))
   ;; voice-states are states starting with the Split-state or later
   ;;
   (is #:init-keyword #:voice-states #:accessor voice-states)
   (synced  #:init-keyword #:synced #:init-value         #f #:getter synced?))

-                            
+

 
 (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)


@@ -69,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))))


@@ -82,19 +96,19 @@
   "Merge lists VS1 and VS2, containing Voice-state objects into vector
 of Split-state objects, crosslinking the Split-state vector and
 Voice-state objects
   "Merge lists VS1 and VS2, containing Voice-state objects into vector
 of Split-state objects, crosslinking the Split-state vector and
 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)))


@@ -114,32 +128,32 @@ Voice-state objects
 
   (define (helper index active)
     "Analyse EVS at INDEX, given state ACTIVE."
 
   (define (helper index active)
     "Analyse EVS at INDEX, given state ACTIVE."

-    
+

     (define (analyse-tie-start active ev)
     (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))
          (acons 'tie (split-index (vector-ref voice-state-vec index))
                 active)
          active))

-    
+

     (define (analyse-tie-end active ev)
     (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))
                   (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)
     (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)))))
            (else (< (cdr a) (cdr b)))))

-    
+

     (define (analyse-span-event active ev)
     (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)


@@ -181,79 +195,129 @@ Voice-state objects
          (set! (span-state (vector-ref voice-state-vec index))
                (list-copy active))
          (helper (1+ index) active))))
          (set! (span-state (vector-ref voice-state-vec index))
                (list-copy active))
          (helper (1+ index) active))))

-  
+

   (helper 0 '()))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   (helper 0 '()))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

-(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"
+(define-public (recording-group-emulate music odef)
+  "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*
   (let*

-      ((context-list '())
-       (now-mom (ly:make-moment 0 0))
-       (global (ly:make-global-context odef))
-       (mom-listener (ly:make-listener 
-                     (lambda (tev)
-                       (set! now-mom (ly:event-property tev 'moment)))))
-       (new-context-listener
-       (ly:make-listener
-        (lambda (sev)
-            (let*
-                ((child (ly:event-property sev 'context))
-                 (this-moment-list
-                  (cons (ly:context-id child) '()))
-                 (dummy
-                  (set! context-list (cons this-moment-list context-list)))
-                 (acc '())
-                 (accumulate-event-listener
-                  (ly:make-listener (lambda (ev)
-                                      (set! acc (cons (cons ev #t) acc)))))
-                 (save-acc-listener (ly:make-listener (lambda (tev)
-                                                        (if (pair? acc)
-                                                            (let ((this-moment (cons (cons now-mom (ly:context-property child 'instrumentTransposition))
-                                                                                     acc)))
-                                                              (set-cdr! this-moment-list (cons this-moment (cdr this-moment-list)))
-                                                              (set! acc '())))))))
-              (ly:add-listener accumulate-event-listener (ly:context-event-source child) 'music-event)
-              (ly:add-listener save-acc-listener (ly:context-event-source global) 'OneTimeStep))))))
-    (ly:add-listener new-context-listener (ly:context-events-below global) 'AnnounceNewContext)
+     ((context-list '())
+      (now-mom (ly:make-moment 0 0))
+      (global (ly:make-global-context odef))
+      (mom-listener (ly:make-listener
+             (lambda (tev) (set! now-mom (ly:event-property tev 'moment)))))
+      (new-context-listener
+       (ly:make-listener
+        (lambda (sev)
+          (let*
+             ((child (ly:event-property sev 'context))
+              (this-moment-list (cons (ly:context-id child) '()))
+              (dummy (set! context-list (cons this-moment-list context-list)))
+              (acc '())
+              (accumulate-event-listener
+                  (ly:make-listener (lambda (ev)
+                                       (set! acc (cons (cons ev #t) acc)))))
+              (save-acc-listener
+                  (ly:make-listener (lambda (tev)
+                      (if (pair? acc)
+                        (let ((this-moment
+                              (cons (cons now-mom
+                                (ly:context-property child 'instrumentTransposition))
+                                ;; The accumulate-event-listener above creates
+                                ;; the list of events in reverse order, so we
+                                ;; have to revert it to the original order again
+                                (reverse acc))))
+                          (set-cdr! this-moment-list
+                                (cons this-moment (cdr this-moment-list)))
+                          (set! acc '())))))))
+            (ly:add-listener accumulate-event-listener
+                (ly:context-event-source child) 'StreamEvent)
+            (ly:add-listener save-acc-listener
+                (ly:context-event-source global) 'OneTimeStep))))))
+    (ly:add-listener new-context-listener
+        (ly:context-events-below global) 'AnnounceNewContext)

     (ly:add-listener mom-listener (ly:context-event-source global) 'Prepare)
     (ly:interpret-music-expression (make-non-relative-music music) global)
     context-list))
 
     (ly:add-listener mom-listener (ly:context-event-source global) 'Prepare)
     (ly:interpret-music-expression (make-non-relative-music music) global)
     context-list))
 

-(define noticed '())
-;; todo: junk this, extract $defaultlayout from parser instead
-(define part-combine-listener '())
-
-; UGH - should pass noticed setter to part-combine-listener
-(define-safe-public (set-part-combine-listener x)
-  (set! part-combine-listener x))
-
-(define-public (notice-the-events-for-pc context lst)
-  "add CONTEXT-ID, EVENT list to NOTICED variable."
-  
-  (set! noticed (acons (ly:context-id context) lst noticed)))
-
-(define-public (make-part-combine-music 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")))

-        (evs2 (recording-group-emulate m2 part-combine-listener))
-        (evs1 (recording-group-emulate m1 part-combine-listener)))
-    
+        (listener (ly:parser-lookup parser 'partCombineListener))
+        (evs2 (recording-group-emulate m2 listener))
+        (evs1 (recording-group-emulate m1 listener)))
+

     (set! (ly:music-property m 'elements) (list m1 m2))
     (set! (ly:music-property m 'elements) (list m1 m2))

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

     (set! (ly:music-property m 'split-list)
     (set! (ly:music-property m 'split-list)

-         (determine-split-list (reverse! (cdr (assoc "one" evs1)) '())
-                               (reverse! (cdr (assoc "two" evs2)) '())))
+         (if (and (assoc "one" evs1) (assoc "two" evs2))
+             (determine-split-list (reverse! (assoc-get "one" evs1) '())
+                                   (reverse! (assoc-get "two" evs2) '()))
+             '()))

     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))
         (voice-state-vec2 (make-voice-states evl2))
         (result (make-split-state voice-state-vec1 voice-state-vec2)))
   (let* ((pc-debug #f)
         (chord-threshold 8)
         (voice-state-vec1 (make-voice-states evl1))
         (voice-state-vec2 (make-voice-states evl2))
         (result (make-split-state voice-state-vec1 voice-state-vec2)))

-    
+
+    ;; Go through all moments recursively and check if the events of that
+    ;; moment contain a part-combine-force-event override. If so, store its
+    ;; value in the forced-configuration field, which will override. The
+    ;; previous configuration is used to determine non-terminated settings.
+    (define (analyse-forced-combine result-idx prev-res)
+
+      (define (get-forced-event x)
+       (if (ly:in-event-class? x 'part-combine-force-event)
+           (cons (ly:event-property x 'forced-type) (ly:event-property x 'once))
+           #f))
+      (define (part-combine-events vs)
+       (if (not vs)
+           '()
+           (filter-map get-forced-event (events vs))))
+      ;; end part-combine-events
+
+      ;; forced-result: Take the previous config and analyse whether
+      ;; any change happened.... Return new once and permanent config
+      (define (forced-result evt state)
+       ;; sanity check, evt should always be (new-state . once)
+       (if (not (and (pair? evt) (pair? state)))
+           state
+           (if (cdr evt)
+               ;; Once-event, leave permanent state unchanged
+               (cons (car evt) (cdr state))
+               ;; permanent change, leave once state unchanged
+               (cons (car state) (car evt)))))
+      ;; end forced-combine-result
+
+      ;; body of analyse-forced-combine:
+      (if (< result-idx (vector-length result))
+         (let* ((now-state (vector-ref result result-idx)) ; current result
+                ;; Extract all part-combine force events
+                (ev1 (part-combine-events (car (voice-states now-state))))
+                (ev2 (part-combine-events (cdr (voice-states now-state))))
+                (evts (append ev1 ev2))
+                ;; result is (once-state permament-state):
+                (state (fold forced-result (cons 'automatic prev-res) evts))
+                ;; Now let once override permanent changes:
+                (force-state (if (equal? (car state) 'automatic)
+                                 (cdr state)
+                                 (car state))))
+           (set! (forced-configuration (vector-ref result result-idx))
+                 force-state)
+           ;; For the next moment, ignore the once override (car stat)
+           ;; and pass on the permanent override, stored as (cdr state)
+           (analyse-forced-combine (1+ result-idx) (cdr state)))))
+    ;; end analyse-forced-combine
+
+

     (define (analyse-time-step result-idx)
       (define (put x . index)
        "Put the result to X, starting from INDEX backwards.
     (define (analyse-time-step result-idx)
       (define (put x . index)
        "Put the result to X, starting from INDEX backwards.


@@ -266,7 +330,7 @@ Only set if not set previously.
              (begin
                (set! (configuration (vector-ref result i)) x)
                (put x (1- i))))))
              (begin
                (set! (configuration (vector-ref result i)) x)
                (put x (1- i))))))

-      
+

       (define (copy-state-from state-vec vs)
        (define (copy-one-state key-idx)
          (let* ((idx (cdr key-idx))
       (define (copy-state-from state-vec vs)
        (define (copy-one-state key-idx)
          (let* ((idx (cdr key-idx))


@@ -324,12 +388,12 @@ Only set if not set previously.
                                                (previous-voice-state vs2)))
                           (if (and (null? (span-state vs1)) (null? (span-state vs2)))
                               (put 'chords)))))))))
                                                (previous-voice-state vs2)))
                           (if (and (null? (span-state vs1)) (null? (span-state vs2)))
                               (put 'chords)))))))))

-      
+

       (if (< result-idx (vector-length result))
          (let* ((now-state (vector-ref result result-idx))
                 (vs1 (car (voice-states now-state)))
                 (vs2 (cdr (voice-states now-state))))
       (if (< result-idx (vector-length result))
          (let* ((now-state (vector-ref result result-idx))
                 (vs1 (car (voice-states now-state)))
                 (vs2 (cdr (voice-states now-state))))

-           
+

            (cond ((not vs1) (put 'apart))
                  ((not vs2) (put 'apart))
                  (else
            (cond ((not vs1) (put 'apart))
                  ((not vs2) (put 'apart))
                  (else


@@ -338,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")))


@@ -346,13 +410,13 @@ Only set if not set previously.
                              (equal? active1 active2)
                              (equal? new-active1 new-active2))
                         (analyse-notes now-state)
                              (equal? active1 active2)
                              (equal? new-active1 new-active2))
                         (analyse-notes now-state)

-                        
+

                         ;; active states different:
                         (put 'apart)))
                         ;; active states different:
                         (put 'apart)))

-                  
+

                   ;; go to the next one, if it exists.
                   (analyse-time-step (1+ result-idx)))))))
                   ;; go to the next one, if it exists.
                   (analyse-time-step (1+ result-idx)))))))

-    
+

     (define (analyse-a2 result-idx)
       (if (< result-idx (vector-length result))
          (let* ((now-state (vector-ref result result-idx))
     (define (analyse-a2 result-idx)
       (if (< result-idx (vector-length result))
          (let* ((now-state (vector-ref result result-idx))


@@ -360,7 +424,7 @@ Only set if not set previously.
                 (vs2 (cdr (voice-states now-state))))
            (if (and (equal? (configuration now-state) 'chords)
                     vs1 vs2)
                 (vs2 (cdr (voice-states now-state))))
            (if (and (equal? (configuration now-state) 'chords)
                     vs1 vs2)

-               (let ((notes1 (note-events vs1)) 
+               (let ((notes1 (note-events vs1))

                      (notes2 (note-events vs2)))
                  (cond ((and (= 1 (length notes1))
                              (= 1 (length notes2))
                      (notes2 (note-events vs2)))
                  (cond ((and (= 1 (length notes1))
                              (= 1 (length notes2))


@@ -371,9 +435,9 @@ Only set if not set previously.
                              (= 0 (length notes2)))
                         (set! (configuration now-state) 'unisilence)))))
            (analyse-a2 (1+ result-idx)))))
                              (= 0 (length notes2)))
                         (set! (configuration now-state) 'unisilence)))))
            (analyse-a2 (1+ result-idx)))))

-    
+

     (define (analyse-solo12 result-idx)
     (define (analyse-solo12 result-idx)

-      
+

       (define (previous-config vs)
        (let* ((pvs (previous-voice-state vs))
               (spi (if pvs (split-index pvs) #f))
       (define (previous-config vs)
        (let* ((pvs (previous-voice-state vs))
               (spi (if pvs (split-index pvs) #f))


@@ -381,26 +445,26 @@ Only set if not set previously.
          (if prev-split
              (configuration prev-split)
              'apart)))
          (if prev-split
              (configuration prev-split)
              'apart)))

-      
+

       (define (put-range x a b)
        ;; (display (list "put range "  x a b "\n"))
        (do ((i a (1+ i)))
            ((> i b) b)
          (set! (configuration (vector-ref result i)) x)))
       (define (put-range x a b)
        ;; (display (list "put range "  x a b "\n"))
        (do ((i a (1+ i)))
            ((> i b) b)
          (set! (configuration (vector-ref result i)) x)))

-      
+

       (define (put x)
        ;; (display (list "putting "  x "\n"))
        (set! (configuration (vector-ref result result-idx)) x))
       (define (put x)
        ;; (display (list "putting "  x "\n"))
        (set! (configuration (vector-ref result result-idx)) x))

-      
+

       (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)))
            vs
            (previous-voice-state vs)))

-      
+

       (define (try-solo type start-idx current-idx)
       (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.


@@ -411,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)


@@ -424,7 +488,7 @@ the mark when there are no spanners active.
                     ;;
                     ;; This includes rests. This isn't a problem: long rests
                     ;; will be shared with the silent voice, and be marked
                     ;;
                     ;; This includes rests. This isn't a problem: long rests
                     ;; will be shared with the silent voice, and be marked

-                    ;; as unisilence. Therefore, long rests won't 
+                    ;; as unisilence. Therefore, long rests won't

                     ;;  accidentally be part of a solo.
                     ;;
                     (put-range type start-idx current-idx)
                     ;;  accidentally be part of a solo.
                     ;;
                     (put-range type start-idx current-idx)


@@ -433,9 +497,9 @@ the mark when there are no spanners active.
                     (try-solo type start-idx (1+ current-idx)))))
            ;; try-solo
            start-idx))
                     (try-solo type start-idx (1+ current-idx)))))
            ;; try-solo
            start-idx))

-      
+

       (define (analyse-moment result-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))


@@ -445,25 +509,25 @@ 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))

-                
+

                 (else (1+ result-idx)))
           ;; analyse-moment
           (1+ result-idx))))
                 (else (1+ result-idx)))
           ;; analyse-moment
           (1+ result-idx))))

-      
+

       (if (< result-idx (vector-length result))
          (if (equal? (configuration (vector-ref result result-idx)) 'apart)
              (analyse-solo12 (analyse-moment result-idx))
       (if (< result-idx (vector-length result))
          (if (equal? (configuration (vector-ref result result-idx)) 'apart)
              (analyse-solo12 (analyse-moment result-idx))


@@ -479,14 +543,25 @@ the mark when there are no spanners active.
          (display "***\n")
          (display result)
          (display "***\n")))
          (display "***\n")
          (display result)
          (display "***\n")))

+
+    ;; Extract all forced combine strategies, i.e. events inserted by
+    ;; \partcombine(Apart|Automatic|SoloI|SoloII|Chords)[Once]
+    ;; They will in the end override the automaically determined ones.
+    ;; Initial state for both voices is no override
+    (analyse-forced-combine 0 #f)
+    ;; Now go through all time steps in a loop and find a combination strategy
+    ;; based only on the events of that one moment (i.e. neglecting longer
+    ;; periods of solo/apart, etc.)

     (analyse-time-step 0)
     ;; (display result)
     (analyse-time-step 0)
     ;; (display result)

+    ;; Check for unisono or unisilence moments

     (analyse-a2 0)
     ;;(display result)
     (analyse-solo12 0)
     ;; (display result)
     (set! result (map
     (analyse-a2 0)
     ;;(display result)
     (analyse-solo12 0)
     ;; (display result)
     (set! result (map

-                 (lambda (x) (cons (when x) (configuration x)))
+                 ;; forced-configuration overrides, if it is set
+                 (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))


@@ -495,13 +570,29 @@ the mark when there are no spanners active.
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 

-(define-public (add-quotable name mus)
-  (set! noticed '())
+(define-public (add-quotable parser name mus)

   (let* ((tab (eval 'musicQuotes (current-module)))
   (let* ((tab (eval 'musicQuotes (current-module)))

-        (context-list (recording-group-emulate (context-spec-music mus 'Voice)
-                                             part-combine-listener)))
-    (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)))))