Function for overriding broken spanners

The music function \alterBroken is intended to facilitate overrides
applied independently to the pieces of broken spanners--one of the
perennial difficulties faced by users of LilyPond (addressed in
Extending 2.6:"Difficult Tweaks").  The function aims at generalization
by allowing the user to specify the name of the spanner and the property
to be overridden.

The function will override unbroken spanners, but it will ignore
non-spanners with a warning.

The function calls \override and may be prefaced by \once (or followed by
a \revert of the relevant property).

3 files changed, 96 insertions, 0 deletions

diff --git a/input/regression/alter-broken.ly b/input/regression/alter-broken.ly
new file mode 100644
index 0000000000..4f03f4d6e7
--- /dev/null
+++ b/input/regression/alter-broken.ly
@@ -0,0 +1,45 @@
+\version "2.15.42"
+
+\header {
+  texidoc = "The command @code{\\alterBroken} may be used to override the
+pieces of a broken spanner independently.  The following example demonstrates
+its usage with a variety of data types."
+}
+
+\layout {
+  ragged-right = ##t
+}
+
+#(ly:expect-warning (_ "not a spanner name"))
+
+\relative c'' {
+  \alterBroken Slur #'positions #'((3 . 3) (5 . 5))
+  \alterBroken Slur #'color #'((0 0 1) (1 0 0))
+  \alterBroken Slur #'dash-definition #'( ((0 1 0.4 0.75))
+                                          ((0 0.5 0.4 0.75) (0.5 1 1 1)) )
+  d4( d' b g
+  \break
+  d d' b g)
+  \alterBroken "Staff.OttavaBracket" #'padding #'(1 3)
+  % Spaces in spanner's name are disregarded.
+  \alterBroken "Staff . OttavaBracket" #'style #'(line dashed-line)
+  \ottava #1
+  % It is possible to use procedures as arguments.
+  \alterBroken Hairpin #'stencil #`(
+    ,ly:hairpin::print
+    ,(lambda (grob)
+      (ly:stencil-rotate (ly:hairpin::print grob) -5 0 0)))
+  c\< d e
+  % Since `NoteHead' is not the name of a spanner, the following has no
+  % effect on layout.  A warning (suppressed here) is issued.
+  \alterBroken NoteHead #'color #`(,red ,blue)
+  \alterBroken Tie #'color #`(() ,blue)
+  \alterBroken Tie #'control-points #'(
+     ((1 . 3) (2 . 4) (3 . 4) (4 . 3))
+     ((3 . 3) (4 . 4) (5 . 4) (6 . 3))
+    )
+  f~
+  \break
+  f c a f\!
+  \ottava #0
+}
diff --git a/ly/music-functions-init.ly b/ly/music-functions-init.ly
index 45f9a13638..95bf9ce08a 100644
--- a/ly/music-functions-init.ly
+++ b/ly/music-functions-init.ly
@@ -85,6 +85,37 @@ markups), or inside a score.")
 	       'elements (list (make-music 'PageTurnEvent
 					   'break-permission 'allow))))
 
+alterBroken =
+#(define-music-function (parser location name property arg)
+  (string? scheme? list?)
+  (_i "Override @var{property} for pieces of broken spanner @var{name} with
+values @var{arg}.")
+  (let* ((name (string-delete name char-set:blank)) ; remove any spaces
+         (name-components (string-split name #\.))
+         (context-name "Bottom")
+         (grob-name #f))
+
+    (if (> 2 (length name-components))
+        (set! grob-name (car name-components))
+        (begin
+          (set! grob-name (cadr name-components))
+          (set! context-name (car name-components))))
+
+    ;; only apply override if grob is a spanner
+    (let ((description
+            (assoc-get (string->symbol grob-name) all-grob-descriptions)))
+      (if (and description
+               (member 'spanner-interface
+                       (assoc-get 'interfaces
+                                  (assoc-get 'meta description))))
+          #{
+            \override $context-name . $grob-name $property =
+              #(value-for-spanner-piece arg)
+          #}
+          (begin
+            (ly:input-warning location (_ "not a spanner name, `~a'") grob-name)
+            (make-music 'SequentialMusic 'void #t))))))
+
 appendToTag =
 #(define-music-function (parser location tag more music)
    (symbol? ly:music? ly:music?)
diff --git a/scm/music-functions.scm b/scm/music-functions.scm
index ec264b700a..6e3f79cb5f 100644
--- a/scm/music-functions.scm
+++ b/scm/music-functions.scm
@@ -1856,3 +1856,23 @@ other stems just because of that."
       ((process-acknowledged trans)
         (make-stem-spans! ctx stems trans)
         (set! stems '())))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; The following is used by the alterBroken function.
+
+(define-public ((value-for-spanner-piece arg) grob)
+  "Associate a piece of broken spanner @var{grob} with an element
+of list @var{arg}."
+  (let* ((orig (ly:grob-original grob))
+         (siblings (ly:spanner-broken-into orig)))
+
+   (define (helper sibs arg)
+     (if (null? arg)
+         arg
+         (if (eq? (car sibs) grob)
+             (car arg)
+             (helper (cdr sibs) (cdr arg)))))
+
+   (if (>= (length siblings) 2)
+       (helper siblings arg)
+       (car arg))))