+ (if (< current-idx (vector-length result))
+ (let* ((now-state (vector-ref result current-idx))
+ (solo-state (current-voice-state now-state (if (equal? type 'solo1) 1 2)))
+ (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 " (moment now-state) solo-state silent-state "\n"))
+ (cond ((not (equal? (configuration now-state) 'apart))
+ current-idx)
+ ((> (length silent-notes) 0) start-idx)
+ ((not solo-state)
+ (put-range type start-idx current-idx)
+ current-idx)
+ ((and
+ (null? (span-state solo-state)))
+
+ ;;
+ ;; 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
+ ;; accidentally be part of a solo.
+ ;;
+ (put-range type start-idx current-idx)
+ (try-solo type (1+ current-idx) (1+ current-idx)))
+ (else
+ (try-solo type start-idx (1+ current-idx)))))
+ ;; try-solo
+ start-idx))
+
+ (define (analyse-apart-silence result-idx)
+ "Analyse 'apart-silence 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))
+ (rests1 (if vs1 (rest-or-skip-events vs1) '()))
+ (rests2 (if vs2 (rest-or-skip-events vs2) '()))
+ (prev-state (if (> result-idx 0)
+ (vector-ref result (- result-idx 1))
+ #f))
+ (prev-config (if prev-state
+ (configuration prev-state)
+ 'apart-silence)))
+ (cond
+ ;; rest with multi-measure rest: choose the rest
+ ((and (synced? now-state)
+ (= 1 (length rests1))
+ (ly:in-event-class? (car rests1) 'rest-event)
+ (= 0 (length rests2))) ; probably mmrest
+ (put 'silence1))
+
+ ;; as above with parts swapped
+ ((and (synced? now-state)
+ (= 1 (length rests2))
+ (ly:in-event-class? (car rests2) 'rest-event)
+ (= 0 (length rests1))) ; probably mmrest
+ (put 'silence2))
+
+ ((synced? now-state)
+ (put 'apart-silence))
+
+ ;; remain in the silence1/2 states until resync
+ ((equal? prev-config 'silence1)
+ (put 'silence1))
+
+ ((equal? prev-config 'silence2)
+ (put 'silence2))
+
+ (else
+ (put 'apart-silence)))
+
+ (1+ result-idx)))
+
+ (define (analyse-apart result-idx)
+ "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))
+ ;; (vs1 (car (voice-states now-state)))
+ ;; (vs2 (cdr (voice-states now-state)))
+ (notes1 (if vs1 (note-events vs1) '()))
+ (notes2 (if vs2 (note-events vs2) '()))
+ (n1 (length notes1))
+ (n2 (length notes2)))
+ ;; (display (list "analyzing step " result-idx " moment " (moment now-state) vs1 vs2 "\n"))
+ (max
+ ;; we should always increase.
+ (cond ((and (= n1 0) (= n2 0))
+ ;; If we hit this, it means that the previous passes
+ ;; have designated as 'apart what is really
+ ;; 'apart-silence.
+ (analyse-apart-silence result-idx))
+ ((and (= n2 0)
+ (equal? (moment vs1) (moment now-state))
+ (null? (previous-span-state vs1)))
+ (try-solo 'solo1 result-idx result-idx))
+ ((and (= n1 0)
+ (equal? (moment vs2) (moment now-state))
+ (null? (previous-span-state vs2)))
+ (try-solo 'solo2 result-idx result-idx))
+
+ (else (1+ result-idx)))
+ ;; analyse-moment
+ (1+ result-idx))))
+
+ (if (< result-idx (vector-length result))
+ (let ((conf (configuration (vector-ref result result-idx))))
+ (cond
+ ((equal? conf 'apart)
+ (analyse-solo12 (analyse-apart result-idx)))
+ ((equal? conf 'apart-silence)
+ (analyse-solo12 (analyse-apart-silence result-idx)))
+ (else
+ (analyse-solo12 (1+ result-idx))))))) ; analyse-solo12
+
+ (analyse-spanner-states voice-state-vec1)
+ (analyse-spanner-states voice-state-vec2)
+ (if #f
+ (begin
+ (display voice-state-vec1)
+ (display "***\n")
+ (display voice-state-vec2)
+ (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)
+ ;; Check for unisono or unisilence moments
+ (analyse-a2 0)
+ ;;(display result)
+ (analyse-solo12 0)
+ ;; (display result)
+ (set! result (map
+ ;; 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))
+ result))
+
+(define-public default-part-combine-mark-state-machine
+ ;; (current-state . ((split-state-event .
+ ;; (output-voice output-event next-state)) ...))
+ '((Initial . ((solo1 . (solo SoloOneEvent Solo1))
+ (solo2 . (solo SoloTwoEvent Solo2))
+ (unisono . (shared UnisonoEvent Unisono))))
+ (Solo1 . ((apart . (#f #f Initial))
+ (chords . (#f #f Initial))
+ (solo2 . (solo SoloTwoEvent Solo2))
+ (unisono . (shared UnisonoEvent Unisono))))
+ (Solo2 . ((apart . (#f #f Initial))
+ (chords . (#f #f Initial))
+ (solo1 . (solo SoloOneEvent Solo1))
+ (unisono . (shared UnisonoEvent Unisono))))
+ (Unisono . ((apart . (#f #f Initial))
+ (chords . (#f #f Initial))
+ (solo1 . (solo SoloOneEvent Solo1))
+ (solo2 . (solo SoloTwoEvent Solo2))))))
+
+(define-public (make-part-combine-marks state-machine split-list)
+ "Generate a sequence of part combiner events from a split list"
+
+ (define (get-state state-name)
+ (assq-ref state-machine state-name))
+
+ (let ((full-seq '()) ; sequence of { \context Voice = "x" {} ... }
+ (segment '()) ; sequence within \context Voice = "x" {...}
+ (prev-moment ZERO-MOMENT)
+ (prev-voice #f)
+ (state (get-state 'Initial)))
+
+ (define (commit-segment)
+ "Add the current segment to the full sequence and begin another."
+ (if (pair? segment)
+ (set! full-seq
+ (cons (make-music 'ContextSpeccedMusic
+ 'context-id (symbol->string prev-voice)
+ 'context-type 'Voice
+ 'element (make-sequential-music (reverse! segment)))
+ full-seq)))
+ (set! segment '()))
+
+ (define (handle-split split)
+ (let* ((moment (car split))
+ (action (assq-ref state (cdr split))))
+ (if action
+ (let ((voice (car action))
+ (part-combine-event (cadr action))
+ (next-state-name (caddr action)))
+ (if part-combine-event
+ (let ((dur (ly:moment-sub moment prev-moment)))
+ ;; start a new segment when the voice changes
+ (if (not (eq? voice prev-voice))
+ (begin
+ (commit-segment)
+ (set! prev-voice voice)))
+ (if (not (equal? dur ZERO-MOMENT))
+ (set! segment (cons (make-music 'SkipEvent
+ 'duration (make-duration-of-length dur)) segment)))
+ (set! segment (cons (make-music part-combine-event) segment))
+
+ (set! prev-moment moment)))
+ (set! state (get-state next-state-name))))))
+
+ (for-each handle-split split-list)
+ (commit-segment)
+ (make-sequential-music (reverse! full-seq))))
+
+(define-public default-part-combine-context-change-state-machine-one
+ ;; (current-state . ((split-state-event . (output-voice next-state)) ...))
+ '((Initial . ((apart . (one . Initial))
+ (apart-silence . (one . Initial))
+ (apart-spanner . (one . Initial))
+ (chords . (shared . Initial))
+ (silence1 . (shared . Initial))
+ (silence2 . (null . Demoted))
+ (solo1 . (solo . Initial))
+ (solo2 . (null . Demoted))
+ (unisono . (shared . Initial))
+ (unisilence . (shared . Initial))))
+
+ ;; After a part has been used as the exclusive input for a
+ ;; passage, we want to use it by default for unisono/unisilence
+ ;; passages because Part_combine_iterator might have killed
+ ;; multi-measure rests in the other part. Here we call such a
+ ;; part "promoted". Part one begins promoted.
+ (Demoted . ((apart . (one . Demoted))
+ (apart-silence . (one . Demoted))
+ (apart-spanner . (one . Demoted))
+ (chords . (shared . Demoted))
+ (silence1 . (shared . Initial))
+ (silence2 . (null . Demoted))
+ (solo1 . (solo . Initial))
+ (solo2 . (null . Demoted))
+ (unisono . (null . Demoted))
+ (unisilence . (null . Demoted))))))
+
+(define-public default-part-combine-context-change-state-machine-two
+ ;; (current-state . ((split-state-event . (output-voice next-state)) ...))
+ '((Initial . ((apart . (two . Initial))
+ (apart-silence . (two . Initial))
+ (apart-spanner . (two . Initial))
+ (chords . (shared . Initial))
+ (silence1 . (null . Initial))
+ (silence2 . (shared . Promoted))
+ (solo1 . (null . Initial))
+ (solo2 . (solo . Promoted))
+ (unisono . (null . Initial))
+ (unisilence . (null . Initial))))
+
+ ;; See the part-one state machine for the meaning of "promoted".
+ (Promoted . ((apart . (two . Promoted))
+ (apart-silence . (two . Promoted))
+ (apart-spanner . (two . Promoted))
+ (chords . (shared . Promoted))
+ (silence1 . (null . Initial))
+ (silence2 . (shared . Promoted))
+ (solo1 . (null . Initial))
+ (solo2 . (solo . Promoted))
+ (unisono . (shared . Promoted))
+ (unisilence . (shared . Promoted))))))
+
+(define-public (make-part-combine-context-changes state-machine split-list)
+ "Generate a sequence of part combiner context changes from a split list"
+
+ (define (get-state state-name)
+ (assq-ref state-machine state-name))
+
+ (let ((change-list '())
+ (prev-voice #f)
+ (state (get-state 'Initial)))
+
+ (define (handle-split split)
+ (let* ((moment (car split))
+ (action (assq-ref state (cdr split))))
+ (if action
+ (let ((voice (car action))
+ (next-state-name (cdr action)))
+ (if (not (eq? voice prev-voice))
+ (begin
+ (set! change-list (cons (cons moment voice) change-list))
+ (set! prev-voice voice)))
+ (set! state (get-state next-state-name))))))
+
+ (for-each handle-split split-list)
+ (reverse! change-list)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-public (add-quotable name mus)
+ (let* ((tab (eval 'musicQuotes (current-module)))
+ (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 '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)))))