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:get-mus-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)
51 (is #:init-keyword #:voice-states #:accessor voice-states)
52 (synced #:init-keyword #:synced #:init-value #f #:getter synced?) )
57 (define-method (write (x <Split-state> ) f)
60 (display (configuration x) f)
65 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
68 (define (previous-span-state vs)
70 ((p (previous-voice-state vs)))
76 (define (make-voice-states evl)
84 #:events (map car (cdr v))
89 ( (= i (vector-length vec)) vec)
90 (slot-set! (vector-ref vec i) 'vector-index i)
91 (slot-set! (vector-ref vec i) 'state-vector vec)
95 (define (make-split-state vs1 vs2)
96 "Merge lists VS1 and VS2, containing Voice-state objects into vector
97 of Split-state objects, crosslinking the Split-state vector and
101 (define (helper ss-idx ss-list idx1 idx2)
103 ((s1 (if (< idx1 (vector-length vs1)) (vector-ref vs1 idx1) #f))
104 (s2 (if (< idx2 (vector-length vs2)) (vector-ref vs2 idx2) #f))
105 (min (cond ((and s1 s2) (moment-min (when s1) (when s2)))
111 (inc1 (if (and s1 (equal? min (when s1))) 1 0))
112 (inc2 (if (and s2 (equal? min (when s2))) 1 0))
117 #:voice-states (cons s1 s2)
118 #:synced (= inc1 inc2)
121 (set! (split-index s1) ss-idx))
123 (set! (split-index s2) ss-idx))
127 (cons ss-object ss-list)
135 (helper 0 '() 0 0) '())) )
139 (define (analyse-spanner-states voice-state-vec)
141 (define (helper index active)
142 "Analyse EVS at INDEX, given state ACTIVE."
144 (define (analyse-tie-start active ev)
145 (if (equal? (ly:get-mus-property ev 'name) 'TieEvent)
146 (acons 'tie index active)
150 (define (analyse-tie-end active ev)
151 (if (equal? (ly:get-mus-property ev 'name) 'NoteEvent)
152 (assoc-remove! active 'tie)
155 (define (analyse-absdyn-end active ev)
156 (if (equal? (ly:get-mus-property ev 'name) 'AbsoluteDynamicEvent)
158 (assoc-remove! active 'cresc)
162 (define (active<? a b)
164 ((symbol<? (car a) (car b)) #t)
165 ((symbol<? (car b) (car b)) #f)
170 (define (analyse-span-event active ev)
172 ((name (ly:get-mus-property ev 'name))
174 ((equal? name 'SlurEvent) 'slur)
175 ((equal? name 'PhrasingSlurEvent) 'tie)
176 ((equal? name 'BeamEvent) 'beam)
177 ((equal? name 'CrescendoEvent) 'cresc)
178 ((equal? name 'DecrescendoEvent) 'decr)
180 (sp (ly:get-mus-property ev 'span-direction)) )
182 (if (and (symbol? key) (ly:dir? sp))
184 (assoc-remove! active key)
186 (split-index (vector-ref voice-state-vec index))
191 (define (analyse-events active evs)
192 "Run all analyzers on ACTIVE and EVS"
194 (define (run-analyzer analyzer active evs)
196 (run-analyzer analyzer (analyzer active (car evs)) (cdr evs))
199 (define (run-analyzers analyzers active evs)
200 (if (pair? analyzers)
203 (run-analyzer (car analyzers) active evs)
212 ;; todo: use fold or somesuch.
218 ;; note: tie-start/span comes after tie-end/absdyn.
219 analyse-tie-end analyse-tie-start)
225 ;; must copy, since we use assoc-remove!
226 (if (< index (vector-length voice-state-vec))
228 (set! active (analyse-events active (events (vector-ref voice-state-vec index))))
229 (set! (span-state (vector-ref voice-state-vec index))
232 (helper (1+ index) active))) )
240 (define part-combine-listener '())
241 (define-public (set-part-combine-listener x)
242 (set! part-combine-listener x))
244 (define-public (notice-the-events-for-pc context lst)
245 (set! noticed (acons (ly:context-id context) lst noticed)))
247 (define-public (make-part-combine-music music-list)
249 ((m (make-music-by-name 'PartCombineMusic))
250 (m1 (context-spec-music (car music-list) 'Voice "one"))
251 (m2 (context-spec-music (cadr music-list) 'Voice "two"))
252 (props '((denies Thread)
253 (consists Rest_engraver)
254 (consists Note_heads_engraver)
257 (ly:set-mus-property! m 'elements (list m1 m2))
258 (ly:set-mus-property! m1 'property-operations props)
259 (ly:set-mus-property! m2 'property-operations props)
260 (ly:run-translator m2 part-combine-listener)
261 (ly:run-translator m1 part-combine-listener)
262 (ly:set-mus-property! m 'split-list
263 (determine-split-list (reverse! (cdr (assoc "one" noticed)) '())
264 (reverse! (cdr (assoc "two" noticed)) '())))
275 (define-public (determine-split-list evl1 evl2)
276 "EVL1 and EVL2 should be ascending"
283 (voice-state-vec1 (make-voice-states evl1))
284 (voice-state-vec2 (make-voice-states evl2))
285 (result (make-split-state voice-state-vec1 voice-state-vec2)) )
288 (define (analyse-time-step ri)
289 (define (put x . index)
290 "Put the result to X, starting from INDEX backwards.
292 Only set if not set previously.
296 ((i (if (pair? index) (car index) ri)))
299 (not (symbol? (configuration (vector-ref result i)))))
301 (set! (configuration (vector-ref result i)) x)
307 (define (copy-state-from state-vec vs)
308 (define (copy-one-state key-idx)
311 (prev-ss (vector-ref result idx))
312 (prev (configuration prev-ss)) )
316 (map copy-one-state (span-state vs)) )
318 (define (analyse-notes now-state)
321 (vs1 (car (voice-states now-state)))
322 (vs2 (cdr (voice-states now-state)))
324 (notes1 (note-events vs1))
325 (durs1 (sort (map (lambda (x) (ly:get-mus-property x 'duration)) notes1) ly:duration<?))
327 (map (lambda (x) (ly:get-mus-property x 'pitch)) notes1) ly:pitch<?))
328 (notes2 (note-events vs2))
329 (durs2 (sort (map (lambda (x) (ly:get-mus-property x 'duration)) notes2) ly:duration<?))
331 (map (lambda (x) (ly:get-mus-property x 'pitch)) notes2) ly:pitch<?)) )
334 ((> (length notes1) 1) (put 'apart))
335 ((> (length notes2) 1) (put 'apart))
336 ((not (= (length notes1) (length notes2)))
341 (not (equal? (car durs1) (car durs2))))
345 (if (and (= (length pitches1) (length pitches2)))
346 (if (and (pair? pitches1)
348 (< chord-threshold (ly:pitch-steps
349 (ly:pitch-diff (car pitches1) (car pitches2)))))
352 ;; copy previous split state from spanner state
354 (if (previous-voice-state vs1)
355 (copy-state-from voice-state-vec1
356 (previous-voice-state vs1)))
357 (if (previous-voice-state vs2)
358 (copy-state-from voice-state-vec2
359 (previous-voice-state vs2)))
360 (if (and (null? (span-state vs1)) (null? (span-state vs2)))
368 (if (< ri (vector-length result))
370 ((now-state (vector-ref result ri))
371 (vs1 (car (voice-states now-state)))
372 (vs2 (cdr (voice-states now-state))))
375 ((not vs1) (put 'apart))
376 ((not vs2) (put 'apart))
380 (active1 (previous-span-state vs1))
381 (active2 (previous-span-state vs2))
383 (new-active1 (span-state vs1))
384 (new-active2 (span-state vs2)) )
387 (display (list (when now-state) ri
388 active1 "->" new-active1
389 active2 "->" new-active2
394 (if (and (synced? now-state)
395 (equal? active1 active2)
396 (equal? new-active1 new-active2))
398 (analyse-notes now-state)
400 ;; active states different:
404 ; go to the next one, if it exists.
405 (analyse-time-step (1+ ri))
408 (define (analyse-a2 ri)
409 (if (< ri (vector-length result))
411 ((now-state (vector-ref result ri))
412 (vs1 (car (voice-states now-state)))
413 (vs2 (cdr (voice-states now-state))) )
415 (if (and (equal? (configuration now-state) 'chords)
419 ((notes1 (note-events vs1))
420 (notes2 (note-events vs2)) )
423 (= 1 (length notes1))
424 (= 1 (length notes2))
425 (equal? (ly:get-mus-property (car notes1) 'pitch)
426 (ly:get-mus-property (car notes2) 'pitch)))
428 (set! (configuration now-state) 'unisono))
430 (= 0 (length notes1))
431 (= 0 (length notes2)))
432 (set! (configuration now-state) 'unisilence)))
439 (define (analyse-solo12 ri)
441 (define (previous-config vs)
442 (let* ((pvs (previous-voice-state vs))
443 (spi (if pvs (split-index pvs) #f))
444 (prev-split (if spi (vector-ref result spi) #f)) )
447 (configuration prev-split)
451 (define (put-range x a b)
455 (set! (configuration (vector-ref result i)) x)
458 (set! (configuration (vector-ref result ri)) x))
460 (define (try-solo type start-idx current-idx)
461 (if (< current-idx (vector-length result))
463 ((now-state (vector-ref result current-idx))
464 (solo-state ((if (equal? type 'solo1) car cdr) (voice-states now-state)))
465 (silent-state ((if (equal? type 'solo1) cdr car) (voice-states now-state)))
466 (silent-notes (if silent-state (note-events silent-state) '()))
467 (solo-notes (if solo-state (note-events solo-state) '()))
468 (soln (length solo-notes))
469 (siln (length silent-notes)))
472 ((not (equal? (configuration now-state) 'apart))
474 ((= soln 0) current-idx)
475 ((> siln 0) current-idx)
476 ((null? (span-state solo-state))
477 (put-range type start-idx current-idx)
480 (try-solo type start-idx (1+ current-idx)))
485 (define (analyse-moment ri)
486 "Analyse 'apart starting at RI. Return next index.
490 ((now-state (vector-ref result ri))
491 (vs1 (car (voice-states now-state)))
492 (vs2 (cdr (voice-states now-state)))
493 (notes1 (if vs1 (note-events vs1) '()))
494 (notes2 (if vs2 (note-events vs2) '()))
496 (n2 (length notes2)) )
499 ((and (= n1 0) (= n2 0))
504 (equal? (when vs1) (when now-state))
505 (null? (previous-span-state vs1)))
506 (try-solo 'solo1 ri ri))
508 (equal? (when vs2) (when now-state))
509 (null? (previous-span-state vs2)))
510 (try-solo 'solo2 ri ri))
515 (if (< ri (vector-length result))
516 (if (equal? (configuration (vector-ref result ri)) 'apart)
517 (analyse-solo12 (analyse-moment ri))
518 (analyse-solo12 (1+ ri)))) )
521 (analyse-spanner-states voice-state-vec1)
522 (analyse-spanner-states voice-state-vec2)
526 (display voice-state-vec1)
528 (display voice-state-vec2)
534 (analyse-time-step 0)
538 ; (if pc-debug (display result))
541 (lambda (x) (cons (when x) (configuration x)))
542 (vector->list result)))
544 (if pc-debug (display result))
548 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
549 ;; autochange - fairly related to part combining.
551 (define-public (make-autochange-music music)
553 (define (generate-split-list event-list acc)
554 (if (null? event-list)
557 ((evs (map car (cdar event-list)))
558 (now (caar event-list))
559 (notes (filter (lambda (x)
560 (equal? (ly:get-mus-property x 'name) 'NoteEvent))
562 (pitch (if (pair? notes)
563 (ly:get-mus-property (car notes) 'pitch)
567 (if (and pitch (not (= (ly:pitch-steps pitch) 0)))
570 (cons (cons now (sign (ly:pitch-steps pitch))) acc))
571 (generate-split-list (cdr event-list) acc)
578 ((m (make-music-by-name 'AutoChangeMusic))
579 (context (ly:run-translator music part-combine-listener))
580 (evs (last-pair noticed))
583 (generate-split-list (if (pair? evs)
584 (reverse! (cdar evs) '()) '())
589 (ly:set-mus-property! m 'element music)
590 (ly:set-mus-property! m 'split-list split)