Subject: Slur with left and/or right arrow head

From: Ya Gloops <[email-masked]>
Date: Fri, 11 Aug 2023 12:25:30 +0000 (UTC)

Bonjour à tous

J'utilise pas mal cette fonction de Aaron Hill, mais depuis la v 2.25 ça ne fonctionne plus!
Je soupsonne un problème de font-encoding, vu qu'il y a eu pas mal de changements à ce niveau là. 
Malheureusement je ne trouve pas la solution, mais peut-etre qu'il n'y en à pas !

Bonnes vacances à tous...
Gilles

\version "2.24.1"
%\version "2.25.7"

%% Thanks to Aaron Hill
%% http://lists.gnu.org/archive/html/lilypond-user/2019-04/msg00240.html 

%% Does not work for 2.18.2 because of
%%   - grob::name (could be replaced by grob-name, see p.e. LSR)
%%   - minimum-length-after-break (no direct replacement possible, only used in
%%     the examples, though)
  
#(define (make-coord x-value y-value)
  "Make a coordinate pair from @var{x-valye} and @var{y-value}."
  (cons x-value y-value))

#(define (coord+ coord1 coord2)
  "Add @var{coord1} to @var{coord2}, returning a coordinate."
  (cons (+ (car coord1) (car coord2))
        (+ (cdr coord1) (cdr coord2))))

#(define (coord- coord1 coord2)
  "Subtract @var{coord2} from @var{coord1}."
  (cons (- (car coord1) (car coord2))
        (- (cdr coord1) (cdr coord2))))

#(define (coord* scalar coord)
  "Multiply each component of @var{coord} by @var{scalar}."
  (cons (* (car coord) scalar)
        (* (cdr coord) scalar)))

#(define (make-bezier point-0 point-1 point-2 point-3)
  "Create a cubic bezier from the four control points."
  (list point-0 point-1 point-2 point-3))

#(define (interpolated-control-points control-points split-value)
  "Interpolate @var{control-points} at @var{split-value}.  Return a
set of control points that is one degree less than @var{control-points}."
  (if (null? (cdr control-points))
      '()
      (let ((first (car control-points))
            (second (cadr control-points)))
        (cons* (coord+ first (coord* split-value (coord- second first)))
               (interpolated-control-points
                (cdr control-points)
                split-value)))))

#(define (split-bezier bezier split-value)
  "Split a cubic bezier defined by @var{bezier} at the value
@var{split-value}.  @var{bezier} is a list of pairs; each pair is
is the coordinates of a control point.  Returns a list of beziers.
The first element is the LHS spline; the second
element is the RHS spline."
  (let* ((quad-points (interpolated-control-points
                       bezier
                       split-value))
         (lin-points (interpolated-control-points
                      quad-points
                      split-value))
         (const-point (interpolated-control-points
                       lin-points
                       split-value))
         (left-side (list (car bezier)
                          (car quad-points)
                          (car lin-points)
                          (car const-point)))
         (right-side (list (car const-point)
                           (list-ref lin-points 1)
                           (list-ref quad-points 2)
                           (list-ref bezier 3))))
    (cons left-side right-side)))

#(define (multi-split-bezier bezier start-t split-list)
  "Split @var{bezier} at all the points listed in @var{split-list}.
@var{bezier} has a parameter value that goes from @var{start-t} to 1.
Returns a list of @var{(1+ (length split-list))} beziers."
  (let* ((bezier-split (split-bezier bezier
                                     (/ (- (car split-list) start-t)
                                        (- 1 start-t))))
         (left-bezier (car bezier-split))
         (right-bezier (cdr bezier-split)))
    (if (null? (cdr split-list))
        bezier-split
        (cons* left-bezier
               (multi-split-bezier right-bezier
                                   (car split-list)
                                   (cdr split-list))))))

#(define (bezier-sandwich-list top-bezier bottom-bezier)
  "create the list of control points for a bezier sandwich consisting
of @var{top-bezier} and @var{bottom-bezier}."
  (list (list-ref bottom-bezier 1)
        (list-ref bottom-bezier 2)
        (list-ref bottom-bezier 3)
        (list-ref bottom-bezier 0)
        (list-ref top-bezier 2)
        (list-ref top-bezier 1)
        (list-ref top-bezier 0)
        (list-ref top-bezier 3)))

#(define (note-column-bounded? dir grob)
"Checks wether @var{grob} is a spanner and whether the spanner is bounded in
@var{dir}-direction by a note-column."
  (if (ly:spanner? grob)
      (grob::has-interface (ly:spanner-bound grob dir) 'note-column-interface)
      #f))

#(define (offset-number-pair-list l1 l2)
"Offset the number-pairs of @var{l1} by the matching number-pairs of @var{l2}"
;; NB no type-checking or checking for equal lengths is done here
  (map (lambda (p1 p2) (offset-add p1 p2)) l1 l2))

#(define (bezier::point control-points t)
"Given a Bezier curve of arbitrary degree specified by @var{control-points},
compute the point at the specified position @var{t}."
  (if (< 1 (length control-points))
      (let ((q0 (bezier::point (drop-right control-points 1) t))
            (q1 (bezier::point (drop control-points 1) t)))
        (cons
          (+ (* (car q0) (- 1 t)) (* (car q1) t))
          (+ (* (cdr q0) (- 1 t)) (* (cdr q1) t))))
      (car control-points)))

#(define (bezier::angle control-points t)
"Given a Bezier curve of arbitrary degree specified by @var{control-points},
compute the slope at the specified position @var{t}."
  (let ((q0 (bezier::point (drop-right control-points 1) t))
        (q1 (bezier::point (drop control-points 1) t)))
    (ly:angle (- (car q1) (car q0)) (- (cdr q1) (cdr q0)))))

#(define* 
  (bezier::approx-control-points-to-length 
    control-points dir length 
    #:optional (precision 0.01) (right-t 0.2) (left-t 0.8))
"Given a Bezier curve specified by @var{control-points}, return 
new control-points where the length of the Bezier specified by them is approx
@var{length}.
The procedure returns if difference of the new calculated length and the given
@var{length} is lower than optional @var{precision}.
The optional @var{left-t} and @var{right-t} represent the steps where new
control-points are calculated relying on @var{dir}."
  ;; TODO
  ;; Do the values for precision, left-t, right-t cover all cases?
  (let*  ((frst-cp (car control-points))
          (last-cp (last control-points))
          (actual-length
            (ly:length 
              (- (car frst-cp) (car last-cp))
              (- (cdr frst-cp) (cdr last-cp))))
          (diff (- (abs actual-length) (abs length))))
      (if (< diff precision)
          control-points
          (bezier::approx-control-points-to-length
            (if (positive? dir)
                (cdr (split-bezier control-points right-t))
                (car (split-bezier control-points left-t)))
            dir
            length))))

#(define (bezier::adjusted-arrow-head dir control-points)
(lambda (curve)
"Returns a stencil build from an arrowhead-glyph, adjusted to fit at start/end
of a curve looking at the curve's @var{control-points}.
Relying on @var{dir} for looking at left or right side of the curve."
  (if (not dir)
      empty-stencil
      (let* ((staff-space (ly:staff-symbol-staff-space curve))
             ;; reducing fs-from-staff-space a bit looks nicer
             (fs-from-staff-space (1- (magnification->font-size staff-space)))
             (grob-font
               (ly:paper-get-font
                 (ly:grob-layout curve)
                 `(((font-encoding . fetaMusic)
                    (font-size . ,fs-from-staff-space)))))
             (arrowhead-stil
               (ly:font-get-glyph grob-font
                 (format #f "arrowheads.open.0~a1"
                   (if (positive? dir) "" "M"))))
             (arrowhead-width 
               (interval-length (ly:stencil-extent arrowhead-stil X)))
             (offset-stil
               (ly:stencil-translate
                 arrowhead-stil
                 (cons (* dir 0.4 arrowhead-width) 0)))
             (arrowhead-end 
               (interval-bound (ly:stencil-extent offset-stil X) (- dir)))
             (offset (* 0.33 arrowhead-end))
             (angle 
               (bezier::angle 
                 (bezier::approx-control-points-to-length 
                   control-points dir offset)
                 (if (positive? dir) 0 1))))
        (ly:stencil-rotate-absolute offset-stil angle 0 0)))))
        
#(define modify-control-points-for-arrows
(lambda (grob)
"Returns a number-pair-list suitable for setting @code{control-points}-property.
The values are modified with respect to a probably printed arrowhead, which
is done by looking at the subproperties of @code{details}:
@code{arrow-left} and @code{arrow-right}."
  (let* ((curve-dir (ly:grob-property grob 'direction))
         (details (ly:grob-property grob 'details))
         (arrow-left (assoc-get 'arrow-left details #f))
         (arrow-right (assoc-get 'arrow-right details #f))
         (nc-right-bound?
           (note-column-bounded? RIGHT grob))
         (nc-left-bound?
           (note-column-bounded? LEFT grob))
         (c-ps (ly:grob-property grob 'control-points)))
    ;; numerical values are my choice -- harm
    (cond ((and (not arrow-left) (not arrow-right))
            c-ps)
          ((eq? (grob::name grob) 'LaissezVibrerTie)
            (if arrow-left ;; move a little to right
                (offset-number-pair-list
                  c-ps
                  '((0.3 . 0) (0.3 . 0) (0.3 . 0) (0.3 . 0)))
                 c-ps))
          ((eq? (grob::name grob) 'RepeatTie)
            (if arrow-right ;; move a little to left
                (offset-number-pair-list
                  c-ps
                  '((-0.3 . 0) (-0.3 . 0) (-0.3 . 0) (-0.3 . 0)))
                c-ps))
          (else ;; Tie, Slur, PhrasingSlur
            (let ((move-this-to-left
                    (if arrow-left
                        (if nc-left-bound? 0.4 0.5)
                        0))
                  (move-this-to-right
                    (if arrow-right
                        (if nc-right-bound? -0.4 -0.5)
                        0))
                  ;; For Ties we want to keep a horizontal look
                  (move-Y-at-left
                    (if (or arrow-left
                            (grob::has-interface grob 'tie-interface))
                        (* 0.2 curve-dir)
                        0))
                  (move-Y-at-right
                    (if (or arrow-right
                            (grob::has-interface grob 'tie-interface))
                        (* 0.2 curve-dir)
                        0)))
              (offset-number-pair-list
                c-ps
                (list
                  (cons move-this-to-left  move-Y-at-left)
                  (cons move-this-to-left  move-Y-at-left)
                  (cons move-this-to-right move-Y-at-right)
                  (cons move-this-to-right move-Y-at-right)))))))))

#(define add-arrow-head-to-curve
(lambda (grob)
"Returns a curve stencil with optional arrowheads at start/end.
Whether to print arrowheads is decided by looking at the subproperties of
@code{details}: @code{arrow-left} and @code{arrow-right}."
  (let* ((control-points (modify-control-points-for-arrows grob))
         (details (ly:grob-property grob 'details))
         (details-arrow-left (assoc-get 'arrow-left details #f))  
         (details-arrow-right (assoc-get 'arrow-right details #f))
         (arrow-left
           (if (procedure? details-arrow-left)
               (details-arrow-left grob)
               details-arrow-left))
         (arrow-right
           (if (procedure? details-arrow-right)
               (details-arrow-right grob)
               details-arrow-right)))
     (if (and (not arrow-left) (not arrow-right))
         ;; we're setting 'after-line-breaking, thus do nothing for no arrows
         '()
         (let* ((frst (car control-points))
                (frth (cadddr control-points))
                (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)))
                          (begin
                            (ly:grob-set-property! grob 
                              'control-points control-points)
                            (function grob))
                          (begin
                            (ly:warning "~a has no stencil. Ignoring." grob)
                            #f)))
                (arrow-right-stil
                  (if arrow-right
                      ((bezier::adjusted-arrow-head RIGHT control-points)
                        grob)
                      empty-stencil))
                (arrow-left-stil
                  (if arrow-left
                      ((bezier::adjusted-arrow-head LEFT control-points)
                        grob)
                      empty-stencil)))
           (ly:grob-set-property! grob 'stencil
             (ly:stencil-add
               (ly:stencil-translate arrow-left-stil frst)
               (ly:stencil-translate arrow-right-stil frth)
               stil)))))))

pointing-curve =
#(define-music-function (curve) (string?)
"Set property @code{after-line-breaking} for grob @code{curve}. Finally setting
the @code{stencil} to @code{arrowed-curve}.
It's needed to go for @code{after-line-breaking}, otherwise changes to
@code{control-points} done by @code{shape} wouldn't be respected.
Whether or not arrows are printed should done by applying, p.e.
@lilypond[verbatim,quote]
  \\override Tie.details.arrow-left = ##t
  \\override Slur.details.arrow-left = ##t
@end lilypond
separately."
  #{
    \temporary \override $curve . after-line-breaking = #add-arrow-head-to-curve
  #})

revert-pointing-curve =
#(define-music-function (curve) (string?)
"Revert the setting for @code{after-line-breaking} of grob @var{curve}."
  #{
    \revert $curve . after-line-breaking
  #})

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% EXAMPLES
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

\layout {
  \override Tie.details.arrow-left = ##t
  \override Slur.details.arrow-left = ##t
  \override PhrasingSlur.details.arrow-left = ##t
  \override RepeatTie.details.arrow-left = ##t
  \override LaissezVibrerTie.details.arrow-left = ##t

  \override Tie.details.arrow-right = ##t
  \override Slur.details.arrow-right = ##t
  \override PhrasingSlur.details.arrow-right = ##t
  \override RepeatTie.details.arrow-right = ##t
  \override LaissezVibrerTie.details.arrow-right = ##t
  
  %% Two possibilities to limit printing of arrows for broken spanner
  %%
  %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  %% \alterBroken
  %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  %%
  %\alterBroken details.arrow-right #(list #f #f #t) Slur
  %\alterBroken details.arrow-left #(list #t #f #f) Slur
  %%
  %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  %% Setting details.arrow-right to a procedure
  %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  %%
  %\override Slur.details.arrow-right = 
  %  #(lambda (grob) 
  %    (let* ((orig (if (ly:spanner? grob)
  %                 (ly:grob-original grob)
  %                 #f))
  %           (siblings (if (ly:grob? orig)
  %                         (ly:spanner-broken-into orig)
  %                         '())))
  %      ;; print arrow-right for unbroken or last part of a broken Slur
  %      (if (or (not (pair? siblings))
  %              (and (pair? siblings) 
  %                   (equal? grob (car (last-pair siblings)))))
  %          #t
  %          #f)))
}

% {
\new Staff \with { instrumentName = "Slurs" }
\relative c'' {
    \pointing-curve Slur
    c'1( c 
    \break  
    c 
    \break 
    c)

    \slurDown
    c4( c c c)

    \voiceOne
    c,,4( c c c'')

    <>^"default"
    \revert-pointing-curve Slur
    \oneVoice
    c( c c c)
}
%}
% {
m = { c4( d e f e d des c) }

testI = {
  \relative c \m
  \relative c' \m
  \relative c'' \m
  \relative c''' \m
}

\new Staff \with { instrumentName = "Slurs" }
{
  \pointing-curve Slur
  <>^"no Slur-Stem-direction"
  \testI
  \break

  <>^"Slur down, Stem up"
  \slurDown
  \stemUp
  \testI
  \break

  <>^"Slur up, Stem down"
  \slurUp
  \stemDown
  \testI
  \break

  <>^"Slur up, Stem up"
  \slurUp
  \stemUp
  \testI
  \break

  <>^"Slur down, Stem down"
  \slurDown
  \stemDown
  \testI
  \break

  <>^"default"
  \stemNeutral
  \slurNeutral
  \revert-pointing-curve Slur
  \testI
  \break
}
%}
% {
\new Staff \with { instrumentName = "Ties" }
\relative c' {
    \pointing-curve Tie
    %% overriding TieColumn.tie-configuration works
    <c e g c>1~
    \once \override TieColumn.tie-configuration =
      #'((3.0 . 1) (-1.0 . 1) (-5.0 . -1) (-8.0 . -1))
    q
    \once \override Tie.minimum-length-after-break = 8

    <c e g c>1~
    \break
    q
    <>^"default"
    \revert-pointing-curve Tie
    <c e g c>1~ q
}
%}
% {
\new Staff \with { instrumentName = "PhrasingSlur" }
\relative c' {
    \pointing-curve PhrasingSlur
    <c e g c>1^\( q q <g d' g b g'>\)
    <>^"default"
    \revert-pointing-curve PhrasingSlur
    <c e g c>1^\( q q <g d' g b g'>\)
}
%}
% {
%% \shape works
\new Staff \with { instrumentName = "RepeatTie" }
\relative c' {
  \pointing-curve RepeatTie
  c1\repeatTie
  %% If left _and_ right arrow is wished, the RepeatTie may be too
  %% short, use \shape then
  <>^"shaped"
  \shape #'((-0.6 . 0) (-0.6 . -0.1) (0 . -0.1) (0 . 0)) RepeatTie
  c1\repeatTie
  <>^"default"
  \revert-pointing-curve RepeatTie
  c1\repeatTie
}
%}
% {
\new Staff \with { instrumentName = "LaissezVibrerTie" }
\relative c' {
  \pointing-curve LaissezVibrerTie
  c1\laissezVibrer
  %% If left _and_ right arrow is wished, the LaissezVibrerTie may be too
  %% short, use \shape then
  <>^"shaped"
  c1-\shape #'((0 . 0) (0 . -0.1) (0.6 . -0.1) (0.6 . 0))-\laissezVibrer
  <>^"default"
  \revert-pointing-curve LaissezVibrerTie
  c1\laissezVibrer
}
%}
\paper { indent = 30 }

#(set-global-staff-size 18)

%% time values on my machine

%% arrow-slur-05.ly
%% real    0m4,855s
%% user    0m4,376s
%% sys    0m0,456s

%% arrow-slur-04.ly
%% real    0m3,880s
%% user    0m3,595s
%% sys    0m0,286s

%% arrow-slur-03.ly
%% real    0m3,540s
%% user    0m3,323s
%% sys    0m0,216s

%% arrow-slur-03-patch.ly
%% real    0m4,191s
%% user    0m3,776s
%% sys    0m0,414s

---

From: Jean Abou Samra <[email-masked]>
Date: Fri, 11 Aug 2023 18:39:46 +0200

Bonjour Gilles,

> Bonnes vacances à tous...

Tu veux dire, pour ceux qui en ont :-)

```
\version "2.25.7"

%% Thanks to Aaron Hill

#(define* 

                  `((font-encoding . fetaMusic)
                     (font-size . ,fs-from-staff-space))
                  (ly:grob-alist-chain curve))))

pointing-curve =

revert-pointing-curve =

\layout {

% {

    \slurDown
    c4( c c c)

    \voiceOne
    c,,4( c c c'')

    <>^"default"

testI = {
  \relative c \m
  \relative c' \m
  \relative c'' \m
  \relative c''' \m
}

  <>^"Slur down, Stem up"
  \slurDown
  \stemUp
  \testI
  \break

  <>^"Slur up, Stem down"
  \slurUp
  \stemDown
  \testI
  \break

  <>^"Slur up, Stem up"
  \slurUp
  \stemUp
  \testI
  \break

  <>^"default"
  \stemNeutral
  \slurNeutral

    <c e g c>1~
    \break
    q
    <>^"default"

%% arrow-slur-05.ly
%% real    0m4,855s
%% user    0m4,376s
%% sys    0m0,456s

%% arrow-slur-04.ly
%% real    0m3,880s
%% user    0m3,595s
%% sys    0m0,286s

%% arrow-slur-03.ly
%% real    0m3,540s
%% user    0m3,323s
%% sys    0m0,216s

```

Cordialement,

Jean

---

From: Ya Gloops <[email-masked]>
Date: Fri, 11 Aug 2023 17:06:31 +0000 (UTC)

Effectivement tu as raison Jean " pour ceux qui en ont "
Comme d'habitude, absolument génial, ça marche super!!!
Merciiiiii Jean

Le vendredi 11 août 2023 à 18:39:50 UTC+2, Jean Abou Samra <[email-masked]> a écrit : 

Bonjour Gilles,

%% Thanks to Aaron Hill

#(define* 

pointing-curve =

revert-pointing-curve =

\layout {

% {

    \slurDown
    c4( c c c)

    \voiceOne
    c,,4( c c c'')

    <>^"default"

testI = {
  \relative c \m
  \relative c' \m
  \relative c'' \m
  \relative c''' \m
}

  <>^"Slur down, Stem up"
  \slurDown
  \stemUp
  \testI
  \break

  <>^"Slur up, Stem down"
  \slurUp
  \stemDown
  \testI
  \break

  <>^"Slur up, Stem up"
  \slurUp
  \stemUp
  \testI
  \break

  <>^"default"
  \stemNeutral
  \slurNeutral

    <c e g c>1~
    \break
    q
    <>^"default"

%% arrow-slur-05.ly
%% real    0m4,855s
%% user    0m4,376s
%% sys    0m0,456s

%% arrow-slur-04.ly
%% real    0m3,880s
%% user    0m3,595s
%% sys    0m0,286s

%% arrow-slur-03.ly
%% real    0m3,540s
%% user    0m3,323s
%% sys    0m0,216s

Cordialement,

Jean

---

From: Christian LE BARS <[email-masked]>
Date: Sun, 13 Aug 2023 08:43:30 +0200

bonjour Jean.

j'ai voulu incorporer dans ton code :

\version "2.24.1"
\include "lilyjazz.ily"

je n'ai pas obtenu la police jazz est-ce normal?

cordialement

christian

---

From: Jean Abou Samra <[email-masked]>
Date: Sun, 13 Aug 2023 13:17:02 +0200

> je n'ai pas obtenu la police jazz est-ce normal?

Il y a un

qui traîne vers la fin du code. En 2.24, cela réinitialise les polices, donc il
faut mettre le \include "lilyjazz.ily" après cette ligne, et pas avant. Je sais
que c'est énervant, et c'est pour ça qu'en 2.25, set-global-staff-size ne touche
plus aux polices.

Cordialement,
Jean

---

From: Christian LE BARS <[email-masked]>
Date: Mon, 14 Aug 2023 11:11:39 +0200

Bonjour jean.

Merci