- (prev-split (if spi (vector-ref result spi) #f))
- )
-
- (if prev-split
- (configuration prev-split)
- 'apart)
-
- ))
- (define (put-range x a b)
- (do
- ((i a (1+ i)))
- ((> i b) b)
- (set! (configuration (vector-ref result i)) x)
- ))
- (define (put x)
- (set! (configuration (vector-ref result ri)) x))
-
- (define (try-solo type start-idx current-idx)
- (if (< current-idx (vector-length result))
- (let*
- ((now-state (vector-ref result current-idx))
- (solo-state ((if (equal? type 'solo1) car cdr) (voice-states now-state)))
- (silent-state ((if (equal? type 'solo1) cdr car) (voice-states now-state)))
- (silent-notes (note-events silent-state))
- (solo-notes (note-events solo-state))
- (soln (length solo-notes))
- (siln (length silent-notes)))
-
- (cond
- ((not (equal? (configuration now-state) 'apart))
- current-idx)
- ((= soln 0) current-idx)
- ((> siln 0) current-idx)
- ((null? (span-state solo-state))
- (put-range type start-idx current-idx)
- current-idx)
- (else
- (try-solo type start-idx (1+ current-idx)))
-
- ))
- (1- current-idx)))
-
- (define (analyse-moment ri)
- "Analyse 'apart starting at RI. Return next index.
-"
-
- (let*
- ((now-state (vector-ref result ri))
- (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))
- )
-
- (cond
- ((and (= n1 0) (= n2 0))
- (put 'apart-silence)
- (1+ ri)
- )
-
- ((and (= n2 0)
- (equal? (when vs1) (when now-state))
- (null? (previous-span-state vs1)))
- (try-solo 'solo1 ri ri))
- ((and (= n1 0)
- (equal? (when vs2) (when now-state))
- (null? (previous-span-state vs2)))
- (try-solo 'solo2 ri ri))
- (else
- (1+ ri))
- )))
-
- (if (< ri (vector-length result))
- (if (equal? (configuration (vector-ref result ri)) 'apart)
- (analyse-solo12 (analyse-moment ri))
- (analyse-solo12 (1+ ri))))
- )
-
-
- (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")
- ))
-
- (analyse-time-step 0)
- (analyse-a2 0)
-; (display result)
- (analyse-solo12 0)
-; (if pc-debug (display result))
-
- (set! result (map
- (lambda (x) (cons (when x) (configuration x)))
- (vector->list result)))
-
- (if pc-debug (display result))
- result))
+ (prev-split (if spi (vector-ref result spi) #f)))
+ (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 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)))
+ (if (or (not vs) (equal? (when now-state) (when vs)))
+ 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
+the mark when there are no spanners active."
+ (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 " (when 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-moment 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 " (when 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)
+ (equal? (when vs1) (when now-state))
+ (null? (previous-span-state vs1)))
+ (try-solo 'solo1 result-idx result-idx))
+ ((and (= n1 0)
+ (equal? (when vs2) (when 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))
+ (if (equal? (configuration (vector-ref result result-idx)) 'apart)
+ (analyse-solo12 (analyse-moment result-idx))
+ (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")))
+ (analyse-time-step 0)
+ ;; (display result)
+ (analyse-a2 0)
+ ;;(display result)
+ (analyse-solo12 0)
+ ;; (display result)
+ (set! result (map
+ (lambda (x) (cons (when x) (configuration x)))
+ (vector->list result)))
+ (if #f ;; pc-debug
+ (display result))
+ result))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; autochange - fairly related to part combining.
+
+(define-public (make-autochange-music music)
+ (define (generate-split-list change-moment event-list acc)
+ (if (null? event-list)
+ acc
+ (let* ((now-tun (caar event-list))
+ (evs (map car (cdar event-list)))
+ (now (car now-tun))
+ (notes (filter (lambda (x)
+ (equal? (ly:music-property x 'name) 'NoteEvent))
+ evs))
+ (pitch (if (pair? notes)
+ (ly:music-property (car notes) 'pitch)
+ #f)))
+ ;; tail recursive.
+ (if (and pitch (not (= (ly:pitch-steps pitch) 0)))
+ (generate-split-list #f
+ (cdr event-list)
+ (cons (cons
+
+ (if change-moment
+ change-moment
+ now)
+ (sign (ly:pitch-steps pitch))) acc))
+ (generate-split-list
+ (if pitch #f now)
+ (cdr event-list) acc)))))
+
+ (set! noticed '())
+ (let* ((m (make-music 'AutoChangeMusic))
+ (context (ly:run-translator (make-non-relative-music music) part-combine-listener))
+ (evs (last-pair noticed))
+ (split (reverse! (generate-split-list
+ #f
+ (if (pair? evs)
+ (reverse! (cdar evs) '()) '())
+ '())
+ '())))
+ (set! (ly:music-property m 'element) music)
+ (set! (ly:music-property m 'split-list) split)
+ (set! noticed '())
+ m))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-public (add-quotable name mus)
+ (set! noticed '())
+ (let* ((tab (eval 'musicQuotes (current-module)))
+ (context (ly:run-translator (context-spec-music mus 'Voice)
+ part-combine-listener))
+ (first-voice-handle (last-pair noticed)))
+
+ ;; (display (last-pair noticed))
+ (if (pair? first-voice-handle)
+ (hash-set! tab name
+ ;; cdr : skip name string
+ (list->vector (reverse! (cdar first-voice-handle)
+ '()))))))
+