\version "2.20.0"

#(define (note-column::main-extent grob)
"Return extent of the noteheads in the 'main column', (i.e. excluding any
suspended noteheads), or extent of the rest (if there are no heads)."
  (let* ((note-heads (ly:grob-object grob 'note-heads))
         ;; stem is currently not needed below, for now we let it in commented
         ;(stem (ly:grob-object grob 'stem))
         (rest (ly:grob-object grob 'rest)))
    (cond ((ly:grob-array? note-heads)
           (let (;; get the cdr from all note-heads-extents, where the car
                 ;; is zero
                 (n-h-right-coords
                   (filter-map
                     (lambda (n-h)
                       (let ((ext (ly:grob-extent n-h grob X)))
                          (and (= (car ext) 0) (cdr ext))))
                     (ly:grob-array->list note-heads))))
             ;; better be paranoid, find the max of n-h-right-coords and return
             ;; a pair with (cons 0 <max>)
             (cons 0.0 (reduce max 0 n-h-right-coords))))
          ((ly:grob? rest)
           (ly:grob-extent rest grob X))
          ;; better be paranoid again
          (else '(0 . 0)))))

#(define note-column-cluster
  (lambda (grob)
    (let* ((nhds-array (ly:grob-object grob 'note-heads))
           (nhds-list
             (if (ly:grob-array? nhds-array)
                 (ly:grob-array->list nhds-array)
                 #f)))
      (if nhds-list
          (let* ((staff-pos-list
                   (map
                     (lambda (nhd) (ly:grob-property nhd 'staff-position))
                     nhds-list))
                 (staff-space (ly:staff-symbol-staff-space grob))
                 (bottom-pos
                   (/ (* (apply min staff-pos-list) staff-space) 2))
                 (top-pos
                   (/ (* (apply max staff-pos-list) staff-space) 2))
                 (nc-width (note-column::main-extent grob))
                 (mid-nc
                   (interval-center nc-width))
                 (stem (ly:grob-object grob 'stem))
                 (stem-details
                   (ly:grob-property stem 'details))
                 (cluster-thick-short
                   (* staff-space
                      (assoc-get 'cluster-thick-short stem-details 0.54)))
                 (stem-y-attach 
                   (* staff-space
                      (cdr 
                        (ly:grob-property (car nhds-list) 'stem-attachment))))
                 (stem-dir (ly:grob-property stem 'direction))
                 (dur-log (ly:grob-property stem 'duration-log))
                 (layout (ly:grob-layout grob))
                 (blot (ly:output-def-lookup layout 'blot-diameter))
                 (line-thick (ly:output-def-lookup layout 'line-thickness 0.1))
                 (stem-thick (ly:grob-property stem 'thickness 1.3))
                 (thick 
                   (* (ly:grob-property 
                        grob 
                        'thickness 
                        (* stem-thick line-thick))
                      staff-space)))
   
            (ly:grob-set-property! stem 'avoid-note-head #t)
            (ly:grob-set-property! grob 'stencil
              (cond 
                ((= dur-log 0)
                  (ly:stencil-add
                    (ly:round-filled-box
                      (cons 0 thick)
                      (cons bottom-pos top-pos)
                      blot)
                    (ly:round-filled-box
                      (cons (- (cdr nc-width) thick) (cdr nc-width))
                      (cons bottom-pos top-pos)
                      blot)))
                ((= dur-log 1)
                   (ly:stencil-add
                    (stencil-with-color
                     (ly:round-filled-box
                       (cons 0 thick)
                       (cons 
                         (+ (/ staff-space 4) (- bottom-pos stem-y-attach))
                         (+ (/ staff-space 4) (- top-pos stem-y-attach)))
                       blot)
                      green)
                     (ly:round-filled-box
                       (cons (- (cdr nc-width) thick) (cdr nc-width))
                       (cons  
                         (- (+ bottom-pos stem-y-attach) (/ staff-space 4))
                         (- (+ top-pos stem-y-attach) (/ staff-space 4)))
                       blot)))
                (else
                  (let* ((x-left (- mid-nc (/ thick 2) cluster-thick-short))
                         (x-right (+ mid-nc (/ thick 2) cluster-thick-short))
                         (y-bottom-left
                           (+ (- bottom-pos thick stem-y-attach) 
                              (/ staff-space 4)))
                         (y-bottom-right
                           (- (+ bottom-pos thick stem-y-attach) 
                              (/ staff-space 4)))
                         (y-top-right
                           (- (+ top-pos thick stem-y-attach) 
                              (/ staff-space 4)))
                         (y-top-left
                           (+ (- top-pos thick stem-y-attach) 
                              (/ staff-space 4))))
                    (ly:make-stencil
                      `(polygon
                         ;; with 2.20.0 use
                         ',(list
                         ;; with newer versions:
                         ;,(list
                             x-left y-bottom-left
                             x-right y-bottom-right
                             x-right y-top-right
                             x-left y-top-left)
                          ,blot
                          #t) 
                      (cons x-left x-right)
                      (cons y-bottom-left y-top-right)))))))
          ;; else, do nothing
          '()))))

          
#(define (close-enough? x y)
  "Values are close enough to ignore the difference"
  (< (abs (- x y)) 0.0001))

#(define (extent-combine extents)
  "Combine a list of extents, return the minimum of the car and the maximum of
te cdr of all extents."
  (reduce interval-union '() extents))

#(define ((cluster-stem-connectable? ref root) stem)
  "Check if the @var{stem} is connectable to the @var{root}, done by comparing 
their horizontal positions and their @code{direction} property.
For whole Notes fall back to compare the extent of the related @code{NoteColumn}
grobs."
  (let* ((root-dur-log (ly:grob-property root 'duration-log))
         (root-x-ext
           (if (eqv? root-dur-log 0)
               (ly:grob-extent (ly:grob-parent root X) ref X)
               (ly:grob-extent root ref X)))
         (stem-x-ext
           (if (eqv? root-dur-log 0)
               (ly:grob-extent (ly:grob-parent stem X) ref X)
               (ly:grob-extent stem ref X))))
  ;; The root is always connectable to itself
  (or (eq? root stem)
      (and
       ;; Horizontal positions of the stems (or NoteColumns) must be almost the 
       ;; same
       (close-enough? (car root-x-ext) (car stem-x-ext))
       ;; The stem must be in the direction away from the root's notehead
       ;; Special case whole notes: always return #t
       (if (eqv? root-dur-log 0)
           #t
           (positive? (* (ly:grob-property root 'direction)
                         (- (car (ly:grob-extent stem ref Y))
                            (car (ly:grob-extent root ref Y))))))))))

#(define (cluster-stem-span-stencil span)
  "Connect stems if we have at least one stem connectable to the root.
@var{span} is the created target @code{grob}."
  (let* ((system (ly:grob-system span))
         (staff-space (ly:staff-symbol-staff-space span))
         (root (ly:grob-parent span X))
         (root-dir (ly:grob-property root 'direction 1))
         (root-duration-log (ly:grob-property root 'duration-log))
         (root-thick
           (ly:grob-property root 'thickness 1.3))
         (root-details
           (ly:grob-property root 'details))
         (cluster-thick-short
           (assoc-get 'cluster-thick-short root-details 0.54))
         (stems 
           (filter 
             (cluster-stem-connectable? system root)
             (ly:grob-object span 'stems)))
         (parent-ncs 
           (map
             (lambda (stem)
               (ly:grob-parent stem X))
             stems))
         (ncs-extents
           (map
              note-column::main-extent
              parent-ncs))
         ;; Use half width for half notes and longer
         (nc-x-width
           (interval-center
             (extent-combine ncs-extents)))
         (layout (ly:grob-layout root))
         (line-thick (ly:output-def-lookup layout 'line-thickness 0.1))
;(foo
;  (pretty-print
;    (list
;      staff-space
;      (ly:output-def-lookup layout 'staff-space)
;      (ly:output-def-lookup layout 'output-scale)
;      (ly:output-def-lookup (ly:grob-layout (car stems)) 'staff-space)
;      )
;    ))
         (half-used-thick
           (/ (* line-thick root-thick) 2))
         (blot (ly:output-def-lookup layout 'blot-diameter))
             )
             

    (if (= 2 (length stems))
        (let* (;; Get the Y-extents of all the original stems
               ;; For whole note stems fall back to Y-extents of their 
               ;; NoteColumn
               (y-extents 
                 (cond ((< root-duration-log 1)
                         (map
                           (lambda (nc) (ly:grob-extent nc system Y))
                           parent-ncs))
                       (else
                         (map 
                           (lambda (st)
                             (ly:grob-extent st system Y)) 
                           stems))))
               ;; For uppointing Stem accumulate their car, otherwise cdr,
               ;; for whole note stems use the center of their NoteColumn extent
               ;; to build a list. This list is used to determine bottom/top
               ;; values to print the cluster-stem lateron
               (stem-starts-ls
                 (cond ((< root-duration-log 1)
                         (list (interval-center (car y-extents))
                               (interval-center (last y-extents))))
                       (else
                         (if (positive? root-dir)
                             (map car y-extents)
                             (map cdr y-extents)))))
               (y-ext
                 (cons (car stem-starts-ls) (last stem-starts-ls)))
               (raw-stencil
                   (ly:round-filled-box
                     (interval-scale (cons (- half-used-thick) half-used-thick) 1)
                     y-ext 
                     blot))
               (stem-attach
                 (ly:grob-property
                   (car 
                     (ly:grob-array->list 
                       (ly:grob-object root 'note-heads)))
                   'stem-attachment)))

          ;; Hide root stem, i.e. the stem of the lowest connected note
          (set! (ly:grob-property root 'stencil) #f)
          ;; Draw a nice looking stem with rounded corners
          (cond 
            ;; whole notes
            ((= root-duration-log 0)
              (ly:stencil-add
                (ly:stencil-translate-axis
                  raw-stencil
                  (- half-used-thick nc-x-width)
                  X)
                (ly:stencil-translate-axis
                  raw-stencil
                  (- nc-x-width half-used-thick)
                  X)
                ))
            ;; half notes
            ((= root-duration-log 1)
              (ly:stencil-add
                raw-stencil
                (ly:round-filled-box 
                  (coord-translate
                    (cons (- half-used-thick) half-used-thick)
                    (* 2 root-dir (- half-used-thick nc-x-width)))
                  (cons 
                    (+ (car y-ext) (* -1 root-dir (cdr stem-attach)))
                    (+ (cdr y-ext) (* -1 root-dir (cdr stem-attach))))
                  blot)))
            ;; 4th and shorter
            (else
              (let* ((x-right (+ half-used-thick cluster-thick-short))
                     (x-left (- x-right))
                     (y-left-bottom
                       (+ (car y-ext) 
                          (if (negative? root-dir)
                              0
                              (- (cdr stem-attach)))))
                     (y-right-bottom
                       (+ (car y-ext) 
                          (if (negative? root-dir)
                              (cdr stem-attach)
                              0)))
                     (y-right-top
                       (+ (cdr y-ext)
                          (if (negative? root-dir)
                              (cdr stem-attach)
                              0)))
                     (y-left-top
                       (+ (cdr y-ext) 
                          (if (negative? root-dir)
                              0
                              (- (cdr stem-attach))))))
            (ly:stencil-translate-axis 
              (ly:make-stencil
                `(polygon
                   ;; with 2.20.0 use
                   ',(list
                   ;; with newer versions:
                   ;,(list
                      x-left  y-left-bottom
                      x-right y-right-bottom
                      x-right y-right-top
                      x-left  y-left-top 
                      
                      )
                    ,blot
                    #t) 
                (cons (- half-used-thick) half-used-thick)
                y-ext
                )
              (* -1 root-dir (- nc-x-width half-used-thick))
              X)
              ))))
        ;; Nothing to connect, don't draw the span
        #f)))

#(define ((make-cluster-stem-span! stems trans) root)
  "Create a stem span as a child of the cross-staff stem (the root)"
  (let ((span (ly:engraver-make-grob trans 'Stem '())))
    (ly:grob-set-parent! span X root)
    (set! (ly:grob-object span 'stems) stems)
    ;; Suppress positioning, the stem code is confused by this weird stem
    (set! (ly:grob-property span 'X-offset) 0)
    (set! (ly:grob-property span 'stencil) cluster-stem-span-stencil)))

#(define-public (cross-staff-connect stem)
  "Set cross-staff property of the stem to this function to connect it to
other stems automatically"
  #t)

#(define (stem-is-root? stem)
  "Check if automatic connecting of the stem was requested.  Stems connected
to cross-staff beams are cross-staff, but they should not be connected to
other stems just because of that."
  (eq? cross-staff-connect (ly:grob-property-data stem 'cross-staff)))

#(define (make-cluster-stem-spans! ctx stems trans)
  "Create stem spans for cross-staff stems"
  ;; Cannot do extensive checks here, just make sure there are at least
  ;; two stems at this musical moment
  (if (= 2 (length stems))
      (let ((roots (filter stem-is-root? stems)))
        (for-each (make-cluster-stem-span! stems trans) roots))))

#(define-public (Cluster-span_stem_engraver ctx)
  "Connect cross-staff stems to the stems above in the system"
  (let ((stems '()))
    (make-engraver
     ;; Record all stems with note-heads for the given moment
     (acknowledgers
      ((stem-interface trans grob source)
       (if (ly:grob-array? (ly:grob-object grob 'note-heads))
           (set! stems (cons grob stems)))))
     ;; Process stems and reset the stem list to empty
     ((process-acknowledged trans)
      (make-cluster-stem-spans! ctx stems trans)
      (set! stems '())))))

cluster =
#(define-music-function (cross-staff notes) ((boolean? #f) ly:music?)
  (_i "Create cross-staff stems")
  (if cross-staff
      #{
        \temporary \override Stem.cross-staff = #cross-staff-connect
        \temporary \override Flag.style = #'no-flag
        $notes
        \revert Stem.cross-staff
        \revert Flag.style
      #}
      #{
      	 \temporary \override NoteColumn.before-line-breaking = 
      	   #note-column-cluster
      	 $notes
      	 \revert NoteColumn.before-line-breaking
      #})
)