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

%{
;; C++ is from lily/hairpin.cc
;;
;; MAKE_SCHEME_CALLBACK (Hairpin, print, 1);
;; SCM
;; Hairpin::print (SCM smob)
;; {
;;   Spanner *me = unsmob<Spanner> (smob);
%}

#(define hairpin::print-scheme
   (lambda (grob)

;;   SCM s = me->get_property ("grow-direction");

     (let ((grow-dir (ly:grob-property grob 'grow-direction)))

;;   if (!is_direction (s))
;;     {
;;       me->suicide ();
;;       return SCM_EOL;
;;     }

       (if (not (ly:dir? grow-dir))
           (begin
            (ly:grob-suicide! grob)
            '())

;;   Direction grow_dir = to_dir (s);
;;   Real padding = robust_scm2double (me->get_property ("bound-padding"), 0.5);
;;
;;   Drul_array<bool> broken;
;;   Drul_array<Item *> bounds;
;;   for (LEFT_and_RIGHT (d))
;;     {
;;       bounds[d] = me->get_bound (d);
;;       broken[d] = bounds[d]->break_status_dir () != CENTER;
;;     }

           (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 (broken[RIGHT])
;;     {
;;       Spanner *next = me->broken_neighbor (RIGHT);
;;       // Hairpin-parts suicide in after-line-breaking if they need not be drawn
;;       if (next)
;;         {
;;           (void) next->get_property ("after-line-breaking");
;;           broken[RIGHT] = next->is_live ();
;;         }
;;       else
;;         broken[RIGHT] = false;
;;     }

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

;;   Grob *common = bounds[LEFT]->common_refpoint (bounds[RIGHT], X_AXIS);
;;   Drul_array<Real> x_points;
;;
;;   /*
;;     Use the height and thickness of the hairpin when making a circled tip
;;   */
;;   bool circled_tip = ly_scm2bool (me->get_property ("circled-tip"));
;;   Real height = robust_scm2double (me->get_property ("height"), 0.2)
;;                 * Staff_symbol_referencer::staff_space (me);
;;   /*
;;     FIXME: 0.525 is still just a guess...
;;   */
;;   Real rad = height * 0.525;
;;   Real thick = 1.0;
;;   if (circled_tip)
;;     thick = robust_scm2double (me->get_property ("thickness"), 1.0)
;;             * Staff_symbol_referencer::line_thickness (me);

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

;;   for (LEFT_and_RIGHT (d))
;;     {
;;       Item *b = bounds[d];
;;       Interval e = Axis_group_interface::generic_bound_extent (b, common, X_AXIS);
;;
;;       x_points[d] = b->relative_coordinate (common, X_AXIS);

               (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 (broken [d])
;;         {
;;           if (d == LEFT)
;;             x_points[d] = e[-d];

                   (if (interval-bound broken dir)
                       (if (= dir LEFT)
                           (interval-dir-set
                            x-points (interval-bound e (other-dir dir)) dir)

;;           else
;;             {
;;               Real broken_bound_padding
;;                 = robust_scm2double (me->get_property ("broken-bound-padding"), 0.0);
;;               extract_grob_set (me, "concurrent-hairpins", chp);

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

;;               for (vsize i = 0; i < chp.size (); i++)
;;                 {
;;                   Spanner *span_elt = dynamic_cast<Spanner *> (chp[i]);
;;                   if (span_elt->get_bound (RIGHT)->break_status_dir () == LEFT)
;;                     broken_bound_padding = max (broken_bound_padding,
;;                                                 robust_scm2double (span_elt->get_property ("broken-bound-padding"), 0.0));
;;                 }

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

;;               x_points[d] -= d * broken_bound_padding;
;;             }
;;         }

                             (interval-dir-set
                              x-points
                              (- (interval-bound x-points dir)
                                (* dir broken-bound-padding))
                              dir)))

;;       else
;;         {
;;           if (Text_interface::has_interface (b))
;;             {
;;               if (!e.is_empty ())
;;                 x_points[d] = e[-d] - d * padding;
;;             }

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

;;           else
;;             {
;;               bool neighbor_found = false;
;;               Spanner *adjacent = NULL;
;;               extract_grob_set (me, "adjacent-spanners", neighbors);

                           (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

;;               for (vsize i = 0; i < neighbors.size (); i++)
;;                 {
;;                   /*
;;                     FIXME: this will f*ck up in case of polyphonic
;;                     notes in other voices. Need to look at note-columns
;;                     in the current staff/voice.
;;                   */
;;                   adjacent = dynamic_cast<Spanner *> (neighbors[i]);
;;                   if (adjacent
;;                       && (adjacent->get_bound (-d)->get_column ()
;;                           == b->get_column ()))
;;                     {
;;                       neighbor_found = true;
;;                       break;
;;                     }
;;                 }

                             (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 (Hairpin::has_interface (adjacent))
;;                     {
;;                       /*
;;                         Handle back-to-back hairpins with a circle in the middle
;;                       */
;;                       if (circled_tip && (grow_dir != d))
;;                         x_points[d] = e.center () + d * (rad - thick / 2.0);
;;                       /*
;;                         If we're hung on a paper column, that means we're not
;;                         adjacent to a text-dynamic, and we may move closer. We
;;                         make the padding a little smaller, here.
;;                       */
;;                       else
;;                         x_points[d] = e.center () - d * padding / 3;
;;                     }
;;                   // Our neighbor is a dynamic text spanner.
;;                   // If we end on the text, pad as for text dynamics
;;                   else if (d == RIGHT)
;;                     x_points[d] = e[-d] - d * padding;
;;                 }

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

;;               else
;;                 {
;;                   if (d == RIGHT // end at the left edge of a rest
;;                       && Note_column::has_interface (b)
;;                       && Note_column::has_rests (b))
;;                     x_points[d] = e[-d];
;;                   else
;;                     x_points[d] = e[d];

                                 (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 (Item::is_non_musical (b))
;;                     x_points[d] -= d * padding;
;;                 }
;;             }
;;         }
;;     }

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

;;   Real width = x_points[RIGHT] - x_points[LEFT];
;;
;;   if (width < 0)
;;     {
;;       me->warning (_ ((grow_dir < 0) ? "decrescendo too small"
;;                       : "crescendo too small"));
;;       width = 0;
;;     }

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

;;   bool continued = broken[Direction (-grow_dir)];
;;   bool continuing = broken[Direction (grow_dir)];

                      (continued (interval-bound broken (other-dir grow-dir)))
                      (continuing (interval-bound broken grow-dir))

;;   Real starth = 0;
;;   Real endh = 0;
;;   if (grow_dir < 0)
;;     {
;;       starth = continuing ? 2 * height / 3 : height;
;;       endh = continued ? height / 3 : 0.0;
;;     }
;;   else
;;     {
;;       starth = continued ? height / 3 : 0.0;
;;       endh = continuing ? 2 * height / 3 : height;
;;     }

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

;;   /*
;;     should do relative to staff-symbol staff-space?
;;   */
;;   Stencil mol;
;;   Real x = 0.0;
;;
;;   /*
;;     Compensate for size of circle
;;   */
;;   Direction tip_dir = -grow_dir;

                      (mol empty-stencil)
                      (x 0.0)
                      (tip-dir (other-dir grow-dir)))

;;   if (circled_tip && !broken[tip_dir])
;;     {
;;       if (grow_dir > 0)
;;         x = rad * 2.0;
;;       else if (grow_dir < 0)
;;         width -= rad * 2.0;
;;     }

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

;;   mol = Line_interface::line (me, Offset (x, starth), Offset (width, endh));
;;   mol.add_stencil (Line_interface::line (me,
;;                                          Offset (x, -starth),
;;                                          Offset (width, -endh)));

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

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

;;   /*
;;     Support al/del niente notation by putting a circle at the
;;     tip of the (de)crescendo.
;;   */
;;   if (circled_tip)
;;     {
;;       Box extent (Interval (-rad, rad), Interval (-rad, rad));
;;
;;       /* Hmmm, perhaps we should have a Lookup::circle () method? */
;;       Stencil circle (extent,
;;                       scm_list_4 (ly_symbol2scm ("circle"),
;;                                   scm_from_double (rad),
;;                                   scm_from_double (thick),
;;                                   SCM_BOOL_F));

                 (if circled-tip
                     (let ((circle (make-circle-stencil rad thick #f)))

;;       /*
;;         don't add another circle if the hairpin is broken
;;       */
;;       if (!broken[tip_dir])
;;         mol.add_at_edge (X_AXIS, tip_dir, Stencil (circle), 0);
;;     }

                       (if (not (interval-bound broken tip-dir))
                           (set! mol
                                 (ly:stencil-combine-at-edge mol X tip-dir circle 0)))))

;;   mol.translate_axis (x_points[LEFT]
;;                       - bounds[LEFT]->relative_coordinate (common, X_AXIS),
;;                       X_AXIS);
;;   return mol.smobbed_copy ();
;; }

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