%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% http://lsr.dsi.unimi.it/LSR/Snippet?id=639 :
% http://lists.gnu.org/archive/html/lilypond-user/2007-08/msg00539.html
% http://lists.gnu.org/archive/html/lilypond-user/2009-09/msg00495.html
% thanks, Neil and David!!

%%%%%%%%%%%%%%%%%%%%% Slur -----------------------------------------------------
%%{
#(define ((alter-curve offsets) grob)
   ;; get default control-points
   (let ((coords (ly:slur::calc-control-points grob)))
     ;; add offsets to default coordinates
     (define (add-offsets coords offsets)
       (if (null? coords)
       '()
       (cons
         (cons (+ (caar coords) (car offsets))
               (+ (cdar coords) (cadr offsets)))
         (add-offsets (cdr coords) (cddr offsets)))))

     (if (null? offsets)
         coords
         (add-offsets coords offsets))))


#(define ((shape-slur offsets) grob)
   (let* (
          ;; have we been split?
          (orig (ly:grob-original grob))
          ;; if yes, get the split pieces (our siblings)
          (siblings (if (ly:grob? orig)
                        (ly:spanner-broken-into orig) '() ))
          (total-found (length siblings)))
     (if (>= total-found 2)
         ;; shape BROKEN
         ;; walk through siblings, find index in list
         ;; and apply offsets from list of offsets:
         (let loop ((n 0))
                   (if (eq? (list-ref siblings n) grob)
                       ;; return altered:
                       ((alter-curve (list-ref offsets n)) grob)
                       (if (< n total-found)
                           (loop (1+ n))
                           ;; end of list -- none found?!
                           ;; return defaults:
                           ((alter-curve '()) grob))))
         ;;
         ;; shape UNBROKEN
         ((alter-curve offsets) grob))))

shapeSlur =
#(define-music-function (parser location offsets)
                        (list?)
  #{
    \once \override Slur #'control-points = #(shape-slur $offsets)
  #})
  

%%%%%%%%%%%%%%%%%%%%%%%%%%%% Tie -----------------------------------------------

#(define ((alter-Curve offsets) grob)
   ;; get default control-points
   (let ((coords (ly:tie::calc-control-points grob)))
     ;; add offsets to default coordinates
     (define (add-offsets coords offsets)
       (if (null? coords)
       '()
       (cons
         (cons (+ (caar coords) (car offsets))
               (+ (cdar coords) (cadr offsets)))
         (add-offsets (cdr coords) (cddr offsets)))))

     (if (null? offsets)
         coords
         (add-offsets coords offsets))))


#(define ((shape-tie offsets) grob)
   (let* (
          ;; have we been split?
          (orig (ly:grob-original grob))
          ;; if yes, get the split pieces (our siblings)
          (siblings (if (ly:grob? orig)
                        (ly:spanner-broken-into orig) '() ))
          (total-found (length siblings)))
     (if (>= total-found 2)
         ;; shape BROKEN
         ;; walk through siblings, find index in list
         ;; and apply offsets from list of offsets:
         (let loop ((n 0))
                   (if (eq? (list-ref siblings n) grob)
                       ;; return altered:
                       ((alter-Curve (list-ref offsets n)) grob)
                       (if (< n total-found)
                           (loop (1+ n))
                           ;; end of list -- none found?!
                           ;; return defaults:
                           ((alter-Curve '()) grob))))
         ;;
         ;; shape UNBROKEN
         ((alter-Curve offsets) grob))))

shapeTie =
#(define-music-function (parser location offsets)
                        (list?)
  #{
    \once \override Tie #'control-points = #(shape-tie $offsets)
  #})
  

%%%%%%%%%%%%%%%%%%%%%%% PhrasingSlur -------------------------------------------
       
shapePhrasingSlur =
#(define-music-function (parser location offsets)
                        (list?)
  #{
    \once \override PhrasingSlur #'control-points = #(shape-slur $offsets)
  #})
  
%%%%%%%%%%%%%%%%%%%%%%% RepeatTie and LaissezVibrerTie -------------------------
  
#(define ((alter-semi-curve offsets) grob)
   ;; get default control-points
   (let ((coords (ly:semi-tie::calc-control-points grob)))
     ;; add offsets to default coordinates
     (define (add-offsets coords offsets)
       (if (null? coords)
       '()
       (cons
         (cons (+ (caar coords) (car offsets))
               (+ (cdar coords) (cadr offsets)))
         (add-offsets (cdr coords) (cddr offsets)))))

     (if (null? offsets)
         coords
         (add-offsets coords offsets))))
  
shapeLaissezVibrerTie = 
#(define-music-function (parser location offsets)
                        (list?)
  #{
          \once\override LaissezVibrerTie #'control-points = #(alter-semi-curve $offsets) 
  #})
  
shapeRepeatTie = 
#(define-music-function (parser location offsets)
                        (list?)
  #{
          \once\override RepeatTie #'control-points = #(alter-semi-curve $offsets) 
  #})

%------------------- Test: Slurs -----------------------------------------------
%{
\version "2.13.28"
  
\relative c'' {              
        \set Staff.instrumentName = "Slurs"
  \once \override Slur #'color = #green
  \shapeSlur #'(
    ;; make them funny enough:
    (0 0  1 3  0 4  0 0)
    ;; shorten a bit:
    (2 0  2 0  0 1  0 0))
  c4( b \stemUp <d d'> \stemNeutral c
  \break
  a4 d c b)
  \break
  \once \override Slur #'color = #blue
  \shapeSlur #'(
    (0 0  1 3  0 4  0 0)
    (0 -7  -1 -9  0 -9  0 -4)
    ;; do not touch:
    ()
    (2 0  2 0  0 1  0 0))
  c4( b \stemUp <d d'> \stemNeutral c
  \break
  a4 d c b
  \break
  a4 d c b
  \break
  a4 d c b)
  \break
  % shape unbroken:
  \shapeSlur #'(0 -3  1 1  1 2  0 -3)
  c4( b \stemUp <d d'> \stemNeutral c)
}

\paper {
  indent = 20
  ragged-right = ##t
}

\header {
  tagline = ""
}

%-------------------- Test: Tie ------------------------------------------------

\version "2.13.28"
  
\relative c'' {
        \set Staff.instrumentName = "Ties"
  \once \override Tie #'color = #red
  \shapeTie #'(
    ;; make them funny enough:
    (0 0  0 5  0 7  0 0)
    ;; shorten a bit:
    (2 0  2 0  0 1  0 0))
  c1 ~ \break
  c
}

%-------------------------- Test: PhrasingSlur ---------------------------------
  
  \relative c'' {
          \set Staff.instrumentName = "PhrasingSlurs "
  \once \override PhrasingSlur #'color = #green
  \shapePhrasingSlur #'(
    ;; make them funny enough:
    (0 0  1 3  0 4  0 0)
    ;; shorten a bit:
    (0 0  2 0  0 1  0 0))
  c4\( b \stemUp <d d'> \stemNeutral c 
  \break
  a4 d c b\)
  \break
  \once \override PhrasingSlur #'color = #blue
  \shapePhrasingSlur #'(
    (0 0  1 3  0 4  0 0)
    (0 -7  -1 -9  0 -9  0 -4)
    ;; do not touch:
    ()
    (0 0  2 0  0 1  0 0))
  c4\( b \stemUp <d d'> \stemNeutral c 
  \break
  a4 d c b
  \break
  a4 d c b
  \break
  a4 d c b\)
  \break
  % shape unbroken:
  \shapePhrasingSlur #'(0 -3  1 1  1 2  0 -3)
  c4\( b \stemUp <d d'> \stemNeutral c\)
}

%}