From baa1692d38a0c89fedcb6cd8ff4c52646ed0acc8 Mon Sep 17 00:00:00 2001
From: Valentin Villenave <valentin@villenave.net>
Date: Tue, 21 Dec 2010 19:43:58 +0100
Subject: [PATCH] new feature: \hairpinText

For now, it will be implemented as a "simple"
override.  Hopefully later it will become a
proper grob.
---
 bin/text.scm       | 30 ++++++++++++++++++++++
 lib/libdynamic.scm | 74 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 104 insertions(+)
 create mode 100644 lib/libdynamic.scm

diff --git a/bin/text.scm b/bin/text.scm
index 87eee54..6e5ce36 100644
--- a/bin/text.scm
+++ b/bin/text.scm
@@ -61,6 +61,36 @@
                                  (markup #:dynamic-string arg)))
                             (else arg)))))
 
+(define *hairpin-text-direction* (make-parameter #f))
+;; Adapted from LSR snippet #233 (from Reinhold?)
+(define hairpinText
+  (define-music-function (parser location text) (markup?)
+    (make-sequential-music
+     (list
+       (make-music
+        'ApplyContext
+        'procedure (lambda (ctx)
+                     (let ((parent-staff (ly:context-id (ly:context-parent ctx)))
+                           (global-dir (assoc-get 'direction
+                                                  (ly:context-grob-definition ctx 'DynamicLineSpanner))))
+                       (*hairpin-text-direction*
+                        (if (or (string-suffix-ci? lang:upper-hand parent-staff)
+                                (eq? global-dir UP))
+                            UP
+                            DOWN)))))
+        (make-music
+         'OverrideProperty
+         'grob-property-path (list 'stencil)
+         'grob-value (lambda (grob)
+                       (ly:stencil-aligned-to
+                        (ly:stencil-combine-at-edge
+                         (ly:stencil-aligned-to (ly:hairpin::print grob) X CENTER)
+                         Y (*hairpin-text-direction*)
+                         (ly:stencil-aligned-to (grob-interpret-markup grob text) X CENTER))
+                        X LEFT))
+         'symbol
+         'Hairpin)))))
+
 (define startText
   (define-music-function (location parser txt) (markup?)
      (make-text-span txt)))
diff --git a/lib/libdynamic.scm b/lib/libdynamic.scm
new file mode 100644
index 0000000..6505bc5
--- /dev/null
+++ b/lib/libdynamic.scm
@@ -0,0 +1,74 @@
+;------------------------------------------------------------------;
+; opus_libre -- libdynamic.scm                                     ;
+;                                                                  ;
+; (c) 2008-2010 Valentin Villenave <valentin@villenave.net>        ;
+;                                                                  ;
+;     opus_libre is a free framework for GNU LilyPond: you may     ;
+; redistribute it and/or modify it under the terms of the GNU      ;
+; General Public License as published by the Free Software         ;
+; Foundation, either version 3 of the License, or (at your option) ;
+; any later version.                                               ;
+;     This program is distributed WITHOUT ANY WARRANTY; without    ;
+; even the implied warranty of MERCHANTABILITY or FITNESS FOR A    ;
+; PARTICULAR PURPOSE.  You should have received a copy of the GNU  ;
+; General Public License along with this program (typically in the ;
+; share/doc/ directory).  If not, see http://www.gnu.org/licenses/ ;
+;                                                                  ;
+;------------------------------------------------------------------;
+
+
+; Dynamic functions.
+
+;; automatic dynamics
+(define (dynamic? x)
+  (let ((name (ly:music-property x 'name)))
+    (or
+     (eq? name 'DynamicEvent)
+     (eq? name 'AbsoluteDynamicEvent)
+     (eq? name 'CrescendoEvent)
+     (eq? name 'DecrescendoEvent)
+     (eq? name 'SpanDynamicEvent))))
+
+(define keepDyn
+;; Tag all dynamics in MUSIC.
+  (define-music-function (parser location music) (ly:music?)
+    (music-filter
+     (lambda (x)
+       (if (dynamic? x)
+           (set! (ly:music-property x 'tags)
+                 (cons 'staff-dynamics
+                       (ly:music-property x 'tags))))
+       x) music)))
+
+(define removeDynamics
+;; Remove untagged dynamics.
+  (define-music-function (parser location music) (ly:music?)
+    (if (ly:get-option 'no-auto-piano-dynamics)
+        music
+        (music-filter
+         (lambda (x)
+           (let ((tags (ly:music-property x 'tags))
+                 (dir (ly:music-property x 'direction)))
+             (not (and
+                   (dynamic? x)
+                   (not (memq 'staff-dynamics tags))
+                   (null? dir)))))
+         music))))
+
+(define filterDynamics
+;; Like \removeWithTag, but will not affect other contexts
+;; (i.e. no \change, no \bar or \time etc.)
+  (define-music-function (parser location music) (ly:music?)
+    (if (ly:get-option 'no-auto-piano-dynamics)
+        (make-music 'Music 'void #t)
+        (music-filter
+          (lambda (x)
+            (let ((name (ly:music-property x 'name))
+                  (tags (ly:music-property x 'tags))
+                  (dir (ly:music-property x 'direction)))
+              (not (or
+                    (eq? name 'ContextChange)
+                    ;(eq? name 'ContextSpeccedMusic)
+                    (memq 'staff-dynamics tags)
+                    (not (null? dir))))))
+          music))))
-- 
2.11.4.GIT