%%%%%%%%%%%%%%%%%%%%%%%%
\version "2.19.47"
\language "deutsch"

%%%%%%%%%%%%%%%%%%%%%%%
% Display Configuration

#(define col-bg (rgb-color .9 .9 .8))
#(define col-orig-slur cyan)
#(define col-new-slur red)
#(define conn-thickness 0.05)
#(define cross-thickness 0.1)
#(define cross-size 0.2)

%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Geometry helper functions

#(define (mirror-point pt1 pt2)
   "Mirror pt2 against pt1"
   (cons
    (- (* 2 (car pt1)) (car pt2))
    (- (* 2 (cdr pt1)) (cdr pt2))))

#(define (add-points pt1 pt2)
   "Add two points"
   (cons (+ (car pt1) (car pt2))
     (+ (cdr pt1) (cdr pt2))))

#(define (sloped-point slope dist)
   "Create a point with given slope and distance"
   (let 
    ; TODO: Is this too confused, can it be done inline?
    ((factor (* dist (/ 1 (distance '(0 . 0) slope )))))
   (cons
     (* (cdr slope) factor)
     (* (car slope) factor))))

#(define (inflection-point pt1 pt2 ratio)
   "Find a point between two points, giving the X and Y ratio independently"
   (let*
    ((xratio (car ratio))
     (yratio (cdr ratio)))
    (cons
     (+ (* (- 1 xratio) (car pt1)) (* xratio (car pt2)))
     (+ (* (- 1 yratio) (cdr pt1)) (* yratio (cdr pt2))))))

#(define (distance pt1 pt2)
   "Caculate distance between two points"
   (let
    ((square (lambda (x) (* x x))))
    (sqrt
     (+
      (square (- (car pt1) (car pt2)))
      (square (- (cdr pt1) (cdr pt2)))))))

#(define (line-slope pt1 pt2)
   "Determine the slope of a line connecting two points"
   (/ (- (cdr pt2) (cdr pt1)) (- (car pt2) (car pt1))))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Control point visualization

#(define (make-cross-stencil coord col)
   "Draw a cross-stencil at coord."
   (stencil-with-color
    (ly:stencil-add
     (make-line-stencil
      cross-thickness
      (- (car coord) cross-size)
      (- (cdr coord) cross-size)
      (+ (car coord) cross-size)
      (+ (cdr coord) cross-size))
     (make-line-stencil
      cross-thickness
      (- (car coord) cross-size)
      (+ (cdr coord) cross-size)
      (+ (car coord) cross-size)
      (- (cdr coord) cross-size)))
    col))

#(define (connect-dots pt1 pt2 col)
   "Draw a thin line connecting two points"
   (stencil-with-color
    (ly:stencil-add
     (make-line-stencil
      conn-thickness
      (car pt1)
      (cdr pt1)
      (car pt2)
      (cdr pt2)))
    col))


#(define (default-option opts name value)
   "Retrieve an option value or a default"
   (let ((prop (assq name opts)))
     (if prop (cdr prop) value)))

compoundSlur =
#(define-event-function (options)(ly:context-mod?)
   ; TODO: Change inner-segment to
   ; - a ratio (to the length of the line between cp1 and cp4)
   ; - an angle (relative to the same line cp1--cp2)
   (let
    ((proc
      (lambda (grob)
        (let*
         ((opts 
           (map 
            (lambda (o)
              (cons (second o) (third o))) 
            (ly:get-context-mods options)))
          ;; Retrieve options and set defaults
          (offsets
           (default-option opts 'offsets '((0 . 0)(0 . 0)(0 . 0)(0 . 0))))
          (inflection-ratio
           (default-option opts 'inflection-ratio '(.5 . .5)))
          (inflection-slope
           (default-option opts 'inflection-slope '(1 . 1)))
          (ann?
           (default-option opts 'ann #f))
          
          (inflection-ratio-left
           (default-option opts 'inflection-ratio-left #f))
          (inflection-ratio-right
           (default-option opts 'inflection-ratio-right #f))
          ; TODO:
          (inner-segment (assq-ref opts 'inner-segment))
          
          ;; automatic control points of the non-compound slur
          (cps (ly:slur::calc-control-points grob))
          
          ;; add offsets to the four control points
          (cp1 (add-points (first cps) (first offsets)))
          (cp2 (add-points (second cps) (second offsets)))
          (cp6 (add-points (third cps) (third offsets)))
          (cp7 (add-points (fourth cps) (fourth offsets)))

          ;; calculate inflection point and surrounding control points
          (cp4 (inflection-point cp1 cp7 inflection-ratio))
          ;; left hand side length of the inflection
          ;; (if given it is the ratio to the left "baseline"
          ;; otherwise it is the same length as the leftmost control point distance)
          (cp3 (add-points cp4 
                 (sloped-point 
                  inflection-slope 
                  (if inflection-ratio-left
                      (* -1 inflection-ratio-left (distance cp1 cp4))
                      (* -1 (distance cp1 cp2))))))
          ;; right hand side length of the inflection
          (cp5 (add-points cp4 
                 (sloped-point 
                  inflection-slope 
                  (if inflection-ratio-right
                      (* inflection-ratio-right (distance cp4 cp7))
                      (distance cp7 cp6)))))

          (first-spline-stil
           (begin
            (ly:grob-set-property! grob 'control-points (list cp1 cp2 cp3 cp4))
            (ly:slur::print grob)))
          (second-spline-stil
           (begin
            (ly:grob-set-property! grob 'control-points (list cp4 cp5 cp6 cp7))
            (ly:slur::print grob)))
          ;; display original slur and its control points
          (original-slur
           (if ann?
               (apply
                ly:stencil-add
                ;; display control points of the original, non-compound slur
                (append
                 ;; display original slur
                 (list
                  (stencil-with-color
                   (begin
                    (ly:grob-set-property! grob 'control-points cps)
                    (ly:grob-set-property! grob 'layer -1)
                    (ly:slur::print grob))
                   col-bg))
                 (map
                  (lambda (c)
                    (make-cross-stencil c col-orig-slur))
                  cps)
                 ))
               empty-stencil))
          ;; display new control-points and connections
          (crosses
           (if ann?
               (apply
                ly:stencil-add
                (append
                 ;; display actual control points of the compound slur
                 (map
                  (lambda (c)
                    (make-cross-stencil c col-new-slur))
                  (list cp1 cp2 cp3 cp4 cp5 cp6 cp7))
                 ;; display connections between original and offset control points
                 (map
                  (lambda (c1 c2)
                    (connect-dots c1 c2 col-orig-slur))
                  cps
                  (list cp1 cp2 cp6 cp7))
                 ;; display obsolete handles of the original slur
                 (map
                  (lambda (c1 c2)
                    (connect-dots c1 c2 col-bg))
                  (list (first cps) (fourth cps))
                  (list (second cps) (third cps)))
                 ;; display handles indicating the
                 (map
                  (lambda (c1 c2)
                    (connect-dots c1 c2 col-new-slur))
                  (list cp1 cp3 cp4 cp7)
                  (list cp2 cp4 cp5 cp6))
                 ))
               empty-stencil))
          )

         (ly:stencil-add
          original-slur
          first-spline-stil
          second-spline-stil
          crosses
          )))))
    #{ -\tweak stencil $proc ( #}))


upper = \relative {
  \once \override Score.MetronomeMark.Y-offset = 8
  \once \override Score.MetronomeMark.color = #white
  \tempo "X"
  \key d \major
  \clef bass
  s2 r8 d,16 g h d g h
  d8 r s2.
  s4 \voiceTwo h8.(-- c16-- h2--)
}
lower = \relative {
  \key d \major
  \clef bass
  r2
  <d' h g=>~-^
  % Uncomment one out of the following lines to compare the
  % default slur with the compound one
  %(
  %%{
  -\compoundSlur \with {
    offsets =       % offsets against the automatic control points
    % of the original, non-compound slur
    #'((0 . -1.5)   ; left starting point
        (-2 . -1)   ; second control point
        (2 . -5)    ; second-to-last control point
        (0 . 0))    % right end point

    inflection-slope = 5/3
    inflection-ratio-right = 0.5
    inflection-ratio-left = 0.25
    
    inflection-ratio =
    #'(0.6 . 0.65)  % X/Y ratio of the inflection point
    % calculated between the actual end points of the slur

    % TODO: change to ratio and angle props (then create defaults)
    inner-segment =
    #'(4 . 6)       % X/Y of the (so far symmetric) line around the
    % inflection point
    ann = ##t 	    % Display control points
  }
  %}
  <<
    {
      <d h g>4
      % Uncomment one of the following lines to see the robustness of the slur
      <c g e>4 \(
      %      <c g e>16 q q q
      <h g>4 \voiceOne cis \)
      \change Staff = upper
      \clef treble \voiceOne d e fis2 )
      \fermata
    }
    \new Voice {
      \voiceTwo
      s2. <g,= e>4 \oneVoice
      <fis h,> <g e> <fis dis>2\fermata
    }
  >>
}
\score {
  <<
    \new PianoStaff <<
      \new Staff = upper \upper
      \new Staff = lower \lower
    >>
  >>
}
%%%%%%%%%%%%%%%%%%%%%%%