%\version "2.14.2"
\version "2.15.13"

\pointAndClickOff

#(set-global-staff-size 18)
\paper { tagline = ##f }

\markup \column { \bold \fill-line { "EXAMPLES" } \vspace #2 }

xy = \once\override Stem #'french-beaming = ##t

#(define ((stem-length y) grob)
   (ly:grob-set-property! grob 'length y)
   (ly:stem::print grob))

xyOut =
#(define-music-function (parser location y-length)(number?)
#{
        \once \override  Stem #'stencil = #(stem-length $y-length)
#})

#(define ((grow-beam-var number) grob)
 (cond
   ((< (length (cdr (ly:grob-property (ly:grob-parent grob X) 'beaming))) 2)
    (ly:beam::print grob))
   ((= number 0)
    (begin
      (ly:grob-set-property! grob 'grow-direction LEFT)
      (ly:beam::print grob)))
   ((>= number (1- (ly:grob-array-length (ly:grob-object grob 'stems))))
    (begin
     (ly:grob-set-property! grob 'grow-direction RIGHT)
     (ly:beam::print grob)))

   ((ly:stencil? (ly:beam::print grob)) ;; delete this?
     ;; Thanks to David Nalesnik
    (let* ((beam (ly:beam::print grob))
           (dir (ly:beam::calc-direction grob))
           (b-d (ly:output-def-lookup (ly:grob-layout grob) 'blot-diameter))
           (beam-extent-X (ly:stencil-extent beam X))
           (beam-length-x-orig (interval-length beam-extent-X))
           (beam-length-x (- beam-length-x-orig b-d))
           (beam-extent-Y (ly:stencil-extent beam Y))
           (beam-length-y (interval-length beam-extent-Y))
           (orig-beam-thickness (ly:grob-property grob 'beam-thickness))
           (beam-count (length (cdr (ly:grob-property (ly:grob-parent grob X) 'beaming))))  ;; the number of beams
           (space-between-beams (* 0.46 (ly:grob-property grob 'gap)))                      ;; the space between the beams
           (orig-beam-length-at-stem (+ (* beam-count orig-beam-thickness)(* (- beam-count 1) space-between-beams)))
           (beam-positions (ly:grob-property grob 'positions))

           (beam-slant (cond ((<= (car beam-positions) (cdr beam-positions)) 1)
                             ;;((= (car beam-positions) (cdr beam-positions)) 0)
                             ((> (car beam-positions) (cdr beam-positions)) -1)))
           (orig-slope (* beam-slant (/ (- beam-length-y orig-beam-length-at-stem) beam-length-x)))
           (alpha (atan orig-slope))
           (beam-thickness (* 0.8 orig-beam-thickness))
           (h-max (- (/ orig-beam-length-at-stem (cos alpha)) (* 1.3 beam-thickness)))
;;;;;
           (dir-peak (if (and (ly:grob-property grob 'knee) (< number 0) (= (car beam-positions) (cdr beam-positions)))
	       -1
	       1))
           (number-a (if (integer? (abs number))
                   (abs number)
                   (inexact->exact (floor (abs number)))))
           (number-b (- (abs number) (floor (abs number))))
           (stems (ly:grob-object grob 'stems))
           (stem-count (ly:grob-array-length stems))
           (refp (ly:grob-system grob))
           (first-stem (ly:grob-array-ref stems 0))
           (target-stem (if (< (abs number-a) stem-count)
                   (ly:grob-array-ref stems number-a)
                   (ly:grob-array-ref stems (- stem-count 1 ))))
           (next-stem (if (< (+ (abs number-a) 1) stem-count)
                   (ly:grob-array-ref stems (+ number-a 1))
                   (ly:grob-array-ref stems (- stem-count 1 ))))
           (first-stem-coord (ly:grob-relative-coordinate first-stem refp X))
           (target-stem-coord (ly:grob-relative-coordinate target-stem refp X))
           (next-stem-coord (ly:grob-relative-coordinate next-stem refp X))
           (first-stem-to-target-stem-length (interval-length (cons first-stem-coord target-stem-coord)))
           (stem-to-next-stem-length (interval-length (cons target-stem-coord next-stem-coord)))
           (factor (if (eq? first-stem target-stem);(= first-stem-to-target-stem-length 0)
                 beam-length-x
                 (/ beam-length-x first-stem-to-target-stem-length)))

;; markup-a is the longest beam

           (markup-a (markup #:beam beam-length-x
                                    orig-slope
                                    beam-thickness))

  ;; left piece
     ;; y-length of left piece
           (y-L
             (lambda (n)
               (- (/ (- beam-length-y orig-beam-length-at-stem) factor) (* dir beam-slant (* n (/ h-max (- beam-count 1)))))
               ))
     ;; x-length of left piece
           (x-L (if (= number 0);(= first-stem-to-target-stem-length 0)
                     0.001
                    (+ first-stem-to-target-stem-length (* number-b stem-to-next-stem-length))))
     ;; slope of left piece
           (slope-part-beam-L
             (lambda (n)
               (cond ((or (and (> dir 0) (> beam-slant 0)) (and (< dir 0) (> beam-slant 0)))
                      (* dir-peak (/ (y-L n) x-L)))
                     ((or (and (> dir 0) (< beam-slant 0)) (and (< dir 0) (< beam-slant 0)))
                      (* -1 (/ (y-L n) x-L))))))
     ;; construct left piece
           (part-beam-L
             (lambda (n)
                 (markup #:beam x-L
                                (slope-part-beam-L n)
                                beam-thickness)))
     ;; markup of left piece
           (markup-L (lambda (n) (markup (part-beam-L n))))
     ;; stencil of left piece
           (beam-part-L (lambda (n) (grob-interpret-markup grob (markup-L n))))
     ;; y-extent of left piece
           (beam-part-L-ext-y (lambda (n) (ly:stencil-extent (beam-part-L n) Y)))
     ;; length of left piece
           (length-beam-part-L-y (lambda (n) (interval-length (beam-part-L-ext-y n))))

  ;; right piece
           (y-R (lambda (n) (- (- beam-length-y orig-beam-length-at-stem) (y-L n))))
           (x-R (- beam-length-x x-L))
           (slope-part-beam-R
             (lambda (n)
               (cond
               ((or (and (> dir 0) (> beam-slant 0)) (and (< dir 0) (> beam-slant 0)))
                      (* dir-peak (/ (y-R n) x-R)))
                     ((or (and (> dir 0) (< beam-slant 0)) (and (< dir 0) (< beam-slant 0)))
                      (* -1  (/ (y-R n) x-R))))))
           (part-beam-R
             (lambda (n)
               (markup #:beam (- beam-length-x x-L)
                              (slope-part-beam-R n)
                              beam-thickness)))
           (markup-R (lambda (n) (markup (part-beam-R n))))

   ;; parts of feathered beams
           (beam-pieces
             (map
               (lambda (n)
                 (ly:stencil-combine-at-edge
                   (ly:stencil-translate-axis
                     (grob-interpret-markup grob (markup-L n))
                     -0.025 X)
                   X RIGHT
                   (ly:stencil-translate-axis
                     (grob-interpret-markup grob (markup-R n))
                     (cond ((and (> dir 0)(> beam-slant 0))
                            (if (and (>= (slope-part-beam-L n) 0)(>= (slope-part-beam-R n) 0))
                                (- (length-beam-part-L-y n) beam-thickness)
                                (* -1 (- (length-beam-part-L-y n) beam-thickness))))
                           ((and (> dir 0)(< beam-slant 0))
                            (* -1 (- (length-beam-part-L-y n) beam-thickness)))

                           ((and (< dir 0)(> beam-slant 0))
                            (* dir-peak (- (length-beam-part-L-y n) beam-thickness)))
                           ((and (< dir 0)(< beam-slant 0))
                            (if (and (<= (slope-part-beam-L n) 0)(<= (slope-part-beam-R n) 0))
                                (* -1 (- (length-beam-part-L-y n) beam-thickness))
                                (- (length-beam-part-L-y n) beam-thickness)))
                                  )
                     Y)
                   0))
               (cdr (iota beam-count))))

                       )   ;; end of defs in let*

      (define (helper beam-pieces)
        (ly:stencil-add
          (car beam-pieces)
          (if (null? (cdr beam-pieces))
              (car beam-pieces)
              (helper (cdr beam-pieces)))))

      (ly:stencil-translate-axis
       (ly:stencil-add
         ;; first (long beam)
         (ly:stencil-translate-axis
           (grob-interpret-markup grob markup-a)
             -0.025 X)
           ;; other beams
           (helper beam-pieces))
       (car beam-positions)
       Y)
     ) ;; end of let*
    )
  )
)

%--------------------- Test ----------------------------------------------------

\relative c' {
        \once \override Beam #'positions = #'(0.2 . 0.2)
        \override Beam #'auto-knee-gap = #4
        \override Beam #'stencil = #(grow-beam-var -16)
        c''32 [b a g
        f g a b
        c b a g
        f g a b
        \xy e,,, c''' b a
        g a b c
        d c b a
        g a b c]
\bar "" \break
        \override Beam #'stencil = #(grow-beam-var 16)
        c32 [b a g
        f g a b
        c b a g
        f g a b
        e,,, c''' b a
        g a b c
        d c b a
        g a b c]
}

% This works
\relative c {
  \once \override Beam #'stencil = #(grow-beam-var 5)
  f32 [ \xy f''' f,,, \xy f''' f,,, \xy f''' f,,, \xy f''' f,,,
  \xyOut #11
  f''']
}

% This not. Issue in \change Staff ?

top = \change Staff = "1"
bottom = \change Staff = "2"

music = \relative c {
  \override Beam #'auto-knee-gap = #0
  \override Beam #'stencil = #(grow-beam-var 1)
    \bottom cis32[ 
    f 
    %\xyOut #0
    \once \override  Stem #'stencil = #(lambda (grob) (ly:grob-set-property! grob 'length 0)
    (ly:stem::print grob))  
    \top f'']
}

\score {
  \new PianoStaff <<
    \new Staff = "1" {
      s16.
    }
    \new Staff = "2" {
      \clef bass
      \music
    }
  >>
}