\version "2.19.82"

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

  
#(ly:load "bezier-tools.scm")

#(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 c-ps)
(lambda (grob)
"Returns a number-pair-list suitable for setting @code{control-points}-property.
The given values, @var{c-ps}, 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)))
    ;; 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}.
Text may be added to the curve, controlled by the @code{attach} subproperty of
@code{details}."
  (let* ((default-cps (ly:grob-property grob 'control-points))
         (control-points ((modify-control-points-for-arrows default-cps) 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))
         (attach (assoc-get 'attach 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))
         (raw-stil
           (if (and (not arrow-left) (not arrow-right))
               (ly:slur::print grob)
               (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:stencil-add
                   (ly:stencil-translate arrow-left-stil frst)
                   (ly:stencil-translate arrow-right-stil frth)
                   stil)))))
    (if attach
        (let* ((dir (ly:grob-property grob 'direction UP))
               (slur-text-distance (assoc-get 'slur-text-distance details 0))
               (slur-thick (ly:grob-property grob 'thickness))
               (slur-line-thick (ly:grob-property grob 'line-thickness))
               (line-thick (ly:staff-symbol-line-thickness grob))
               (start-x (caar control-points))
               (end-x (car (last control-points)))
               (text-stil 
                 (grob-interpret-markup grob 
                   (make-fontsize-markup
                     (1- (- (ly:grob-property grob 'fontsize 0)))
                     attach)))
               (text-stil-Y-ext (ly:stencil-extent text-stil Y))
               (move-Y-text-stil
                 (if (positive? dir)
                     (* -1 (car text-stil-Y-ext))
                     (* -1 (cdr text-stil-Y-ext))))
               (half-way-pt
                 (bezier::point control-points 
                   (/ (/ (- end-x start-x) 2)
                      (- end-x start-x)))))
           (ly:stencil-add
             raw-stil
             (ly:stencil-translate
               (ly:stencil-aligned-to text-stil X CENTER)
               (cons 
                 (car half-way-pt) 
                 (+ (cdr half-way-pt) 
                    move-Y-text-stil 
                    (* dir (+ slur-thick slur-line-thick) line-thick)
                    (* dir slur-text-distance))))))
        raw-stil))))
               
#(define outside-staff-curve
;; prints the curve outside the staff
;; TODO whole coding is a little half-baked, revise it!
  (lambda (grob)
    (let* ((details (ly:grob-property grob 'details))
           (outside-staff? (assoc-get 'outside-staff details #f))
           (function 
             (assoc-get 
               'control-points
               (reverse (ly:grob-basic-properties grob))))
           (c-ps (function grob)))

      (if outside-staff?
          (let* ((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))
                            (ly:stencil? 
                              (ly:grob-property left-bound-stem 'stencil)) 
                            (ly:stencil? 
                              (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 creatw 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)
          c-ps))))

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.
If @code{details.attach} is set, the text appears centered above/below the 
@var{curve}.  The distance is adjustable by @code{details.slur-text-distance}.
In this case  @code{\\override Slur.vertical-skylines = 
#grob::unpure-vertical-skylines-from-stencil} should be used.
If @code{details.outside-staff} is set the curve appears outside staff as a more
or less flat curve.
"
  #{
    \override $curve . control-points = #outside-staff-curve
    \temporary \override $curve . stencil = #add-arrow-head-to-curve
  #})
  
arrowed-slur = \pointing-curve Slur

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 Slur.details.slur-text-distance = 0
  %% needed if text is attached to Slur, although expensive
  \override Slur.vertical-skylines = 
    #grob::unpure-vertical-skylines-from-stencil
  \override Slur.details.outside-staff = ##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)))


%%%%%%%%%%%%%%%%%%%%%%
%% EXAMPLES
%%%%%%%%%%%%%%%%%%%%%%
%{
\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)