\version "2.19.82"

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% Distribute Stem's NoteHeads and draw a new Stem connecting them all
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

#(define (distribute-stem-note-heads note-head-shifts)
  (lambda (grob)
  "Takes the note-heads from a stem.grob and applies offsets in X-direction
taken from @var{note-head-shifts}.  If accidentals are present they are moved
along with their corresponding note-head.
Preserves user-generated overrides/tweaks for @code{X-offset} of NoteColumn 
and/or Accidentals.
  "
    (let* ((nhds-array (ly:grob-object grob 'note-heads))
           (nhds-list
             (if (ly:grob-array? nhds-array)
                 (ly:grob-array->list nhds-array)
                 '()))
           ;; NoteColumn
           (nc (ly:grob-parent grob X))
           (nc-x-off (ly:grob-property nc 'X-offset 0))
           ;; AccidentalPlacement of the NoteColumn
           (acc-col (ly:note-column-accidentals nc))
           ;; Accidentals of each NoteHead
           (accidental-grobs 
             (map 
               (lambda (nhd) (ly:grob-object nhd 'accidental-grob)) 
               nhds-list)))
      ;; Move note-heads in X-direction, looking at 'note-head-shifts'
      (for-each
        (lambda (nhd nhd-shift y)
          (ly:grob-translate-axis! nhd 
          ;(* nhd-shift y) 
          nhd-shift
          X))
        nhds-list 
        note-head-shifts
        (iota (length nhds-list)))
        
      ;; If Accidentals present, move along with their NoteHeads
      (if (ly:grob? acc-col)
          (for-each
            (lambda (nhd-shift acc y)
              ;; AccidentalColumn may be present, although not every 
              ;; NoteHeadis altered, thus the need to check for Accidental 
              ;; as well
              (if (ly:grob? acc)
                  (let* ((acc-col-right-padding 
                           (ly:grob-property acc-col 'right-padding))
                         ;; Read and later apply acc's X-offset to offer the
                         ;; user a possibility to fine-tune appearance.
                         ;; Directly using (ly:grob-property acc 'X-offset)
                         ;; disturbs in this stage, thus we read 'X-offset from
                         ;; (ly:grob-properties acc).
                         (acc-X-off 
                           (assoc-get 'X-offset (ly:grob-properties acc) 0)))
                    (ly:grob-translate-axis! 
                      acc 
                      (- (+ nhd-shift nc-x-off acc-X-off)
                         ;; 1.2 is a little then then the width of crotchet
                         ;; other values don't look as good
                         ;; TODO make it a property of Stem?
                         1.2
                         acc-col-right-padding)
                      X))))
            note-head-shifts
            accidental-grobs 
            (iota (length nhds-list))))
      #t)))

#(define (splitted-stem-stencil stem-pos)
  (lambda (grob)
  "Returns a stem-stencil.
  There will be a vertical line, drawn from the end of the stem to a
  point where all other lines (drawn from note-heads to this point) will meet.
  @var{stem-pos}, a number, will determine where the vertical part happens.
  A value of zero usually means above the first note-head.  If set @code{#f}
  the default stem-stencil is taken.
  The length of the vertical part is customizable by an override for
  @code{Stem.details.splitted-stem-vertical-length} defaulting to '(1 0 2), with
  values for beamed-stem, flagged-stem, stem-only.
  Preserves user-generated overrides for @code{NoteColumn.X-offset}.
  "
    (let* ((default-stil (ly:stem::print grob))
           (nc (ly:grob-parent grob X))
           (rest? (ly:grob? (ly:grob-object nc 'rest))))

      (if (or rest? (not stem-pos) (< (ly:grob-property grob 'duration-log) 1))
          ;; use default for whole and longer notes, if stem-pos is set #f or
          ;; for rests
          default-stil
          (let* ((pc (ly:item-get-column grob))
                 (nc-x-off (ly:grob-property nc 'X-offset 0))
                 (dir (ly:grob-property grob 'direction))
                 (thick (* (ly:grob-property grob 'thickness)
                           (ly:staff-symbol-line-thickness grob)))
                 (staff-space (ly:staff-symbol-staff-space grob))
                 (half-space (* 0.5 staff-space))
                 (details (ly:grob-property grob 'details))
                 ;; How long should be the vertical part of the Stem?
                 ;; Look at Stem.details.splitted-stem-vertical-length which   
                 ;; should be a list containing three values for:
                 ;; beamed-stem, flagged-stem, stem-only
                 (splitted-stem-vertical-lengths 
                   (assoc-get 'splitted-stem-vertical-length details '(1 0 2)))
                 (stem-length-fraction
                   (ly:grob-property grob 'length-fraction 1))
                 (beam (ly:grob-object grob 'beam))
                 (beam-count
                   (if (ly:grob? beam)
                       (- (ly:grob-property grob 'duration-log) 2)
                       0))
                 (beam-thick
                   (if (ly:grob? beam)
                       (ly:grob-property beam 'beam-thickness)
                       0))
                 (flag (ly:grob-object grob 'flag))
                 (flag-y-ext 
                   (if (ly:grob? flag)
                       (ly:grob-extent flag flag Y)
                       '(+inf.0 . -inf.0)))
                 (flag-length
                   (if (interval-sane? flag-y-ext)
                       (interval-length flag-y-ext)
                       0))
                 (note-heads-array (ly:grob-object grob 'note-heads))
                 (note-heads-list 
                   (if (ly:grob-array? note-heads-array)
                       (ly:grob-array->list note-heads-array)
                       '()))
                 (note-heads-staff-pos 
                   (map 
                     (lambda (nhd) (ly:grob-property nhd 'staff-position)) 
                     note-heads-list))
                 (note-heads-stem-attachments
                   (map 
                     (lambda (nhd) (ly:grob-property nhd 'stem-attachment)) 
                     note-heads-list))
                 (stem-stil-y-ext 
                   ;;;; TODO
                   ;; Why not
                   ;; (ordered-cons
                   ;;   (/ (ly:stem::calc-stem-begin-position grob) 2)
                   ;;   (/ (ly:stem::calc-stem-end-position grob) 2))
                   ;;;; or: 
                   ;; (ly:grob-robust-relative-extent 
                   ;;   grob (ly:grob-common-refpoint grob pc Y) Y)
                   ;;;; ??
                   (ly:stencil-extent default-stil Y))
                 ;; Calculate the difference from default-stem-end-coordinate to 
                 ;; the various note-head's staff-positions.
                 ;; Applied later, while doing the various stem-lines
                 (y-corr-values
                   (map
                     (lambda (nhd-stem-attchment nhd-staff-pos)
                       (- 
                          (if (positive? dir)
                              (car stem-stil-y-ext) 
                              (cdr stem-stil-y-ext))
                          (+ (/ nhd-staff-pos 2) 
                             (* dir (cdr nhd-stem-attchment)))))
                     note-heads-stem-attachments
                     note-heads-staff-pos))
                 ;; first note-head X-coord
                 (x 
                   (- 
                      (ly:grob-relative-coordinate (car note-heads-list) pc X)
                      nc-x-off))
                 ;; Make sure the stem-melting point is above/below Flag/Beam
                 ;; Relying on details.splitted-stem-vertical-lengths, a list 
                 ;; with three entries
                 (length-vertical-stem 
                   (if (>= (length splitted-stem-vertical-lengths) 3)
                       (cond ((ly:grob? beam)
                              (+ (list-ref splitted-stem-vertical-lengths 0)
                                 (/ (+ (* 2 beam-thick) 
                                    (* beam-count stem-length-fraction)) 2)))
                             ((ly:grob? flag)
                              (+ (list-ref splitted-stem-vertical-lengths 1) 
                                 flag-length))
                             (else (list-ref splitted-stem-vertical-lengths 2)))
                       (begin
                         (ly:warning 
                  "splitted-stem-vertical-lengths needs 3 entries: ~a, ignoring"
                           splitted-stem-vertical-lengths)
                         0))))
                 
            ;;;; Move possible Flag/Beam
            (cond ((ly:grob? beam)
                   (let* ((stems (ly:grob-object beam 'stems))
                          ;; TODO Is 1 the correct fallback value?
                          ;;      Need to check with ly:grob-array? at all?
                          (stem-count 
                            (if (ly:grob-array? stems)
                                (ly:grob-array-length stems)
                                1)))
                   ;; TODO Mmhh, this will translate the beam a little bit   
                   ;; every time a new stem is encountered. 
                   ;; How to do it better?
                   (ly:grob-translate-axis! beam (/ stem-pos stem-count) X)))
                  ;; If a beam is printed flag-grobs are "turned down", but  
                  ;; not suicided, thus check flags _after_ beam.
                  ((ly:grob? flag)
                   (ly:grob-translate-axis! flag stem-pos X)))
                   
            ;;;; Construct the new stem-stencil
            (apply
              ly:stencil-add
              ;; A vertical line-stencil drawn from a melting-point to  
              ;; Flag, Beam or default-end
              (make-line-stencil
                thick
                ;; x-start
                (+ stem-pos x)  
                ;; y-start
                (+ (* dir -1 length-vertical-stem)
                   (if (positive? dir) 
                       (cdr stem-stil-y-ext) 
                       (car stem-stil-y-ext)))
                ;; x-end
                (+ stem-pos x) 
                ;; y-end
                (if (positive? dir) 
                    (cdr stem-stil-y-ext) 
                    (car stem-stil-y-ext)))
              ;; A list of line-stencils, drawn from note-head to a 
              ;; melting-point
              (map 
                (lambda (y-corr nh)
                  (let ((my-x (car (ly:grob-extent nh pc X))))
                    (make-line-stencil 
                      thick 
                      ;; x-start
                      (+ stem-pos x) 
                      ;; y-start
                      (+ (* dir -1 length-vertical-stem)
                         (if (positive? dir) 
                             (cdr stem-stil-y-ext) 
                             (car stem-stil-y-ext)))    
                      ;; x-end
                      (- my-x nc-x-off)
                      ;; y-end
                      (- (if (positive? dir) 
                             (car stem-stil-y-ext) 
                             (cdr stem-stil-y-ext))
                         y-corr))))
                y-corr-values
                note-heads-list)))))))
     
distributeNoteHeads =
#(define-music-function (stem-pos nhd-shifts)(boolean-or-number? list?)
"Returns overrides to distribute note-heads of a stem, according to 
@var{nhd-shifts}, and to get a new stem-stencil connecting all those note-heads,
looking at @var{stem-pos}, which may be set @code{#f} to keep default.
The provided new stem-stencil frequently needs to be longer, thus larger values
for @code{beamed-lengths} and @code{lengths} are supplied.  Those can be 
modified by overrides for @code{Stem.length} or @code{Beam.positions}."
#{
  \override Stem.details.beamed-lengths = #'(5.25 5.25 5.25)
  \override Stem.details.lengths = #'(4.5 5.5 6.0 7.0 8.0 9.0)
  \override Stem.positioning-done = #(distribute-stem-note-heads nhd-shifts)
  \override Stem.stencil = #(splitted-stem-stencil stem-pos)
#})

%% Revert settings of \distributeNoteHeads
revertDistributeNoteHeads = {
  \revert Stem.details.beamed-lengths
  \revert Stem.details.lengths
  \revert Stem.positioning-done
  \revert Stem.stencil
}
  
%%%%%%%%%%%%%%%%%%%%%%%
%% EXAMPLES
%%%%%%%%%%%%%%%%%%%%%%%

\paper { ragged-right = ##t }

\layout {
  %\override Stem.color = #red
  %\override Stem.layer = 200
  \accidentalStyle forget
}

%\transpose c c
{
  \cadenzaOn
  
  \distributeNoteHeads #0 #'(0 0 2.8)
  <b des' dis' f'>2
  
  \bar "||"
  
  <ees' ees'' \tweak Accidental.X-offset #0.2 e''!>8[ 
  <ees' ees'' \tweak Accidental.X-offset #0.2 e''!>]
  
  \bar "||"
  
  \distributeNoteHeads #0 #'(0 3)
  <f'' fisis''>4
  \once \override Stem.length = 11
  \once \override Stem.details.splitted-stem-vertical-length =
    %% Default for: beamed-stem, flagged-stem, stem-only 
    %% '(1 0 2)
    #'(1 0 3)
  \distributeNoteHeads #1.9 #'(0 3)
  <f'' fisis''>4
    
  \bar "||"
  
  \once \override Stem.length = 8
  \once \override Stem.details.splitted-stem-vertical-length =
    %% Default for: beamed-stem, flagged-stem, stem-only 
    %% '(1 0 2)
    #'(1 -1 3)
  \distributeNoteHeads #3 #'(0 3)
  <f'' fis''>8
  \distributeNoteHeads #1.9 #'(0 3)
  <f'' fis''>
    
  \bar "||"
  
  \distributeNoteHeads #0.8 #'(0 2.3)
  <ees' \tweak Accidental.X-offset #0.7 \tweak Accidental.font-size #-3 e'!>8
  
  \bar "||"
  
%  \distributeNoteHeads #-1.2 #'(0 -3 3 -6 6 -9 9 -12)
%  <cis' des' eis' fisis' geses' ais' bes' c''!>2
%  
%  \bar "||"
%  
%  \revertDistributeNoteHeads
%  <c' e'>4
}

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% Draw a bracket between to NoteColumns from different Voices 
%% happening at the same moment
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

bracketMrkp =
#(define-scheme-function (y-off dir bracket-info)(number? ly:dir? pair?)
"Return an empty chord with a bracket-markup.
 The style of the bracket depends on @var{bracket-info}.  
   - If it is a number-pair then a bracket like |__| is drawn.
   - If it is a list of number-lists then a bracket like /\\ is drawn.
 @var{y-off} serves to place the bracket vertically.
 @var{dir} determines the direction of the bracket flares and (for the 
 |__|-bracket) where the number is printed."
  (if (number-pair? bracket-info)
      #{
        <>-\tweak staff-padding #'()
          -\tweak outside-staff-priority #'()
          -\tweak Y-offset $y-off
          -\markup 
             \override #`(direction . ,(* dir -1))
             \override #`(baseline-skip . ,(if (negative? dir) 1.5 0.5))
             \dir-column 
               \with-dimensions #'(0 . 0) #'(0 . 0)  {
                 \translate #(cons (interval-center bracket-info) 0)
                 \fontsize #-5 \halign #CENTER \number "1"
                 \stencil #(ly:bracket X bracket-info 0.1 (* dir -1))
               }
      #}
      (let* ((inner-list (drop-right bracket-info 1))
             (dir-bracket-info
               (append
                 (map
                   (lambda (e)
                     (list (car e) (* dir (cadr e))))
                   inner-list)
                 (last-pair bracket-info))))
               

        #{
          <>-\tweak staff-padding #'()
            -\tweak outside-staff-priority #'()
            -\tweak Y-offset $y-off
            -\markup 
               \translate #'(0.5 . 0)
               \stencil 
               #(make-connected-path-stencil 
                  dir-bracket-info 0.2 1 1 #f #f)
        #})))
      
\new Staff {
  %% DISCLAIMER AND WARNING:
  %% Using this override means, you tell LilyPond: "Don't care placing
  %% Accidentals, I'll do it myself"
  %% You better do so then!!
  \once \override Staff.AccidentalPlacement.positioning-done = ##t
  \bracketMrkp #-1.2 #DOWN #'(-3.0 . 1.3)
  <<
    \new Voice { 
      \voiceOne 
      <\tweak Accidental.X-offset #-3.8 f''! f'''>4  
    }
    \new Voice { 
      \voiceTwo 
      \once \override NoteColumn.force-hshift = -2.8
      <\tweak Accidental.X-offset #-1.2 fis'' c'''>4. 
    }
  >>
}

\new Staff {
  %% DISCLAIMER AND WARNING:
  %% Using this override means, you tell LilyPond: "Don't care placing
  %% Accidentals, I'll do it myself"
  %% You better do so then!!
  \once \override Staff.AccidentalPlacement.positioning-done = ##t
  \bracketMrkp #6.4 #UP #'((1.5 1) (3 0))
  <<
    \new Voice { 
      \voiceOne 
      \once \override NoteColumn.force-hshift = 1.8
      <
       \tweak Accidental.X-offset #1.5 eis'' 
       \tweak Accidental.X-offset #1.5 eis'''
      >8[(
      <fis'' fis'''>])
    }
    \new Voice { 
      \voiceTwo 
      <c''' e'''>4  
    }
  >>
}


%% Other test-examples
%% 2.21.0 is required because of used r256
%{
%<<   
 \new Staff
 \relative c' {
  \autoBeamOff
  %\override Beam.positions = #'(8 . 8)
  %\override Stem.length = 20
  %\override Stem.positioning-done = #distribute-stem-note-heads
  %\override Stem.stencil = #splitted-stem-stencil
  
  %% Long notes, no Stem, but distributing of NoteHeads is possible
  \distributeNoteHeads ##f #'(0 2.75 6.5)
  \compressFullBarRests
  <dis e fis>\longa 
  <dis e fis>\breve
  <dis e fis>1
  
  %\break
  
  \distributeNoteHeads #2 #'(0 2 5)
  
  %% Customizings
  <dis e fis>2
  %% Lengthen Stem generally
  \once \override Stem.length = 12
  <dis e fis>2
  %% Shorten the vertical part after the melting point
  \once \override Stem.details.splitted-stem-vertical-length =
    %% Default for: beamed-stem, flagged-stem, stem-only 
    %% '(1 0 2)
    #'(1 0 1)
  <dis e fis>2
  %% Sometimes there's need for tweaking, X-offset works
  \once\override NoteColumn.X-offset = 2
  <dis'' e fis>2
  
  \break
  
  %% Short Notes
  <dis,, e fis>4
  <dis e fis>8
  <dis e fis>16
  <dis e fis>32
  \distributeNoteHeads #3 #'(0 3 6)
  \override Stem.length = 24
  <dis eis fis>64
  <dis eis fis>128
  r128
  r2
  \override Beam.positions = 
  #(lambda (grob)
    (let ((dir (ly:grob-property grob 'direction)))
     (cons (* dir 5) (* dir 8))))
  <dis eis fis>8[
  <dis eis fis>16
  <dis eis fis>32
  <dis eis fis>64
  <dis eis fis>128
  \once \override Stem.details.splitted-stem-vertical-length =
    #'(1.6 0 2)
  <dis eis fis>256]
  r2.
  r256
  |
 }

 \new Staff
 \relative c'' {
  \autoBeamOff
  \voiceTwo
  %\override Beam.positions = #'(-8 . -8)
  %\override Stem.length = 20
  \distributeNoteHeads #0 #'(0 3 6 9)
  <dis e fis>4
  <dis e fis>8
  <dis e fis>16
  <dis e fis>32
  \once \revert Stem.positioning-done
  \once \revert Stem.stencil
  <dis eis fis>32
  <dis eis fis>64
  <dis eis fis>128
  <dis eis fis>32[] 
  <dis eis fis>
 }
%>>
%}