2 ;;;; slur.scm -- Slur scheme stuff
4 ;;;; source file of the GNU LilyPond music typesetter
6 ;;;; (c) 2000--2003 Jan Nieuwenhuizen <janneke@gnu.org>
9 (define (attached-to-stem slur dir)
10 (let* ((note-columns (ly:get-grob-property slur 'note-columns))
11 (col (if (= dir 1) (car note-columns) (car (reverse note-columns))))
12 (stem (ly:get-grob-property col 'stem)))
14 (eq? col (ly:get-spanner-bound slur dir))
16 (ly:get-grob-property stem 'heads))))
19 ;; Slur-extremity-rules is a list of rules. Each rule is a pair
20 ;; (fuction . attachment), where function takes two arguments,
21 ;; the slur and the direction of the attachment.
23 ;; The rules are tried starting from the car of this list. If the
24 ;; function part (car) evaluates to #t, the corresponding
25 ;; attachment (cdr) is used for the slur's dir. Otherwise, the next
28 ;; Currently, we have attachments:
30 ;; 'head 'along-side-stem 'stem 'loose-end
33 (define default-slur-extremity-rules
36 ;; (cons (lambda (slur dir) (begin (display "before sanity check") (newline))#f) #f)
38 ;; urg: don't crash on a slur without note-columns
39 (cons (lambda (slur dir)
40 (< (length (ly:get-grob-property slur 'note-columns)) 1)) 'head)
42 ;; (cons (lambda (slur dir) (begin (display "before loose-end") (newline))#f) #f)
43 (cons (lambda (slur dir) (not (attached-to-stem slur dir))) 'loose-end)
45 ;; (cons (lambda (slur dir) (begin (display "before head") (newline))#f) #f)
47 (cons (lambda (slur dir)
49 (let* ((note-columns (ly:get-grob-property slur 'note-columns))
50 (col (car (if (= dir 1) note-columns (reverse note-columns))))
51 (stem (ly:get-grob-property col 'stem)))
54 (not (equal? (ly:get-grob-property slur 'direction)
55 (ly:get-grob-property stem 'direction)))))) 'head)
57 ;; (cons (lambda (slur dir) (begin (display "before stem") (newline))#f) #f)
59 (cons (lambda (slur dir)
60 ;; if attached-to-stem
61 (and (attached-to-stem slur dir)
64 (let* ((note-columns (ly:get-grob-property slur 'note-columns))
65 (col (if (= dir 1) (car note-columns) (car (reverse note-columns))))
66 (stem (ly:get-grob-property col 'stem)))
68 (ly:get-grob-property stem 'beam)
69 ;; and beam on same side as slur
70 (let ((beaming (ly:get-grob-property stem 'beaming)))
71 ;; (display "beaming (") (display dir) (display "): ") (write beaming) (newline)
73 (>= (length (if (= dir -1) (cdr beaming) (car beaming)))
78 ;; (cons (lambda (slur dir) (begin (display "before loose-end") (newline))#f) #f)
79 (cons (lambda (slur dir) (not (attached-to-stem slur dir))) 'loose-end)
80 ;; (cons (lambda (slur dir) (begin (display "after loose-end") (newline))#f) #f)
82 ;; default case, attach to head
83 (cons (lambda (x y) #t) 'head)
87 ;; This list defines the offsets for each type of attachment.
88 ;; The format of each element is
89 ;; (attachment stem-dir*dir slur-dir*dir)
90 ;; Different attachments have different default points:
92 ;; head: Default position is centered in X, on outer side of head Y
93 ;; along-side-stem: Default position is on stem X, on outer side of head Y
94 ;; stem: Default position is on stem X, at stem end Y
95 (define default-slur-extremity-offset-alist
97 ((head 1 1) . (-0.25 . 0.75))
98 ((head 1 -1) . (-0.25 . 0.75))
99 ((head -1 1) . (-0.25 . 0.75))
100 ((head -1 -1) . (-0.85 . 0.75))
102 ((stem 1 1) . (-0.125 . 0.5))
103 ((stem -1 -1) . (-0.125 . 0.5))
105 ((loose-end 1 1) . (-0.4 . 0))
106 ((loose-end 1 -1) . (-0.4 . 0))
107 ((loose-end -1 -1) . (-4 . 0))
108 ((loose-end -1 1) . (-4 . 0))
111 ;; This is a bit of a hack: slurs and phrasing slurs
112 ;; attaching at the same note must not collide.
113 ;; However, slurs (and phrasing slurs) should look
114 ;; at scripts and eachother.
115 (define default-phrasing-slur-extremity-offset-alist
117 ((head 1 1) . (-0.25 . 1.25))
118 ((head 1 -1) . (-0.25 . 1.25))
119 ((head -1 1) . (-0.25 . 1.25))
120 ((head -1 -1) . (-0.85 . 1.25))
122 ((stem 1 1) . (-0.25 . 1.5))
123 ((stem -1 -1) . (-0.25 . 1.5))
125 ((loose-end 1 1) . (-0.4 . 0))
126 ((loose-end 1 -1) . (-0.4 . 0))
127 ((loose-end -1 -1) . (-4 . 0))
128 ((loose-end -1 1) . (-4 . 0))