-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; part-combiner.
-
-
-
-(define noticed '())
-(define part-combine-listener '())
-(define-public (set-part-combine-listener x)
- (set! part-combine-listener x))
-
-(define-public (notice-the-events-for-pc context lst)
- (set! noticed (acons (ly:context-id context) lst noticed)))
-
-(define-public (make-new-part-combine-music music-list)
- (let*
- ((m (make-music-by-name 'NewPartCombineMusic))
- (m1 (context-spec-music (car music-list) 'Voice "one"))
- (m2 (context-spec-music (cadr music-list) 'Voice "two"))
- (props '((denies Thread)
- (consists Rest_engraver)
- (consists Note_heads_engraver)
- )))
-
- (ly:set-mus-property! m 'elements (list m1 m2))
- (ly:set-mus-property! m1 'property-operations props)
- (ly:set-mus-property! m2 'property-operations props)
- (ly:run-translator m2 part-combine-listener)
- (ly:run-translator m1 part-combine-listener)
- (ly:set-mus-property! m 'split-list
- (determine-split-list (reverse (cdr (assoc "one" noticed)))
- (reverse (cdr (assoc "two" noticed)))))
- (set! noticed '())
-
- m))
-
-
-
-;;
-;; due to a bug in the GUILE evaluator,
-;; stack traces result in core dumps.
-;; therefore we retain debugging code.
-;;
-(define-public (determine-split-list evl1 evl2)
- "EVL1 and EVL2 should be ascending"
-
- (define ev1 (list->vector evl1))
- (define ev2 (list->vector evl2))
- (define (when v i)
- (car (vector-ref v i)))
- (define (what v i)
- (cdr (vector-ref v i)))
-
- (define chord-threshold 8)
-
- (define result
- (list->vector
- (map (lambda (x)
- (cons x '()))
- (uniq-list
- (merge (map car evl1) (map car evl2) ly:moment<?)))))
-
- (define (analyse-events i1 i2 ri
- active1
- active2)
-
- (define (analyse-span-events active evs)
- (define (analyse-span-event active ev)
- (let*
- ((name (ly:get-mus-property ev 'name))
- (key (cond
- ((equal? name 'SlurEvent) 'slur)
- ((equal? name 'PhrasingSlurEvent) 'tie)
- ((equal? name 'Beam) 'beam)
- (else #f)))
- (sp (ly:get-mus-property ev 'span-direction)))
-
- (if (and (symbol? key) (ly:dir? sp))
- ((if (= sp STOP) delete! cons) key active)
- active))
- )
-
- (if (pair? evs)
- (analyse-span-events
- (analyse-span-event active (car evs))
- (cdr evs))
- active
- ))
-
- (define (get-note-evs v i)
- (define (f? x)
- (equal? (ly:get-mus-property x 'name) 'NoteEvent))
- (filter f? (map car (what v i))))
-
- (define (put x . index)
- (set-cdr! (vector-ref result (if (pair? index)
- (car index) ri)) x) )
-
-; (display (list i1 i2 ri active1 active2 (vector-length ev1) (vector-length ev2) (vector-length result) "\n"))
- (cond
- ((= ri (vector-length result)) '())
- ((= i1 (vector-length ev1)) (put 'apart))
- ((= i2 (vector-length ev2)) (put 'apart))
- (else
- (let*
- (
-; (x (display (list "\nelse" (= i1 (vector-length ev1)) i2 (vector-length ev2) (= i2 (vector-length ev2)))))
- (m1 (when ev1 i1))
- (m2 (when ev2 i2))
-; (x (display "oked"))
- (new-active1
- (sort
- (analyse-span-events active1 (map car (what ev1 i1)))
- symbol<?))
- (new-active2
- (sort (analyse-span-events active2 (map car (what ev2 i2)))
- symbol<?)))
-
- (if (not (or (equal? m1 (when result ri))
- (equal? m2 (when result ri))))
- (begin
- (display
- (list "<? M1,M2 != result :"
- m1 m2 (when result ri)))
- (scm-error "boem")))
-
- (cond
- ((ly:moment<? m1 m2)
- (put 'apart)
- (if (> ri 0) (put 'apart (1- ri)))
- (analyse-events (1+ i1) i2 (1+ ri) new-active1 new-active2))
- ((ly:moment<? m2 m1)
- (put 'apart)
- (if (> ri 0) (put 'apart (1- ri)))
- (analyse-events i1 (1+ i2) (1+ ri) new-active1 new-active2))
- (else
- (if (or (not (equal? active1 active2)) (not (equal? new-active2 new-active1)))
- (put 'apart)
-
- (let*
- ((notes1 (get-note-evs ev1 i1))
- (pitches1 (sort
- (map (lambda (x) (ly:get-mus-property x 'pitch)) notes1) ly:pitch<?))
- (notes2 (get-note-evs ev2 i2))
- (pitches2 (sort
- (map (lambda (x) (ly:get-mus-property x 'pitch)) notes2) ly:pitch<?))
- )
- (cond
- ((equal? pitches1 pitches2) (put 'unisono))
- ((= (length notes1) 0) (put 'solo2))
- ((= (length notes2) 0) (put 'solo1))
- ((> (length notes1) 1) (put 'apart))
- ((> (length notes2) 1) (put 'apart))
- (else
- (let* (
-; (bla (display (list (length pitches1) (length pitches2))))
- (diff (ly:pitch-diff (car pitches1) (car pitches2))))
- (if (< (ly:pitch-steps diff) chord-threshold)
- (put 'chords)
- (put 'apart))
- ))))
- )
- (analyse-events (1+ i1) (1+ i2) (1+ ri) new-active1 new-active2))
- )))))
-
-
- (analyse-events 0 0 0 '() '())
- (vector->list result))
-
-
-
-; (determine-split-list '((1 . 2) (3 . 4)) '((1 . 2) (3 . 4)))