))
(define direction-polyphonic-grobs
- '(Tie Slur Script TextScript Stem Dots DotColumn))
+ '(Tie Rest Slur Script TextScript Stem Dots DotColumn))
(define-public (make-voice-props-set n)
(make-sequential-music
))
-(define-public (make-nonevent-skip dur)
- (let* ((m (make-music-by-name 'NonEventSkip)))
+(define-public (make-skip-music dur)
+ (let* ((m (make-music-by-name 'SkipMusic)))
(ly:set-mus-property! m 'duration dur)
m
))
(let*
(
(start (make-music-by-name 'MultiMeasureRestEvent))
- (stop (make-music-by-name 'MultiMeasureRestEvent))
- (skip ( make-music-by-name 'SkipEvent))
(ch (make-music-by-name 'BarCheck))
(ch2 (make-music-by-name 'BarCheck))
- (seq (make-music-by-name 'MultiMeasureRestMusicGroup))
+ (seq (make-music-by-name 'MultiMeasureRestMusicGroup))
)
(map (lambda (x) (ly:set-mus-property! x 'origin location))
- (list start stop skip ch ch2 seq))
- (ly:set-mus-property! start 'span-direction START)
- (ly:set-mus-property! stop 'span-direction STOP)
- (ly:set-mus-property! skip 'duration duration)
+ (list start ch ch2 seq))
+ (ly:set-mus-property! start 'duration duration)
(ly:set-mus-property! seq 'elements
(list
ch
(make-event-chord (list start))
- (make-event-chord (list skip))
- (make-event-chord (list stop))
ch2
))
;;; splitting chords into voices.
-
(define (voicify-list lst number)
"Make a list of Musics.
(make-simultaneous-music (car lst))))
'Voice (number->string number))
- (voicify-list (cdr lst) (+ number 1))
+ (voicify-list (cdr lst) (1+ number))
))
)
(if
(and (equal? (ly:music-name m) "Simultaneous_music")
(reduce (lambda (x y ) (or x y)) #f (map music-separator? es)))
- (voicify-chord m)
+ (set! m (context-spec-music (voicify-chord m) 'Staff))
)
m
(let*
((meta (ly:get-grob-property grob 'meta))
(nm (if (pair? meta) (cdr (assoc 'name meta)) "nonexistant"))
- (cb (ly:get-grob-property grob 'molecule-callback)))
+ (cb (ly:get-grob-property grob 'print-function)))
(if (equal? nm object-name)
(begin
- (ly:set-grob-property! grob 'molecule-callback Balloon_interface::brew_molecule)
+ (ly:set-grob-property! grob 'print-function Balloon_interface::print)
(ly:set-grob-property! grob 'balloon-original-callback cb)
(ly:set-grob-property! grob 'balloon-text text)
(ly:set-grob-property! grob 'balloon-text-offset off)
))))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; 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)))
projects / lilypond.git / blobdiff