From bbfb7404fbc6e58ac4a48e7e79a61f3cee768e6f Mon Sep 17 00:00:00 2001
From: Mike Solomon <mike@apollinemike.com>
Date: Thu, 28 Mar 2013 20:18:55 +0100
Subject: [PATCH] Adds hairpins from Ferneyhough scores to LilyPond.

The two new commands are:

  * flared-hairpin. Creates a hairpin that is skinny for the bulk
    of its duration and has a flare at the end.
  * constante-hairpin. Creates a hairpin maintaining a dynamic over
    a duration.
---
 input/regression/ferneyhough-hairpins.ly | 25 ++++++++
 scm/bar-line.scm                         |  7 ---
 scm/output-lib.scm                       | 72 ++++++++++++++++++++++++
 3 files changed, 97 insertions(+), 7 deletions(-)
 create mode 100644 input/regression/ferneyhough-hairpins.ly

diff --git a/input/regression/ferneyhough-hairpins.ly b/input/regression/ferneyhough-hairpins.ly
new file mode 100644
index 0000000000..000d9da403
--- /dev/null
+++ b/input/regression/ferneyhough-hairpins.ly
@@ -0,0 +1,25 @@
+\version "2.17.14"
+
+\header {
+  texidoc = "LilyPond creates hairpins found in Ferneyhough scores.
+"
+}
+
+\relative c'' {
+  \override Hairpin #'stencil = #flared-hairpin
+  a4\< a a a\f
+  a4\p\< a a a\ff
+  a4\sfz\< a a a\!
+  \override Hairpin #'stencil = #constante-hairpin
+  a4\< a a a\f
+  a4\p\< a a a\ff
+  a4\sfz\< a a a\!
+  \override Hairpin #'stencil = #flared-hairpin
+  a4\> a a a\f
+  a4\p\> a a a\ff
+  a4\sfz\> a a a\!
+  \override Hairpin #'stencil = #constante-hairpin
+  a4\> a a a\f
+  a4\p\> a a a\ff
+  a4\sfz\> a a a\!
+}
\ No newline at end of file
diff --git a/scm/bar-line.scm b/scm/bar-line.scm
index 8ac123e11e..e23ff8c0f2 100644
--- a/scm/bar-line.scm
+++ b/scm/bar-line.scm
@@ -68,13 +68,6 @@ Pad the string with @code{annotation-char}s to the length of the
 
         blot-diameter))
 
-(define (layout-line-thickness grob)
-  "Get the line thickness of the @var{grob}'s corresponding layout."
-  (let* ((layout (ly:grob-layout grob))
-         (line-thickness (ly:output-def-lookup layout 'line-thickness)))
-
-        line-thickness))
-
 (define (staff-symbol-line-count staff)
   "Get or compute the number of lines of staff @var{staff}."
   (let ((line-count 0))
diff --git a/scm/output-lib.scm b/scm/output-lib.scm
index f52203468e..4533cf2a96 100644
--- a/scm/output-lib.scm
+++ b/scm/output-lib.scm
@@ -99,6 +99,13 @@
 (define-public grob::always-Y-extent-from-stencil
   (ly:make-unpure-pure-container ly:grob::stencil-height))
 
+(define-public (layout-line-thickness grob)
+  "Get the line thickness of the @var{grob}'s corresponding layout."
+  (let* ((layout (ly:grob-layout grob))
+         (line-thickness (ly:output-def-lookup layout 'line-thickness)))
+
+        line-thickness))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; beam slope
 
@@ -1008,6 +1015,71 @@ between the two text elements."
 					     '(bound-details left padding)
 					     (+ my-padding script-padding)))))))
 
+(define-public ((elbowed-hairpin coords mirrored?) grob)
+  "Create hairpin based on a list of @var{coords} in @code{(cons x y)}
+form.  @code{x} is the portion of the width consumed for a given line
+and @code{y} is the portion of the height.  For example,
+@code{'((0.3 . 0.7) (0.8 . 0.9) (1.0 . 1.0))} means that at the point
+where the hairpin has consumed 30% of its width, it must
+be at 70% of its height.  Once it is to 80% width, it
+must be at 90% height.  It finishes at
+100% width and 100% height.  @var{mirrored?} indicates if the hairpin
+is mirrored over the Y-axis or if just the upper part is drawn.
+Returns a function that accepts a hairpin grob as an argument
+and draws the stencil based on its coordinates.
+@lilypond[verbatim,quote]
+#(define simple-hairpin
+  (elbowed-hairpin '((1.0 . 1.0)) #t))
+
+\\relative c' {
+  \\override Hairpin #'stencil = #simple-hairpin
+  a\\p\\< a a a\\f
+}
+@end lilypond
+"
+  (define (pair-to-list pair)
+    (list (car pair) (cdr pair)))
+  (define (normalize-coords goods x y)
+    (map
+      (lambda (coord)
+        (cons (* x (car coord)) (* y (cdr coord))))
+      goods))
+  (define (my-c-p-s points thick decresc?)
+    (make-connected-path-stencil
+      points
+      thick
+      (if decresc? -1.0 1.0)
+      1.0
+      #f
+      #f))
+  ; outer let to trigger suicide
+  (let ((sten (ly:hairpin::print grob)))
+    (if (grob::is-live? grob)
+      (let* ((decresc? (eq? (ly:grob-property grob 'grow-direction) LEFT))
+             (thick (ly:grob-property grob 'thickness 0.1))
+             (thick (* thick (layout-line-thickness grob)))
+             (xex (ly:stencil-extent sten X))
+             (lenx (interval-length xex))
+             (yex (ly:stencil-extent sten Y))
+             (leny (interval-length yex))
+             (xtrans (+ (car xex) (if decresc? lenx 0)))
+             (ytrans (car yex))
+             (uplist (map pair-to-list
+                          (normalize-coords coords lenx (/ leny 2))))
+             (downlist (map pair-to-list
+                            (normalize-coords coords lenx (/ leny -2)))))
+      (ly:stencil-translate
+        (ly:stencil-add
+          (my-c-p-s uplist thick decresc?)
+          (if mirrored? (my-c-p-s downlist thick decresc?) empty-stencil))
+        (cons xtrans ytrans)))
+      '())))
+
+(define-public flared-hairpin
+  (elbowed-hairpin '((0.95 . 0.4) (1.0 . 1.0)) #t))
+
+(define-public constante-hairpin
+  (elbowed-hairpin '((1.0 . 0.0) (1.0 . 1.0)) #f))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; lyrics
-- 
2.39.2