\version "2.19.30"

#(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))))
                  (broken (if (cdr broken)
                              (let ((next (broken-right-neighbor grob)))
                                (if (ly:spanner? next)
                                    (begin
                                     (ly:grob-property next 'after-line-breaking) ; call for side-effect
                                     (cons (car broken) (grob::is-live? next)))
                                    (cons (car broken) #f)))
                              broken))
                  (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))
                  (thick (* (ly:grob-property grob 'thickness 1.0)
                           (ly:staff-symbol-line-thickness grob)))
                  (shorten-pair (ly:grob-property grob 'shorten-pair '(0.0 . 0.0)))) ; enhancement

             (define (set-x-points 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 broken ...

                     ;; starting a line
                     (if (= dir LEFT)
                         (interval-dir-set
                          ;x-points (interval-bound e (other-dir dir)) dir)
                          x-points (interval-bound e RIGHT) LEFT)

                         ;; ending a line
                         (let* ((broken-bound-padding
                                 (ly:grob-property grob 'broken-bound-padding 0.0))
                                (chp (ly:grob-object grob 'concurrent-hairpins)))

                           ; make sure that concurrent broken hairpins end at the same time at line break
                           (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)))

                     ;; Not broken ...

                     ;; If a dynamic is present at bound
                     (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))

                         ;; If no dynamic, we consider adjacent spanners
                         (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
                           ;; is there a spanner sharing bound?
                           (let find-neighbor ((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))
                                  (find-neighbor (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)))))))

                 (interval-dir-set x-points
                   (- (interval-bound x-points dir) (* dir (interval-bound shorten-pair dir)))
                   dir)))

             (set-x-points LEFT)
             (set-x-points 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:line-interface::line grob x starth width endh))

               (set! mol
                     (ly:stencil-add
                      mol
                      ;(make-line-stencil thick x (- starth) width (- endh))))
                      (ly:line-interface::line grob x (- starth) width (- endh))))

               ;; Support al/del niente notation by putting a circle at the
               ;; tip of the (de)crescendo.
               (if circled-tip
                   (let ((circle (make-circle-stencil rad thick #f)))

                     ;;  don't add another circle if the hairpin is broken
                     (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))))))

hairpin = {
  c'1~\<
  c'1~
  %\break
  c'2~ c'2\!
}

\markup \bold "DEFAULT"

{
  \hairpin
  \break
}

\markup \bold "Shorten right"

{
  \override Hairpin.shorten-pair = #'(0 . 4)
  \hairpin
  \break
}

\markup \bold "Lengthen right"

{
  \override Hairpin.shorten-pair = #'(0 . -4)
  \hairpin
  \break
}

\markup \bold "Shorten left"

{
  \override Hairpin.shorten-pair = #'(4 . 0)
  \hairpin
  \break
}

\markup \bold "Lengthen left"

{
  \override Hairpin.shorten-pair = #'(-4 . 0)
  \hairpin
  \break
}

\markup \bold "Shorten both ends"

{
  \override Hairpin.shorten-pair = #'(4 . 4)
  \hairpin
  \break
}

\markup \bold "Lengthen both ends"

{
  \override Hairpin.shorten-pair = #'(-4 . -4)
  \hairpin
  \break
}

\layout {
  \override Hairpin.stencil = #hairpin::print-scheme
  %\override Hairpin.to-barline = ##f
  %\override Hairpin.circled-tip = ##t
  %\override Hairpin.style = #'zigzag
}

\paper {
  indent = 0
  ragged-right = ##f
}