X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fpart-combiner.scm;h=ddaa17033fc8a9540651efd31306eeaef2e688f6;hb=5b4b0d6e9a197e8f9eb085b7c2ad78b8be3e5cfc;hp=8996fa2739fb96b75288cc21a3aeb9317e0683e9;hpb=b0c62342c18106b243542e1706612077df7716d2;p=lilypond.git diff --git a/scm/part-combiner.scm b/scm/part-combiner.scm index 8996fa2739..ddaa17033f 100644 --- a/scm/part-combiner.scm +++ b/scm/part-combiner.scm @@ -1,24 +1,24 @@ - +;;;; part-combiner.scm -- Part combining, staff changes. +;;;; +;;;; source file of the GNU LilyPond music typesetter +;;;; +;;;; (c) 2004--2008 Han-Wen Nienhuys ;; todo: figure out how to make module, ;; without breaking nested ly scopes -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; part-combiner. - (define-class () (event-list #:init-value '() #:accessor events #:init-keyword #:events) (when-moment #:accessor when #:init-keyword #:when) + (tuning #:accessor tuning #:init-keyword #:tuning) (split-index #:accessor split-index) (vector-index) (state-vector) - - ;;; - ; spanner-state is an alist - ; of (SYMBOL . RESULT-INDEX), which indicates where - ; said spanner was started. - (spanner-state #:init-value '() #:accessor span-state) ) + ;; spanner-state is an alist + ;; of (SYMBOL . RESULT-INDEX), which indicates where + ;; said spanner was started. + (spanner-state #:init-value '() #:accessor span-state)) (define-method (write (x ) file) (display (when x) file) @@ -26,114 +26,89 @@ (display (events x) file) (display " active = " file) (display (span-state x) file) - (display "\n" file) ) + (display "\n" file)) (define-method (note-events (vs )) (define (f? x) - (equal? (ly:get-mus-property x 'name) 'NoteEvent)) + (equal? (ly:event-property x 'class) 'note-event)) (filter f? (events vs))) (define-method (previous-voice-state (vs )) - (let* ((i (slot-ref vs 'vector-index)) - (v (slot-ref vs 'state-vector)) ) + (let ((i (slot-ref vs 'vector-index)) + (v (slot-ref vs 'state-vector))) (if (< 0 i) (vector-ref v (1- i)) - #f) - )) - + #f))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-class () (configuration #:init-value '() #:accessor configuration) (when-moment #:accessor when #:init-keyword #:when) + ;; 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?) ) + (synced #:init-keyword #:synced #:init-value #f #:getter synced?)) - - (define-method (write (x ) f) (display (when x) f) (display " = " f) (display (configuration x) f) (if (synced? x) (display " synced ")) - (display "\n" f) ) + (display "\n" f)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (previous-span-state vs) - (let* - ((p (previous-voice-state vs))) - - (if p (span-state p) - '()) - )) + (let ((p (previous-voice-state vs))) + (if p (span-state p) '()))) (define (make-voice-states evl) - (let - ((vec - (list->vector - (map - (lambda (v) - (make - #:when (car v) - #:events (map car (cdr v)) - )) - evl)))) - - (do ( (i 0 (1+ i)) ) - ( (= i (vector-length vec)) vec) + (let ((vec (list->vector (map (lambda (v) + (make + #:when (caar v) + #:tuning (cdar v) + #:events (map car (cdr v)))) + evl)))) + (do ((i 0 (1+ i))) + ((= i (vector-length vec)) vec) (slot-set! (vector-ref vec i) 'vector-index i) - (slot-set! (vector-ref vec i) 'state-vector vec) - ))) - + (slot-set! (vector-ref vec i) 'state-vector vec)))) (define (make-split-state vs1 vs2) "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* - ((s1 (if (< idx1 (vector-length vs1)) (vector-ref vs1 idx1) #f)) - (s2 (if (< idx2 (vector-length vs2)) (vector-ref vs2 idx2) #f)) - (min (cond ((and s1 s2) (moment-min (when s1) (when s2))) - (s1 (when s1)) - (s2 (when s2)) - (else #f) - )) - - (inc1 (if (and s1 (equal? min (when s1))) 1 0)) - (inc2 (if (and s2 (equal? min (when s2))) 1 0)) - (ss-object - (if min - (make - #:when min - #:voice-states (cons s1 s2) - #:synced (= inc1 inc2) - ) #f)) ) - (if s1 - (set! (split-index s1) ss-idx)) - (if s2 - (set! (split-index s2) ss-idx)) - + (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)) + (else #f))) + (inc1 (if (and state1 (equal? min (when state1))) 1 0)) + (inc2 (if (and state2 (equal? min (when state2))) 1 0)) + (ss-object (if min + (make + #:when min + #:voice-states (cons state1 state2) + #:synced (= inc1 inc2)) + #f))) + (if state1 + (set! (split-index state1) ss-idx)) + (if state2 + (set! (split-index state2) ss-idx)) (if min (helper (1+ ss-idx) (cons ss-object ss-list) (+ idx1 inc1) (+ idx2 inc2)) - ss-list ) - )) - - (list->vector - (reverse! - (helper 0 '() 0 0) '())) ) - - + ss-list))) + (list->vector (reverse! (helper 0 '() 0 0) '()))) (define (analyse-spanner-states voice-state-vec) @@ -141,84 +116,62 @@ Voice-state objects "Analyse EVS at INDEX, given state ACTIVE." (define (analyse-tie-start active ev) - (if (equal? (ly:get-mus-property ev 'name) 'TieEvent) - (acons 'tie index active) - active - )) + (if (equal? (ly:event-property ev 'class) 'tie-event) + (acons 'tie (split-index (vector-ref voice-state-vec index)) + active) + active)) (define (analyse-tie-end active ev) - (if (equal? (ly:get-mus-property ev 'name) 'NoteEvent) + (if (equal? (ly:event-property ev 'class) 'note-event) (assoc-remove! active 'tie) - active) ) + active)) (define (analyse-absdyn-end active ev) - (if (equal? (ly:get-mus-property ev 'name) 'AbsoluteDynamicEvent) - (assoc-remove! - (assoc-remove! active 'cresc) - 'decr) - active) ) + (if (or (equal? (ly:event-property ev 'class) 'absolute-dynamic-event) + (and (equal? (ly:event-property ev 'class) 'crescendo-event) + (equal? STOP (ly:event-property ev 'span-direction)))) + (assoc-remove! (assoc-remove! active 'cresc) 'decr) + active)) (define (active (length notes1) 1) (put 'apart)) + ((> (length notes2) 1) (put 'apart)) + ((= 1 (+ (length notes2) (length notes1))) (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) + (or + (< chord-threshold (ly:pitch-steps + (ly:pitch-diff (car pitches1) + (car pitches2)))) + + ;; voice crossings: + (> 0 (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))))))))) - (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:get-mus-property x 'duration)) notes1) ly:duration (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)) - ))))) + (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 (when 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 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:get-mus-property (car notes1) 'pitch) - (ly:get-mus-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 (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)))) + (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:event-property (car notes1) 'pitch) + (ly:event-property (car notes2) 'pitch))) + (set! (configuration now-state) 'unisono)) + ((and (= 0 (length notes1)) + (= 0 (length notes2))) + (set! (configuration now-state) 'unisilence))))) + (analyse-a2 (1+ result-idx))))) - (define (previous-config vs) - (let* ((pvs (previous-voice-state vs)) + (define (analyse-solo12 result-idx) + + (define (previous-config vs) + (let* ((pvs (previous-voice-state vs)) (spi (if pvs (split-index pvs) #f)) - (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 (if silent-state (note-events silent-state) '())) - (solo-notes (if solo-state (note-events solo-state) '())) - (soln (length solo-notes)) - (siln (length silent-notes))) + (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. - (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. + return next idx to analyse. " - - (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)) + (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 event-list) - (if (null? event-list) - '() - (let* - ((evs (map car (cdar event-list))) - (now (caar event-list)) - (notes (filter (lambda (x) - (equal? (ly:get-mus-property x 'name) 'NoteEvent)) - evs)) - (pitch (if (pair? notes) - (ly:get-mus-property (car notes) 'pitch) - #f)) ) - - ;; tail recursive. - (if (and pitch (not (= (ly:pitch-steps pitch) 0))) - (cons (cons now (sign (ly:pitch-steps pitch))) - (generate-split-list (cdr event-list))) - (generate-split-list (cdr event-list))) - ))) - - (set! noticed '()) - - (let* - ((m (make-music-by-name 'AutoChangeMusic)) - (context (ly:run-translator music part-combine-listener)) - (evs (last-pair noticed)) ) - - (ly:set-mus-property! m 'element music) - (ly:set-mus-property! - m 'split-list - (generate-split-list (if (pair? evs) (reverse! (cdar evs) '()) '())) ) - - (set! noticed '()) - m - )) - +(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) + '()))))))