X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fpart-combiner.scm;h=ddaa17033fc8a9540651efd31306eeaef2e688f6;hb=5b4b0d6e9a197e8f9eb085b7c2ad78b8be3e5cfc;hp=40039f7d5c57b20e3e4785dbb897f27e3e24366a;hpb=40ce03239ae5e7d7056508c2dea7d368a7cd9bf4;p=lilypond.git diff --git a/scm/part-combiner.scm b/scm/part-combiner.scm index 40039f7d5c..ddaa17033f 100644 --- a/scm/part-combiner.scm +++ b/scm/part-combiner.scm @@ -2,7 +2,7 @@ ;;;; ;;;; source file of the GNU LilyPond music typesetter ;;;; -;;;; (c) 2004 Han-Wen Nienhuys +;;;; (c) 2004--2008 Han-Wen Nienhuys ;; todo: figure out how to make module, ;; without breaking nested ly scopes @@ -18,7 +18,7 @@ ;; 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 #:init-value '() #:accessor span-state)) (define-method (write (x ) file) (display (when x) file) @@ -26,16 +26,16 @@ (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:music-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)) ) + (v (slot-ref vs 'state-vector))) (if (< 0 i) (vector-ref v (1- i)) #f))) @@ -57,7 +57,7 @@ (display (configuration x) f) (if (synced? x) (display " synced ")) - (display "\n" f) ) + (display "\n" f)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -73,8 +73,8 @@ #:tuning (cdar v) #:events (map car (cdr v)))) evl)))) - (do ( (i 0 (1+ i)) ) - ( (= i (vector-length vec)) vec) + (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)))) @@ -84,24 +84,24 @@ 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)) + (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 s1 (equal? min (when s1))) 1 0)) - (inc2 (if (and s2 (equal? min (when s2))) 1 0)) + (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 s1 s2) + #:voice-states (cons state1 state2) #:synced (= inc1 inc2)) #f))) - (if s1 - (set! (split-index s1) ss-idx)) - (if s2 - (set! (split-index s2) ss-idx)) + (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) @@ -110,25 +110,26 @@ Voice-state objects ss-list))) (list->vector (reverse! (helper 0 '() 0 0) '()))) - (define (analyse-spanner-states voice-state-vec) (define (helper index active) "Analyse EVS at INDEX, given state ACTIVE." (define (analyse-tie-start active ev) - (if (equal? (ly:music-property ev 'name) 'TieEvent) + (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:music-property ev 'name) 'NoteEvent) + (if (equal? (ly:event-property ev 'class) 'note-event) (assoc-remove! active 'tie) active)) (define (analyse-absdyn-end active ev) - (if (equal? (ly:music-property ev 'name) 'AbsoluteDynamicEvent) + (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)) @@ -138,14 +139,14 @@ Voice-state objects (else (< (cdr a) (cdr b))))) (define (analyse-span-event active ev) - (let* ((name (ly:music-property ev 'name)) - (key (cond ((equal? name 'SlurEvent) 'slur) - ((equal? name 'PhrasingSlurEvent) 'tie) - ((equal? name 'BeamEvent) 'beam) - ((equal? name 'CrescendoEvent) 'cresc) - ((equal? name 'DecrescendoEvent) 'decr) + (let* ((name (ly:event-property ev 'class)) + (key (cond ((equal? name 'slur-event) 'slur) + ((equal? name 'phrasing-slur-event) 'tie) + ((equal? name 'beam-event) 'beam) + ((equal? name 'crescendo-event) 'cresc) + ((equal? name 'decrescendo-event) 'decr) (else #f))) - (sp (ly:music-property ev 'span-direction))) + (sp (ly:event-property ev 'span-direction))) (if (and (symbol? key) (ly:dir? sp)) (if (= sp STOP) (assoc-remove! active key) @@ -183,29 +184,56 @@ Voice-state objects (helper 0 '())) - - -(define noticed '()) -(define part-combine-listener '()) - -; UGH - should pass noticed setter to part-combine-listener -(define-public (set-part-combine-listener x) - (set! part-combine-listener x)) - -(define-public (notice-the-events-for-pc context lst) - (set! noticed (acons (ly:context-id context) lst noticed))) - -(define-public (make-part-combine-music music-list) - (let ((m (make-music 'PartCombineMusic)) - (m1 (make-non-relative-music (context-spec-music (car music-list) 'Voice "one"))) - (m2 (make-non-relative-music (context-spec-music (cadr music-list) 'Voice "two")))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(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" + (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) + (ly:add-listener mom-listener (ly:context-event-source global) 'Prepare) + (ly:interpret-music-expression (make-non-relative-music music) global) + context-list)) + +(define-public (make-part-combine-music parser music-list) + (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"))) + (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)) - (ly:run-translator m2 part-combine-listener) - (ly:run-translator m1 part-combine-listener) (set! (ly:music-property m 'split-list) - (determine-split-list (reverse! (cdr (assoc "one" noticed)) '()) - (reverse! (cdr (assoc "two" noticed)) '()))) - (set! noticed '()) + (if (and (assoc "one" evs1) (assoc "two" evs2)) + (determine-split-list (reverse! (cdr (assoc "one" evs1)) '()) + (reverse! (cdr (assoc "two" evs2)) '())) + '() )) m)) (define-public (determine-split-list evl1 evl2) @@ -216,13 +244,13 @@ Voice-state objects (voice-state-vec2 (make-voice-states evl2)) (result (make-split-state voice-state-vec1 voice-state-vec2))) - (define (analyse-time-step ri) + (define (analyse-time-step result-idx) (define (put x . index) "Put the result to X, starting from INDEX backwards. Only set if not set previously. " - (let ((i (if (pair? index) (car index) ri))) + (let ((i (if (pair? index) (car index) result-idx))) (if (and (<= 0 i) (not (symbol? (configuration (vector-ref result i))))) (begin @@ -238,27 +266,26 @@ Only set if not set previously. (put prev)))) (map copy-one-state (span-state vs))) - (define (analyse-notes now-state) + (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 (length notes1) 1) (put 'apart)) ((> (length notes2) 1) (put 'apart)) - ((not (= (length notes1) (length notes2))) - (put 'apart)) + ((= 1 (+ (length notes2) (length notes1))) (put 'apart)) ((and (= (length durs1) 1) (= (length durs2) 1) (not (equal? (car durs1) (car durs2)))) @@ -288,11 +315,10 @@ Only set if not set previously. (if (and (null? (span-state vs1)) (null? (span-state vs2))) (put 'chords))))))))) - (if (< ri (vector-length result)) - (let* ((now-state (vector-ref result 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)) @@ -301,23 +327,25 @@ Only set if not set previously. (active2 (previous-span-state vs2)) (new-active1 (span-state vs1)) (new-active2 (span-state vs2))) - (if pc-debug - (display (list (when now-state) ri + (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))) + (analyse-notes now-state) + + ;; active states different: + (put 'apart))) + ;; go to the next one, if it exists. - (analyse-time-step (1+ ri))))))) + (analyse-time-step (1+ result-idx))))))) - (define (analyse-a2 ri) - (if (< ri (vector-length result)) - (let* ((now-state (vector-ref result 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) @@ -326,15 +354,15 @@ Only set if not set previously. (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))) + (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+ ri))))) + (analyse-a2 (1+ result-idx))))) - (define (analyse-solo12 ri) + (define (analyse-solo12 result-idx) (define (previous-config vs) (let* ((pvs (previous-voice-state vs)) @@ -352,7 +380,7 @@ Only set if not set previously. (define (put x) ;; (display (list "putting " x "\n")) - (set! (configuration (vector-ref result ri)) x)) + (set! (configuration (vector-ref result result-idx)) x)) (define (current-voice-state now-state voice-num) (define vs ((if (= 1 voice-num) car cdr) @@ -363,24 +391,26 @@ Only set if not set previously. (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." +the mark when there are no spanners active. + + return next idx to analyse. +" (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) '())) - (soln (length solo-notes)) - (siln (length silent-notes))) + (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) - ((> siln 0) start-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 @@ -391,11 +421,12 @@ the mark when there are no spanners active." (try-solo type (1+ current-idx) (1+ current-idx))) (else (try-solo type start-idx (1+ current-idx))))) - start-idx)) ; try-solo + ;; try-solo + start-idx)) - (define (analyse-moment ri) - "Analyse 'apart starting at RI. Return next index. " - (let* ((now-state (vector-ref result ri)) + (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))) @@ -404,26 +435,29 @@ the mark when there are no spanners active." (notes2 (if vs2 (note-events vs2) '())) (n1 (length notes1)) (n2 (length notes2))) - ;; (display (list "analyzing step " ri " moment " (when now-state) vs1 vs2 "\n")) - (max ; we should always increase. + ;; (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+ ri)) + (1+ result-idx)) ((and (= n2 0) (equal? (when vs1) (when now-state)) (null? (previous-span-state vs1))) - (try-solo 'solo1 ri ri)) + (try-solo 'solo1 result-idx result-idx)) ((and (= n1 0) (equal? (when vs2) (when now-state)) (null? (previous-span-state vs2))) - (try-solo 'solo2 ri ri)) - (else (1+ ri))) - (1+ ri)))) ; analyse-moment + (try-solo 'solo2 result-idx result-idx)) + + (else (1+ result-idx))) + ;; analyse-moment + (1+ result-idx)))) - (if (< ri (vector-length result)) - (if (equal? (configuration (vector-ref result ri)) 'apart) - (analyse-solo12 (analyse-moment ri)) - (analyse-solo12 (1+ ri))))) ; analyse-solo12 + (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) @@ -438,7 +472,7 @@ the mark when there are no spanners active." (analyse-time-step 0) ;; (display result) (analyse-a2 0) - ;; (display result) + ;;(display result) (analyse-solo12 0) ;; (display result) (set! result (map @@ -448,62 +482,15 @@ the mark when there are no spanners active." (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)) - (evs (last-pair noticed))) - (if (pair? evs) +(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 evs) '())))))) - + (list->vector (reverse! (cdar context-list) + '()))))))