1 ;;;; part-combiner.scm -- Part combining, staff changes.
3 ;;;; source file of the GNU LilyPond music typesetter
5 ;;;; (c) 2004 Han-Wen Nienhuys <hanwen@cs.uu.nl>
7 ;; todo: figure out how to make module,
8 ;; without breaking nested ly scopes
10 (define-class <Voice-state> ()
11 (event-list #:init-value '() #:accessor events #:init-keyword #:events)
12 (when-moment #:accessor when #:init-keyword #:when)
13 (tuning #:accessor tuning #:init-keyword #:tuning)
14 (split-index #:accessor split-index)
18 ;; spanner-state is an alist
19 ;; of (SYMBOL . RESULT-INDEX), which indicates where
20 ;; said spanner was started.
21 (spanner-state #:init-value '() #:accessor span-state) )
23 (define-method (write (x <Voice-state> ) file)
24 (display (when x) file)
25 (display " evs = " file)
26 (display (events x) file)
27 (display " active = " file)
28 (display (span-state x) file)
31 (define-method (note-events (vs <Voice-state>))
33 (equal? (ly:music-property x 'name) 'NoteEvent))
34 (filter f? (events vs)))
36 (define-method (previous-voice-state (vs <Voice-state>))
37 (let ((i (slot-ref vs 'vector-index))
38 (v (slot-ref vs 'state-vector)) )
43 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
45 (define-class <Split-state> ()
46 (configuration #:init-value '() #:accessor configuration)
47 (when-moment #:accessor when #:init-keyword #:when)
48 ;; voice-states are states starting with the Split-state or later
50 (is #:init-keyword #:voice-states #:accessor voice-states)
51 (synced #:init-keyword #:synced #:init-value #f #:getter synced?))
54 (define-method (write (x <Split-state> ) f)
57 (display (configuration x) f)
62 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
65 (define (previous-span-state vs)
66 (let ((p (previous-voice-state vs)))
67 (if p (span-state p) '())))
69 (define (make-voice-states evl)
70 (let ((vec (list->vector (map (lambda (v)
74 #:events (map car (cdr v))))
77 ( (= i (vector-length vec)) vec)
78 (slot-set! (vector-ref vec i) 'vector-index i)
79 (slot-set! (vector-ref vec i) 'state-vector vec))))
81 (define (make-split-state vs1 vs2)
82 "Merge lists VS1 and VS2, containing Voice-state objects into vector
83 of Split-state objects, crosslinking the Split-state vector and
86 (define (helper ss-idx ss-list idx1 idx2)
87 (let* ((state1 (if (< idx1 (vector-length vs1)) (vector-ref vs1 idx1) #f))
88 (state2 (if (< idx2 (vector-length vs2)) (vector-ref vs2 idx2) #f))
89 (min (cond ((and state1 state2) (moment-min (when state1) (when state2)))
90 (state1 (when state1))
91 (state2 (when state2))
93 (inc1 (if (and state1 (equal? min (when state1))) 1 0))
94 (inc2 (if (and state2 (equal? min (when state2))) 1 0))
98 #:voice-states (cons state1 state2)
99 #:synced (= inc1 inc2))
102 (set! (split-index state1) ss-idx))
104 (set! (split-index state2) ss-idx))
107 (cons ss-object ss-list)
111 (list->vector (reverse! (helper 0 '() 0 0) '())))
114 (define (analyse-spanner-states voice-state-vec)
116 (define (helper index active)
117 "Analyse EVS at INDEX, given state ACTIVE."
119 (define (analyse-tie-start active ev)
120 (if (equal? (ly:music-property ev 'name) 'TieEvent)
121 (acons 'tie (split-index (vector-ref voice-state-vec index))
125 (define (analyse-tie-end active ev)
126 (if (equal? (ly:music-property ev 'name) 'NoteEvent)
127 (assoc-remove! active 'tie)
130 (define (analyse-absdyn-end active ev)
131 (if (equal? (ly:music-property ev 'name) 'AbsoluteDynamicEvent)
132 (assoc-remove! (assoc-remove! active 'cresc) 'decr)
135 (define (active<? a b)
136 (cond ((symbol<? (car a) (car b)) #t)
137 ((symbol<? (car b) (car b)) #f)
138 (else (< (cdr a) (cdr b)))))
140 (define (analyse-span-event active ev)
141 (let* ((name (ly:music-property ev 'name))
142 (key (cond ((equal? name 'SlurEvent) 'slur)
143 ((equal? name 'PhrasingSlurEvent) 'tie)
144 ((equal? name 'BeamEvent) 'beam)
145 ((equal? name 'CrescendoEvent) 'cresc)
146 ((equal? name 'DecrescendoEvent) 'decr)
148 (sp (ly:music-property ev 'span-direction)))
149 (if (and (symbol? key) (ly:dir? sp))
151 (assoc-remove! active key)
153 (split-index (vector-ref voice-state-vec index))
157 (define (analyse-events active evs)
158 "Run all analyzers on ACTIVE and EVS"
159 (define (run-analyzer analyzer active evs)
161 (run-analyzer analyzer (analyzer active (car evs)) (cdr evs))
163 (define (run-analyzers analyzers active evs)
164 (if (pair? analyzers)
165 (run-analyzers (cdr analyzers)
166 (run-analyzer (car analyzers) active evs)
169 (sort ;; todo: use fold or somesuch.
170 (run-analyzers (list analyse-absdyn-end analyse-span-event
171 ;; note: tie-start/span comes after tie-end/absdyn.
172 analyse-tie-end analyse-tie-start)
176 ;; must copy, since we use assoc-remove!
177 (if (< index (vector-length voice-state-vec))
179 (set! active (analyse-events active (events (vector-ref voice-state-vec index))))
180 (set! (span-state (vector-ref voice-state-vec index))
182 (helper (1+ index) active))))
189 (define part-combine-listener '())
191 ; UGH - should pass noticed setter to part-combine-listener
192 (define-public (set-part-combine-listener x)
193 (set! part-combine-listener x))
195 (define-public (notice-the-events-for-pc context lst)
196 "add CONTEXT-ID, EVENT list to NOTICED variable."
198 (set! noticed (acons (ly:context-id context) lst noticed)))
200 (define-public (make-part-combine-music music-list)
201 (let ((m (make-music 'PartCombineMusic))
202 (m1 (make-non-relative-music (context-spec-music (car music-list) 'Voice "one")))
203 (m2 (make-non-relative-music (context-spec-music (cadr music-list) 'Voice "two"))))
204 (set! (ly:music-property m 'elements) (list m1 m2))
205 (ly:run-translator m2 part-combine-listener)
206 (ly:run-translator m1 part-combine-listener)
207 (set! (ly:music-property m 'split-list)
208 (determine-split-list (reverse! (cdr (assoc "one" noticed)) '())
209 (reverse! (cdr (assoc "two" noticed)) '())))
213 (define-public (determine-split-list evl1 evl2)
214 "EVL1 and EVL2 should be ascending"
217 (voice-state-vec1 (make-voice-states evl1))
218 (voice-state-vec2 (make-voice-states evl2))
219 (result (make-split-state voice-state-vec1 voice-state-vec2)))
221 (define (analyse-time-step result-idx)
222 (define (put x . index)
223 "Put the result to X, starting from INDEX backwards.
225 Only set if not set previously.
227 (let ((i (if (pair? index) (car index) result-idx)))
229 (not (symbol? (configuration (vector-ref result i)))))
231 (set! (configuration (vector-ref result i)) x)
234 (define (copy-state-from state-vec vs)
235 (define (copy-one-state key-idx)
236 (let* ((idx (cdr key-idx))
237 (prev-ss (vector-ref result idx))
238 (prev (configuration prev-ss)))
241 (map copy-one-state (span-state vs)))
243 (define (analyse-notes now-state)
244 (let* ((vs1 (car (voice-states now-state)))
245 (vs2 (cdr (voice-states now-state)))
246 (notes1 (note-events vs1))
247 (durs1 (sort (map (lambda (x) (ly:music-property x 'duration))
250 (pitches1 (sort (map (lambda (x) (ly:music-property x 'pitch))
253 (notes2 (note-events vs2))
254 (durs2 (sort (map (lambda (x) (ly:music-property x 'duration))
257 (pitches2 (sort (map (lambda (x) (ly:music-property x 'pitch))
260 (cond ((> (length notes1) 1) (put 'apart))
261 ((> (length notes2) 1) (put 'apart))
262 ((= 1 (+ (length notes2) (length notes1))) (put 'apart))
263 ((and (= (length durs1) 1)
265 (not (equal? (car durs1) (car durs2))))
268 (if (and (= (length pitches1) (length pitches2)))
269 (if (and (pair? pitches1)
272 (< chord-threshold (ly:pitch-steps
273 (ly:pitch-diff (car pitches1)
277 (> 0 (ly:pitch-steps (ly:pitch-diff (car pitches1)
281 ;; copy previous split state from spanner state
283 (if (previous-voice-state vs1)
284 (copy-state-from voice-state-vec1
285 (previous-voice-state vs1)))
286 (if (previous-voice-state vs2)
287 (copy-state-from voice-state-vec2
288 (previous-voice-state vs2)))
289 (if (and (null? (span-state vs1)) (null? (span-state vs2)))
290 (put 'chords)))))))))
292 (if (< result-idx (vector-length result))
293 (let* ((now-state (vector-ref result result-idx))
294 (vs1 (car (voice-states now-state)))
295 (vs2 (cdr (voice-states now-state))))
297 (cond ((not vs1) (put 'apart))
298 ((not vs2) (put 'apart))
300 (let ((active1 (previous-span-state vs1))
301 (active2 (previous-span-state vs2))
302 (new-active1 (span-state vs1))
303 (new-active2 (span-state vs2)))
305 (display (list (when now-state) result-idx
306 active1 "->" new-active1
307 active2 "->" new-active2
309 (if (and (synced? now-state)
310 (equal? active1 active2)
311 (equal? new-active1 new-active2))
312 (analyse-notes now-state)
314 ;; active states different:
317 ;; go to the next one, if it exists.
318 (analyse-time-step (1+ result-idx)))))))
320 (define (analyse-a2 result-idx)
321 (if (< result-idx (vector-length result))
322 (let* ((now-state (vector-ref result result-idx))
323 (vs1 (car (voice-states now-state)))
324 (vs2 (cdr (voice-states now-state))))
325 (if (and (equal? (configuration now-state) 'chords)
327 (let ((notes1 (note-events vs1))
328 (notes2 (note-events vs2)))
329 (cond ((and (= 1 (length notes1))
330 (= 1 (length notes2))
331 (equal? (ly:music-property (car notes1) 'pitch)
332 (ly:music-property (car notes2) 'pitch)))
333 (set! (configuration now-state) 'unisono))
334 ((and (= 0 (length notes1))
335 (= 0 (length notes2)))
336 (set! (configuration now-state) 'unisilence)))))
337 (analyse-a2 (1+ result-idx)))))
339 (define (analyse-solo12 result-idx)
341 (define (previous-config vs)
342 (let* ((pvs (previous-voice-state vs))
343 (spi (if pvs (split-index pvs) #f))
344 (prev-split (if spi (vector-ref result spi) #f)))
346 (configuration prev-split)
349 (define (put-range x a b)
350 ;; (display (list "put range " x a b "\n"))
353 (set! (configuration (vector-ref result i)) x)))
356 ;; (display (list "putting " x "\n"))
357 (set! (configuration (vector-ref result result-idx)) x))
359 (define (current-voice-state now-state voice-num)
360 (define vs ((if (= 1 voice-num) car cdr)
361 (voice-states now-state)))
362 (if (or (not vs) (equal? (when now-state) (when vs)))
364 (previous-voice-state vs)))
366 (define (try-solo type start-idx current-idx)
367 "Find a maximum stretch that can be marked as solo. Only set
368 the mark when there are no spanners active."
369 (if (< current-idx (vector-length result))
370 (let* ((now-state (vector-ref result current-idx))
371 (solo-state (current-voice-state now-state (if (equal? type 'solo1) 1 2)))
372 (silent-state (current-voice-state now-state (if (equal? type 'solo1) 2 1)))
373 (silent-notes (if silent-state (note-events silent-state) '()))
374 (solo-notes (if solo-state (note-events solo-state) '())))
375 ;; (display (list "trying " type " at " (when now-state) solo-state silent-state "\n"))
376 (cond ((not (equal? (configuration now-state) 'apart))
378 ((> (length silent-notes) 0) start-idx)
380 (put-range type start-idx current-idx)
383 (null? (span-state solo-state)))
385 ;; This includes rests. This isn't a problem: long rests
386 ;; will be shared with the silent voice, and be marked
387 ;; as unisilence. Therefore, long rests won't
388 ;; accidentally be part of a solo.
390 (put-range type start-idx current-idx)
391 (try-solo type (1+ current-idx) (1+ current-idx)))
393 (try-solo type start-idx (1+ current-idx)))))
394 start-idx)) ; try-solo
396 (define (analyse-moment result-idx)
397 "Analyse 'apart starting at RESULT-IDX. Return next index. "
398 (let* ((now-state (vector-ref result result-idx))
399 (vs1 (current-voice-state now-state 1))
400 (vs2 (current-voice-state now-state 2))
401 ;; (vs1 (car (voice-states now-state)))
402 ;; (vs2 (cdr (voice-states now-state)))
403 (notes1 (if vs1 (note-events vs1) '()))
404 (notes2 (if vs2 (note-events vs2) '()))
406 (n2 (length notes2)))
407 ;; (display (list "analyzing step " result-idx " moment " (when now-state) vs1 vs2 "\n"))
408 (max ; we should always increase.
410 (cond ((and (= n1 0) (= n2 0))
414 (equal? (when vs1) (when now-state))
415 (null? (previous-span-state vs1)))
416 (try-solo 'solo1 result-idx result-idx))
418 (equal? (when vs2) (when now-state))
419 (null? (previous-span-state vs2)))
420 (try-solo 'solo2 result-idx result-idx))
422 (else (1+ result-idx)))
423 (1+ result-idx)))) ; analyse-moment
425 (if (< result-idx (vector-length result))
426 (if (equal? (configuration (vector-ref result result-idx)) 'apart)
427 (analyse-solo12 (analyse-moment result-idx))
428 (analyse-solo12 (1+ result-idx))))) ; analyse-solo12
430 (analyse-spanner-states voice-state-vec1)
431 (analyse-spanner-states voice-state-vec2)
434 (display voice-state-vec1)
436 (display voice-state-vec2)
440 (analyse-time-step 0)
447 (lambda (x) (cons (when x) (configuration x)))
448 (vector->list result)))
453 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
454 ;; autochange - fairly related to part combining.
456 (define-public (make-autochange-music music)
457 (define (generate-split-list change-moment event-list acc)
458 (if (null? event-list)
460 (let* ((now-tun (caar event-list))
461 (evs (map car (cdar event-list)))
463 (notes (filter (lambda (x)
464 (equal? (ly:music-property x 'name) 'NoteEvent))
466 (pitch (if (pair? notes)
467 (ly:music-property (car notes) 'pitch)
470 (if (and pitch (not (= (ly:pitch-steps pitch) 0)))
471 (generate-split-list #f
478 (sign (ly:pitch-steps pitch))) acc))
481 (cdr event-list) acc)))))
484 (let* ((m (make-music 'AutoChangeMusic))
485 (context (ly:run-translator (make-non-relative-music music) part-combine-listener))
486 (evs (last-pair noticed))
487 (split (reverse! (generate-split-list
490 (reverse! (cdar evs) '()) '())
493 (set! (ly:music-property m 'element) music)
494 (set! (ly:music-property m 'split-list) split)
499 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
501 (define-public (add-quotable name mus)
503 (let* ((tab (eval 'musicQuotes (current-module) ))
504 (context (ly:run-translator (context-spec-music mus 'Voice)
505 part-combine-listener))
506 (first-voice-handle (last-pair noticed)))
508 (if (pair? first-voice-handle)
510 ;; cdr : skip name string
511 (list->vector (reverse! (cdar first-voice-handle)