scm/slur.scm

   1 ;;;;
   2 ;;;; slur.scm -- Slur scheme stuff
   3 ;;;;
   4 ;;;; source file of the GNU LilyPond music typesetter
   5 ;;;;
   6 ;;;; (c)  2000--2004 Jan Nieuwenhuizen <janneke@gnu.org>
   7 ;;;;
   8
   9 (define (attached-to-stem slur dir)
  10   (let* ((note-columns (ly:grob-property slur 'note-columns))
  11          (col (if (= dir RIGHT)
  12                   (car note-columns)
  13                   (car (last-pair note-columns))))
  14          (stem (ly:grob-property col 'stem)))
  15     (and
  16      (eq? col (ly:spanner-get-bound slur dir))
  17      ;(ly:grob? stem)
  18      ;(pair?  (ly:grob-property stem 'heads))
  19
  20      )))
  21
  22
  23 ;;
  24 ;; Currently, we have attachments:
  25 ;;
  26 ;;    'head 'along-side-stem 'stem 'loose-end
  27 ;;
  28 (define (calc-slur-extremity slur dir)
  29   (let* ((note-columns (ly:grob-property slur 'note-columns))
  30          (col (if (= dir 1)
  31                   (car note-columns)
  32                   (car (last-pair note-columns))))
  33          (stem (ly:grob-property col 'stem))
  34          (beaming (if (and (ly:grob? stem)
  35                            (ly:grob? (ly:grob-property stem 'beam)))
  36                       (ly:grob-property stem 'beaming)
  37                       '(() . ())))
  38          (one-side-beaming (if (= dir RIGHT)
  39                                (car beaming)
  40                                (cdr beaming)))
  41
  42          )
  43
  44    (cond
  45     ((< (length note-columns) 1) 'head)
  46     ((not (attached-to-stem slur dir))
  47
  48      'loose-end)
  49     ((and stem
  50           (not (equal? (ly:grob-property slur 'direction)
  51                        (ly:grob-property stem 'direction))))  'head)
  52     ((and (memq (ly:spanner-get-bound slur dir)
  53                 (ly:grob-property slur 'note-columns))
  54           (ly:grob? stem)
  55
  56           ;; slur would go under beam for 'head
  57           (> (length one-side-beaming ) 0)
  58           ;; and beam on same side as slur
  59           (equal?
  60            (ly:grob-property stem 'direction)
  61            (ly:grob-property slur 'direction))
  62           )
  63      'stem)
  64     ((not (attached-to-stem slur dir))
  65      'loose-end)
  66     (else
  67      'head))
  68    ))
  69
  70
  71 ;; This list defines the offsets for each type of attachment.
  72 ;; The format of each element is
  73 ;; (attachment stem-dir*dir slur-dir*dir)
  74 ;; Different attachments have different default points:
  75 ;;
  76 ;; head: Default position is centered in X, on outer side of head Y
  77 ;; along-side-stem: Default position is on stem X, on outer side of head Y
  78 ;; stem: Default position is on stem X, at stem end Y
  79 (define default-slur-extremity-offset-alist
  80   '(
  81     ((head 1 1) . (-0.25 . 0.75))
  82     ((head 1 -1) . (-0.25 . 0.75))
  83     ((head -1 1) . (-0.25 . 0.75))
  84     ((head -1 -1) . (-0.85 . 0.75))
  85
  86     ((stem 1 1) . (-0.125 . 0.5))
  87     ((stem -1 -1) . (-0.125 . 0.5))
  88
  89     ((loose-end 1 1) . (-0.4 . 0))
  90     ((loose-end 1 -1) . (-0.4 . 0))
  91     ((loose-end -1 -1) . (-4 . 0))
  92     ((loose-end -1 1) . (-4 . 0))
  93     ))
  94
  95 ;; This is a bit of a hack: slurs and phrasing slurs
  96 ;; attaching at the same note must not collide.
  97 ;; However, slurs (and phrasing slurs) should look
  98 ;; at scripts and eachother.
  99 (define default-phrasing-slur-extremity-offset-alist
 100   '(
 101     ((head 1 1) . (-0.25 . 1.25))
 102     ((head 1 -1) . (-0.25 . 1.25))
 103     ((head -1 1) . (-0.25 . 1.25))
 104     ((head -1 -1) . (-0.85 . 1.25))
 105
 106     ((stem 1 1) . (-0.25 . 1.5))
 107     ((stem -1 -1) . (-0.25 . 1.5))
 108
 109     ((loose-end 1 1) . (-0.4 . 0))
 110     ((loose-end 1 -1) . (-0.4 . 0))
 111     ((loose-end -1 -1) . (-4 . 0))
 112     ((loose-end -1 1) . (-4 . 0))
 113     ))
 114
 115