X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fmusic-functions.scm;h=d5a4b2478a00acce7fa6b18ca72c7dcee2a64f97;hb=0f3099177a2a23347b0a8c0895adbebc87d416be;hp=97bb8c4f67f89aa0ce79482595f8d0f86d978f44;hpb=fb54b6968c3b70c102bcb89c54bc9b1f15a71327;p=lilypond.git diff --git a/scm/music-functions.scm b/scm/music-functions.scm index 97bb8c4f67..d5a4b2478a 100644 --- a/scm/music-functions.scm +++ b/scm/music-functions.scm @@ -35,6 +35,14 @@ "Does @code{mus} belong to the music class @code{type}?" (memq type (ly:music-property mus 'types))) +(define-safe-public (music-type-predicate types) + "Returns a predicate function that can be used for checking +music to have one of the types listed in @var{types}." + (if (cheap-list? types) + (lambda (m) + (any (lambda (t) (music-is-of-type? m t)) types)) + (lambda (m) (music-is-of-type? m types)))) + ;; TODO move this (define-public ly:grob-property (make-procedure-with-setter ly:grob-property @@ -505,9 +513,33 @@ error (using optionally @code{location})." location) #f)))) +(define-safe-public (check-music-path path #:optional location #:key default) + "Check a music property path specification @var{path}, a symbol +list (or a single symbol), for validity and possibly complete it. +Returns the completed specification, or @code{#f} when rising an +error (using optionally @code{location})." + (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 (property? s) + (object-property s 'music-type?)) + (define (unspecial? s) + (not (property? s))) + (or (case (length path) + ((1) (and (property? (car path)) (cons default path))) + ((2) (and (unspecial? (car path)) (property? (cadr path)) path)) + (else #f)) + (begin + (ly:parser-error + (format #f (_ "bad music property ~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." + "Make a @code{Music} expression that overrides a @var{gprop} to +@var{val} in @var{grob}. Does a pop first, i.e. this is not a +@code{\\temporary \\override}." (make-music 'OverrideProperty 'symbol grob 'grob-property gprop @@ -515,8 +547,9 @@ error (using optionally @code{location})." 'pop-first #t)) (define-public (make-grob-property-override grob gprop val) - "Make a @code{Music} expression that overrides @var{gprop} to @var{val} -in @var{grob}." + "Make a @code{Music} expression that overrides @var{gprop} to +@var{val} in @var{grob}. This is a @code{\\temporary \\override}, +making it possible to @code{\\revert} to any previous value afterwards." (make-music 'OverrideProperty 'symbol grob 'grob-property gprop @@ -606,18 +639,23 @@ in @var{grob}." (make-grob-property-revert 'NoteColumn 'horizontal-shift))))) -(define-safe-public (context-spec-music m context #:optional id) - "Add \\context CONTEXT = ID to M." +(define-safe-public (context-spec-music m context #:optional id mods) + "Add \\context @var{context} = @var{id} \\with @var{mods} to @var{m}." (let ((cm (make-music 'ContextSpeccedMusic 'element m 'context-type context))) (if (string? id) (set! (ly:music-property cm 'context-id) id)) + (if mods + (set! (ly:music-property cm 'property-operations) + (if (ly:context-mod? mods) + (ly:get-context-mods mods) + mods))) cm)) -(define-public (descend-to-context m context) +(define-safe-public (descend-to-context m context #:optional id mods) "Like @code{context-spec-music}, but only descending." - (let ((cm (context-spec-music m context))) + (let ((cm (context-spec-music m context id mods))) (ly:music-set-property! cm 'descend-only #t) cm)) @@ -739,9 +777,7 @@ duration is replaced with the specified @var{duration}." ;; articulations on individual events since they can't actually get ;; into a repeat chord given its input syntax. - (define (keep-element? m) - (any (lambda (t) (music-is-of-type? m t)) - event-types)) + (define keep-element? (music-type-predicate event-types)) (for-each (lambda (field) @@ -953,9 +989,6 @@ NUMBER is 0-base, i.e., Voice=1 (upstems) has number 0. mus)) -(define-public (music-has-type music type) - (memq type (ly:music-property music 'types))) - (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 @@ -1908,7 +1941,7 @@ Entries that conform with the current key signature are not invalidated." (define-public (pitch-of-note event-chord) (let ((evs (filter (lambda (x) - (music-has-type x 'note-event)) + (music-is-of-type? x 'note-event)) (ly:music-property event-chord 'elements)))) (and (pair? evs) @@ -2001,14 +2034,9 @@ not recursing into matches themselves." "Return a flat list of all music with @var{type} (either a single type symbol or a list of alternatives) inside of @var{music}, not recursing into matches themselves." - (extract-music - music - (if (cheap-list? type) - (lambda (m) - (any (lambda (t) (music-is-of-type? m t)) type)) - (lambda (m) (music-is-of-type? m type))))) + (extract-music music (music-type-predicate type))) -(define*-public (event-chord-wrap! music) +(define-public (event-chord-wrap! music) "Wrap isolated rhythmic events and non-postevent events in @var{music} inside of an @code{EventChord}. Chord repeats @samp{q} are expanded using the default settings of the parser." @@ -2028,10 +2056,11 @@ are expanded using the default settings of the parser." (set! (ly:music-property m 'articulations) '())) (make-event-chord (cons m arts)))) (else #f))) - (expand-repeat-chords! - (cons 'rhythmic-event - (ly:parser-lookup '$chord-repeat-events)) - music))) + (expand-repeat-notes! + (expand-repeat-chords! + (cons 'rhythmic-event + (ly:parser-lookup '$chord-repeat-events)) + music)))) (define-public (event-chord-notes event-chord) "Return a list of all notes from @var{event-chord}." @@ -2290,33 +2319,62 @@ list or if there is a type-mismatch, @var{arg} will be returned." arg offsets)) (else arg))) +(define-public (grob-transformer property func) + "Create an override value good for applying @var{func} to either +pure or unpure values. @var{func} is called with the respective grob +as first argument and the default value (after resolving all callbacks) +as the second." + (define (worker self container-part grob . rest) + (let* ((immutable (ly:grob-basic-properties grob)) + ;; We need to search the basic-properties alist for our + ;; property to obtain values to offset. Our search is + ;; complicated by the fact that calling the music function + ;; `offset' as an override conses a pair to the head of the + ;; alist. This pair must be discounted. The closure it + ;; contains is named `self' so it can be easily recognized. + ;; If `offset' is called as a tweak, the basic-property + ;; alist is unaffected. + (target (find-value-to-offset property self immutable)) + ;; if target is a procedure, we need to apply it to our + ;; grob to calculate values to offset. + (vals (cond ((procedure? target) (target grob)) + ;; Argument lists for a pure procedure pulled + ;; from an unpure-pure-container may be + ;; different from a normal procedure, so we + ;; need a different code path and calling + ;; convention for procedures pulled from an + ;; container as opposed to from the property + ((ly:unpure-pure-container? target) + (let ((part (container-part target))) + (if (procedure? part) + (apply part grob rest) + part))) + (else target)))) + (func grob vals))) + ;; return the container named `self'. The container self-reference + ;; seems like chasing its own tail but gets dissolved by + ;; define/lambda separating binding and referencing of "self". + (define self (ly:make-unpure-pure-container + (lambda (grob) + (worker self ly:unpure-pure-container-unpure-part grob)) + (lambda (grob . rest) + (apply worker self ly:unpure-pure-container-pure-part + grob rest)))) + self) + (define-public (offsetter property offsets) "Apply @var{offsets} to the default values of @var{property} of @var{grob}. Offsets are restricted to immutable properties and values of type @code{number}, @code{number-pair}, or @code{number-pair-list}." - (define (self grob) - (let* ((immutable (ly:grob-basic-properties grob)) - ; We need to search the basic-properties alist for our property to - ; obtain values to offset. Our search is complicated by the fact that - ; calling the music function `offset' as an override conses a pair to - ; the head of the alist. This pair must be discounted. The closure it - ; contains is named `self' so it can be easily recognized. If `offset' - ; is called as a tweak, the basic-property alist is unaffected. - (target (find-value-to-offset property self immutable)) - ; if target is a procedure, we need to apply it to our grob to calculate - ; values to offset. - (vals - (if (procedure? target) - (target grob) - target)) - (can-type-be-offset? - (or (number? vals) - (number-pair? vals) - (number-pair-list? vals)))) - + (define (offset-fun grob vals) + (let ((can-type-be-offset? + (or (number? vals) + (number-pair? vals) + (number-pair-list? vals)))) (if can-type-be-offset? - ; '(+inf.0 . -inf.0) would offset to itself. This will be confusing to a - ; user unaware of the default value of the property, so issue a warning. + ;; '(+inf.0 . -inf.0) would offset to itself. This will be + ;; confusing to a user unaware of the default value of the + ;; property, so issue a warning. (if (equal? empty-interval vals) (ly:warning "default '~a of ~a is ~a and can't be offset" property grob vals) @@ -2326,8 +2384,8 @@ Offsets are restricted to immutable properties and values of type @code{number}, (ly:spanner-broken-into orig) '())) (total-found (length siblings)) - ; Since there is some flexibility in input syntax, - ; structure of `offsets' is normalized. + ;; Since there is some flexibility in input + ;; syntax, structure of `offsets' is normalized. (offsets (if (or (not (pair? offsets)) (number-pair? offsets) @@ -2337,7 +2395,7 @@ Offsets are restricted to immutable properties and values of type @code{number}, offsets))) (define (helper sibs offs) - ; apply offsets to the siblings of broken spanners + ;; apply offsets to the siblings of broken spanners (if (pair? offs) (if (eq? (car sibs) grob) (offset-multiple-types vals (car offs)) @@ -2348,12 +2406,10 @@ Offsets are restricted to immutable properties and values of type @code{number}, (helper siblings offsets) (offset-multiple-types vals (car offsets))))) - (begin - (ly:warning "the property '~a of ~a cannot be offset" property grob) - vals)))) - ; return the closure named `self' - self) - + (begin + (ly:warning "the property '~a of ~a cannot be offset" property grob) + vals)))) + (grob-transformer property offset-fun)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; \magnifyMusic and \magnifyStaff