))
(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
))
;;; 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.
-;;
-
-;;
-;; todo: this is too hairy.
-;;
-(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-time-step i1 i2 ri
- active1
- active2)
-
- (define (analyse-tie-start active ev)
- (if (equal? (ly:get-mus-property ev 'name) 'TieEvent)
- (acons 'tie ri active)
- active
- ))
-
- (define (analyse-tie-end active ev)
- (if (equal? (ly:get-mus-property ev 'name) 'NoteEvent)
- (assoc-remove! active 'tie)
- active) )
- (define (active<? a b)
- (cond
- ((symbol<? (car a) (car b)) #t)
- ((symbol<? (car b) (car b)) #f)
- (else
- (< (cdr a) (cdr b)))
- ))
-
- (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 'BeamEvent) 'beam)
- ((equal? name 'CrescendoEvent) 'cresc)
- ((equal? name 'DecrescendoEvent) 'decr)
- (else #f)) )
- (sp (ly:get-mus-property ev 'span-direction))
- )
-
- (if (and (symbol? key) (ly:dir? sp))
- (if (= sp STOP)
- (assoc-remove! active key)
- (acons key ri active))
- active)
- ))
-
- (define (analyse-events active evs)
- (define (helper analyzer active evs)
- (if (pair? evs)
- (helper analyzer (analyzer active (car evs)) (cdr evs))
- active
- ))
- (sort
- (helper analyse-span-event
- (helper analyse-tie-start
- (helper analyse-tie-end active evs) evs) 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)
- "Put the result to X, starting from INDEX backwards."
- (let
- ((i (if (pair? index) (car index) ri)))
-
- (if (and (<= 0 i) (not (symbol? (what result i))))
- (begin
- (set-cdr! (vector-ref result i) x)
- (put x (1- i))
- ))
- ))
-
-
-; (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"))
- (evs1 (map car (what ev1 i1)))
- (evs2 (map car (what ev2 i2)))
-
- (new-active1 (analyse-events active1 evs1))
- (new-active2 (analyse-events active2 evs2))
- )
-
- (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-time-step (1+ i1) i2 (1+ ri) new-active1 new-active2))
- ((ly:moment<? m2 m1)
- (put 'apart)
- (if (> ri 0) (put 'apart (1- ri)))
- (analyse-time-step i1 (1+ i2) (1+ ri) new-active1 new-active2))
- (else
- (if (and (equal? active1 active2) (equal? new-active2 new-active1))
- (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
- ((> (length notes1) 1) (put 'apart))
- ((> (length notes2) 1) (put 'apart))
- (else
- (if
- (and (= (length pitches1) 1) (= (length pitches2) 1)
- (< chord-threshold (ly:pitch-steps
- (ly:pitch-diff (car pitches1) (car pitches2)))))
- (put 'apart)
-
-
- ;; copy previous split state from spanner state
- (begin
- (map (lambda (key-idx)
- (let*
- ((idx (cdr key-idx))
- (prev (what result idx))
- )
- (if (symbol? prev)
- (put prev))
- )) (append active1 active2))
- (if (and (null? new-active1) (null? new-active2))
- (put 'chords ri)))
-
- ))) )
- ;; active states different:
- (put 'apart) )
- (analyse-time-step (1+ i1) (1+ i2) (1+ ri) new-active1 new-active2))
- )))))
-
-;;
-
-
-
- (analyse-time-step 0 0 0 '() '())
-; (display result)
- (vector->list result))
projects / lilypond.git / blobdiff