2 ;;; slur.scm -- Slur scheme stuff
4 ;;; source file of the GNU LilyPond music typesetter
6 ;;; (c) 2000 Jan Nieuwenhuizen <janneke@gnu.org>
9 (define (attached-to-stem slur dir)
10 (let* ((note-columns (ly-get-elt-property slur 'note-columns))
11 (col (if (= dir 1) (car note-columns) (car (reverse note-columns))))
12 (stem (ly-get-elt-property col 'stem)))
14 (eq? col (ly-get-spanner-bound slur dir))
16 (ly-get-elt-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-elt-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-elt-property slur 'note-columns))
50 (col (if (= dir 1) (car note-columns) (car (reverse note-columns))))
51 (stem (ly-get-elt-property col 'stem)))
53 (not (= (ly-get-elt-property slur 'direction)
54 (ly-get-elt-property stem 'direction)))))) 'head)
56 ;; (cons (lambda (slur dir) (begin (display "before stem") (newline))#f) #f)
58 (cons (lambda (slur dir)
59 ;; if attached-to-stem
60 (and (attached-to-stem slur dir)
63 (let* ((note-columns (ly-get-elt-property slur 'note-columns))
64 (col (if (= dir 1) (car note-columns) (car (reverse note-columns))))
65 (stem (ly-get-elt-property col 'stem)))
67 (ly-get-elt-property stem 'beam)
68 ;; and beam on same side as slur
69 (let ((beaming (ly-get-elt-property stem 'beaming)))
72 (if (= dir -1) (car beaming) (cdr beaming)))
76 ;;(cons (lambda (slur dir) (begin (display "before loose-end") (newline))#f) #f)
77 (cons (lambda (slur dir) (not (attached-to-stem slur dir))) 'loose-end)
78 ;; (cons (lambda (slur dir) (begin (display "after loose-end") (newline))#f) #f)
80 ;; default case, attach to head
81 (cons (lambda (x y) #t) 'head)
85 ;; This list defines the offsets for each type of attachment.
86 ;; The format of each element is
87 ;; (attachment stem-dir*dir slur-dir*dir)
88 ;; Different attachments have different default points:
90 ;; head: Default position is centered in X, on outer side of head Y
91 ;; along-side-stem: Default position is on stem X, on outer side of head Y
92 ;; stem: Default position is on stem X, at stem end Y
93 (define default-slur-extremity-offset-alist
95 ((head 1 1) . (-0.25 . 0.25))
96 ((head 1 -1) . (-0.25 . -0.25))
97 ((head -1 1) . (-0.25 . 0.25))
98 ((head -1 -1) . (-0.85 . -0.25))
100 ((stem 1 1) . (0 . 0.5))
101 ((stem -1 -1) . (0 . -0.5))
103 ((loose-end 1 1) . (-0.4 . 0))
104 ((loose-end 1 -1) . (-0.4 . 0))
105 ((loose-end -1 -1) . (-4 . 0))
106 ((loose-end -1 1) . (-4 . 0))
110 (define default-basic-slur-properties
112 (molecule-callback . ,Slur::brew_molecule)
114 (spacing-procedure . ,Slur::set_spacing_rods)
115 (minimum-length . 1.5)
116 (after-line-breaking-callback . ,Slur::after_line_breaking)
117 (extremity-rules . ,default-slur-extremity-rules)
118 (extremity-offset-alist . ,default-slur-extremity-offset-alist)
119 (de-uglify-parameters . ( 1.5 0.8 -2.0))
120 (details . ((height-limit . 2.0) (ratio . 0.333) (force-blowfit . 0.5)
121 (bezier-pct-c0 . -0.2) (bezier-pct-c3 . 0.000006)
122 (bezier-pct-out-max . 0.8) (bezier-pct-in-max . 1.2)
123 (bezier-area-steps . 1.0)))
126 (attachment-offset . ((0 . 0) . (0 . 0)))
128 (meta . ,(element-description "Slur" slur-interface))