\version "2.14.2"

\pointAndClickOff

#(set-global-staff-size 18)

\paper { tagline = ##f }

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

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

% xyOut needs "2.15.13"

#(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)
     ;; Thanks to David Nalesnik
 (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?
    (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))))  
           (space-between-beams (* 0.46 (ly:grob-property grob 'gap)))                      
           (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 (/ beam-length-x first-stem-to-target-stem-length))

;; markup-a is the longest beam

           (markup-a (markup #:beam beam-length-x
           		    (if (and (ly:grob-property grob 'knee) (< number 0)(= (car beam-positions) (cdr beam-positions)))
                                        (* dir-peak orig-slope)
                                        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 (+ 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)))
                      (if (and (ly:grob-property grob 'knee) (< number 0))
                          (* dir-peak (/ (y-L n) x-L))
                          (/ (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 0.86
           (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)))
                      (if (and (ly:grob-property grob 'knee) (< number 0))
                        (* dir-peak (/ (y-R n) x-R))
                        (/ (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*
    )
  )
)


#(define (moment=? a b)
   (not (or (ly:moment<? a b) (ly:moment<? b a))))

#(define (moment>? a b)
   (not (or (ly:moment<? a b) (moment=? a b))))
   
featherDurationsTest=
#(define-music-function (parser location factor turnaround-orig argument)
                                         (ly:moment? number? ly:music?)
   (let* ((orig-duration (ly:music-length argument))
          (multiplier (ly:make-moment 1 1))
          (turnaround (if (and (integer? turnaround-orig) (>= turnaround-orig 0))
          		turnaround-orig
          		(inexact->exact (floor (abs turnaround-orig)))))
          (elements (ly:music-property argument 'elements))
          (dif (- (length elements) turnaround))
          (lth (cond ((>= dif 0) dif)
                     (else (length elements))))
          (peak-multiplier
            (reduce
              (lambda (mom prev) (ly:moment-mul mom prev))
              multiplier
              (make-list turnaround factor)))
          (end-multiplier
            (reduce
              (lambda (mom prev) (ly:moment-mul mom prev))
              peak-multiplier
              (append
                (list peak-multiplier)
                (make-list lth ;;(- (length elements) turnaround)
                           (ly:moment-div (ly:make-moment 1 1) factor)))))
          (comparison
            (if (< (ly:moment-main-numerator factor) (ly:moment-main-denominator factor))
                (lambda (a b) (ly:moment<? a b))
                (lambda (a b) (moment>? a b)))))
     (music-map
       (lambda (mus)
         (if (and (eq? (ly:music-property mus 'name) 'EventChord)
                  (< 0 (ly:moment-main-denominator (ly:music-length mus))))
             (begin
               (display multiplier) (newline) ; shows pattern of modification
               (ly:music-compress mus multiplier)
               (if (comparison peak-multiplier multiplier)
                   (set! multiplier (ly:moment-mul factor multiplier))
                   (begin
                     (set! multiplier (ly:moment-div multiplier factor))
                     (set! peak-multiplier end-multiplier)))))
        mus)
      argument)

     (ly:music-compress
       argument
       (ly:moment-div orig-duration (ly:music-length argument)))

     argument))
 
\score {
  \relative c'' {
          \once \override Beam #'stencil = #(grow-beam-var 7.5)
          \featherDurationsTest #(ly:make-moment 1 4) #7.5
          { c,32[ d e f g a b c c, d e f g a b c ] } c2
           \break
           \featherDurationsTest #(ly:make-moment 1 4) #8
           { c32[ c c c c c c c c c c c c c c c] } c2
          % \break         
          % \featherDurationsTest #(ly:make-moment 4 1) #8
          % { c32[ c c c c c c c c c c c c c c c c] } c2
  }
}