\version "2.19.23"

#(define broken-right-neighbor
   (lambda (grob)
     (let* ((pieces (ly:spanner-broken-into (ly:grob-original grob)))
            (me-list (member grob pieces)))
       (if (> (length me-list) 1)
           (cadr me-list)
           '()))))

#(define (interval-dir-set i val dir)
   (cond ((= dir LEFT) (set-car! i val))
     ((= dir RIGHT) (set-cdr! i val))
     (else (ly:error "dir must be LEFT or RIGHT"))))

#(define (other-dir dir) (- dir))

#(define hairpin::print-scheme
   (lambda (grob)
     (let ((grow-dir (ly:grob-property grob 'grow-direction)))
       (if (not (ly:dir? grow-dir))
           (begin
            (ly:grob-suicide! grob)
            '()))
       
       (let* ((padding (ly:grob-property grob 'bound-padding 0.5))
              (bounds (cons (ly:spanner-bound grob LEFT)
                        (ly:spanner-bound grob RIGHT)))
              (broken (cons
                       (not (= (ly:item-break-dir (car bounds)) CENTER))
                       (not (= (ly:item-break-dir (cdr bounds)) CENTER)))))
         
         (if (cdr broken)
             (let ((next (broken-right-neighbor grob)))
               (if (ly:spanner? next)
                   (begin
                    (ly:grob-property next 'after-line-breaking)
                    (set-cdr! broken (grob::is-live? next)))
                   (set-cdr! broken #f))))
         
         (let* ((common
                 (ly:grob-common-refpoint (car bounds) (cdr bounds) X))
                (x-points (cons 0 0))
                (circled-tip (ly:grob-property grob 'circled-tip))
                (height (* (ly:grob-property grob 'height 0.2)
                          (ly:staff-symbol-staff-space grob)))
                (rad (* 0.525 height))
                ; commented out is directly from C++, but it leads to think lines when
                ; no circled tip!
                ;(thick 1.0)
                ;(thick (if circled-tip
                ;(* (ly:grob-property grob 'thickness 1.0)
                ;(ly:staff-symbol-line-thickness grob))
                ;thick))
                (thick (* (ly:grob-property grob 'thickness 1.0)
                         (ly:staff-symbol-line-thickness grob))))
           
           (define (inner dir)
             (let* ((b (interval-bound bounds dir))
                    (e (ly:generic-bound-extent b common))) ; X-AXIS assumed
               (interval-dir-set
                x-points (ly:grob-relative-coordinate b common X) dir)
               
               (if (interval-bound broken dir)
                   (if (= dir LEFT)
                       (interval-dir-set
                        x-points (interval-bound e (other-dir dir)) dir)
                       (let* ((broken-bound-padding
                               (ly:grob-property grob 'broken-bound-padding 0.0))
                              (chp (ly:grob-object grob 'concurrent-hairpins)))
                         (let loop ((i 0))
                           (if (and (ly:grob-array? chp) ; hmm...why no test in C++ needed?
                                    (< i (ly:grob-array-length chp)))
                               (let ((span-elt (ly:grob-array-ref chp i)))
                                 (if (= (ly:item-break-dir (ly:spanner-bound span-elt RIGHT))
                                        LEFT)
                                     (set! broken-bound-padding
                                           (max broken-bound-padding
                                             (ly:grob-property span-elt 'broken-bound-padding 0.0))))
                                 (loop (1+ i)))))
                         (interval-dir-set
                          x-points
                          (- (interval-bound x-points dir)
                            (* dir broken-bound-padding))
                          dir)))
                   
                   (if (grob::has-interface b 'text-interface)
                       (if (not (interval-empty? e))
                           (interval-dir-set x-points
                             (- (interval-bound e (other-dir dir))
                               (* dir padding))
                             dir))
                       (let* ((neighbor-found #f)
                              (adjacent '()) ; spanner
                              (neighbors (ly:grob-object grob 'adjacent-spanners))
                              (neighbors-len (if (ly:grob-array? neighbors)
                                                 (ly:grob-array-length neighbors)
                                                 0))) ; this shouldn't be necessary -- see comment above
                         
                         (let inner-two ((i 0))
                           (if (and (< i neighbors-len)
                                    (not neighbor-found))
                               (begin
                                (set! adjacent (ly:grob-array-ref neighbors i))
                                (if (and (ly:spanner? adjacent)
                                         (eq? (ly:item-get-column (ly:spanner-bound adjacent (other-dir dir)))
                                              (ly:item-get-column b)))
                                    (set! neighbor-found #t))
                                (inner-two (1+ i)))))
                         
                         (if neighbor-found
                             (if (grob::has-interface adjacent 'hairpin-interface)
                                 (if (and circled-tip (not (eq? grow-dir dir)))
                                     (interval-dir-set x-points
                                       (+ (interval-center e)
                                         (* dir
                                           (- rad (/ thick 2.0))))
                                       dir)
                                     (interval-dir-set x-points
                                       (- (interval-center e)
                                         (/ (* dir padding) 3.0))
                                       dir))
                                 (if (= dir RIGHT)
                                     (interval-dir-set x-points
                                       (- (interval-bound e (other-dir dir))
                                         (* dir padding))
                                       dir)))
                             (begin
                              (if (and (= dir RIGHT)
                                       (grob::has-interface b 'note-column-interface)
                                       (ly:grob-array? (ly:grob-object b 'rest)))
                                  (interval-dir-set x-points
                                    (interval-bound e (other-dir dir))
                                    dir)
                                  (interval-dir-set x-points
                                    (interval-bound e dir)
                                    dir))
                             
                              (if (eq? (ly:grob-property b 'non-musical) #t)
                                  (interval-dir-set x-points
                                    (- (interval-bound x-points dir)
                                      (* dir padding))
                                    dir)))))))))
           
           
           (inner LEFT)
           (inner RIGHT)
           
           (let* ((width (- (interval-bound x-points RIGHT)
                           (interval-bound x-points LEFT)))
                  (width (if (< width 0)
                             (begin
                              (ly:warning
                               (if (< grow-dir 0)
                                   "decrescendo too small"
                                   "crescendo too small"))
                              0)
                             width))
                  (continued (interval-bound broken (other-dir grow-dir)))
                  (continuing (interval-bound broken grow-dir))
                  (starth (if (< grow-dir 0)
                              (if continuing
                                  (* 2 (/ height 3))
                                  height)
                              (if continued
                                  (/ height 3)
                                  0.0)))
                  (endh (if (< grow-dir 0)
                            (if continued
                                (/ height 3)
                                0.0)
                            (if continuing
                                (* 2 (/ height 3))
                                height)))
                  (mol empty-stencil)
                  (x 0.0)
                  (tip-dir (other-dir grow-dir)))
             
             (if (and circled-tip
                      (not (interval-bound broken tip-dir)))
                 (if (> grow-dir 0)
                     (set! x (* rad 2.0))
                     (if (< grow-dir 0)
                         (set! width (- width (* rad 2.0))))))
             
             (set! mol (make-line-stencil thick x starth width endh))
             
             (set! mol
                   (ly:stencil-add
                    mol
                    (make-line-stencil thick x (- starth) width (- endh))))
             
             (if circled-tip
                 (let ((circle (make-circle-stencil rad thick #f)))
                   (if (not (interval-bound broken tip-dir))
                       (set! mol
                             (ly:stencil-combine-at-edge mol X tip-dir circle 0)))))
             
             (set! mol
                   (ly:stencil-translate-axis mol
                     (- (interval-bound x-points LEFT)
                       (ly:grob-relative-coordinate (interval-bound bounds LEFT) common X))
                     X))
             
             mol))))))

music =
{
  c'1\<
  c'2\! c'2~\>
  c'2~ c'2\! 
  c'2\> c'2\< c'1
  c''1\< 
  c''4 a' c''\< a'
  c''4 a' c''\! a'\<
  c''4 a' c'' a'\!
  c''1~\<
  c''1~
  \break
  c''1\!
  c'1\!\<
  \break
  c'1
  \break
  c'2 c'2\!
  c''1\<
  c''4 a' c''\mf a'
  c''1\<
  c''4 a' c''\ffff a'
  c''4\< c''\! d''\> e''\!
  << 
    f''1
    { s4 s4\< s4\> s4\! }
  >>
  \override Hairpin.to-barline = ##f
  c''1\<
  c''1\!
}

\markup \huge \bold "DEFAULT"


{
  \music
  \override Hairpin.circled-tip = ##t
  \music
}

\markup \huge \bold "SCHEME REWRITE"

{
  \override Hairpin.stencil = #hairpin::print-scheme
  \music
  \override Hairpin.circled-tip = ##t
  \music
}

\layout {
  ragged-right = ##t
}