X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fmusic-functions.scm;h=611879ae8b517ec9bb23d3507d1cdd3b10af84b6;hb=5a6340b7f319802a7313c0e6b82eef96909cde42;hp=791547706f4e8f6faf302bbd0e46a72a5dcb575b;hpb=49adeb064850d230ef3f1163aa29cfa5930f996e;p=lilypond.git diff --git a/scm/music-functions.scm b/scm/music-functions.scm index 791547706f..611879ae8b 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 @@ -234,8 +234,7 @@ which often can be read back in order to generate an equivalent expression." "Display the music expression using LilyPond syntax" (memoize-clef-names supported-clefs) (parameterize ((*indent* 0) - (*previous-duration* (ly:make-duration 2)) - (*force-duration* force-duration)) + (*omit-duration* #f)) (display (music->lily-string expr parser) port) (newline port))) @@ -400,18 +399,7 @@ beats to be distinguished." (lambda (m) (and (music-is-of-type? m 'unfolded-repeated-music) (make-sequential-music - (ly:music-deep-copy - (let ((n (ly:music-property m 'repeat-count)) - (alts (ly:music-property m 'elements)) - (body (ly:music-property m 'element))) - (cond ((<= n 0) '()) - ((null? alts) (make-list n body)) - (else - (concatenate - (zip (make-list n body) - (append! (make-list (max 0 (- n (length alts))) - (car alts)) - alts)))))))))) + (ly:music-deep-copy (make-unfolded-set m))))) (unfold-repeats music))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -751,7 +739,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 +817,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) @@ -1067,10 +1062,6 @@ value (evaluated at definition time). An optional parameter can be omitted in a call only when it can't get confused with a following parameter of different type. -Predicates with syntactical significance are @code{ly:pitch?}, -@code{ly:duration?}, @code{ly:music?}, @code{markup?}. Other -predicates require the parameter to be entered as Scheme expression. - @code{result-type?} can specify a default in the same manner as predicates, to be used in case of a type error in arguments or result." @@ -1080,9 +1071,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) @@ -1121,10 +1112,6 @@ value (evaluated at definition time). An optional parameter can be omitted in a call only when it can't get confused with a following parameter of different type. -Predicates with syntactical significance are @code{ly:pitch?}, -@code{ly:duration?}, @code{ly:music?}, @code{markup?}. Other -predicates require the parameter to be entered as Scheme expression. - Must return a music expression. The @code{origin} is automatically set to the @code{location} parameter." @@ -1145,10 +1132,6 @@ value (evaluated at definition time). An optional parameter can be omitted in a call only when it can't get confused with a following parameter of different type. -Predicates with syntactical significance are @code{ly:pitch?}, -@code{ly:duration?}, @code{ly:music?}, @code{markup?}. Other -predicates require the parameter to be entered as Scheme expression. - Can return arbitrary expressions. If a music expression is returned, its @code{origin} is automatically set to the @code{location} parameter." @@ -1177,10 +1160,6 @@ value (evaluated at definition time). An optional parameter can be omitted in a call only when it can't get confused with a following parameter of different type. -Predicates with syntactical significance are @code{ly:pitch?}, -@code{ly:duration?}, @code{ly:music?}, @code{markup?}. Other -predicates require the parameter to be entered as Scheme expression. - Must return an event expression. The @code{origin} is automatically set to the @code{location} parameter." @@ -1580,7 +1559,8 @@ For convenience, returns @code{0} if entry is @code{#f}." 0)) (define-public (find-pitch-entry keysig pitch accept-global accept-local) - "Return the first entry in @var{keysig} that matches @var{pitch}. + "Return the first entry in @var{keysig} that matches @var{pitch} +by notename and octave. Alteration is not considered. @var{accept-global} states whether key signature entries should be included. @var{accept-local} states whether local accidentals should be included. If no matching entry is found, @var{#f} is returned." @@ -1620,15 +1600,19 @@ look at bar lines nor different accidentals at the same note name." note (just as in the dodecaphonic accidental style) @emph{except} if the note is immediately preceded by a note with the same pitch. This is a common accidental style in contemporary notation." - (let* ((keysig (ly:context-property context 'localKeySignature)) - (entry (find-pitch-entry keysig pitch #t #t))) + (let* ((keysig (ly:context-property context 'localAlterations)) + (entry (find-pitch-entry keysig pitch #f #t))) (if (not entry) - (cons #f #t) - (let* ((entrymp (key-entry-measure-position entry)) - (entrybn (key-entry-bar-number entry))) - (cons #f - (not - (and (equal? entrybn barnum) (equal? entrymp measurepos)))))))) + (cons #f #t) + (let ((entrymp (key-entry-measure-position entry)) + (entrybn (key-entry-bar-number entry)) + (entryalt (key-entry-alteration entry)) + (alt (ly:pitch-alteration pitch))) + (cons #t + (not (and (equal? entrybn barnum) + (or (equal? measurepos entrymp) + (ly:momentlist (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 @@ -2400,37 +2323,124 @@ Offsets are restricted to immutable properties and values of type @code{number}, self) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; The following are used by \magnifyMusic +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; \magnifyMusic and \magnifyStaff -(define-public (scale-fontSize mag) - "Used by @code{\\magnifyMusic}. Look up the current fontSize and -scale it by the magnification factor @var{mag}." +;; defined as a function instead of a list because the +;; all-grob-descriptions alist is not available yet +(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 +'((grob prop-name) + (grob prop-name) + ...) +@end example" + (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)) + (old-mag (ly:context-property Staff 'magnifyStaffValue))) + (not (null? old-mag)))) + +(define (staff-magnification-is-changing? context mag) + (let* ((Staff (ly:context-find context 'Staff)) + (old-mag (ly:context-property Staff 'magnifyStaffValue 1))) + (not (= old-mag mag)))) + +(define-public (scale-fontSize func-name mag) + "Used by @code{\\magnifyMusic} and @code{\\magnifyStaff}. Look up the +current @code{fontSize} in the appropriate context and scale it by the +magnification factor @var{mag}. @var{func-name} is either +@code{'magnifyMusic} or @code{'magnifyStaff}." (make-apply-context (lambda (context) - (let* ((fontSize (ly:context-property context 'fontSize 0)) - (new-fontSize (+ fontSize (magnification->font-size mag)))) - (ly:context-set-property! context 'fontSize new-fontSize))))) - -(define-public (revert-fontSize mag) - "Used by @code{\\magnifyMusic}. Calculate the previous fontSize value -(before scaling) by factoring out the magnification factor @var{mag}." + (if (or (eq? func-name 'magnifyMusic) + ;; for \magnifyStaff, only scale the fontSize + ;; if staff magnification is changing + ;; 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)))) + (fontSize (ly:context-property where 'fontSize 0)) + (new-fontSize (+ fontSize (magnification->font-size mag)))) + (ly:context-set-property! where 'fontSize new-fontSize)))))) + +(define-public (revert-fontSize func-name mag) + "Used by @code{\\magnifyMusic} and @code{\\magnifyStaff}. Calculate +the previous @code{fontSize} value (before scaling) by factoring out the +magnification factor @var{mag} (if @var{func-name} is +@code{'magnifyMusic}), or by factoring out the context property +@code{magnifyStaffValue} (if @var{func-name} is @code{'magnifyStaff}). +Revert the @code{fontSize} in the appropriate context accordingly. + +With @code{\\magnifyMusic}, the scaling is reverted after the music +block it operates on. @code{\\magnifyStaff} does not operate on a music +block, so the scaling from a previous call (if there is one) is reverted +before the new scaling takes effect." (make-apply-context (lambda (context) - (let* ((fontSize (ly:context-property context 'fontSize 0)) - (old-fontSize (- fontSize (magnification->font-size mag)))) - (ly:context-set-property! context 'fontSize old-fontSize))))) - -(define-public (scale-props props mag allowed-to-shrink?) - "Used by @code{\\magnifyMusic}. For each prop in @var{props}, find -the current value of the requested prop, scale it by the magnification -factor @var{mag}, and do the equivalent of a -@code{\\temporary@tie{}\\override} with the new value. If -@code{allowed-to-shrink?} is @code{#f}, don't let the new value be less -than the current value. Props are formatted like: - + (if (or (eq? func-name 'magnifyMusic) + ;; for \magnifyStaff... + (and + ;; don't revert the user's fontSize choice + ;; the first time \magnifyStaff is called + (magnifyStaff-is-set? context mag) + ;; only revert the previous fontSize + ;; if staff magnification is changing + (staff-magnification-is-changing? context mag))) + (let* ((where + (case func-name + ((magnifyMusic) context) + ((magnifyStaff) (ly:context-find context 'Staff)))) + (old-mag + (case func-name + ((magnifyMusic) mag) + ((magnifyStaff) + (ly:context-property where 'magnifyStaffValue 1)))) + (fontSize (ly:context-property where 'fontSize 0)) + (old-fontSize (- fontSize (magnification->font-size old-mag)))) + (ly:context-set-property! where 'fontSize old-fontSize)))))) + +(define-public (scale-props func-name mag allowed-to-shrink? props) + "Used by @code{\\magnifyMusic} and @code{\\magnifyStaff}. For each +prop in @var{props}, find the current value of the requested prop, scale +it by the magnification factor @var{mag}, and do the equivalent of a +@code{\\temporary@tie{}\\override} with the new value in the appropriate +context. If @var{allowed-to-shrink?} is @code{#f}, don't let the new +value be less than the current value. @var{func-name} is either +@code{'magnifyMusic} or @code{'magnifyStaff}. The @var{props} list is +formatted like: @example -'(Slur height-limit) +'((Stem thickness) + (Slur line-thickness) + ...) @end example" (make-apply-context (lambda (context) @@ -2439,23 +2449,78 @@ than the current value. Props are formatted like: (prop (cadr grob-prop-list)) (where (if (eq? grob 'SpacingSpanner) (ly:context-find context 'Score) - context)) - (grob-def (ly:context-grob-definition where grob)) - (val (ly:assoc-get prop grob-def 1)) - (proc (lambda (x) - (if allowed-to-shrink? - (* x mag) - (* x (max 1 mag))))) - (new-val (if (number-pair? val) - (cons (proc (car val)) - (proc (cdr val))) - (proc val)))) - (ly:context-pushpop-property where grob prop new-val))) - (for-each scale-prop props)))) - + (case func-name + ((magnifyMusic) context) + ((magnifyStaff) (ly:context-find context 'Staff))))) + (grob-def (ly:context-grob-definition where grob))) + (if (eq? prop 'space-alist) + (let* ((space-alist (ly:assoc-get prop grob-def)) + (scale-spacing-tuple (lambda (x) + (cons (car x) + (cons (cadr x) + (* mag (cddr x)))))) + (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 (case prop + ((baseline-skip) 3) + ((word-space) 0.6) + (else 1)))) + (proc (lambda (x) + (if allowed-to-shrink? + (* x mag) + (* x (max 1 mag))))) + (new-val (if (number-pair? val) + (cons (proc (car val)) + (proc (cdr val))) + (proc val)))) + (ly:context-pushpop-property where grob prop new-val))))) + (if (or (eq? func-name 'magnifyMusic) + ;; for \magnifyStaff, only scale the properties + ;; if staff magnification is changing + ;; 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) + "Used by @code{\\magnifyMusic} and @code{\\magnifyStaff}. Revert each +prop in @var{props} in the appropriate context. @var{func-name} is +either @code{'magnifyMusic} or @code{'magnifyStaff}. The @var{props} +list is formatted like: +@example +'((Stem thickness) + (Slur line-thickness) + ...) +@end example" + (make-apply-context + (lambda (context) + (define (revert-prop grob-prop-list) + (let* ((grob (car grob-prop-list)) + (prop (cadr grob-prop-list)) + (where (if (eq? grob 'SpacingSpanner) + (ly:context-find context 'Score) + (case func-name + ((magnifyMusic) context) + ((magnifyStaff) (ly:context-find context 'Staff)))))) + (ly:context-pushpop-property where grob prop))) + (if (or (eq? func-name 'magnifyMusic) + ;; for \magnifyStaff... + (and + ;; don't revert the user's property overrides + ;; the first time \magnifyStaff is called + (magnifyStaff-is-set? context mag) + ;; revert the overrides from the previous \magnifyStaff, + ;; but only if staff magnification is changing + (staff-magnification-is-changing? context mag))) + (for-each revert-prop props))))) + +;; \magnifyMusic only (define-public (scale-beam-thickness mag) "Used by @code{\\magnifyMusic}. Scaling @code{Beam.beam-thickness} -exactly to the @var{mag} value won't work. This uses two reference +exactly to the @var{mag} value will not work. This uses two reference values for @code{beam-thickness} to determine an acceptable value when scaling, then does the equivalent of a @code{\\temporary@tie{}\\override} with the new value." @@ -2470,20 +2535,62 @@ scaling, then does the equivalent of a (new-val (* scaled-default ratio-to-default))) (ly:context-pushpop-property context 'Beam 'beam-thickness new-val))))) -(define-public (revert-props props) - "Used by @code{\\magnifyMusic}. Revert each prop in @var{props}. -Props are formatted like: +;; tag management +;; -@example -'(Slur height-limit) -@end example" - (make-apply-context - (lambda (context) - (define (revert-prop grob-prop-list) - (let* ((grob (car grob-prop-list)) - (prop (cadr grob-prop-list)) - (where (if (eq? grob 'SpacingSpanner) - (ly:context-find context 'Score) - context))) - (ly:context-pushpop-property where grob prop))) - (for-each revert-prop props)))) +(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))))))))