\version "2.19.80"

#(define (proc-number-or-false? obj)
   (or (procedure? obj)
       (number? obj)
       (eq? obj #f)))

#(define (define-grob-property symbol type? description)
   (if (not (equal? (object-property symbol 'backend-doc) #f))
       (ly:error (_ "symbol ~S redefined") symbol))

   (set-object-property! symbol 'backend-type? type?)
   (set-object-property! symbol 'backend-doc description)
   symbol)

#(map
  (lambda (x)
    (apply define-grob-property x))

  `(
     (circled-tip-radius ,number? "Radius for hairpin circled tip")
     (rotate ,proc-number-or-false? "Custom rotation: a number specifies angle in degrees, a procedure will receive the grob and return an angle, #f deactivates rotation")
     (straight-end ,boolean? "Straighten the end of the hairpin when it's rotated?")
     ))


#(define broken-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-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 (ly:grob-property grob 'circled-tip-radius (* 0.525 height)))
                (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)))
               (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)
                                    (< 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 '())
                              (neighbors (ly:grob-object grob 'adjacent-spanners))
                              (neighbors-len (if (ly:grob-array? neighbors)
                                                 (ly:grob-array-length neighbors)
                                                 0)))

                         (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))))))

             ;add support for rotation and straightened end-points
             (let* ((rotate (ly:grob-property-data grob 'rotate))
                    (straighten (ly:grob-property grob 'straight-end #f))
                    (ang (cond
                          ((number? rotate) rotate)
                          ((procedure? rotate)
                           (if (eq? (procedure-name rotate) 'hairpin-follow-beam)
                               (rotate grob)
                               (rotate grob width starth endh)))
                          (else 0)))
                    (offset (if (or (= ang 0) (not straighten))
                                0
                                (let* ((adj-hgt (- starth endh))
                                       (def-ang (atan (/ adj-hgt width)))
                                       (and-rad (degrees->radians ang))
                                       (tot-ang (+ def-ang and-rad)))
                                  (- (* width (tan tot-ang)) adj-hgt)))))

               (set! mol (make-line-stencil thick x starth width (+ endh offset)))

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

               ;TODO: circle on the right end of the object should be placed with the offset. How?
               (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)))))

               ;if straight end-points are not needed, just rotate the stencil
               (if (and (not straighten) (not (= ang 0)))
                   (set! mol (ly:stencil-rotate mol ang CENTER CENTER)))

               (set! mol
                     (ly:stencil-translate-axis mol
                       (- (interval-bound x-points LEFT)
                         (ly:grob-relative-coordinate (interval-bound bounds LEFT) common X))
                       X))

               mol)))))))

#(define hairpin-follow-beam
   (lambda (grob)
     (let* ((lb (ly:spanner-bound grob LEFT))
            (rb (ly:spanner-bound grob RIGHT))
            (bound
             (find (lambda (b)
                     (grob::has-interface b 'note-column-interface))
               (list lb rb)))
            (beam
             (if bound
                 (ly:grob-object (ly:grob-object bound 'stem) 'beam)
                 (let* ((col (ly:item-get-column lb))
                        (elts (ly:grob-array->list
                               (ly:grob-object col 'bounded-by-me))))
                   (find (lambda (e) (grob::has-interface e 'beam-interface))
                     elts)))))
       (if (ly:grob? beam)
           (let* ((X-pos (ly:grob-property beam 'X-positions))
                  (Y-pos (ly:grob-property beam 'positions))
                  (ang (ly:angle (- (cdr X-pos) (car X-pos))
                         (- (cdr Y-pos) (car Y-pos)))))
             ang)
           0))))

% The following doesn't work because of the following error when Hairpin.rotate has a lambda that requires more than one variable.
%   226:29: Wrong number of arguments to #<procedure hairpin-upper-with-staff (grob width starth endh)>
#(define hairpin-upper-with-staff
   (lambda (grob width starth endh)
     (let* ((adj-hgt (- endh starth))
            (def-ang (atan (/ adj-hgt width)))
            (def-ang-degrees (* def-ang (/ 180 PI))))
       (- def-ang-degrees))))

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\! }
  >>
  \once \override Hairpin.to-barline = ##f
  c''1\<
  c''1\!

  c'8\< e' g' b'\! d''\> b' g' e'\!
  << f''1 { s4 s\< s\> s\! } >>
  \override Hairpin.minimum-length = #5
  << f''1 { s4 s\< s\> s\! } >>
  \revert Hairpin.minimum-length
}

\markup \huge \bold "DEFAULT"


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

\markup \huge \bold "ANGLE REWRITE"

{
  \override Hairpin.stencil = #hairpin::print-scheme
  \music
  \override Hairpin.rotate = 10
  \override Hairpin.straight-end = ##f
  \music
  \override Hairpin.rotate = -15
  \override Hairpin.straight-end = ##t
  \music
  %\override Hairpin.circled-tip = ##t %can't properly position circled-tip
  \override Hairpin.rotate = #hairpin-follow-beam
  \override Hairpin.straight-end = ##t
  \music

  \override Hairpin.rotate = #hairpin-upper-with-staff
  \override Hairpin.straight-end = ##t
  \music

}

\layout {
  ragged-right = ##t
}