- (define (copy-one-state key-idx)
- (let* ((idx (cdr key-idx))
- (prev-ss (vector-ref result idx))
- (prev (configuration prev-ss)))
- (if (symbol? prev)
- (put prev))))
- (map copy-one-state (span-state vs)))
-
- (define (analyse-notes now-state)
- (let* ((vs1 (car (voice-states now-state)))
- (vs2 (cdr (voice-states now-state)))
- (notes1 (note-events vs1))
- (durs1 (sort (map (lambda (x) (ly:music-property x 'duration))
- notes1)
- ly:duration<?))
- (pitches1 (sort (map (lambda (x) (ly:music-property x 'pitch))
- notes1)
- ly:pitch<?))
- (notes2 (note-events vs2))
- (durs2 (sort (map (lambda (x) (ly:music-property x 'duration))
- notes2)
- ly:duration<?))
- (pitches2 (sort (map (lambda (x) (ly:music-property x 'pitch))
- notes2)
- ly:pitch<?)))
- (cond ((> (length notes1) 1) (put 'apart))
- ((> (length notes2) 1) (put 'apart))
- ((not (= (length notes1) (length notes2)))
- (put 'apart))
- ((and (= (length durs1) 1)
- (= (length durs2) 1)
- (not (equal? (car durs1) (car durs2))))
- (put 'apart))
- (else
- (if (and (= (length pitches1) (length pitches2)))
- (if (and (pair? pitches1)
- (pair? pitches2)
- (< chord-threshold (ly:pitch-steps
- (ly:pitch-diff (car pitches1) (car pitches2)))))
- (put 'apart)
- ;; copy previous split state from spanner state
- (begin
- (if (previous-voice-state vs1)
- (copy-state-from voice-state-vec1
- (previous-voice-state vs1)))
- (if (previous-voice-state vs2)
- (copy-state-from voice-state-vec2
- (previous-voice-state vs2)))
- (if (and (null? (span-state vs1)) (null? (span-state vs2)))
- (put 'chords)))))))))
-
- (if (< ri (vector-length result))
- (let* ((now-state (vector-ref result ri))
- (vs1 (car (voice-states now-state)))
- (vs2 (cdr (voice-states now-state))))
- (cond ((not vs1) (put 'apart))
- ((not vs2) (put 'apart))
- (else
- (let ((active1 (previous-span-state vs1))
- (active2 (previous-span-state vs2))
- (new-active1 (span-state vs1))
- (new-active2 (span-state vs2)))
- (if pc-debug
- (display (list (when now-state) ri
- active1 "->" new-active1
- active2 "->" new-active2
- "\n")))
- (if (and (synced? now-state)
- (equal? active1 active2)
- (equal? new-active1 new-active2))
- (analyse-notes now-state)
- ;; active states different:
- (put 'apart)))
- ;; go to the next one, if it exists.
- (analyse-time-step (1+ ri)))))))
-
- (define (analyse-a2 ri)
- (if (< ri (vector-length result))
- (let* ((now-state (vector-ref result ri))
- (vs1 (car (voice-states now-state)))
- (vs2 (cdr (voice-states now-state))))
- (if (and (equal? (configuration now-state) 'chords)
- vs1 vs2)
- (let ((notes1 (note-events vs1))
- (notes2 (note-events vs2)))
- (cond ((and (= 1 (length notes1))
- (= 1 (length notes2))
- (equal? (ly:music-property (car notes1) 'pitch)
- (ly:music-property (car notes2) 'pitch)))
- (set! (configuration now-state) 'unisono))
- ((and (= 0 (length notes1))
- (= 0 (length notes2)))
- (set! (configuration now-state) 'unisilence)))))
- (analyse-a2 (1+ ri)))))
-
- (define (analyse-solo12 ri)
-
+ (define (copy-one-state key-idx)
+ (let* ((idx (cdr key-idx))
+ (prev-ss (vector-ref result idx))
+ (prev (configuration prev-ss)))
+ (if (symbol? prev)
+ (put prev))))
+ (for-each copy-one-state (span-state vs)))
+
+ (define (analyse-notes now-state)
+ (let* ((vs1 (car (voice-states now-state)))
+ (vs2 (cdr (voice-states now-state)))
+ (notes1 (comparable-note-events vs1))
+ (notes2 (comparable-note-events vs2)))
+ (cond
+ ;; if neither part has notes, do nothing
+ ((and (not (pair? notes1)) (not (pair? notes2))))
+
+ ;; if one part has notes and the other does not
+ ((or (not (pair? notes1)) (not (pair? notes2))) (put 'apart))
+
+ ;; if either part has a chord
+ ((or (> (length notes1) 1)
+ (> (length notes2) 1))
+ (if (and (<= chord-min-diff 0) ; user requests combined unisons
+ (equal? notes1 notes2)) ; both parts have the same chord
+ (put 'chords)
+ (put 'apart)))
+
+ ;; if the durations are different
+ ;; TODO articulations too?
+ ((and (not (equal? (ly:event-property (car notes1) 'duration)
+ (ly:event-property (car notes2) 'duration))))
+ (put 'apart))
+
+ (else
+ ;; Is the interval outside of chord-range?
+ (if (let ((diff (ly:pitch-steps
+ (ly:pitch-diff
+ (ly:event-property (car notes1) 'pitch)
+ (ly:event-property (car notes2) 'pitch)))))
+ (or (< diff chord-min-diff)
+ (> diff chord-max-diff)
+ ))
+ (put 'apart)
+ ;; copy previous split state from spanner state
+ (begin
+ (if (previous-voice-state vs1)
+ (copy-state-from voice-state-vec1
+ (previous-voice-state vs1)))
+ (if (previous-voice-state vs2)
+ (copy-state-from voice-state-vec2
+ (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))))
+
+ (cond ((not vs1) (put 'apart))
+ ((not vs2) (put 'apart))
+ (else
+ (let ((active1 (previous-span-state vs1))
+ (active2 (previous-span-state vs2))
+ (new-active1 (span-state vs1))
+ (new-active2 (span-state vs2)))
+ (if #f ; debug
+ (display (list (moment now-state) result-idx
+ active1 "->" new-active1
+ active2 "->" new-active2
+ "\n")))
+ (if (and (synced? now-state)
+ (equal? active1 active2)
+ (equal? new-active1 new-active2))
+ (analyse-notes now-state)
+
+ ;; active states different:
+ (put 'apart)))
+
+ ;; 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))
+ (vs1 (car (voice-states now-state)))
+ (vs2 (cdr (voice-states now-state))))
+
+ (define (analyse-synced-silence)
+ (let ((rests1 (if vs1 (rest-or-skip-events vs1) '()))
+ (rests2 (if vs2 (rest-or-skip-events vs2) '())))
+ (cond
+
+ ;; multi-measure rests (probably), which the
+ ;; part-combine iterator handles well
+ ((and (= 0 (length rests1))
+ (= 0 (length rests2)))
+ (set! (configuration now-state) 'unisilence))
+
+ ;; equal rests or equal skips, but not one of each
+ ((and (= 1 (length rests1))
+ (= 1 (length rests2))
+ (equal? (ly:event-property (car rests1) 'class)
+ (ly:event-property (car rests2) 'class))
+ (equal? (ly:event-property (car rests1) 'duration)
+ (ly:event-property (car rests2) 'duration)))
+ (set! (configuration now-state) 'unisilence))
+
+ ;; rests of different durations or mixed with
+ ;; skips or multi-measure rests
+ (else
+ ;; TODO For skips, route the rest to the shared
+ ;; voice and the skip to the voice for its part?
+ (set! (configuration now-state) 'apart-silence))
+
+ )))
+
+ (define (analyse-unsynced-silence vs1 vs2)
+ (let ((any-mmrests1 (if vs1 (any-mmrest-events vs1) #f))
+ (any-mmrests2 (if vs2 (any-mmrest-events vs2) #f)))
+ (cond
+ ;; If a multi-measure rest begins now while the other
+ ;; part has an ongoing multi-measure rest (or has
+ ;; ended), start displaying the one that begins now.
+ ((and any-mmrests1
+ (equal? (moment vs1) (moment now-state))
+ (or (not vs2) any-mmrests2))
+ (set! (configuration now-state) 'silence1))
+
+ ;; as above with parts swapped
+ ((and any-mmrests2
+ (equal? (moment vs2) (moment now-state))
+ (or (not vs1) any-mmrests1))
+ (set! (configuration now-state) 'silence2))
+ )))
+
+ (if (or vs1 vs2)
+ (let ((notes1 (if vs1 (comparable-note-events vs1) '()))
+ (notes2 (if vs2 (comparable-note-events vs2) '())))
+ (cond ((and (equal? (configuration now-state) 'chords)
+ (pair? notes1)
+ (equal? notes1 notes2))
+ (set! (configuration now-state) 'unisono))
+
+ ((synced? now-state)
+ (if (and (= 0 (length notes1))
+ (= 0 (length notes2)))
+ (analyse-synced-silence)))
+
+ (else ;; not synchronized
+ (let* ((vss
+ (current-or-previous-voice-states now-state))
+ (vs1 (car vss))
+ (vs2 (cdr vss)))
+ (if (and
+ (or (not vs1) (= 0 (length (note-events vs1))))
+ (or (not vs2) (= 0 (length (note-events vs2)))))
+ (analyse-unsynced-silence vs1 vs2))))
+ )))
+ (analyse-a2 (1+ result-idx)))))
+
+ (define (analyse-solo12 result-idx)
+