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 (split-index #:accessor split-index)
19 ; spanner-state is an alist
20 ; of (SYMBOL . RESULT-INDEX), which indicates where
21 ; said spanner was started.
22 (spanner-state #:init-value '() #:accessor span-state) )
24 (define-method (write (x <Voice-state> ) file)
25 (display (when x) file)
26 (display " evs = " file)
27 (display (events x) file)
28 (display " active = " file)
29 (display (span-state x) file)
32 (define-method (note-events (vs <Voice-state>))
34 (equal? (ly:music-property x 'name) 'NoteEvent))
35 (filter f? (events vs)))
37 (define-method (previous-voice-state (vs <Voice-state>))
38 (let* ((i (slot-ref vs 'vector-index))
39 (v (slot-ref vs 'state-vector)) )
46 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
48 (define-class <Split-state> ()
49 (configuration #:init-value '() #:accessor configuration)
50 (when-moment #:accessor when #:init-keyword #:when)
52 ; voice-states are states starting with the Split-state or later
54 (is #:init-keyword #:voice-states #:accessor voice-states)
55 (synced #:init-keyword #:synced #:init-value #f #:getter synced?) )
58 (define-method (write (x <Split-state> ) f)
61 (display (configuration x) f)
66 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
69 (define (previous-span-state vs)
71 ((p (previous-voice-state vs)))
77 (define (make-voice-states evl)
85 #:events (map car (cdr v))
90 ( (= i (vector-length vec)) vec)
91 (slot-set! (vector-ref vec i) 'vector-index i)
92 (slot-set! (vector-ref vec i) 'state-vector vec)
96 (define (make-split-state vs1 vs2)
97 "Merge lists VS1 and VS2, containing Voice-state objects into vector
98 of Split-state objects, crosslinking the Split-state vector and
102 (define (helper ss-idx ss-list idx1 idx2)
104 ((s1 (if (< idx1 (vector-length vs1)) (vector-ref vs1 idx1) #f))
105 (s2 (if (< idx2 (vector-length vs2)) (vector-ref vs2 idx2) #f))
106 (min (cond ((and s1 s2) (moment-min (when s1) (when s2)))
112 (inc1 (if (and s1 (equal? min (when s1))) 1 0))
113 (inc2 (if (and s2 (equal? min (when s2))) 1 0))
118 #:voice-states (cons s1 s2)
119 #:synced (= inc1 inc2)
122 (set! (split-index s1) ss-idx))
124 (set! (split-index s2) ss-idx))
128 (cons ss-object ss-list)
136 (helper 0 '() 0 0) '())) )
140 (define (analyse-spanner-states voice-state-vec)
142 (define (helper index active)
143 "Analyse EVS at INDEX, given state ACTIVE."
145 (define (analyse-tie-start active ev)
146 (if (equal? (ly:music-property ev 'name) 'TieEvent)
147 (acons 'tie index active)
151 (define (analyse-tie-end active ev)
152 (if (equal? (ly:music-property ev 'name) 'NoteEvent)
153 (assoc-remove! active 'tie)
156 (define (analyse-absdyn-end active ev)
157 (if (equal? (ly:music-property ev 'name) 'AbsoluteDynamicEvent)
159 (assoc-remove! active 'cresc)
163 (define (active<? a b)
165 ((symbol<? (car a) (car b)) #t)
166 ((symbol<? (car b) (car b)) #f)
171 (define (analyse-span-event active ev)
173 ((name (ly:music-property ev 'name))
175 ((equal? name 'SlurEvent) 'slur)
176 ((equal? name 'PhrasingSlurEvent) 'tie)
177 ((equal? name 'BeamEvent) 'beam)
178 ((equal? name 'CrescendoEvent) 'cresc)
179 ((equal? name 'DecrescendoEvent) 'decr)
181 (sp (ly:music-property ev 'span-direction)) )
183 (if (and (symbol? key) (ly:dir? sp))
185 (assoc-remove! active key)
187 (split-index (vector-ref voice-state-vec index))
192 (define (analyse-events active evs)
193 "Run all analyzers on ACTIVE and EVS"
195 (define (run-analyzer analyzer active evs)
197 (run-analyzer analyzer (analyzer active (car evs)) (cdr evs))
200 (define (run-analyzers analyzers active evs)
201 (if (pair? analyzers)
204 (run-analyzer (car analyzers) active evs)
213 ;; todo: use fold or somesuch.
219 ;; note: tie-start/span comes after tie-end/absdyn.
220 analyse-tie-end analyse-tie-start)
226 ;; must copy, since we use assoc-remove!
227 (if (< index (vector-length voice-state-vec))
229 (set! active (analyse-events active (events (vector-ref voice-state-vec index))))
230 (set! (span-state (vector-ref voice-state-vec index))
233 (helper (1+ index) active))) )
241 (define part-combine-listener '())
242 (define-public (set-part-combine-listener x)
243 (set! part-combine-listener x))
245 (define-public (notice-the-events-for-pc context lst)
246 (set! noticed (acons (ly:context-id context) lst noticed)))
248 (define-public (make-part-combine-music music-list)
250 ((m (make-music-by-name 'PartCombineMusic))
251 (m1 (context-spec-music (car music-list) 'Voice "one"))
252 (m2 (context-spec-music (cadr music-list) 'Voice "two"))
255 (ly:music-set-property! m 'elements (list m1 m2))
256 (ly:run-translator m2 part-combine-listener)
257 (ly:run-translator m1 part-combine-listener)
258 (ly:music-set-property! m 'split-list
259 (determine-split-list (reverse! (cdr (assoc "one" noticed)) '())
260 (reverse! (cdr (assoc "two" noticed)) '())))
271 (define-public (determine-split-list evl1 evl2)
272 "EVL1 and EVL2 should be ascending"
279 (voice-state-vec1 (make-voice-states evl1))
280 (voice-state-vec2 (make-voice-states evl2))
281 (result (make-split-state voice-state-vec1 voice-state-vec2)) )
284 (define (analyse-time-step ri)
285 (define (put x . index)
286 "Put the result to X, starting from INDEX backwards.
288 Only set if not set previously.
292 ((i (if (pair? index) (car index) ri)))
295 (not (symbol? (configuration (vector-ref result i)))))
297 (set! (configuration (vector-ref result i)) x)
303 (define (copy-state-from state-vec vs)
304 (define (copy-one-state key-idx)
307 (prev-ss (vector-ref result idx))
308 (prev (configuration prev-ss)) )
312 (map copy-one-state (span-state vs)) )
314 (define (analyse-notes now-state)
317 (vs1 (car (voice-states now-state)))
318 (vs2 (cdr (voice-states now-state)))
320 (notes1 (note-events vs1))
321 (durs1 (sort (map (lambda (x) (ly:music-property x 'duration)) notes1) ly:duration<?))
323 (map (lambda (x) (ly:music-property x 'pitch)) notes1) ly:pitch<?))
324 (notes2 (note-events vs2))
325 (durs2 (sort (map (lambda (x) (ly:music-property x 'duration)) notes2) ly:duration<?))
327 (map (lambda (x) (ly:music-property x 'pitch)) notes2) ly:pitch<?)) )
330 ((> (length notes1) 1) (put 'apart))
331 ((> (length notes2) 1) (put 'apart))
332 ((not (= (length notes1) (length notes2)))
337 (not (equal? (car durs1) (car durs2))))
341 (if (and (= (length pitches1) (length pitches2)))
342 (if (and (pair? pitches1)
344 (< chord-threshold (ly:pitch-steps
345 (ly:pitch-diff (car pitches1) (car pitches2)))))
348 ;; copy previous split state from spanner state
350 (if (previous-voice-state vs1)
351 (copy-state-from voice-state-vec1
352 (previous-voice-state vs1)))
353 (if (previous-voice-state vs2)
354 (copy-state-from voice-state-vec2
355 (previous-voice-state vs2)))
356 (if (and (null? (span-state vs1)) (null? (span-state vs2)))
364 (if (< ri (vector-length result))
366 ((now-state (vector-ref result ri))
367 (vs1 (car (voice-states now-state)))
368 (vs2 (cdr (voice-states now-state))))
371 ((not vs1) (put 'apart))
372 ((not vs2) (put 'apart))
376 (active1 (previous-span-state vs1))
377 (active2 (previous-span-state vs2))
379 (new-active1 (span-state vs1))
380 (new-active2 (span-state vs2)) )
383 (display (list (when now-state) ri
384 active1 "->" new-active1
385 active2 "->" new-active2
390 (if (and (synced? now-state)
391 (equal? active1 active2)
392 (equal? new-active1 new-active2))
394 (analyse-notes now-state)
396 ;; active states different:
400 ; go to the next one, if it exists.
401 (analyse-time-step (1+ ri))
404 (define (analyse-a2 ri)
405 (if (< ri (vector-length result))
407 ((now-state (vector-ref result ri))
408 (vs1 (car (voice-states now-state)))
409 (vs2 (cdr (voice-states now-state))) )
411 (if (and (equal? (configuration now-state) 'chords)
415 ((notes1 (note-events vs1))
416 (notes2 (note-events vs2)) )
419 (= 1 (length notes1))
420 (= 1 (length notes2))
421 (equal? (ly:music-property (car notes1) 'pitch)
422 (ly:music-property (car notes2) 'pitch)))
424 (set! (configuration now-state) 'unisono))
426 (= 0 (length notes1))
427 (= 0 (length notes2)))
428 (set! (configuration now-state) 'unisilence)))
435 (define (analyse-solo12 ri)
437 (define (previous-config vs)
438 (let* ((pvs (previous-voice-state vs))
439 (spi (if pvs (split-index pvs) #f))
440 (prev-split (if spi (vector-ref result spi) #f)) )
443 (configuration prev-split)
447 (define (put-range x a b)
448 ; (display (list "put range " x a b "\n"))
452 (set! (configuration (vector-ref result i)) x)
456 ; (display (list "putting " x "\n"))
458 (set! (configuration (vector-ref result ri)) x))
460 (define (current-voice-state now-state voice-num)
461 (define vs ((if (= 1 voice-num) car cdr)
462 (voice-states now-state) ) )
463 (if (or (not vs) (equal? (when now-state) (when vs)))
465 (previous-voice-state vs)
468 (define (try-solo type start-idx current-idx)
469 "Find a maximum stretch that can be marked as solo. Only set
470 the mark when there are no spanners active."
471 (if (< current-idx (vector-length result))
473 ((now-state (vector-ref result current-idx))
474 (solo-state (current-voice-state now-state (if (equal? type 'solo1) 1 2)))
476 (silent-state (current-voice-state now-state (if (equal? type 'solo1) 2 1)))
477 (silent-notes (if silent-state (note-events silent-state) '()))
478 (solo-notes (if solo-state (note-events solo-state) '()))
480 (soln (length solo-notes))
481 (siln (length silent-notes)))
483 ; (display (list "trying " type " at " (when now-state) solo-state silent-state "\n"))
485 ((not (equal? (configuration now-state) 'apart))
487 ((> siln 0) start-idx)
491 ; This includes rests. This isn't a problem: long rests
492 ; will be shared with the silent voice, and be marked
493 ; as unisilence. Therefore, long rests won't
494 ; accidentally be part of a solo.
496 (null? (span-state solo-state)))
497 (put-range type start-idx current-idx)
498 (try-solo type (1+ current-idx) (1+ current-idx)))
500 (try-solo type start-idx (1+ current-idx)))
503 start-idx)) ; try-solo
506 (define (analyse-moment ri)
507 "Analyse 'apart starting at RI. Return next index. "
509 ((now-state (vector-ref result ri))
510 (vs1 (current-voice-state now-state 1))
511 (vs2 (current-voice-state now-state 2))
512 ; (vs1 (car (voice-states now-state)))
513 ; (vs2 (cdr (voice-states now-state)))
514 (notes1 (if vs1 (note-events vs1) '()))
515 (notes2 (if vs2 (note-events vs2) '()))
517 (n2 (length notes2)) )
519 ; (display (list "analyzing step " ri " moment " (when now-state) vs1 vs2 "\n"))
522 (max ; we should always increase.
524 ((and (= n1 0) (= n2 0))
529 (equal? (when vs1) (when now-state))
530 (null? (previous-span-state vs1)))
531 (try-solo 'solo1 ri ri))
533 (equal? (when vs2) (when now-state))
534 (null? (previous-span-state vs2)))
535 (try-solo 'solo2 ri ri))
540 (if (< ri (vector-length result))
541 (if (equal? (configuration (vector-ref result ri)) 'apart)
542 (analyse-solo12 (analyse-moment ri))
543 (analyse-solo12 (1+ ri)))) ) ; analyse-solo12
546 (analyse-spanner-states voice-state-vec1)
547 (analyse-spanner-states voice-state-vec2)
551 (display voice-state-vec1)
553 (display voice-state-vec2)
559 (analyse-time-step 0)
567 (lambda (x) (cons (when x) (configuration x)))
568 (vector->list result)))
570 ; (if pc-debug (display result))
574 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
575 ;; autochange - fairly related to part combining.
577 (define-public (make-autochange-music music)
579 (define (generate-split-list event-list acc)
580 (if (null? event-list)
583 ((evs (map car (cdar event-list)))
584 (now (caar event-list))
585 (notes (filter (lambda (x)
586 (equal? (ly:music-property x 'name) 'NoteEvent))
588 (pitch (if (pair? notes)
589 (ly:music-property (car notes) 'pitch)
593 (if (and pitch (not (= (ly:pitch-steps pitch) 0)))
596 (cons (cons now (sign (ly:pitch-steps pitch))) acc))
597 (generate-split-list (cdr event-list) acc)
604 ((m (make-music-by-name 'AutoChangeMusic))
605 (context (ly:run-translator music part-combine-listener))
606 (evs (last-pair noticed))
609 (generate-split-list (if (pair? evs)
610 (reverse! (cdar evs) '()) '())
615 (ly:music-set-property! m 'element music)
616 (ly:music-set-property! m 'split-list split)
623 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
625 (define-public (add-quotable name mus)
628 ((tab (eval 'musicQuotes (current-module) ))
629 (context (ly:run-translator (context-spec-music mus 'Voice)
630 part-combine-listener))
631 (evs (last-pair noticed))
636 (list->vector (reverse! (car evs) '()))))