X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fmusic-functions.scm;h=16e035bcbbe1ea71b1afc0ae6869d238f7675837;hb=8b39eb741ede02e7e930fbf6ac107c76133d02fd;hp=6e3f79cb5fefdd504a48c643aa188826941041a2;hpb=f7085cf9b2ff111b7d30c8a59e367c771a7e3c52;p=lilypond.git diff --git a/scm/music-functions.scm b/scm/music-functions.scm index 6e3f79cb5f..16e035bcbb 100644 --- a/scm/music-functions.scm +++ b/scm/music-functions.scm @@ -180,8 +180,7 @@ equivalent to @var{obj}, that is, for a music expression, a (ly:duration? obj) `(ly:make-duration ,(ly:duration-log obj) ,(ly:duration-dot-count obj) - ,(car (ly:duration-factor obj)) - ,(cdr (ly:duration-factor obj)))) + ,(ly:duration-scale obj))) (;; note pitch (ly:pitch? obj) `(ly:make-pitch ,(ly:pitch-octave obj) @@ -237,12 +236,11 @@ which often can be read back in order to generate an equivalent expression." The number of dots in the shifted music may not be less than zero." (let ((d (ly:music-property music 'duration))) (if (ly:duration? d) - (let* ((cp (ly:duration-factor d)) + (let* ((cp (ly:duration-scale d)) (nd (ly:make-duration (+ shift (ly:duration-log d)) (max 0 (+ dot (ly:duration-dot-count d))) - (car cp) - (cdr cp)))) + cp))) (set! (ly:music-property music 'duration) nd))) music)) @@ -387,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." @@ -417,6 +491,7 @@ in @var{grob}." Fingering LaissezVibrerTie LigatureBracket + MultiMeasureRest PhrasingSlur RepeatTie Rest @@ -452,8 +527,8 @@ in @var{grob}." (Voice Fingering font-size -8) (Voice StringNumber font-size -8))) - (make-grob-property-set 'NoteColumn 'horizontal-shift (quotient n 2)) - (make-grob-property-set 'MultiMeasureRest 'staff-position (if (odd? n) -4 4)))))) + (make-grob-property-set 'NoteColumn 'horizontal-shift (quotient n 2)))))) + (define-safe-public (make-voice-props-override n) (make-sequential-music @@ -732,7 +807,7 @@ NUMBER is 0-base, i.e., Voice=1 (upstems) has number 0. (if (ly:music? e) (set! (ly:music-property m 'element) (voicify-music e))) (if (and (equal? (ly:music-property m 'name) 'SimultaneousMusic) - (reduce (lambda (x y ) (or x y)) #f (map music-separator? es))) + (any music-separator? es)) (set! m (context-spec-music (voicify-chord m) 'Staff))) m)) @@ -769,17 +844,37 @@ NUMBER is 0-base, i.e., Voice=1 (upstems) has number 0. (define-public (music-has-type music type) (memq type (ly:music-property music 'types))) -(define-public (music-clone music) - (define (alist->args alist acc) - (if (null? alist) - acc - (alist->args (cdr alist) - (cons (caar alist) (cons (cdar alist) acc))))) - - (apply - make-music - (ly:music-property music 'name) - (alist->args (ly:music-mutable-properties music) '()))) +(define-public (music-clone music . music-properties) + "Clone @var{music} and set properties according to +@var{music-properties}, a list of alternating property symbols and +values: +@example\n(music-clone start-span 'span-direction STOP) +@end example +Only properties that are not overriden by @var{music-properties} are +actually fully cloned." + (let ((old-props (list-copy (ly:music-mutable-properties music))) + (new-props '()) + (m (ly:make-music (ly:prob-immutable-properties music)))) + (define (set-props mus-props) + (if (and (not (null? mus-props)) + (not (null? (cdr mus-props)))) + (begin + (set! old-props (assq-remove! old-props (car mus-props))) + (set! new-props + (assq-set! new-props + (car mus-props) (cadr mus-props))) + (set-props (cddr mus-props))))) + (set-props music-properties) + (for-each + (lambda (pair) + (set! (ly:music-property m (car pair)) + (ly:music-deep-copy (cdr pair)))) + old-props) + (for-each + (lambda (pair) + (set! (ly:music-property m (car pair)) (cdr pair))) + new-props) + m)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; warn for bare chords at start. @@ -867,7 +962,7 @@ NUMBER is 0-base, i.e., Voice=1 (upstems) has number 0. (defmacro-public define-syntax-function (type args signature . body) "Helper macro for `ly:make-music-function'. Syntax: - (define-syntax-function (result-type? parser location arg1 arg2 ...) (result-type? arg1-type arg2-type ...) + (define-syntax-function result-type? (parser location arg1 arg2 ...) (arg1-type arg2-type ...) ...function body...) argX-type can take one of the forms @code{predicate?} for mandatory @@ -1323,33 +1418,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)) @@ -1363,11 +1468,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))))) @@ -1396,13 +1503,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 @@ -1594,15 +1697,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)))) @@ -1768,6 +1870,40 @@ yourself." (map (lambda (x) (ly:music-property x 'pitch)) (event-chord-notes event-chord))) +(defmacro-public make-relative (pitches last-pitch music) + "The list of pitch-carrying variables in @var{pitches} is used as a +sequence for creating relativable music from @var{music}. +The variables in @var{pitches} are, when considered inside of +@code{\\relative}, all considered to be specifications to the preceding +variable. The first variable is relative to the preceding musical +context, and @var{last-pitch} specifies the pitch passed as relative +base onto the following musical context." + + ;; pitch and music generator might be stored instead in music + ;; properties, and it might make sense to create a music type of its + ;; own for this kind of construct rather than using + ;; RelativeOctaveMusic + (define ((make-relative::to-relative-callback pitches p->m p->p) music pitch) + (let* ((chord (make-event-chord + (map + (lambda (p) + (make-music 'NoteEvent + 'pitch p)) + pitches))) + (pitchout (begin + (ly:make-music-relative! chord pitch) + (event-chord-pitches chord)))) + (set! (ly:music-property music 'element) + (apply p->m pitchout)) + (apply p->p pitchout))) + `(make-music 'RelativeOctaveMusic + 'to-relative-callback + (,make-relative::to-relative-callback + (list ,@pitches) + (lambda ,pitches ,music) + (lambda ,pitches ,last-pitch)) + 'element ,music)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; The following functions are all associated with the crossStaff ; function @@ -1876,3 +2012,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))