X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fmusic-functions.scm;h=4ba6c6517ba534fae13cb932f0a030ef893e14cf;hb=47db9a3883d726ca53e2133a3b2298f78dd6a32e;hp=2638e9997952bb75899a7148f9bc752e30553d63;hpb=730d4eb3e0328e8ba0b376f8191a5bb6ae7f904c;p=lilypond.git diff --git a/scm/music-functions.scm b/scm/music-functions.scm index 2638e99979..4ba6c6517b 100644 --- a/scm/music-functions.scm +++ b/scm/music-functions.scm @@ -1,6 +1,6 @@ ;;;; This file is part of LilyPond, the GNU music typesetter. ;;;; -;;;; Copyright (C) 1998--2014 Jan Nieuwenhuizen +;;;; Copyright (C) 1998--2015 Jan Nieuwenhuizen ;;;; Han-Wen Nienhuys ;;;; ;;;; LilyPond is free software: you can redistribute it and/or modify @@ -751,7 +751,11 @@ duration is replaced with the specified @var{duration}." (set! (ly:music-property m 'articulations) (set-origin! (filter! keep-element? arts)))) (if (ly:duration? (ly:music-property m 'duration)) - (set! (ly:music-property m 'duration) duration)))) + (set! (ly:music-property m 'duration) duration)) + (if (ly:music-property m 'cautionary #f) + (set! (ly:music-property m 'cautionary) #f)) + (if (ly:music-property m 'force-accidental #f) + (set! (ly:music-property m 'force-accidental) #f)))) elts) (append! elts (ly:music-property repeat-chord 'elements)))) (let ((arts (filter keep-element? @@ -825,7 +829,10 @@ from the predecessor note/chord if available." m) (cond ((music-is-of-type? m 'event-chord) - (set-and-ret m)) + (if (any (lambda (m) (music-is-of-type? m 'rhythmic-event)) + (ly:music-property m 'elements)) + (set! last-pitch m)) + m) ((music-is-of-type? m 'note-event) (cond ((or (ly:music-property m 'pitch #f) @@ -1076,9 +1083,9 @@ result." (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) @@ -2234,66 +2241,6 @@ of list @var{arg}." (car arg)))) (export value-for-spanner-piece) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; measure counter - -(define (measure-counter-stencil grob) - "Print a number for a measure count. The number is centered using -the extents of @code{BreakAlignment} grobs associated with -@code{NonMusicalPaperColumn} grobs. In the case of an unbroken measure, these -columns are the left and right bounds of a @code{MeasureCounter} spanner. -Broken measures are numbered in parentheses." - (let* ((orig (ly:grob-original grob)) - (siblings (ly:spanner-broken-into orig)) ; have we been split? - (bounds (ly:grob-array->list (ly:grob-object grob 'columns))) - (refp (ly:grob-system grob)) - ;; we use the first and/or last NonMusicalPaperColumn grob(s) of - ;; a system in the event that a MeasureCounter spanner is broken - (all-cols (ly:grob-array->list (ly:grob-object refp 'columns))) - (all-cols - (filter - (lambda (col) (eq? #t (ly:grob-property col 'non-musical))) - all-cols)) - (left-bound - (if (or (null? siblings) ; spanner is unbroken - (eq? grob (car siblings))) ; or the first piece - (car bounds) - (car all-cols))) - (right-bound - (if (or (null? siblings) - (eq? grob (car (reverse siblings)))) - (car (reverse bounds)) - (car (reverse all-cols)))) - (elts-L (ly:grob-array->list (ly:grob-object left-bound 'elements))) - (elts-R (ly:grob-array->list (ly:grob-object right-bound 'elements))) - (break-alignment-L - (filter - (lambda (elt) (grob::has-interface elt 'break-alignment-interface)) - elts-L)) - (break-alignment-R - (filter - (lambda (elt) (grob::has-interface elt 'break-alignment-interface)) - elts-R)) - (break-alignment-L-ext (ly:grob-extent (car break-alignment-L) refp X)) - (break-alignment-R-ext (ly:grob-extent (car break-alignment-R) refp X)) - (num (markup (number->string (ly:grob-property grob 'count-from)))) - (num - (if (or (null? siblings) - (eq? grob (car siblings))) - num - (make-parenthesize-markup num))) - (num (grob-interpret-markup grob num)) - (num (ly:stencil-aligned-to num X (ly:grob-property grob 'self-alignment-X))) - (num - (ly:stencil-translate-axis - num - (+ (interval-length break-alignment-L-ext) - (* 0.5 - (- (car break-alignment-R-ext) - (cdr break-alignment-L-ext)))) - X))) - num)) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; The following are used by the \offset function @@ -2393,25 +2340,39 @@ Offsets are restricted to immutable properties and values of type @code{number}, ;; 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)) @@ -2433,7 +2394,9 @@ magnification factor @var{mag}. @var{func-name} is either (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)))) @@ -2508,10 +2471,15 @@ formatted like: (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) @@ -2524,7 +2492,9 @@ formatted like: (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) @@ -2576,3 +2546,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))))))))