Slur with left and/or right arrow head

[Lukas-Fabian Moser]

Folks,

in https://archiv.lilypondforum.de/index.php?topic=1744.msg9669#msg9669, 
Harm invented a truly wonderful new feature allowing to add an arrow 
head to the right end of a Slur (or, for that matter, a Tie, 
PhrasingSlur etc.). I reproduce it here with only trivial changes 
(mainly omitting parser/location).

Now I also need slurs with arrows pointing to the left (and ideally, 
also the option to have an arrow tip at both ends of the Slur). At first 
glance the asymmetry favoring the right hand side of a Slur seems to be 
hard-coded pretty deeply in Harm's code. Is there a cheap way to add a 
choice of "left or right end" (if not even the "or/and" possibility)?

Best
Lukas


\version "2.19.82"

#(define grob-name
  (lambda (x)
    (if (ly:grob? x)
        (assq-ref (ly:grob-property x 'meta) 'name)
        (ly:error "~a is not a grob" x))))

#(define (add-arrow-head-to-curve control-points)
  (lambda (grob)
    (let* ((orig (if (ly:spanner? grob)
                     (ly:grob-original grob)
                     #f))
           (siblings (if (ly:grob? orig)
                         (ly:spanner-broken-into orig)
                         '()))
           (function (assoc-get 'stencil
                     (reverse (ly:grob-basic-properties grob))))
           (stil ;; Ugh, is there no better way to test that a grob has no
                   ;; 'stencil and that no other previous procedure 
assigned
                   ;; a stencil-value to said grob?
                   (if (and (procedure? function)
                            (not (eq? (procedure-name function)
                                      'add-arrow-head-to-curve)))
                       (function grob)
                       (begin
                         (ly:warning "~a has no stencil. Ignoring." grob)
                         #f))))
       (if (or (null? siblings)
               (equal? grob (car (last-pair siblings))))
           (let* ((default-stil-lngth
                    (interval-length (ly:stencil-extent stil X)))
                  (frst (car control-points))
                  (thrd (caddr control-points))
                  (frth (cadddr control-points))
                  (delta-x-cps (- (car frth) (car frst)))
                  ;; Get the difference between stil-length and the 
distance
                  ;; of first-to-last control-point
                  (diff (- default-stil-lngth delta-x-cps))
                  ;; Get the legs of the triangle at third/fourth control-
                  ;; point.
                  (delta-iv
                    (cons (- (car frth) (car thrd)) (- (cdr frth) (cdr 
thrd))))
                  (radians->degree (lambda (radians) (/ (* radians 180) 
PI)))
                  (angl (radians->degree (atan (cdr delta-iv) (car 
delta-iv))))
                  ;; Ties seems to need a lower angle
                  (ang (if (member (grob-name grob)
                                  '(Tie RepeatTie LaissezVibrerTie))
                           (* angl 0.75)
                           angl))
                  (arrowhead-stil (ly:font-get-glyph 
(ly:grob-default-font grob)
                                            "arrowheads.open.01"))
                  ;; The arrowhead is too small for Tie
                  (arrowhead (if (eq? 'Tie (grob-name grob))
                                 (ly:stencil-scale arrowhead-stil 1.7 1.7)
                                 arrowhead-stil))
                  (rotated-arrowhead (ly:stencil-rotate arrowhead ang 0 0))
                  (arrowhead-lngth
                    (interval-length (ly:stencil-extent 
rotated-arrowhead X))))

             (ly:stencil-add
               stil
               (ly:stencil-translate
                 rotated-arrowhead
                 ;; Ugh, 3.8 found by trial and error
                 (cons (+ diff (/ arrowhead-lngth 3.8) (car frth))
                       (+ (cdr frth) 0)))))
            stil))))

#(define arrowed-curve
  (lambda (grob)
    (let* ((curve-dir (ly:grob-property grob 'direction))
           (right-bound (if (ly:spanner? grob)
                            (ly:spanner-bound grob RIGHT)
                            #f))
           (right-bound-stem (if (ly:grob? right-bound)
                                 (ly:grob-object right-bound 'stem)
                                 #f))
           (right-bound-stem-dir
             (if (ly:grob? right-bound-stem)
                 (ly:grob-property right-bound-stem 'direction)
                 #f))
           (c-ps (ly:grob-property grob 'control-points))
           ;(function (assoc-get 'control-points
           ;                     (reverse (ly:grob-basic-properties 
grob))))
           ;(c-pss (function grob))
           (frst (car c-ps))
           (thrd (caddr c-ps))
           ;; corr-values are my choice.
           ;; A little space is needed to make room for the arrowhead
           (corr (cond ((eq? (grob-name grob) 'RepeatTie)
                        (cons -0.25 (* 0.3 curve-dir)))
                       ((not right-bound-stem-dir)
                        '(0 . 0))
                       ((eq? (grob-name grob) 'Tie)
                        (cons -0.4  (* 0.3 curve-dir)))
                       (else (cons -0.4  (* 0.3 curve-dir)))))
           (frth (offset-add (cadddr c-ps) corr))
           (changed-cps (append (list-head c-ps 3) (list frth))))

     (ly:grob-set-property! grob 'control-points changed-cps)
     ((add-arrow-head-to-curve changed-cps) grob))))

#(define outside-staff-curve
;; prints the curve outside the staff
  (lambda (grob)
    (let* ((function (assoc-get 'control-points
                                (reverse (ly:grob-basic-properties grob))))
           (c-ps (function grob))
           (frst (car c-ps))
           (scnd (cadr c-ps))
           (thrd (caddr c-ps))
           (frth (cadddr c-ps))
           (curve-dir (ly:grob-property grob 'direction))
           (curve-up? (= 1 curve-dir))
           (right-bound (ly:spanner-bound grob RIGHT))
           (right-bound-stem (ly:grob-object right-bound 'stem))
           (right-bound-stem-dir
             (if (ly:grob? right-bound-stem)
                 (ly:grob-property right-bound-stem 'direction)
                 #f))
           (right-bound-beam
             (if (ly:grob? right-bound-stem)
                 (ly:grob-object right-bound-stem 'beam)
                 #f))
           (left-bound (ly:spanner-bound grob LEFT))
           (left-bound-stem (ly:grob-object left-bound 'stem))
           (left-bound-stem-dir
             (if (ly:grob? left-bound-stem)
                 (ly:grob-property left-bound-stem 'direction)
                 #f))
           (left-bound-beam
             (if (ly:grob? left-bound-stem)
                 (ly:grob-object left-bound-stem 'beam)
                 #f))
           ;; If Stem and Slur have same direction, more distance is needed
           ;; But not if a beam is present
           (crr
             (if (and right-bound-stem-dir
                      left-bound-stem-dir
                      (or (= right-bound-stem-dir curve-dir)
                          (= left-bound-stem-dir curve-dir))
                      (not (null? (ly:grob-property left-bound-stem 
'stencil)))
                      (not (null? (ly:grob-property right-bound-stem 
'stencil)))
                      (null? right-bound-beam)
                      (null? left-bound-beam)
                      (or (> (max (cdr frst) (cdr frth)) 2.551)
                          (< (min (cdr frst) (cdr frth)) -2.551)))
                 (* 1.2 curve-dir)
                 0))
           ;; Ensure first and fourth control-points have the same value to
           ;; creat a "flat" curve
           ;; Set second and third appropriate
           ;; The numeric values are my choice.
           (new-cps
             (map
               (lambda (cp)
                 (if (or (eq? cp frst) (eq? cp frth))
                     (cons
                       (car cp)
                       ;; For first and fourth control-point, choose 
the highest
                       ;; y-value, 2.551 at least.
                       ;; Similiar if the curve is below.
                       (+ crr
                         (if curve-up?
                             (max (cdr frst) (cdr frth) 2.551)
                             (min (cdr frst) (cdr frth) -2.551))))
                     (cons
                       (car cp)
                       ;; For second and third control-point, choose an
                       ;; appropiate y-value, 4.235 at least.
                       ;; Similiar if the curve is below.
                       (+ crr
                         (if curve-up?
                             (max
                               4.235
                               (cdr scnd)
                               (cdr thrd)
                               (+ (max (cdr frst) (cdr frth)) 1.2))

                             (min
                               -4.235
                               (cdr scnd)
                               (cdr thrd)
                               (- (min (cdr frst) (cdr frth)) 1.2)))))))
               c-ps)))
      new-cps)))


%
%slurArrow =
%  \override Slur #'stencil = #arrowed-curve
%
%print-slur-outside-staff =
%  \override Slur #'control-points = #outside-staff-curve
%

curve-arrow =
#(define-music-function (curve outside-staff-slur?)
  (string? boolean?)
"
 Prints a curve with an arrowhead at right end.
 If wanted, Slurs and PhrasingSlurs are printed outside staff.
"
  #{
    \override $curve . stencil = #arrowed-curve
    #(if (or outside-staff-slur?
             (not (member curve '(Tie RepeatTie LaissezVibrerTie))))
         #{
           \override #(string->symbol curve) . control-points =
             #outside-staff-curve
         #}
         #{#})
  #})

arrowed-slur-outside-staff = \curve-arrow Slur ##t

neutral-slur = {
    \override Slur.stencil = #ly:slur::print
    %% Why does a simple revert not work?
    %\revert Slur #'stencil
    \revert Slur.control-points
    \slurNeutral
}

arrowed-phrasing-slur-outside-staff = \curve-arrow PhrasingSlur ##t

neutral-phrasing-slur = {
    \revert PhrasingSlur #'stencil
    \revert PhrasingSlur.control-points
}

arrowed-tie = \curve-arrow Tie ##f

neutral-tie = {
    \revert Tie #'stencil
    \revert Tie.control-points
}

arrowed-repeat-tie = \curve-arrow RepeatTie ##f

neutral-repeat-tie = {
    \revert RepeatTie #'stencil
    \revert RepeatTie.control-points
}

arrowed-laissez-vibrer-tie = \curve-arrow LaissezVibrerTie ##f

neutral-laissez-vibrer-tie = {
    \revert LaissezVibrerTie #'stencil
    \revert LaissezVibrerTie.control-points
}


\new Staff \relative a' {
  \curve-arrow Slur ##f
  a4( b c d e)
}