scm/slur.scm

   1 ;;;;
   2 ;;;; slur.scm -- Slur scheme stuff
   3 ;;;;
   4 ;;;; source file of the GNU LilyPond music typesetter
   5 ;;;;
   6 ;;;; (c)  2000--2003 Jan Nieuwenhuizen <janneke@gnu.org>
   7 ;;;;
   8
   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)))
  13     (and
  14      (eq? col (ly:get-spanner-bound slur dir))
  15      stem
  16      (ly:get-grob-property stem 'heads))))
  17
  18
  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.
  22 ;;
  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
  26 ;; rule is tried.
  27 ;;
  28 ;; Currently, we have attachments:
  29 ;;
  30 ;;    'head 'along-side-stem 'stem 'loose-end
  31 ;;
  32
  33 (define default-slur-extremity-rules
  34   (list
  35
  36    ;; (cons (lambda (slur dir) (begin (display "before sanity check") (newline))#f) #f)
  37
  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)
  41
  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)
  44
  45    ;; (cons (lambda (slur dir) (begin (display "before head") (newline))#f) #f)
  46
  47    (cons (lambda (slur dir)
  48            ;; urg, code dup
  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)))
  52
  53              (and stem
  54                   (not (equal? (ly:get-grob-property slur 'direction)
  55                                (ly:get-grob-property stem 'direction))))))  'head)
  56
  57    ;; (cons (lambda (slur dir) (begin (display "before stem") (newline))#f) #f)
  58
  59    (cons (lambda (slur dir)
  60            ;; if attached-to-stem
  61            (and (attached-to-stem slur dir)
  62                 ;; and got beam
  63                 ;; urg, code dup
  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)))
  67                   (and 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)
  72                          (if (pair? beaming)
  73                              (>= (length (if (= dir -1) (cdr beaming) (car beaming)))
  74                                 1)
  75                              #f))))))
  76          'stem)
  77
  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)
  81
  82    ;; default case, attach to head
  83    (cons (lambda (x y) #t)  'head)
  84    ))
  85
  86
  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:
  91 ;;
  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
  96   '(
  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))
 101
 102     ((stem 1 1) . (-0.125 . 0.5))
 103     ((stem -1 -1) . (-0.125 . 0.5))
 104
 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))
 109     ))
 110
 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
 116   '(
 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))
 121
 122     ((stem 1 1) . (-0.25 . 1.5))
 123     ((stem -1 -1) . (-0.25 . 1.5))
 124
 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))
 129     ))
 130
 131