X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fmusic-functions.scm;h=42102a1ee80226f4164c9ceb48a31a2a081bf069;hb=7f96f595916833f1d3e96b1a6e0d8c617703e534;hp=cd0ff32e1cd7ec47b34139e382ffe3c3fef797ec;hpb=c48fb1311516efae39cc880b328e66092f1814ca;p=lilypond.git diff --git a/scm/music-functions.scm b/scm/music-functions.scm index cd0ff32e1c..42102a1ee8 100644 --- a/scm/music-functions.scm +++ b/scm/music-functions.scm @@ -385,6 +385,82 @@ beats to be distinguished." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; property setting music objs. +(define-safe-public (check-grob-path path #:optional parser location + #:key + (start 0) + default + (min 1) + max) + "Check a grob path specification @var{path}, a symbol list (or a +single symbol), for validity and possibly complete it. Returns the +completed specification, or @code{#f} if invalid. If optional +@var{parser} is given, a syntax error is raised in that case, +optionally using @var{location}. If an optional keyword argument +@code{#:start @var{start}} is given, the parsing starts at the given +index in the sequence @samp{Context.Grob.property.sub-property...}, +with the default of @samp{0} implying the full path. + +If there is no valid first element of @var{path} fitting at the given +path location, an optionally given @code{#:default @var{default}} is +used as the respective element instead without checking it for +validity at this position. + +The resulting path after possibly prepending @var{default} can be +constrained in length by optional arguments @code{#:min @var{min}} and +@code{#:max @var{max}}, defaulting to @samp{1} and unlimited, +respectively." + (let ((path (if (symbol? path) (list path) path))) + ;; A Guile 1.x bug specific to optargs precludes moving the + ;; defines out of the let + (define (unspecial? s) + (not (or (object-property s 'is-grob?) + (object-property s 'backend-type?)))) + (define (grob? s) + (object-property s 'is-grob?)) + (define (property? s) + (object-property s 'backend-type?)) + (define (check c p) (c p)) + + (let* ((checkers + (and (< start 3) + (drop (list unspecial? grob? property?) start))) + (res + (cond + ((null? path) + ;; tricky. Should we make use of the default when the + ;; list is empty? In most cases, this question should be + ;; academical as an empty list can only be generated by + ;; Scheme and is likely an error. We consider this a case + ;; of "no valid first element, and default given". + ;; Usually, invalid use cases should be caught later using + ;; the #:min argument, and if the user explicitly does not + ;; catch this, we just follow through. + (if default (list default) '())) + ((not checkers) + ;; no checkers, so we have a valid first element and just + ;; take the path as-is. + path) + (default + (if ((car checkers) (car path)) + (and (every check (cdr checkers) (cdr path)) + path) + (and (every check (cdr checkers) path) + (cons default path)))) + (else + (and (every check checkers path) + path))))) + (if (and res + (if max (<= min (length res) max) + (<= min (length res)))) + res + (begin + (if parser + (ly:parser-error parser + (format #f (_ "bad grob property path ~a") + path) + location)) + #f))))) + (define-public (make-grob-property-set grob gprop val) "Make a @code{Music} expression that sets @var{gprop} to @var{val} in @var{grob}. Does a pop first, i.e., this is not an override." @@ -1321,33 +1397,43 @@ immediately', that is, only look at key signature. @code{#t} is `forever'." (check-pitch-against-signature context pitch barnum laziness octaveness)) (define (key-entry-notename entry) - "Return the pitch of an entry in localKeySignature. The entry is either of the form - '(notename . alter) or '((octave . notename) . (alter barnum . measurepos))." - (if (number? (car entry)) - (car entry) - (cdar entry))) + "Return the pitch of an @var{entry} in @code{localKeySignature}. +The @samp{car} of the entry is either of the form @code{notename} or +of the form @code{(octave . notename)}. The latter form is used for special +key signatures or to indicate an explicit accidental. + +The @samp{cdr} of the entry is either a rational @code{alter} indicating +a key signature alteration, or of the form +@code{(alter . (barnum . measurepos))} indicating an alteration caused by +an accidental in music." + (if (pair? (car entry)) + (cdar entry) + (car entry))) (define (key-entry-octave entry) - "Return the octave of an entry in localKeySignature (or #f if the entry does not have - an octave)." + "Return the octave of an entry in @code{localKeySignature} +or @code{#f} if the entry does not have an octave. +See @code{key-entry-notename} for details." (and (pair? (car entry)) (caar entry))) (define (key-entry-bar-number entry) - "Return the bar number of an entry in localKeySignature (or #f if the entry does not - have a bar number)." - (and (pair? (car entry)) (caddr entry))) + "Return the bar number of an entry in @code{localKeySignature} +or @code {#f} if the entry does not have a bar number. +See @code{key-entry-notename} for details." + (and (pair? (cdr entry)) (caddr entry))) (define (key-entry-measure-position entry) - "Return the measure position of an entry in localKeySignature (or #f if the entry does - not have a measure position)." - (and (pair? (car entry)) (cdddr entry))) + "Return the measure position of an entry in @code{localKeySignature} +or @code {#f} if the entry does not have a measure position. +See @code{key-entry-notename} for details." + (and (pair? (cdr entry)) (cdddr entry))) (define (key-entry-alteration entry) "Return the alteration of an entry in localKeySignature. For convenience, returns @code{0} if entry is @code{#f}." (if entry - (if (number? (car entry)) + (if (number? (cdr entry)) (cdr entry) (cadr entry)) 0)) @@ -1361,11 +1447,13 @@ If no matching entry is found, @var{#f} is returned." (let* ((entry (car keysig)) (entryoct (key-entry-octave entry)) (entrynn (key-entry-notename entry)) - (oct (ly:pitch-octave pitch)) (nn (ly:pitch-notename pitch))) (if (and (equal? nn entrynn) - (or (and accept-global (not entryoct)) - (and accept-local (equal? oct entryoct)))) + (or (not entryoct) + (= entryoct (ly:pitch-octave pitch))) + (if (key-entry-bar-number entry) + accept-local + accept-global)) entry (find-pitch-entry (cdr keysig) pitch accept-global accept-local))))) @@ -1394,13 +1482,9 @@ on the same staff line." (entry (find-pitch-entry keysig pitch #t #t))) (if (not entry) (cons #f #f) - (let* ((global-entry (find-pitch-entry keysig pitch #f #f)) - (key-acc (key-entry-alteration global-entry)) - (acc (ly:pitch-alteration pitch)) - (entrymp (key-entry-measure-position entry)) + (let* ((entrymp (key-entry-measure-position entry)) (entrybn (key-entry-bar-number entry))) - (cons #f (not (or (equal? acc key-acc) - (and (equal? entrybn barnum) (equal? entrymp measurepos))))))))) + (cons #f (not (and (equal? entrybn barnum) (equal? entrymp measurepos)))))))) (define-public (set-accidentals-properties extra-natural auto-accs auto-cauts @@ -1592,15 +1676,14 @@ Entries that conform with the current key signature are not invalidated." (set! (ly:context-property context 'localKeySignature) (map-in-order (lambda (entry) - (let* ((localalt (key-entry-alteration entry)) - (localoct (key-entry-octave entry))) + (let* ((localalt (key-entry-alteration entry))) (if (or (accidental-invalid? localalt) - (not localoct) + (not (key-entry-bar-number entry)) (= localalt (key-entry-alteration (find-pitch-entry keysig - (ly:make-pitch localoct + (ly:make-pitch (key-entry-octave entry) (key-entry-notename entry) 0) #t #t)))) @@ -1874,3 +1957,63 @@ of list @var{arg}." (if (>= (length siblings) 2) (helper siblings arg) (car arg)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; 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))