X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fslur.scm;h=73e087db0f3e8483bfa3e4b892fe5415aa0c4b1e;hb=77a46f6837481b568a0942e6e9ba26787900ed84;hp=fe9e8eeff62c4232fee6576c2eed004795b51bbe;hpb=9a99014bb1c199f187553fa8284521505c569031;p=lilypond.git diff --git a/scm/slur.scm b/scm/slur.scm index fe9e8eeff6..73e087db0f 100644 --- a/scm/slur.scm +++ b/scm/slur.scm @@ -1,85 +1,70 @@ -;;; -;;; slur.scm -- Slur scheme stuff -;;; -;;; source file of the GNU LilyPond music typesetter -;;; -;;; (c) 2000 Jan Nieuwenhuizen -;;; +;;;; +;;;; slur.scm -- Slur scheme stuff +;;;; +;;;; source file of the GNU LilyPond music typesetter +;;;; +;;;; (c) 2000--2004 Jan Nieuwenhuizen +;;;; (define (attached-to-stem slur dir) - (let* ((note-columns (ly-get-elt-property slur 'note-columns)) - (col (if (= dir 1) (car note-columns) (car (reverse note-columns)))) - (stem (ly-get-elt-property col 'stem))) + (let* ((note-columns (ly:grob-property slur 'note-columns)) + (col (if (= dir RIGHT) + (car note-columns) + (car (last-pair note-columns)))) + (stem (ly:grob-property col 'stem))) (and - (eq? col (ly-get-spanner-bound slur dir)) - stem - (ly-get-elt-property stem 'heads)))) + (eq? col (ly:spanner-get-bound slur dir)) + ;(ly:grob? stem) + ;(pair? (ly:grob-property stem 'heads)) + + ))) -;; Slur-extremity-rules is a list of rules. Each rule is a pair -;; (fuction . attachment), where function takes two arguments, -;; the slur and the direction of the attachment. -;; -;; The rules are tried starting from the car of this list. If the -;; function part (car) evaluates to #t, the corresponding -;; attachment (cdr) is used for the slur's dir. Otherwise, the next -;; rule is tried. ;; ;; Currently, we have attachments: ;; ;; 'head 'along-side-stem 'stem 'loose-end ;; - -(define default-slur-extremity-rules - (list - - ;; (cons (lambda (slur dir) (begin (display "before sanity check") (newline))#f) #f) - - ;; urg: don't crash on a slur without note-columns - (cons (lambda (slur dir) - (< (length (ly-get-elt-property slur 'note-columns)) 1)) 'head) - - ;; (cons (lambda (slur dir) (begin (display "before loose-end") (newline))#f) #f) - (cons (lambda (slur dir) (not (attached-to-stem slur dir))) 'loose-end) - - ;; (cons (lambda (slur dir) (begin (display "before head") (newline))#f) #f) - - (cons (lambda (slur dir) - ;; urg, code dup - (let* ((note-columns (ly-get-elt-property slur 'note-columns)) - (col (if (= dir 1) (car note-columns) (car (reverse note-columns)))) - (stem (ly-get-elt-property col 'stem))) - (and stem - (not (= (ly-get-elt-property slur 'direction) - (ly-get-elt-property stem 'direction)))))) 'head) - - ;; (cons (lambda (slur dir) (begin (display "before stem") (newline))#f) #f) - - (cons (lambda (slur dir) - ;; if attached-to-stem - (and (attached-to-stem slur dir) - ;; and got beam - ;; urg, code dup - (let* ((note-columns (ly-get-elt-property slur 'note-columns)) - (col (if (= dir 1) (car note-columns) (car (reverse note-columns)))) - (stem (ly-get-elt-property col 'stem))) - (and stem - (ly-get-elt-property stem 'beam) - ;; and beam on same side as slur - (let ((beaming (ly-get-elt-property stem 'beaming))) - ;; (display "beaming: ") (write beaming) (newline) - (if (pair? beaming) - (<= 1 - (if (= dir -1) (car beaming) (cdr beaming))) - #f)))))) - 'stem) - - ;; (cons (lambda (slur dir) (begin (display "before loose-end") (newline))#f) #f) - (cons (lambda (slur dir) (not (attached-to-stem slur dir))) 'loose-end) - ;; (cons (lambda (slur dir) (begin (display "after loose-end") (newline))#f) #f) - - ;; default case, attach to head - (cons (lambda (x y) #t) 'head) +(define (calc-slur-extremity slur dir) + (let* ((note-columns (ly:grob-property slur 'note-columns)) + (col (if (= dir 1) + (car note-columns) + (car (last-pair note-columns)))) + (stem (ly:grob-property col 'stem)) + (beaming (if (and (ly:grob? stem) + (ly:grob? (ly:grob-property stem 'beam))) + (ly:grob-property stem 'beaming) + '(() . ()))) + (one-side-beaming (if (= dir RIGHT) + (car beaming) + (cdr beaming))) + + ) + + (cond + ((< (length note-columns) 1) 'head) + ((not (attached-to-stem slur dir)) + + 'loose-end) + ((and stem + (not (equal? (ly:grob-property slur 'direction) + (ly:grob-property stem 'direction)))) 'head) + ((and (memq (ly:spanner-get-bound slur dir) + (ly:grob-property slur 'note-columns)) + (ly:grob? stem) + + ;; slur would go under beam for 'head + (> (length one-side-beaming ) 0) + ;; and beam on same side as slur + (equal? + (ly:grob-property stem 'direction) + (ly:grob-property slur 'direction)) + ) + 'stem) + ((not (attached-to-stem slur dir)) + 'loose-end) + (else + 'head)) )) @@ -93,13 +78,33 @@ ;; stem: Default position is on stem X, at stem end Y (define default-slur-extremity-offset-alist '( - ((head 1 1) . (-0.25 . 0.25)) - ((head 1 -1) . (-0.25 . -0.25)) - ((head -1 1) . (-0.25 . 0.25)) - ((head -1 -1) . (-0.85 . -0.25)) + ((head 1 1) . (-0.25 . 0.75)) + ((head 1 -1) . (-0.25 . 0.75)) + ((head -1 1) . (-0.25 . 0.75)) + ((head -1 -1) . (-0.85 . 0.75)) + + ((stem 1 1) . (-0.125 . 0.5)) + ((stem -1 -1) . (-0.125 . 0.5)) + + ((loose-end 1 1) . (-0.4 . 0)) + ((loose-end 1 -1) . (-0.4 . 0)) + ((loose-end -1 -1) . (-4 . 0)) + ((loose-end -1 1) . (-4 . 0)) + )) + +;; This is a bit of a hack: slurs and phrasing slurs +;; attaching at the same note must not collide. +;; However, slurs (and phrasing slurs) should look +;; at scripts and eachother. +(define default-phrasing-slur-extremity-offset-alist + '( + ((head 1 1) . (-0.25 . 1.25)) + ((head 1 -1) . (-0.25 . 1.25)) + ((head -1 1) . (-0.25 . 1.25)) + ((head -1 -1) . (-0.85 . 1.25)) - ((stem 1 1) . (0 . 0.5)) - ((stem -1 -1) . (0 . -0.5)) + ((stem 1 1) . (-0.25 . 1.5)) + ((stem -1 -1) . (-0.25 . 1.5)) ((loose-end 1 1) . (-0.4 . 0)) ((loose-end 1 -1) . (-0.4 . 0))