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)
20 ; spanner-state is an alist
21 ; of (SYMBOL . RESULT-INDEX), which indicates where
22 ; said spanner was started.
23 (spanner-state #:init-value '() #:accessor span-state) )
25 (define-method (write (x <Voice-state> ) file)
26 (display (when x) file)
27 (display " evs = " file)
28 (display (events x) file)
29 (display " active = " file)
30 (display (span-state x) file)
33 (define-method (note-events (vs <Voice-state>))
35 (equal? (ly:music-property x 'name) 'NoteEvent))
36 (filter f? (events vs)))
38 (define-method (previous-voice-state (vs <Voice-state>))
39 (let* ((i (slot-ref vs 'vector-index))
40 (v (slot-ref vs 'state-vector)) )
47 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
49 (define-class <Split-state> ()
50 (configuration #:init-value '() #:accessor configuration)
51 (when-moment #:accessor when #:init-keyword #:when)
53 ; voice-states are states starting with the Split-state or later
55 (is #:init-keyword #:voice-states #:accessor voice-states)
56 (synced #:init-keyword #:synced #:init-value #f #:getter synced?) )
59 (define-method (write (x <Split-state> ) f)
62 (display (configuration x) f)
67 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
70 (define (previous-span-state vs)
72 ((p (previous-voice-state vs)))
78 (define (make-voice-states evl)
87 #:events (map car (cdr v))
92 ( (= i (vector-length vec)) vec)
93 (slot-set! (vector-ref vec i) 'vector-index i)
94 (slot-set! (vector-ref vec i) 'state-vector vec)
98 (define (make-split-state vs1 vs2)
99 "Merge lists VS1 and VS2, containing Voice-state objects into vector
100 of Split-state objects, crosslinking the Split-state vector and
104 (define (helper ss-idx ss-list idx1 idx2)
106 ((s1 (if (< idx1 (vector-length vs1)) (vector-ref vs1 idx1) #f))
107 (s2 (if (< idx2 (vector-length vs2)) (vector-ref vs2 idx2) #f))
108 (min (cond ((and s1 s2) (moment-min (when s1) (when s2)))
114 (inc1 (if (and s1 (equal? min (when s1))) 1 0))
115 (inc2 (if (and s2 (equal? min (when s2))) 1 0))
120 #:voice-states (cons s1 s2)
121 #:synced (= inc1 inc2)
124 (set! (split-index s1) ss-idx))
126 (set! (split-index s2) ss-idx))
130 (cons ss-object ss-list)
138 (helper 0 '() 0 0) '())) )
142 (define (analyse-spanner-states voice-state-vec)
144 (define (helper index active)
145 "Analyse EVS at INDEX, given state ACTIVE."
147 (define (analyse-tie-start active ev)
148 (if (equal? (ly:music-property ev 'name) 'TieEvent)
149 (acons 'tie index active)
153 (define (analyse-tie-end active ev)
154 (if (equal? (ly:music-property ev 'name) 'NoteEvent)
155 (assoc-remove! active 'tie)
158 (define (analyse-absdyn-end active ev)
159 (if (equal? (ly:music-property ev 'name) 'AbsoluteDynamicEvent)
161 (assoc-remove! active 'cresc)
165 (define (active<? a b)
167 ((symbol<? (car a) (car b)) #t)
168 ((symbol<? (car b) (car b)) #f)
173 (define (analyse-span-event active ev)
175 ((name (ly:music-property ev 'name))
177 ((equal? name 'SlurEvent) 'slur)
178 ((equal? name 'PhrasingSlurEvent) 'tie)
179 ((equal? name 'BeamEvent) 'beam)
180 ((equal? name 'CrescendoEvent) 'cresc)
181 ((equal? name 'DecrescendoEvent) 'decr)
183 (sp (ly:music-property ev 'span-direction)) )
185 (if (and (symbol? key) (ly:dir? sp))
187 (assoc-remove! active key)
189 (split-index (vector-ref voice-state-vec index))
194 (define (analyse-events active evs)
195 "Run all analyzers on ACTIVE and EVS"
197 (define (run-analyzer analyzer active evs)
199 (run-analyzer analyzer (analyzer active (car evs)) (cdr evs))
202 (define (run-analyzers analyzers active evs)
203 (if (pair? analyzers)
206 (run-analyzer (car analyzers) active evs)
215 ;; todo: use fold or somesuch.
221 ;; note: tie-start/span comes after tie-end/absdyn.
222 analyse-tie-end analyse-tie-start)
228 ;; must copy, since we use assoc-remove!
229 (if (< index (vector-length voice-state-vec))
231 (set! active (analyse-events active (events (vector-ref voice-state-vec index))))
232 (set! (span-state (vector-ref voice-state-vec index))
235 (helper (1+ index) active))) )
243 (define part-combine-listener '())
244 (define-public (set-part-combine-listener x)
245 (set! part-combine-listener x))
247 (define-public (notice-the-events-for-pc context lst)
248 (set! noticed (acons (ly:context-id context) lst noticed)))
250 (define-public (make-part-combine-music music-list)
252 ((m (make-music-by-name 'PartCombineMusic))
253 (m1 (context-spec-music (car music-list) 'Voice "one"))
254 (m2 (context-spec-music (cadr music-list) 'Voice "two"))
257 (ly:music-set-property! m 'elements (list m1 m2))
258 (ly:run-translator m2 part-combine-listener)
259 (ly:run-translator m1 part-combine-listener)
260 (ly:music-set-property! m 'split-list
261 (determine-split-list (reverse! (cdr (assoc "one" noticed)) '())
262 (reverse! (cdr (assoc "two" noticed)) '())))
273 (define-public (determine-split-list evl1 evl2)
274 "EVL1 and EVL2 should be ascending"
281 (voice-state-vec1 (make-voice-states evl1))
282 (voice-state-vec2 (make-voice-states evl2))
283 (result (make-split-state voice-state-vec1 voice-state-vec2)) )
286 (define (analyse-time-step ri)
287 (define (put x . index)
288 "Put the result to X, starting from INDEX backwards.
290 Only set if not set previously.
294 ((i (if (pair? index) (car index) ri)))
297 (not (symbol? (configuration (vector-ref result i)))))
299 (set! (configuration (vector-ref result i)) x)
305 (define (copy-state-from state-vec vs)
306 (define (copy-one-state key-idx)
309 (prev-ss (vector-ref result idx))
310 (prev (configuration prev-ss)) )
314 (map copy-one-state (span-state vs)) )
316 (define (analyse-notes now-state)
319 (vs1 (car (voice-states now-state)))
320 (vs2 (cdr (voice-states now-state)))
322 (notes1 (note-events vs1))
323 (durs1 (sort (map (lambda (x) (ly:music-property x 'duration)) notes1) ly:duration<?))
325 (map (lambda (x) (ly:music-property x 'pitch)) notes1) ly:pitch<?))
326 (notes2 (note-events vs2))
327 (durs2 (sort (map (lambda (x) (ly:music-property x 'duration)) notes2) ly:duration<?))
329 (map (lambda (x) (ly:music-property x 'pitch)) notes2) ly:pitch<?)) )
332 ((> (length notes1) 1) (put 'apart))
333 ((> (length notes2) 1) (put 'apart))
334 ((not (= (length notes1) (length notes2)))
339 (not (equal? (car durs1) (car durs2))))
343 (if (and (= (length pitches1) (length pitches2)))
344 (if (and (pair? pitches1)
346 (< chord-threshold (ly:pitch-steps
347 (ly:pitch-diff (car pitches1) (car pitches2)))))
350 ;; copy previous split state from spanner state
352 (if (previous-voice-state vs1)
353 (copy-state-from voice-state-vec1
354 (previous-voice-state vs1)))
355 (if (previous-voice-state vs2)
356 (copy-state-from voice-state-vec2
357 (previous-voice-state vs2)))
358 (if (and (null? (span-state vs1)) (null? (span-state vs2)))
366 (if (< ri (vector-length result))
368 ((now-state (vector-ref result ri))
369 (vs1 (car (voice-states now-state)))
370 (vs2 (cdr (voice-states now-state))))
373 ((not vs1) (put 'apart))
374 ((not vs2) (put 'apart))
378 (active1 (previous-span-state vs1))
379 (active2 (previous-span-state vs2))
381 (new-active1 (span-state vs1))
382 (new-active2 (span-state vs2)) )
385 (display (list (when now-state) ri
386 active1 "->" new-active1
387 active2 "->" new-active2
392 (if (and (synced? now-state)
393 (equal? active1 active2)
394 (equal? new-active1 new-active2))
396 (analyse-notes now-state)
398 ;; active states different:
402 ; go to the next one, if it exists.
403 (analyse-time-step (1+ ri))
406 (define (analyse-a2 ri)
407 (if (< ri (vector-length result))
409 ((now-state (vector-ref result ri))
410 (vs1 (car (voice-states now-state)))
411 (vs2 (cdr (voice-states now-state))) )
413 (if (and (equal? (configuration now-state) 'chords)
417 ((notes1 (note-events vs1))
418 (notes2 (note-events vs2)) )
421 (= 1 (length notes1))
422 (= 1 (length notes2))
423 (equal? (ly:music-property (car notes1) 'pitch)
424 (ly:music-property (car notes2) 'pitch)))
426 (set! (configuration now-state) 'unisono))
428 (= 0 (length notes1))
429 (= 0 (length notes2)))
430 (set! (configuration now-state) 'unisilence)))
437 (define (analyse-solo12 ri)
439 (define (previous-config vs)
440 (let* ((pvs (previous-voice-state vs))
441 (spi (if pvs (split-index pvs) #f))
442 (prev-split (if spi (vector-ref result spi) #f)) )
445 (configuration prev-split)
449 (define (put-range x a b)
450 ; (display (list "put range " x a b "\n"))
454 (set! (configuration (vector-ref result i)) x)
458 ; (display (list "putting " x "\n"))
460 (set! (configuration (vector-ref result ri)) x))
462 (define (current-voice-state now-state voice-num)
463 (define vs ((if (= 1 voice-num) car cdr)
464 (voice-states now-state) ) )
465 (if (or (not vs) (equal? (when now-state) (when vs)))
467 (previous-voice-state vs)
470 (define (try-solo type start-idx current-idx)
471 "Find a maximum stretch that can be marked as solo. Only set
472 the mark when there are no spanners active."
473 (if (< current-idx (vector-length result))
475 ((now-state (vector-ref result current-idx))
476 (solo-state (current-voice-state now-state (if (equal? type 'solo1) 1 2)))
478 (silent-state (current-voice-state now-state (if (equal? type 'solo1) 2 1)))
479 (silent-notes (if silent-state (note-events silent-state) '()))
480 (solo-notes (if solo-state (note-events solo-state) '()))
482 (soln (length solo-notes))
483 (siln (length silent-notes)))
485 ; (display (list "trying " type " at " (when now-state) solo-state silent-state "\n"))
487 ((not (equal? (configuration now-state) 'apart))
489 ((> siln 0) start-idx)
493 ; This includes rests. This isn't a problem: long rests
494 ; will be shared with the silent voice, and be marked
495 ; as unisilence. Therefore, long rests won't
496 ; accidentally be part of a solo.
498 (null? (span-state solo-state)))
499 (put-range type start-idx current-idx)
500 (try-solo type (1+ current-idx) (1+ current-idx)))
502 (try-solo type start-idx (1+ current-idx)))
505 start-idx)) ; try-solo
508 (define (analyse-moment ri)
509 "Analyse 'apart starting at RI. Return next index. "
511 ((now-state (vector-ref result ri))
512 (vs1 (current-voice-state now-state 1))
513 (vs2 (current-voice-state now-state 2))
514 ; (vs1 (car (voice-states now-state)))
515 ; (vs2 (cdr (voice-states now-state)))
516 (notes1 (if vs1 (note-events vs1) '()))
517 (notes2 (if vs2 (note-events vs2) '()))
519 (n2 (length notes2)) )
521 ; (display (list "analyzing step " ri " moment " (when now-state) vs1 vs2 "\n"))
524 (max ; we should always increase.
526 ((and (= n1 0) (= n2 0))
531 (equal? (when vs1) (when now-state))
532 (null? (previous-span-state vs1)))
533 (try-solo 'solo1 ri ri))
535 (equal? (when vs2) (when now-state))
536 (null? (previous-span-state vs2)))
537 (try-solo 'solo2 ri ri))
542 (if (< ri (vector-length result))
543 (if (equal? (configuration (vector-ref result ri)) 'apart)
544 (analyse-solo12 (analyse-moment ri))
545 (analyse-solo12 (1+ ri)))) ) ; analyse-solo12
548 (analyse-spanner-states voice-state-vec1)
549 (analyse-spanner-states voice-state-vec2)
553 (display voice-state-vec1)
555 (display voice-state-vec2)
561 (analyse-time-step 0)
569 (lambda (x) (cons (when x) (configuration x)))
570 (vector->list result)))
572 ; (if pc-debug (display result))
576 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
577 ;; autochange - fairly related to part combining.
579 (define-public (make-autochange-music music)
581 (define (generate-split-list event-list acc)
582 (if (null? event-list)
585 ((now-tun (caar event-list))
586 (evs (map car (cdar event-list)))
588 (notes (filter (lambda (x)
589 (equal? (ly:music-property x 'name) 'NoteEvent))
591 (pitch (if (pair? notes)
592 (ly:music-property (car notes) 'pitch)
596 (if (and pitch (not (= (ly:pitch-steps pitch) 0)))
599 (cons (cons now (sign (ly:pitch-steps pitch))) acc))
600 (generate-split-list (cdr event-list) acc)
607 ((m (make-music-by-name 'AutoChangeMusic))
608 (context (ly:run-translator music part-combine-listener))
609 (evs (last-pair noticed))
612 (generate-split-list (if (pair? evs)
613 (reverse! (cdar evs) '()) '())
618 (ly:music-set-property! m 'element music)
619 (ly:music-set-property! m 'split-list split)
626 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
628 (define-public (add-quotable name mus)
631 ((tab (eval 'musicQuotes (current-module) ))
632 (context (ly:run-translator (context-spec-music mus 'Voice)
633 part-combine-listener))
634 (evs (last-pair noticed))
639 (list->vector (reverse! (car evs) '()))))