From ddfb847ea13c58568e14abd5b6845faa1c077399 Mon Sep 17 00:00:00 2001 From: David Kastrup Date: Tue, 2 Sep 2014 12:21:20 +0200 Subject: [PATCH] Issue 4083: Implement \tagGroup command --- ly/music-functions-init.ly | 52 ++++++++++++++++----------------- scm/music-functions.scm | 60 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 85 insertions(+), 27 deletions(-) diff --git a/ly/music-functions-init.ly b/ly/music-functions-init.ly index 477c9c6538..6bb98c6c80 100644 --- 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 4a97c1c664..0c8e7b7cab 100644 --- 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)))))))) -- 2.39.2