\version "2.19.82"

%% 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 replacement possible, only used in
%%     the examples, though)

#(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-curve 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-curve (drop-right control-points 1) t))
          (q1 (bezier-curve (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-curve (drop-right control-points 1) t))
        (q1 (bezier-curve (drop control-points 1) t)))
    (ly:angle (- (car q1) (car q0)) (- (cdr q1) (cdr q0)))))

#(define (bezier-approx-length control-points from to)
"Given a Bezier curve of arbitrary degree specified by @var{control-points},
compute its approximate arc length between the positions @var{from} and @var{to}."
  (let* ((steps 11) ;; Should be accurate enough for reasonable execution time.
         (params (iota steps from (/ (- to from) (1- steps))))
         (points (map (lambda (x) (bezier-curve control-points x)) params))
         (length (fold (lambda (a b prev) (+ prev (ly:length
                   (- (car a) (car b)) (- (cdr a) (cdr b)))))
           0 (drop points 1) (drop-right points 1))))
    ; Need to support negative length when the range is inverted.
    (if (< from to) length (- length))))

#(define (bezier-approx-position control-points length)
"Given a Bezier curve of arbitrary degree specified by @var{control-points},
compute the approximate position that is @var{length} distance along the curve."
  (define (helper control-points target-length precision end)
    (let ((actual-length (bezier-approx-length control-points 0 end)))
      (if (> precision (abs (- actual-length target-length))) end
        (helper control-points target-length precision
          (* end (/ target-length actual-length))))))
  (helper control-points length 0.01 0.5))

#(define (curve-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* ((grob-font
               (ly:paper-get-font
                 (ly:grob-layout curve)
                 '(((font-encoding . fetaMusic) (font-size . -1)))))
             (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)))
             (bezier-length (bezier-approx-length control-points 0 1))
             (bezier-end (if (positive? dir) bezier-length 0))
             (offset (+ bezier-end (* 0.33 arrowhead-end)))
             (pos (bezier-approx-position control-points offset))
             (angle (bezier-angle control-points pos)))
        (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)))
    (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* ((orig (if (ly:spanner? grob)
                   (ly:grob-original grob)
                   #f))
         (siblings (if (ly:grob? orig)
                       (ly:spanner-broken-into orig)
                       '()))
         (control-points (modify-control-points-for-arrows grob))
         (details (ly:grob-property grob 'details))
         (arrow-left (assoc-get 'arrow-left details #f))
         (arrow-right (assoc-get 'arrow-right details #f))
         (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))))
     (cond ((and (not arrow-left) (not arrow-right))
            stil)
           (#t
            ;; TODO
            ;; For now arrowheads are printed as specified even for each
            ;; broken curve, should possibilities to limit behaviour at
            ;; line-break be implemented?
            ;(or (null? siblings)
            ;    #t
            ;    (equal? grob (car (last-pair siblings))))
            (let* (;(control-points (modify-control-points-for-arrows grob))
                   (frst (car control-points))
                   (frth (cadddr control-points))

                   (arrow-right
                     ((curve-adjusted-arrow-head arrow-right control-points)
                       grob))
                   (arrow-left
                     ((curve-adjusted-arrow-head arrow-left control-points)
                       grob)))
              (ly:stencil-add
                (ly:stencil-translate arrow-left frst)
                (ly:stencil-translate arrow-right frth)
                stil)))))))

pointing-curve =
#(define-music-function (p l 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 = #LEFT
  \\override Slur.details.arrow-left = #LEFT
@end lilypond
separately."
  #{
    \temporary \override $curve . after-line-breaking =
      #(lambda (grob)
        (ly:grob-set-property! grob 'stencil (add-arrow-head-to-curve grob)))
  #})

revert-pointing-curve =
#(define-music-function (p l 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 = #LEFT
  \override Slur.details.arrow-left = #LEFT
  \override PhrasingSlur.details.arrow-left = #LEFT
  \override RepeatTie.details.arrow-left = #LEFT
  \override LaissezVibrerTie.details.arrow-left = #LEFT

  \override Tie.details.arrow-right = #RIGHT
  \override Slur.details.arrow-right = #RIGHT
  \override PhrasingSlur.details.arrow-right = #RIGHT
  \override RepeatTie.details.arrow-right = #RIGHT
  \override LaissezVibrerTie.details.arrow-right = #RIGHT
}

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

	\slurDown
	c( 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)

%}