scm/slur.scm

   1 ;;;;
   2 ;;;; slur.scm -- Slur scheme stuff
   3 ;;;;
   4 ;;;; source file of the GNU LilyPond music typesetter
   5 ;;;;
   6 ;;;; (c) 2000--2002 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 (if (= dir 1) (car note-columns) (car (reverse note-columns))))
  51                   (stem (ly:get-grob-property col 'stem)))
  52              (and stem
  53                   (not (= (ly:get-grob-property slur 'direction)
  54                           (ly:get-grob-property stem 'direction))))))  'head)
  55
  56    ;; (cons (lambda (slur dir) (begin (display "before stem") (newline))#f) #f)
  57
  58    (cons (lambda (slur dir)
  59            ;; if attached-to-stem
  60            (and (attached-to-stem slur dir)
  61                 ;; and got beam
  62                 ;; urg, code dup
  63                 (let* ((note-columns (ly:get-grob-property slur 'note-columns))
  64                        (col (if (= dir 1) (car note-columns) (car (reverse note-columns))))
  65                        (stem (ly:get-grob-property col 'stem)))
  66                   (and stem
  67                        (ly:get-grob-property stem 'beam)
  68                        ;; and beam on same side as slur
  69                        (let ((beaming (ly:get-grob-property stem 'beaming)))
  70                          ;; (display "beaming (") (display dir) (display "): ") (write beaming) (newline)
  71                          (if (pair? beaming)
  72                              (>= (length (if (= dir -1) (cdr beaming) (car beaming)))
  73                                 1)
  74                              #f))))))
  75          'stem)
  76
  77    ;; (cons (lambda (slur dir) (begin (display "before loose-end") (newline))#f) #f)
  78    (cons (lambda (slur dir) (not (attached-to-stem slur dir)))  'loose-end)
  79    ;; (cons (lambda (slur dir) (begin (display "after loose-end") (newline))#f) #f)
  80
  81    ;; default case, attach to head
  82    (cons (lambda (x y) #t)  'head)
  83    ))
  84
  85
  86 ;; This list defines the offsets for each type of attachment.
  87 ;; The format of each element is
  88 ;; (attachment stem-dir*dir slur-dir*dir)
  89 ;; Different attachments have different default points:
  90 ;;
  91 ;; head: Default position is centered in X, on outer side of head Y
  92 ;; along-side-stem: Default position is on stem X, on outer side of head Y
  93 ;; stem: Default position is on stem X, at stem end Y
  94 (define default-slur-extremity-offset-alist
  95   '(
  96     ((head 1 1) . (-0.25 . 0.75))
  97     ((head 1 -1) . (-0.25 . 0.75))
  98     ((head -1 1) . (-0.25 . 0.75))
  99     ((head -1 -1) . (-0.85 . 0.75))
 100
 101     ((stem 1 1) . (-0.125 . 0.5))
 102     ((stem -1 -1) . (-0.125 . 0.5))
 103
 104     ((loose-end 1 1) . (-0.4 . 0))
 105     ((loose-end 1 -1) . (-0.4 . 0))
 106     ((loose-end -1 -1) . (-4 . 0))
 107     ((loose-end -1 1) . (-4 . 0))
 108     ))
 109
 110 ;; This is a bit of a hack: slurs and phrasing slurs
 111 ;; attaching at the same note must not collide.
 112 ;; However, slurs (and phrasing slurs) should look
 113 ;; at scripts and eachother.
 114 (define default-phrasing-slur-extremity-offset-alist
 115   '(
 116     ((head 1 1) . (-0.25 . 1.25))
 117     ((head 1 -1) . (-0.25 . 1.25))
 118     ((head -1 1) . (-0.25 . 1.25))
 119     ((head -1 -1) . (-0.85 . 1.25))
 120
 121     ((stem 1 1) . (-0.25 . 1.5))
 122     ((stem -1 -1) . (-0.25 . 1.5))
 123
 124     ((loose-end 1 1) . (-0.4 . 0))
 125     ((loose-end 1 -1) . (-0.4 . 0))
 126     ((loose-end -1 -1) . (-4 . 0))
 127     ((loose-end -1 1) . (-4 . 0))
 128     ))
 129
 130