3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
6 (use-modules (oop goops))
8 (define-class <Voice-state> ()
9 (event-list #:init-value '() #:accessor events #:init-keyword #:events)
10 (when-moment #:accessor when #:init-keyword #:when)
11 (split-idx #:accessor split-idx )
12 (spanner-state #:init-value '() #:accessor span-state)
17 (define-class <Split-state> ()
18 (configuration #:init-value '() #:accessor configuration)
19 (when-moment #:accessor when #:init-keyword #:when)
20 (is #:init-keyword #:indexes #:accessor indexes)
21 (synced #:init-keyword #:synced #:init-value #f #:getter synced?)
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)
33 (define-method (write (x <Split-state> ) f)
36 (display (configuration x) f)
43 (define (make-voice-states evl)
49 #:events (map car (cdr v))
53 (define (moment-min a b)
54 (if (ly:moment<? a b) a b))
56 (define (make-split-state vs1 vs2)
57 "Merge lists VS1 and VS2, containing Voice-state objects into vector
58 of Split-state objects, crosslinking the Split-state vector and
62 (define (helper ss-idx ss-list idx1 idx2)
64 ((m1 (if (< idx1 (vector-length vs1)) (when (vector-ref vs1 idx1)) #f) )
65 (m2 (if (< idx2 (vector-length vs2)) (when (vector-ref vs2 idx2)) #f) )
66 (min (cond ((and m1 m2) (moment-min m1 m2))
72 (inc1 (if (and m1 (equal? min m1)) 1 0))
73 (inc2 (if (and m2 (equal? min m2)) 1 0))
78 #:indexes (cons idx1 idx2)
79 #:synced (= inc1 inc2)
83 (set! (split-idx (vector-ref vs1 idx1)) ss-idx))
85 (set! (split-idx (vector-ref vs2 idx2)) ss-idx))
89 (cons ss-object ss-list)
98 (helper 0 '() 0 0) '()))
103 (define (analyse-spanner-states voice-state-vec)
105 (define (helper index active)
106 "Analyse EVS at INDEX, given state ACTIVE."
108 (define (analyse-tie-start active ev)
109 (if (equal? (ly:get-mus-property ev 'name) 'TieEvent)
110 (acons 'tie index active)
114 (define (analyse-tie-end active ev)
115 (if (equal? (ly:get-mus-property ev 'name) 'NoteEvent)
116 (assoc-remove! active 'tie)
119 (define (active<? a b)
121 ((symbol<? (car a) (car b)) #t)
122 ((symbol<? (car b) (car b)) #f)
127 (define (analyse-span-event active ev)
129 ((name (ly:get-mus-property ev 'name))
131 ((equal? name 'SlurEvent) 'slur)
132 ((equal? name 'PhrasingSlurEvent) 'tie)
133 ((equal? name 'BeamEvent) 'beam)
134 ((equal? name 'CrescendoEvent) 'cresc)
135 ((equal? name 'DecrescendoEvent) 'decr)
137 (sp (ly:get-mus-property ev 'span-direction))
140 (if (and (symbol? key) (ly:dir? sp))
142 (assoc-remove! active key)
143 (acons key index active))
147 (define (analyse-events active evs)
148 "Run all analyzers on ACTIVE and EVS"
150 (define (run-analyzer analyzer active evs)
152 (run-analyzer analyzer (analyzer active (car evs)) (cdr evs))
158 ;; todo: use fold or somesuch.
163 (run-analyzer analyse-tie-end active evs) evs) evs)
167 ;; must copy, since we use assoc-remove!
168 (if (< index (vector-length voice-state-vec))
170 (set! active (analyse-events active (events (vector-ref voice-state-vec index))))
171 (set! (span-state (vector-ref voice-state-vec index))
174 (helper (1+ index) active)))
185 (define part-combine-listener '())
186 (define-public (set-part-combine-listener x)
187 (set! part-combine-listener x))
189 (define-public (notice-the-events-for-pc context lst)
190 (set! noticed (acons (ly:context-id context) lst noticed)))
192 (define-public (make-new-part-combine-music music-list)
194 ((m (make-music-by-name 'NewPartCombineMusic))
195 (m1 (context-spec-music (car music-list) 'Voice "one"))
196 (m2 (context-spec-music (cadr music-list) 'Voice "two"))
197 (props '((denies Thread)
198 (consists Rest_engraver)
199 (consists Note_heads_engraver)
202 (ly:set-mus-property! m 'elements (list m1 m2))
203 (ly:set-mus-property! m1 'property-operations props)
204 (ly:set-mus-property! m2 'property-operations props)
205 (ly:run-translator m2 part-combine-listener)
206 (ly:run-translator m1 part-combine-listener)
207 (ly:set-mus-property! m 'split-list
208 (determine-split-list (reverse (cdr (assoc "one" noticed)))
209 (reverse (cdr (assoc "two" noticed)))))
221 ;; todo: this function is rather too hairy and too long.
223 (define-public (determine-split-list evl1 evl2)
224 "EVL1 and EVL2 should be ascending"
229 (voice-state-vec1 (make-voice-states evl1))
230 (voice-state-vec2 (make-voice-states evl2))
231 (result (make-split-state voice-state-vec1 voice-state-vec2))
235 (define (analyse-time-step ri)
236 (define (put x . index)
237 "Put the result to X, starting from INDEX backwards.
239 Only set if not set previously.
243 ((i (if (pair? index) (car index) ri)))
246 (not (symbol? (configuration (vector-ref result i)))))
248 (set! (configuration (vector-ref result i)) x)
253 (define (get-note-evs vs)
255 (equal? (ly:get-mus-property x 'name) 'NoteEvent))
256 (filter f? (events vs)))
258 (define (copy-state-from state-vec vs)
259 (define (copy-one-state key-idx)
262 (start-vs (vector-ref state-vec idx))
263 (prev-ss (vector-ref result (split-idx start-vs)))
264 (prev (configuration prev-ss))
269 (map copy-one-state (span-state vs))
272 (define (analyse-notes now-state)
275 (i1 (car (indexes now-state)))
276 (i2 (cdr (indexes now-state)))
277 (vs1 (vector-ref voice-state-vec1 i1))
278 (vs2 (vector-ref voice-state-vec2 i2))
280 (notes1 (get-note-evs vs1))
281 (durs1 (sort (map (lambda (x) (ly:get-mus-property x 'duration)) notes1) ly:duration<?))
283 (map (lambda (x) (ly:get-mus-property x 'pitch)) notes1) ly:pitch<?))
284 (notes2 (get-note-evs vs2))
285 (durs2 (sort (map (lambda (x) (ly:get-mus-property x 'duration)) notes2) ly:duration<?))
287 (map (lambda (x) (ly:get-mus-property x 'pitch)) notes2) ly:pitch<?))
291 ((> (length notes1) 1) (put 'apart))
292 ((> (length notes2) 1) (put 'apart))
293 ((not (= (length notes1) (length notes2)))
298 (not (equal? (car durs1) (car durs2))))
302 (if (and (= (length pitches1) (length pitches2)))
303 (if (and (pair? pitches1)
305 (< chord-threshold (ly:pitch-steps
306 (ly:pitch-diff (car pitches1) (car pitches2)))))
309 ;; copy previous split state from spanner state
312 (copy-state-from voice-state-vec1 (vector-ref voice-state-vec1 (1- i1))))
314 (copy-state-from voice-state-vec2 (vector-ref voice-state-vec2 (1- i2))))
315 (if (and (null? (span-state vs1)) (null? (span-state vs2)))
323 (if (< ri (vector-length result))
325 ((now-state (vector-ref result ri))
326 (i1 (car (indexes now-state)))
327 (i2 (cdr (indexes now-state))))
330 ((= i1 (vector-length voice-state-vec1)) (put 'apart))
331 ((= i2 (vector-length voice-state-vec2)) (put 'apart))
335 (vs1 (vector-ref voice-state-vec1 i1))
336 (vs2 (vector-ref voice-state-vec2 i2))
340 (span-state (vector-ref voice-state-vec1 (1- i1)))
344 (span-state (vector-ref voice-state-vec2 (1- i2)))
347 (new-active1 (span-state vs1))
348 (new-active2 (span-state vs2))
353 (display (list (when now-state) i1 i2 ri
354 active1 "->" new-active1
355 active2 "->" new-active2
360 (if (and (synced? now-state)
361 (equal? active1 active2)
362 (equal? new-active1 new-active2))
364 (analyse-notes now-state)
366 ;; active states different:
371 ; go to the next one, if it exists.
372 (analyse-time-step (1+ ri))
376 (define (analyse-solo12 ri)
378 (set-cdr! (vector-ref result ri) x) )
380 (if (< ri (vector-length result))
383 ((now (when result ri))
386 (notes1 (get-note-evs ev1
387 (if (ly:moment<? now m1)
390 (durs1 (sort (map (lambda (x) (ly:get-mus-property x 'duration)) notes1) ly:duration<?))
392 (map (lambda (x) (ly:get-mus-property x 'pitch)) notes1) ly:pitch<?))
394 (notes2 (get-note-evs ev2
395 (if (ly:moment<? now m2)
399 (durs2 (sort (map (lambda (x) (ly:get-mus-property x 'duration)) notes2) ly:duration<?))
401 (map (lambda (x) (ly:get-mus-property x 'pitch)) notes2) ly:pitch<?))
404 (if pc-debug (display (list
406 (when result ri) i1 "/" (vector-length ev1)
408 i2 "/" (vector-length ev2) m2 ":"
410 ri "/" (vector-length result) " = "
417 (if (equal? (what result ri) 'apart)
431 (put 'apart-silence))
435 (equal? (what result ri) 'chords)
436 (equal? pitches1 pitches2))
437 (put (if (pair? pitches2)
438 'unisono 'unisilence) ))
442 (analyse-solo12 (1+ i1) i2 (1+ ri) ))
444 (analyse-solo12 i1 (1+ i2) (1+ ri) ))
446 (analyse-solo12 (1+ i1) (1+ i2) (1+ ri)))
450 (analyse-spanner-states voice-state-vec1)
451 (analyse-spanner-states voice-state-vec2)
452 ; (display voice-state-vec1)
453 ; (display voice-state-vec2)
456 (analyse-time-step 0)
457 ; (analyse-solo12 0 0 0)
459 ; (if pc-debug (display result))
462 (lambda (x) (cons (when x) (configuration x)))
463 (vector->list result)))
465 ; (if pc-debug (display result))