\version "2.18.0"

% #(use-modules (ice-9 pretty-print))
% #(use-modules (srfi srfi-1))

#(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 (parser location 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 (string->symbol curve)
                          '(Ties RepeatTies LaissezVibrerTies))))
         #{ 
           \override $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
}

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

\relative c'' {
	\arrowed-slur-outside-staff
	c'( c \bar "" \break  c c)
	
	\slurDown
	c( c c c)
	
	<>^\markup \with-color #red "How should it look?"
	\stemUp
	\slurUp
	c,,4( c c c'')
	
	<>^"default"
	\neutral-slur
	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 { \arrowed-slur-outside-staff instrumentName = "Slurs" } 
{ 
  <>^"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
  \neutral-slur
  \testI
  \break
}

\new Staff \with { instrumentName = "Ties" }
\relative c' {
	\arrowed-tie
	<c e g c>1~ q
	<>^"default"
	
	\neutral-tie
	<c e g c>1~ q
}

\new Staff \with { instrumentName = "PhrasingSlur" }
\relative c' {
	<>^\markup \with-color #red"How should it look?"
	\arrowed-phrasing-slur-outside-staff
	<c e g c>1^\( q q <g d' g b g'>\)
	<>^"default"
	\neutral-phrasing-slur
	<c e g c>1^\( q q <g d' g b g'>\)
}

\new Staff \with { instrumentName = "RepeatTie" }
\relative c' {
	<>_\markup \fontsize #-2 \with-color #red \column { 
		"TODO: Better output" "for RepeatTie"
	}
	\arrowed-repeat-tie
	c2\repeatTie
	<>^"default"
	\neutral-repeat-tie
	c2\repeatTie
}

\new Staff \with { instrumentName = "LaissezVibrerTie" }
\relative c' {
	\arrowed-laissez-vibrer-tie
	c1\laissezVibrer
	<>^"default"
	\neutral-laissez-vibrer-tie
	c1\laissezVibrer
}

\paper { indent = 30 }

#(set-global-staff-size 19)