Issue 4083: Implement \tagGroup command

diff --git a/ly/music-functions-init.ly b/ly/music-functions-init.ly
index 477c9c6538172a9b098b831c7542d9155ea1b3aa..6bb98c6c801f3c024eb3fce3c43755fd7376e5ab 100644 (file)
--- a/ly/music-functions-init.ly
+++ b/ly/music-functions-init.ly
@@ -554,21 +554,18 @@ instrumentSwitch =
 
 
 keepWithTag =
-#(define-music-function (parser location tag music)
+#(define-music-function (parser location tags music)
    (symbol-list-or-symbol? ly:music?)
-   (_i "Include only elements of @var{music} that are either untagged
-or tagged with one of the tags in @var{tag}.  @var{tag} may be either
-a single symbol or a list of symbols.")
+   (_i "Include only elements of @var{music} that are tagged with one
+of the tags in @var{tags}.  @var{tags} may be either a single symbol
+or a list of symbols.
+
+Each tag may be declared as a member of at most one tag group (defined
+with @code{\\tagGroup}).  If none of a @var{music} element's tags
+share a tag group with one of the specified @var{tags}, the element is
+retained.")
    (music-filter
-    (if (symbol? tag)
-        (lambda (m)
-          (let ((music-tags (ly:music-property m 'tags)))
-            (or (null? music-tags)
-                (memq tag music-tags))))
-        (lambda (m)
-          (let ((music-tags (ly:music-property m 'tags)))
-            (or (null? music-tags)
-                (any (lambda (t) (memq t music-tags)) tag)))))
+    (tags-keep-predicate tags)
     music))
 
 key =
@@ -1261,19 +1258,13 @@ omitted, the first note in @var{music} is given in absolute pitch.")
               'element music))
 
 removeWithTag =
-#(define-music-function (parser location tag music)
+#(define-music-function (parser location tags music)
    (symbol-list-or-symbol? ly:music?)
    (_i "Remove elements of @var{music} that are tagged with one of the
-tags in @var{tag}.  @var{tag} may be either a single symbol or a list
+tags in @var{tags}.  @var{tags} may be either a single symbol or a list
 of symbols.")
    (music-filter
-    (if (symbol? tag)
-        (lambda (m)
-          (not (memq tag (ly:music-property m 'tags))))
-        (lambda (m)
-          (let ((music-tags (ly:music-property m 'tags)))
-            (or (null? music-tags)
-                (not (any (lambda (t) (memq t music-tags)) tag))))))
+    (tags-remove-predicate tags)
     music))
 
 resetRelativeOctave =
@@ -1469,18 +1460,25 @@ styledNoteHeads =
    (style-note-heads heads style music))
 
 tag =
-#(define-music-function (parser location tag music) (symbol-list-or-symbol? ly:music?)
-   (_i "Tag the following @var{music} with @var{tag} and return the
-result, by adding the single symbol or symbol list @var{tag} to the
+#(define-music-function (parser location tags music) (symbol-list-or-symbol? ly:music?)
+   (_i "Tag the following @var{music} with @var{tags} and return the
+result, by adding the single symbol or symbol list @var{tags} to the
 @code{tags} property of @var{music}.")
 
    (set!
     (ly:music-property music 'tags)
-    ((if (symbol? tag) cons append)
-     tag
+    ((if (symbol? tags) cons append)
+     tags
      (ly:music-property music 'tags)))
    music)
 
+tagGroup =
+#(define-void-function (parser location tags) (symbol-list?)
+   (_i "Define a tag group comprising the symbols in the symbol list
+@var{tags}.  Tag groups must not overlap.")
+   (let ((err (define-tag-group tags)))
+     (if err (ly:parser-error parser err location))))
+
 temporary =
 #(define-music-function (parser location music)
    (ly:music?)

diff --git a/scm/music-functions.scm b/scm/music-functions.scm
index 4a97c1c664f635417366382c51e42891ab209228..0c8e7b7cab10c6d5fba17e0a1e6bc30460a611d5 100644 (file)
--- a/scm/music-functions.scm
+++ b/scm/music-functions.scm
@@ -2599,3 +2599,63 @@ scaling, then does the equivalent of a
              (scaled-default (+ 119/925 (* mag 13/37)))
              (new-val (* scaled-default ratio-to-default)))
         (ly:context-pushpop-property context 'Beam 'beam-thickness new-val)))))
+
+;; tag management
+;;
+
+(define tag-groups (make-hash-table))
+(call-after-session (lambda () (hash-clear! tag-groups)))
+
+(define-public (define-tag-group tags)
+  "Define a tag-group consisting of the given @var{tags}, a@tie{}list
+of symbols.  Returns @code{#f} if successful, and an error message if
+there is a conflicting tag group definition."
+  (cond ((not (symbol-list? tags)) (format #f (_ "not a symbol list: ~a") tags))
+        ((any (lambda (tag) (hashq-ref tag-groups tag)) tags)
+         => (lambda (group) (and (not (lset= eq? group tags))
+                                 (format #f (_ "conflicting tag group ~a") group))))
+        (else
+         (for-each
+          (lambda (elt) (hashq-set! tag-groups elt tags))
+          tags)
+         #f)))
+
+(define-public (tag-group-get tag)
+  "Return the tag group (as a list of symbols) that the given
+@var{tag} symbol belongs to, @code{#f} if none."
+  (hashq-ref tag-groups tag))
+
+(define-public (tags-remove-predicate tags)
+  "Returns a predicate that returns @code{#f} for any music that is to
+be removed by @{\\removeWithTag} on the given symbol or list of
+symbols @var{tags}."
+  (if (symbol? tags)
+      (lambda (m)
+        (not (memq tags (ly:music-property m 'tags))))
+      (lambda (m)
+        (not (any (lambda (t) (memq t tags))
+                  (ly:music-property m 'tags))))))
+
+(define-public (tags-keep-predicate tags)
+  "Returns a predicate that returns @code{#f} for any music that is to
+be removed by @{\\keepWithTag} on the given symbol or list of symbols
+@var{tags}."
+  (if (symbol? tags)
+      (let ((group (tag-group-get tags)))
+        (lambda (m)
+          (let ((music-tags (ly:music-property m 'tags)))
+            (or
+             (null? music-tags) ; redundant but very frequent
+             ;; We know of only one tag to keep.  Either we find it in
+             ;; the music tags, or all music tags must be from a
+             ;; different group
+             (memq tags music-tags)
+             (not (any (lambda (t) (eq? (tag-group-get t) group)) music-tags))))))
+      (let ((groups (delete-duplicates (map tag-group-get tags) eq?)))
+        (lambda (m)
+          (let ((music-tags (ly:music-property m 'tags)))
+            (or
+             (null? music-tags) ; redundant but very frequent
+             (any (lambda (t) (memq t tags)) music-tags)
+             ;; if no tag matches, no tag group should match either
+             (not (any (lambda (t) (memq (tag-group-get t) groups)) music-tags))))))))