[tablatures] Bends: tests for appearance of pointed slurs

[Marc Hohl <marc@xxxxxxxxxx>]

Hello tablature users,

hopefully 2010 will bring a user-friendly solution
for coding bends.
Since my last posts concerning bends, I was stuck by
some implementation design problems, but now I think
I know how to handle them ...

Please compile the attached file (test-pointed-slurs.ly),
bend.ly has to be put into the same directory.

There are three possibilities to draw the pointed slurs
in the normal staves.

1) fixed height: the triangle covered by the pointed slur
has a fixed height regardless of the distance of the note heads.
At the moment, the height is 2 staff sizes, but you can change this
value in bend.ly; just adapt the value in

#(define pointed-slur-height 2.0)

to your needs.

2) Here I tried to follow the tangents on the normally drawn slurs in the
outer points.

3) This is approximately a triangle throught the end points and the
middle point of a normally drawn slur.

Please consider the appearance in extreme situations, when the note heads
are close together/accidentals are present etc.

What do you think? How should the pointed slurs look like?

Greetings

Marc

%
% bend.ly
%
% preliminary tests for drawing bends
% 2009-11-01
% 
% Marc Hohl
%
% TODO:
% - draw dashed line for \holdBend
% - enable consecutive bend ups
% - simplify \preBend and \holdBend usage
% - ...

#(display "\n\nbend.ly â?? 2009-12-30\n\n")


%%% sizes and values (to be changed/adapted):

% the line thickness of bends and stuff:
#(define bend-line-thickness 0.1)

% the height of pointed slurs is fixed regardless of its width
% (TODO: should this be changed?):
#(define pointed-slur-height 2.0)

% the linear amount of the bend arrow (TODO: find a better name?)
#(define bend-ratio 0.35)

% the distance between the topmost tablature line and the arrow head
#(define bend-dy 2.75)

% the distance between the end of a bend and the consecuting second one
#(define bend-shift-dy 2.75)


% the height of the bend arrow head:
#(define bend-arrow-height 1.25)

% the width of the arrow head base:
#(define bend-arrow-width 0.8)

% the distance between the tablature line where a bend starts
% and the starting point in vertical direction:
#(define bend-y-offset 0.35)

%%% internal commands
#(define-public (quarterdiff->string quarterdiff)
  (let ((wholesteps (floor (/ quarterdiff 4))))

       (string-append (case wholesteps
                            ((0) "")
                            (else (number->string wholesteps)))
                      (case (modulo quarterdiff 4)
                            ((1) "¼")
                            ((2) "½")
                            ((3) "¾")
                            (else "")))))

%%% markup commands
#(define-markup-command (pointedSlur layout props thickness bx by mx my ex ey)
  (number? number? number? number? number? number? number?)
  (interpret-markup layout props
    (markup #:postscript
            (ly:format "~f setlinewidth
                        ~f ~f moveto
                        ~f ~f lineto
                        ~f ~f lineto stroke" thickness bx by mx my ex ey))))

#(define-markup-command (drawBendArrow layout props
  thickness begin-x middle-x end-x begin-y end-y arrow-lx arrow-rx arrow-y outstring)
  (number? number? number? number? number? number? number? number? number? string?)
  (interpret-markup layout props
    (markup #:postscript
            (ly:format "~f setlinewidth
                        ~f ~f moveto
                        ~f ~f lineto
                        ~f ~f ~f ~f ~f ~f curveto
                        stroke
                        ~f ~f moveto
                        ~f ~f lineto
                        ~f ~f lineto
                        closepath fill"
                        thickness
                        begin-x begin-y
                        middle-x begin-y
                        middle-x begin-y end-x begin-y end-x arrow-y
                        arrow-lx arrow-y
                        end-x end-y
                        arrow-rx arrow-y)
            #:hspace 0
            #:translate (cons (- end-x 1.2) (+ end-y 0.5))
            #:fontsize -2
            #:bold #:center-column (outstring))))

#(define-markup-command (drawHoldBend layout props
  thickness begin-x end-x line-y)
  (number? number? number? number?)
  (interpret-markup layout props
    (markup #:postscript
            (ly:format "~f setlinewidth
                        ~f ~f moveto
                        ~f ~f lineto
                        stroke" thickness begin-x line-y end-x line-y))))

#(define-markup-command (drawHoldBendWithArrow layout props
  thickness begin-x begin-y end-x end-y arrow-lx arrow-rx arrow-y outstring)
  (number? number? number? number? number? number? number? number? string?)
  (interpret-markup layout props
    (markup #:postscript
            (ly:format "~f setlinewidth
                        ~f ~f moveto
                        ~f ~f lineto
                        stroke
                        ~f ~f moveto
                        ~f ~f lineto
                        ~f ~f lineto
                        closepath fill
                        ~f ~f moveto
                        ~f ~f lineto
                        stroke"
                        thickness
                        begin-x begin-y
                        begin-x arrow-y
                        arrow-lx arrow-y
                        begin-x end-y
                        arrow-rx arrow-y
                        begin-x end-y
                        end-x end-y)
            #:hspace 0
            #:translate (cons (- begin-x 1.2) (+ end-y 0.5))
            #:fontsize -2
            #:bold #:center-column (outstring))))

#(define-markup-command (drawHoldBendArrowOnly layout props
  thickness begin-x begin-y end-x end-y arrow-lx arrow-rx arrow-y outstring)
  (number? number? number? number? number? number? number? number? string?)
  (interpret-markup layout props
    (markup #:postscript
            (ly:format "~f setlinewidth
                        ~f ~f moveto
                        ~f ~f lineto
                        stroke
                        ~f ~f moveto
                        ~f ~f lineto
                        ~f ~f lineto
                        closepath fill"
                        thickness
                        begin-x begin-y
                        begin-x arrow-y
                        arrow-lx arrow-y
                        begin-x end-y
                        arrow-rx arrow-y)
            #:hspace 0
            #:translate (cons (- begin-x 1.2) (+ end-y 0.5))
            #:fontsize -2
            #:bold #:center-column (outstring))))

#(define-markup-command (drawDashedLine layout props
  thickness begin-x end-x line-y)
  (number? number? number? number?)
  ;; TODO: draws a full line instead of a dashed line
  (interpret-markup layout props
    (markup #:postscript
            (ly:format "~f setlinewidth
                        ~f ~f moveto
                        ~f ~f lineto
                        stroke"
                        thickness begin-x line-y end-x line-y))))

%%% callbacks

#(define-public (slur::draw-pointed-slur grob)
  (let* (;;(pointed-slur-height 2.0)
         ;;(bend-line-thickness 0.1)
         (control-points (ly:grob-property grob 'control-points))
         (direction (ly:grob-property grob 'direction))
         (left-point (car control-points))
         (right-point (cadddr control-points))
         (begin-x (+ (car left-point) 0.125)) ;; due to David's proposals
         (begin-y (cdr left-point))
         (end-x (- (car right-point) 0.125)) ;; due to David's proposals
         (end-y (cdr right-point))
         (middle-x (/ (+ begin-x end-x) 2))
         (middle-y (/ (+ begin-y end-y) 2))
         (normal-x (* direction (- begin-y end-y)))
         (normal-y (* direction (- end-x begin-x)))
         (normal-length (sqrt (+ (* normal-x normal-x)
                                 (* normal-y normal-y))))
         (point-x (+ middle-x (* pointed-slur-height
                                 (/ normal-x normal-length))))
         (point-y (+ middle-y (* pointed-slur-height
                                 (/ normal-y normal-length)))))

         (grob-interpret-markup grob
                                (make-pointedSlur-markup bend-line-thickness
                                  begin-x begin-y point-x point-y end-x end-y))))

#(define-public (slur::draw-alternate-pointed-slur grob)
  (let* ((control-points (ly:grob-property grob 'control-points))
         (direction (ly:grob-property grob 'direction))
         (first-point (car control-points))
         (second-point (cadr control-points))
         (third-point (caddr control-points))
         (forth-point (cadddr control-points))
         (first-x (car first-point))
         (first-y (cdr first-point))
         (second-x (car second-point))
         (second-y (cdr second-point))
         (third-x (car third-point))
         (third-y (cdr third-point))
         (forth-x (car forth-point))
         (forth-y (cdr forth-point))
         (A (- second-y first-y))
         (B (- first-x second-x))
         (C (- (* second-x first-y)
               (* first-x second-y)))
         (D (- forth-y third-y))
         (E (- third-x forth-x))
         (F (- (* forth-x third-y)
               (* third-x forth-y)))
         (DEN  (- (* A E) (* D B)))
         (NOMx (- (* B F) (* E C)))
         (NOMy (- (* C D) (* F A)))
         (middle-x (/ NOMx DEN))
         (middle-y (/ NOMy DEN)))

         (grob-interpret-markup grob
                                (make-pointedSlur-markup bend-line-thickness
                                  first-x first-y middle-x middle-y forth-x forth-y))))

#(define-public (slur::draw-another-alternate-pointed-slur grob)
  (let* ((control-points (ly:grob-property grob 'control-points))
         (direction (ly:grob-property grob 'direction))
         (first-point (car control-points))
         (second-point (cadr control-points))
         (third-point (caddr control-points))
         (forth-point (cadddr control-points))
         (first-x (car first-point))
         (first-y (cdr first-point))
         (second-x (car second-point))
         (second-y (cdr second-point))
         (third-x (car third-point))
         (third-y (cdr third-point))
         (forth-x (car forth-point))
         (forth-y (cdr forth-point))

         (middle-x (/ (+ third-x second-x) 2))
         (middle-y (/ (+ third-y second-y) 2)))

         (grob-interpret-markup grob
                                (make-pointedSlur-markup bend-line-thickness
                                  first-x first-y middle-x middle-y forth-x forth-y))))

#(define-public (slur::draw-bend-arrow grob)
  (let* ((staff-symbol (ly:grob-object grob 'staff-symbol))
         (line-count (ly:grob-property staff-symbol 'line-count))
         (staff-space (ly:grob-property staff-symbol 'staff-space))
         (left-bound (ly:spanner-bound grob LEFT))
         (right-bound (ly:spanner-bound grob RIGHT))
         (left-tab-note-head (ly:grob-property left-bound 'cause))
         (right-tab-note-head (ly:grob-property right-bound 'cause))
         (control-points (ly:grob-property grob 'control-points))
         (left-point (car control-points))
         (right-point (cadddr control-points))
         (left-pitch  (ly:event-property (event-cause left-bound) 'pitch))
         (right-pitch (ly:event-property (event-cause right-bound) 'pitch))
         (quarterdiff (- (ly:pitch-quartertones right-pitch)
                         (ly:pitch-quartertones left-pitch)))
         (begin-x (car left-point))
         (begin-y (+ (* (/ (ly:grob-property left-tab-note-head 'staff-position) 2)
                        staff-space)
                     bend-y-offset))
         ;; cdr left-point doesn't work, because invisible stems are included
         (end-x (car right-point))
         (end-y (+ (* (/ (- line-count 1) 2) staff-space) bend-dy))
         (arrow-lx (- end-x (/ bend-arrow-width 2)))
         (arrow-rx (+ end-x (/ bend-arrow-width 2)))
         (arrow-y (- end-y bend-arrow-height))
         (middle-x (+ begin-x (* bend-ratio (- end-x begin-x))))
         (bend-amount (quarterdiff->string quarterdiff)))

        (if (< quarterdiff 0)
            ;; bend down
            (let* ((y-offset (cdr (ly:grob-extent left-tab-note-head left-tab-note-head Y)))
                   (temp begin-y))

                  (set! begin-y end-y) ;; swap begin-y/end-y
                  (set! end-y (+ temp y-offset))
                  (set! arrow-y (+ end-y bend-arrow-height))
                  (set! bend-amount "")
                  (ly:grob-set-property! right-tab-note-head 'stencil
                                         (lambda (grob) (parenthesize-tab-note-head grob))))
            ;; bend up
            (let* ((x-offset (/ (cdr (ly:grob-extent left-tab-note-head left-tab-note-head X))
                                2)))

                  (set! begin-x (+ begin-x x-offset))
                  (ly:grob-set-property! right-tab-note-head 'transparent #t)))
        ;; draw resulting bend arrow
        (grob-interpret-markup grob
                               (make-drawBendArrow-markup
                                 bend-line-thickness
                                 begin-x middle-x end-x begin-y end-y
                                 arrow-lx arrow-rx arrow-y
                                 bend-amount))))

#(define-public (slur::draw-shifted-bend-arrow grob)
  (let* ((staff-symbol (ly:grob-object grob 'staff-symbol))
         (line-count (ly:grob-property staff-symbol 'line-count))
         (staff-space (ly:grob-property staff-symbol 'staff-space))
         (left-bound (ly:spanner-bound grob LEFT))
         (right-bound (ly:spanner-bound grob RIGHT))
         (left-tab-note-head (ly:grob-property left-bound 'cause))
         (right-tab-note-head (ly:grob-property right-bound 'cause))
         (control-points (ly:grob-property grob 'control-points))
         (left-point (car control-points))
         (right-point (cadddr control-points))
         (left-pitch  (ly:event-property (event-cause left-bound) 'pitch))
         (right-pitch (ly:event-property (event-cause right-bound) 'pitch))
         (quarterdiff (- (ly:pitch-quartertones right-pitch)
                         (ly:pitch-quartertones left-pitch)))
         (begin-x (car left-point))
         (begin-y (+ (* (/ (ly:grob-property left-tab-note-head 'staff-position) 2)
                        staff-space)
                     bend-dy))
         ;; cdr left-point doesn't work, because invisible stems are included
         (end-x (car right-point))
         (end-y (+ (* (/ (- line-count 1) 2) staff-space) bend-dy bend-shift-dy))
         (arrow-lx (- end-x (/ bend-arrow-width 2)))
         (arrow-rx (+ end-x (/ bend-arrow-width 2)))
         (arrow-y (- end-y bend-arrow-height))
         (middle-x (+ begin-x (* bend-ratio (- end-x begin-x))))
         (bend-amount (quarterdiff->string quarterdiff)))

        (if (< quarterdiff 0)
            ;; bend down
            (let* ((y-offset (cdr (ly:grob-extent left-tab-note-head left-tab-note-head Y)))
                   (temp begin-y))

                  (set! begin-y end-y) ;; swap begin-y/end-y
                  (set! end-y (+ temp y-offset))
                  (set! arrow-y (+ end-y bend-arrow-height))
                  (set! bend-amount "")
                  (ly:grob-set-property! right-tab-note-head 'stencil
                                         (lambda (grob) (parenthesize-tab-note-head grob))))
            ;; bend up
            (ly:grob-set-property! right-tab-note-head 'transparent #t))
        ;; draw resulting bend arrow
        (grob-interpret-markup grob
                               (make-drawBendArrow-markup
                                 bend-line-thickness
                                 begin-x middle-x end-x begin-y end-y
                                 arrow-lx arrow-rx arrow-y
                                 bend-amount))))

#(define-public (slur::draw-pre-bend-hold grob)
  (let* ((staff-symbol (ly:grob-object grob 'staff-symbol))
         (line-count (ly:grob-property staff-symbol 'line-count))
         (staff-space (ly:grob-property staff-symbol 'staff-space))
         (left-bound (ly:spanner-bound grob LEFT))
         (right-bound (ly:spanner-bound grob RIGHT))
         (left-tab-note-head (ly:grob-property left-bound 'cause))
         (right-tab-note-head (ly:grob-property right-bound 'cause))
         (control-points (ly:grob-property grob 'control-points))
         (left-point (car control-points))
         (right-point (cadddr control-points))
         (left-pitch  (ly:event-property (event-cause left-bound) 'pitch))
         (right-pitch (ly:event-property (event-cause right-bound) 'pitch))
         (quarterdiff (- (ly:pitch-quartertones right-pitch)
                         (ly:pitch-quartertones left-pitch)))
         (begin-x (car left-point))
         (y-offset (cdr (ly:grob-extent left-tab-note-head left-tab-note-head Y)))
         (begin-y (+ (* (/ (ly:grob-property left-tab-note-head 'staff-position)
                           2)
                        staff-space)
                     y-offset))
         ;; cdr left-point doesn't work, because invisible stems are included
         (end-x (car right-point))
         (end-y (+ (* (/ (- line-count 1) 2) staff-space) bend-dy))
         (arrow-lx (- begin-x (/ bend-arrow-width 2)))
         (arrow-rx (+ begin-x (/ bend-arrow-width 2)))
         (arrow-y (- end-y bend-arrow-height))
         (bend-amount (quarterdiff->string quarterdiff)))

        (ly:grob-set-property! right-tab-note-head 'transparent #t)
        ;; draw resulting bend arrow
        (grob-interpret-markup grob
                               (make-drawHoldBendWithArrow-markup
                                 bend-line-thickness
                                 begin-x begin-y
                                 end-x end-y
                                 arrow-lx arrow-rx arrow-y
                                 bend-amount))))

#(define-public (slur::draw-pre-bend-only grob)
  (let* ((staff-symbol (ly:grob-object grob 'staff-symbol))
         (line-count (ly:grob-property staff-symbol 'line-count))
         (staff-space (ly:grob-property staff-symbol 'staff-space))
         (left-bound (ly:spanner-bound grob LEFT))
         (right-bound (ly:spanner-bound grob RIGHT))
         (left-tab-note-head (ly:grob-property left-bound 'cause))
         (right-tab-note-head (ly:grob-property right-bound 'cause))
         (control-points (ly:grob-property grob 'control-points))
         (left-point (car control-points))
         (right-point (cadddr control-points))
         (left-pitch  (ly:event-property (event-cause left-bound) 'pitch))
         (right-pitch (ly:event-property (event-cause right-bound) 'pitch))
         (quarterdiff (- (ly:pitch-quartertones right-pitch)
                         (ly:pitch-quartertones left-pitch)))
         (begin-x (car left-point))
         (y-offset (cdr (ly:grob-extent left-tab-note-head left-tab-note-head Y)))
         (begin-y (+ (* (/ (ly:grob-property left-tab-note-head 'staff-position)
                           2)
                        staff-space)
                     y-offset))
         ;; cdr left-point doesn't work, because invisible stems are included
         (end-x (car right-point))
         (end-y (+ (* (/ (- line-count 1) 2) staff-space) bend-dy))
         (arrow-lx (- begin-x (/ bend-arrow-width 2)))
         (arrow-rx (+ begin-x (/ bend-arrow-width 2)))
         (arrow-y (- end-y bend-arrow-height))
         (bend-amount (quarterdiff->string quarterdiff)))

        (ly:grob-set-property! right-tab-note-head 'transparent #t)
        ;; draw resulting bend arrow
        (grob-interpret-markup grob
                               (make-drawHoldBendArrowOnly-markup
                                 bend-line-thickness
                                 begin-x begin-y
                                 end-x end-y
                                 arrow-lx arrow-rx arrow-y
                                 bend-amount))))

#(define-public (tie::draw-hold-bend grob)
  (let* ((staff-symbol (ly:grob-object grob 'staff-symbol))
         (line-count (ly:grob-property staff-symbol 'line-count))
         (staff-space (ly:grob-property staff-symbol 'staff-space))
         (left-tab-note-head (ly:spanner-bound grob LEFT))
         (right-tab-note-head (ly:spanner-bound grob RIGHT))
         (control-points (ly:grob-property grob 'control-points))
         (left-point (car control-points))
         (right-point (cadddr control-points))
         (begin-x (car left-point))
         (end-x (car right-point))
         (line-y (+ (* (/ (- line-count 1) 2) staff-space) bend-dy)))

        (ly:grob-set-property! right-tab-note-head 'transparent #t)
        (grob-interpret-markup grob
                               (make-drawDashedLine-markup
                                 bend-line-thickness
                                 begin-x end-x line-y))))

%%% music functions

bendOn = {
  %\override Voice.Slur #'stencil = #slur::draw-pointed-slur
  \override TabVoice.Slur #'stencil = #slur::draw-bend-arrow
}

bendOff = {
  \revert Voice.Slur #'stencil
  \override TabVoice.Slur #'stencil = #slur::draw-tab-slur
}

bendGrace = #(define-music-function (parser location note) (ly:music?)
  #{
    \once \override Voice.Stem #'stencil = ##f
    \once \override Voice.Stem #'direction = #DOWN
    \once \override Voice.Slur #'direction = #UP
    \grace $note
  #})

preBendHold = #(define-music-function (parser location note) (ly:music?)
  #{
    \once \override TabVoice.Slur #'stencil = #slur::draw-pre-bend-only
    \once \override TabStaff.ParenthesesItem #'transparent = ##t
    \parenthesize $note
  #})

preBendRelease = #(define-music-function (parser location note) (ly:music?)
  #{
    \once \override TabVoice.Slur #'stencil = #slur::draw-pre-bend-hold
    \once \override TabStaff.ParenthesesItem #'transparent = ##t
    \once \override Voice.Slur #'direction = #DOWN
    \parenthesize $note
  #})

holdBend = #(define-music-function (parser location) ()
  #{
    \once \override TabVoice.Tie #'stencil = #tie::draw-hold-bend
  #})

shiftBend = {
  \once \override TabVoice.Slur #'stencil = #slur::draw-shifted-bend-arrow
}

\version "2.13.9"

\include "bend.ly"

\paper {
   indent = 0
   ragged-right = ##f
   ragged-bottom = ##f
   ragged-last-bottom= ##f }

%% the test

test = \relative c'' {
  \bendOn
  % First, some bends to see if they work from the topmost to the lowest string
  c4 ( d )( c2 )
  c4\2 ( d\2 )( c2\2 )
  c4\3 ( des\3 )( c2\3 ) \break
  c,4\4 ( d\4 )( c2\4 )
  c4\5 ( d\5 )( c2\5 )
  c4\6 ( d\6 )( c2\6 ) \break
  % is the bend amount displayed correctly? (should be ½ in both cases)
  c4 ( cis) d ( es )
  % grace notes
  \bendGrace c8(  d4 )( c4 ) r2
  % the distinction between \preBendHold and \preBendRelease is not very
  % elegant here, I hope that there will be a better solution...
  \bendGrace { \preBendHold c8( } d2)  r2
  \bendGrace { \preBendRelease c8( d)( } c2)  r2
  c4 ( es) e\2 ( gis\2 ) \break
  % quarter tone bends are not yet supported as they should be, but
  % the bend amount is calculated correctly ;-)
  c,4 ( cih ) c4 ( cisih )
  % I hope that in future releases the tie will recognize automagically
  % that he ties to a note which is bent, but I don't know how (yet).
  \bendGrace c'8 ( \holdBend d2 ) ~ d2 ( c1 )
  c4 ( \shiftBend d) ( e2 )
  \bendOff
  % switching bends off works apparently
  c,4 ( e ) c4 ( f )
  c'4 ( b ) c4 ( a )
}

\markup { First attempt: pointed slurs have a fixed height. }

\score {
  <<
    \new Staff {
      \new Voice {
        \override Voice.Slur #'stencil = #slur::draw-pointed-slur
        \clef "G_8"
        \test
      }
    }
    \new TabStaff {
      \new TabVoice {
        \clef "tab"
        \test
      }
    }
  >>
}

\pageBreak

\markup {Second variant: pointed slurs are drawn tangential to the slur's
starting point and end point.}

\score {
  <<
    \new Staff {
      \new Voice {
      \override Voice.Slur #'stencil = #slur::draw-alternate-pointed-slur
        \clef "G_8"
        \test
      }
    }
    \new TabStaff {
      \new TabVoice {
        \clef "tab"
        \test
      }
    }
  >>
}

\pageBreak

\markup {Third variant: the coordinates of the point are half-way between the
second and the third point of the control points for the slur's bezier curve.}

\score {
  <<
    \new Staff {
      \new Voice {
      \override Voice.Slur #'stencil = #slur::draw-another-alternate-pointed-slur
        \clef "G_8"
        \test
      }
    }
    \new TabStaff {
      \new TabVoice {
        \clef "tab"
        \test
      }
    }
  >>
}