(pair? (car args)))
(currying-lambda (car args) doc-string?
`((lambda ,(cdr args) ,@body)))
- (if doc-string?
- `(lambda ,args ,doc-string? ,@body)
- `(lambda ,args ,@body))))
+ `(lambda ,args
+ ,(format #f "~a\n~a" (cddr args) (or doc-string? ""))
+ ,@body)))
(set! signature (map (lambda (pred)
(if (pair? pred)
;; defined as a function instead of a list because the
;; all-grob-descriptions alist is not available yet
-(define-public (find-all-space-alist-props grob-descriptions)
- "Used by @code{\\magnifyStaff}. When @var{grob-descriptions} is equal
-to the @code{all-grob-descriptions} alist (defined in
-@file{scm/define-grobs.scm}), this will find all grobs that have an
-initialized value for the @code{space-alist} property, and return them
+(define-public (find-named-props prop-name grob-descriptions)
+ "Used by @code{\\magnifyMusic} and @code{\\magnifyStaff}. When
+@var{grob-descriptions} is equal to the @code{all-grob-descriptions}
+alist (defined in @file{scm/define-grobs.scm}), this will find all grobs
+that can have a value for the @var{prop-name} property, and return them
as a list in the following format:
@example
-'((Ambitus space-alist)
- (BarLine space-alist)
+'((grob prop-name)
+ (grob prop-name)
...)
@end example"
- (define (has-space-alist? grob-desc)
- (ly:assoc-get 'space-alist (cdr grob-desc)))
- (let* ((grob-descriptions-with-space-alist
- (filter has-space-alist? grob-descriptions))
- (grob-names-with-space-alist
- (map car grob-descriptions-with-space-alist)))
- (map (lambda (grob-name) (list grob-name 'space-alist))
- grob-names-with-space-alist)))
+ (define (find-grobs-with-interface interface grob-descriptions)
+ (define (has-this-interface? grob-desc)
+ (let* ((meta (ly:assoc-get 'meta (cdr grob-desc)))
+ (interfaces (ly:assoc-get 'interfaces meta '())))
+ (memq interface interfaces)))
+ (let* ((grob-descriptions-with-this-interface
+ (filter has-this-interface? grob-descriptions))
+ (grob-names-with-this-interface
+ (map car grob-descriptions-with-this-interface)))
+ grob-names-with-this-interface))
+ (let* ((interface
+ (case prop-name
+ ((baseline-skip word-space) 'text-interface)
+ ((space-alist) 'break-aligned-interface)
+ (else (ly:programming-error
+ "find-named-props: no interface associated with ~s"
+ prop-name))))
+ (grobs-with-this-prop
+ (find-grobs-with-interface interface grob-descriptions)))
+ (map (lambda (x) (list x prop-name))
+ grobs-with-this-prop)))
+
(define (magnifyStaff-is-set? context mag)
(let* ((Staff (ly:context-find context 'Staff))
(if (or (eq? func-name 'magnifyMusic)
;; for \magnifyStaff, only scale the fontSize
;; if staff magnification is changing
- (staff-magnification-is-changing? context mag))
+ ;; and does not equal 1
+ (and (staff-magnification-is-changing? context mag)
+ (not (= mag 1))))
(let* ((where (case func-name
((magnifyMusic) context)
((magnifyStaff) (ly:context-find context 'Staff))))
(cons (car x)
(cons (cadr x)
(* mag (cddr x))))))
- (scaled-tuples (map scale-spacing-tuple space-alist))
+ (scaled-tuples (if space-alist
+ (map scale-spacing-tuple space-alist)
+ '()))
(new-alist (append scaled-tuples space-alist)))
(ly:context-pushpop-property where grob prop new-alist))
- (let* ((val (ly:assoc-get prop grob-def 1))
+ (let* ((val (ly:assoc-get prop grob-def (case prop
+ ((baseline-skip) 3)
+ ((word-space) 0.6)
+ (else 1))))
(proc (lambda (x)
(if allowed-to-shrink?
(* x mag)
(if (or (eq? func-name 'magnifyMusic)
;; for \magnifyStaff, only scale the properties
;; if staff magnification is changing
- (staff-magnification-is-changing? context mag))
+ ;; and does not equal 1
+ (and (staff-magnification-is-changing? context mag)
+ (not (= mag 1))))
(for-each scale-prop props)))))
(define-public (revert-props func-name mag props)
(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))))))))
projects / lilypond.git / blobdiff