X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fmusic-functions.scm;h=9c36ceaf4d4c51d3097797256c9e195c157ad330;hb=76efdcf765d2189ee79e390bf51cbb8fca3fb489;hp=36fe99b697cfad945744c3773899c337031ecad4;hpb=610d3aa70a430b620b7175fbe264a9f21eba4482;p=lilypond.git diff --git a/scm/music-functions.scm b/scm/music-functions.scm index 36fe99b697..9c36ceaf4d 100644 --- a/scm/music-functions.scm +++ b/scm/music-functions.scm @@ -513,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 @@ -523,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 @@ -614,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)) @@ -1669,173 +1699,136 @@ on the same staff line." (cons #f (not (or (equal? acc key-acc) (and (equal? entrybn barnum) (equal? entrymp measurepos))))))))) -(define-public (set-accidentals-properties extra-natural - auto-accs auto-cauts - context) - (context-spec-music - (make-sequential-music - (append (if (boolean? extra-natural) - (list (make-property-set 'extraNatural extra-natural)) - '()) - (list (make-property-set 'autoAccidentals auto-accs) - (make-property-set 'autoCautionaries auto-cauts)))) - context)) - -(define-public (set-accidental-style style . rest) - "Set accidental style to @var{style}. Optionally take a context -argument, e.g. @code{'Staff} or @code{'Voice}. The context defaults -to @code{Staff}, except for piano styles, which use @code{GrandStaff} -as a context." - (let ((context (if (pair? rest) - (car rest) 'Staff)) - (pcontext (if (pair? rest) - (car rest) 'GrandStaff))) - (cond +(define-session-public accidental-styles + ;; An alist containing specification for all accidental styles. + ;; Each accidental style needs three entries for the context properties + ;; extraNatural, autoAccidentals and autoCautionaries. + ;; An optional fourth entry may specify a default context for the accidental + ;; style, for use with the piano styles. + `( ;; accidentals as they were common in the 18th century. - ((equal? style 'default) - (set-accidentals-properties #t - `(Staff ,(make-accidental-rule 'same-octave 0)) - '() - context)) + (default #t + (Staff ,(make-accidental-rule 'same-octave 0)) + ()) ;; accidentals from one voice do NOT get canceled in other voices - ((equal? style 'voice) - (set-accidentals-properties #t - `(Voice ,(make-accidental-rule 'same-octave 0)) - '() - context)) - ;; accidentals as suggested by Kurt Stone, Music Notation in the 20th century. - ;; This includes all the default accidentals, but accidentals also needs canceling - ;; in other octaves and in the next measure. - ((equal? style 'modern) - (set-accidentals-properties #f - `(Staff ,(make-accidental-rule 'same-octave 0) - ,(make-accidental-rule 'any-octave 0) - ,(make-accidental-rule 'same-octave 1)) - '() - context)) + (voice #t + (Voice ,(make-accidental-rule 'same-octave 0)) + ()) + ;; accidentals as suggested by Kurt Stone in + ;; ‘Music Notation in the 20th century’. + ;; This includes all the default accidentals, but accidentals also need + ;; canceling in other octaves and in the next measure. + (modern #f + (Staff ,(make-accidental-rule 'same-octave 0) + ,(make-accidental-rule 'any-octave 0) + ,(make-accidental-rule 'same-octave 1)) + ()) ;; the accidentals that Stone adds to the old standard as cautionaries - ((equal? style 'modern-cautionary) - (set-accidentals-properties #f - `(Staff ,(make-accidental-rule 'same-octave 0)) - `(Staff ,(make-accidental-rule 'any-octave 0) - ,(make-accidental-rule 'same-octave 1)) - context)) - ;; same as modern, but accidentals different from the key signature are always - ;; typeset - unless they directly follow a note of the same pitch. - ((equal? style 'neo-modern) - (set-accidentals-properties #f - `(Staff ,(make-accidental-rule 'same-octave 0) - ,(make-accidental-rule 'any-octave 0) - ,(make-accidental-rule 'same-octave 1) - ,neo-modern-accidental-rule) - '() - context)) - ((equal? style 'neo-modern-cautionary) - (set-accidentals-properties #f - `(Staff ,(make-accidental-rule 'same-octave 0)) - `(Staff ,(make-accidental-rule 'any-octave 0) - ,(make-accidental-rule 'same-octave 1) - ,neo-modern-accidental-rule) - context)) - ((equal? style 'neo-modern-voice) - (set-accidentals-properties #f - `(Voice ,(make-accidental-rule 'same-octave 0) - ,(make-accidental-rule 'any-octave 0) - ,(make-accidental-rule 'same-octave 1) - ,neo-modern-accidental-rule - Staff ,(make-accidental-rule 'same-octave 0) - ,(make-accidental-rule 'any-octave 0) - ,(make-accidental-rule 'same-octave 1) - ,neo-modern-accidental-rule) - '() - context)) - ((equal? style 'neo-modern-voice-cautionary) - (set-accidentals-properties #f - `(Voice ,(make-accidental-rule 'same-octave 0)) - `(Voice ,(make-accidental-rule 'any-octave 0) - ,(make-accidental-rule 'same-octave 1) - ,neo-modern-accidental-rule - Staff ,(make-accidental-rule 'same-octave 0) - ,(make-accidental-rule 'any-octave 0) - ,(make-accidental-rule 'same-octave 1) - ,neo-modern-accidental-rule) - context)) + (modern-cautionary #f + (Staff ,(make-accidental-rule 'same-octave 0)) + (Staff ,(make-accidental-rule 'any-octave 0) + ,(make-accidental-rule 'same-octave 1))) + ;; same as modern, but accidentals different from the key signature are + ;; always typeset - unless they directly follow a note of the same pitch. + (neo-modern #f + (Staff ,(make-accidental-rule 'same-octave 0) + ,(make-accidental-rule 'any-octave 0) + ,(make-accidental-rule 'same-octave 1) + ,neo-modern-accidental-rule) + ()) + (neo-modern-cautionary #f + (Staff ,(make-accidental-rule 'same-octave 0)) + (Staff ,(make-accidental-rule 'any-octave 0) + ,(make-accidental-rule 'same-octave 1) + ,neo-modern-accidental-rule)) + (neo-modern-voice #f + (Voice ,(make-accidental-rule 'same-octave 0) + ,(make-accidental-rule 'any-octave 0) + ,(make-accidental-rule 'same-octave 1) + ,neo-modern-accidental-rule + Staff + ,(make-accidental-rule 'same-octave 0) + ,(make-accidental-rule 'any-octave 0) + ,(make-accidental-rule 'same-octave 1) + ,neo-modern-accidental-rule) + ()) + (neo-modern-voice-cautionary #f + (Voice ,(make-accidental-rule 'same-octave 0)) + (Voice ,(make-accidental-rule 'any-octave 0) + ,(make-accidental-rule 'same-octave 1) + ,neo-modern-accidental-rule + Staff + ,(make-accidental-rule 'same-octave 0) + ,(make-accidental-rule 'any-octave 0) + ,(make-accidental-rule 'same-octave 1) + ,neo-modern-accidental-rule)) + ;; Accidentals as they were common in dodecaphonic music with no tonality. ;; Each note gets one accidental. - ((equal? style 'dodecaphonic) - (set-accidentals-properties #f - `(Staff ,(lambda (c p bn mp) '(#f . #t))) - '() - context)) + (dodecaphonic #f + (Staff ,(lambda (c p bn mp) '(#f . #t))) + ()) ;; As in dodecaphonic style with the exception that immediately ;; repeated notes (in the same voice) don't get an accidental - ((equal? style 'dodecaphonic-no-repeat) - (set-accidentals-properties #f - `(Staff ,dodecaphonic-no-repeat-rule) - '() - context)) + (dodecaphonic-no-repeat #f + (Staff ,dodecaphonic-no-repeat-rule) + ()) ;; Variety of the dodecaphonic style. Each note gets an accidental, ;; except notes that were already handled in the same measure. - ((equal? style 'dodecaphonic-first) - (set-accidentals-properties #f - `(Staff ,(make-accidental-dodecaphonic-rule 'same-octave 0)) - '() - context)) + (dodecaphonic-first #f + (Staff ,(make-accidental-dodecaphonic-rule 'same-octave 0)) + ()) ;; Multivoice accidentals to be read both by musicians playing one voice - ;; and musicians playing all voices. - ;; Accidentals are typeset for each voice, but they ARE canceled across voices. - ((equal? style 'modern-voice) - (set-accidentals-properties #f - `(Voice ,(make-accidental-rule 'same-octave 0) - ,(make-accidental-rule 'any-octave 0) - ,(make-accidental-rule 'same-octave 1) - Staff ,(make-accidental-rule 'same-octave 0) - ,(make-accidental-rule 'any-octave 0) - ,(make-accidental-rule 'same-octave 1)) - '() - context)) - ;; same as modernVoiceAccidental eccept that all special accidentals are typeset - ;; as cautionaries - ((equal? style 'modern-voice-cautionary) - (set-accidentals-properties #f - `(Voice ,(make-accidental-rule 'same-octave 0)) - `(Voice ,(make-accidental-rule 'any-octave 0) - ,(make-accidental-rule 'same-octave 1) - Staff ,(make-accidental-rule 'same-octave 0) - ,(make-accidental-rule 'any-octave 0) - ,(make-accidental-rule 'same-octave 1)) - context)) - ;; stone's suggestions for accidentals on grand staff. - ;; Accidentals are canceled across the staves in the same grand staff as well - ((equal? style 'piano) - (set-accidentals-properties #f - `(Staff ,(make-accidental-rule 'same-octave 0) - ,(make-accidental-rule 'any-octave 0) - ,(make-accidental-rule 'same-octave 1) - GrandStaff - ,(make-accidental-rule 'any-octave 0) - ,(make-accidental-rule 'same-octave 1)) - '() - pcontext)) - ((equal? style 'piano-cautionary) - (set-accidentals-properties #f - `(Staff ,(make-accidental-rule 'same-octave 0)) - `(Staff ,(make-accidental-rule 'any-octave 0) - ,(make-accidental-rule 'same-octave 1) - GrandStaff - ,(make-accidental-rule 'any-octave 0) - ,(make-accidental-rule 'same-octave 1)) - pcontext)) - - ;; same as modern, but cautionary accidentals are printed for all sharp or flat - ;; tones specified by the key signature. - ((equal? style 'teaching) - (set-accidentals-properties #f - `(Staff ,(make-accidental-rule 'same-octave 0)) - `(Staff ,(make-accidental-rule 'same-octave 1) - ,teaching-accidental-rule) - context)) + ;; and musicians playing all voices. Accidentals are typeset for each + ;; voice, but they ARE canceled across voices. + (modern-voice #f + (Voice ,(make-accidental-rule 'same-octave 0) + ,(make-accidental-rule 'any-octave 0) + ,(make-accidental-rule 'same-octave 1) + Staff + ,(make-accidental-rule 'same-octave 0) + ,(make-accidental-rule 'any-octave 0) + ,(make-accidental-rule 'same-octave 1)) + ()) + ;; same as modernVoiceAccidental except that all special accidentals + ;; are typeset as cautionaries + (modern-voice-cautionary #f + (Voice ,(make-accidental-rule 'same-octave 0)) + (Voice ,(make-accidental-rule 'any-octave 0) + ,(make-accidental-rule 'same-octave 1) + Staff + ,(make-accidental-rule 'same-octave 0) + ,(make-accidental-rule 'any-octave 0) + ,(make-accidental-rule 'same-octave 1))) + + ;; Stone's suggestions for accidentals on grand staff. + ;; Accidentals are canceled across the staves + ;; in the same grand staff as well + (piano #f + (Staff ,(make-accidental-rule 'same-octave 0) + ,(make-accidental-rule 'any-octave 0) + ,(make-accidental-rule 'same-octave 1) + GrandStaff + ,(make-accidental-rule 'any-octave 0) + ,(make-accidental-rule 'same-octave 1)) + () + GrandStaff) + (piano-cautionary #f + (Staff ,(make-accidental-rule 'same-octave 0)) + (Staff ,(make-accidental-rule 'any-octave 0) + ,(make-accidental-rule 'same-octave 1) + GrandStaff + ,(make-accidental-rule 'any-octave 0) + ,(make-accidental-rule 'same-octave 1)) + GrandStaff) + + ;; same as modern, but cautionary accidentals are printed for all + ;; non-natural tones specified by the key signature. + (teaching #f + (Staff ,(make-accidental-rule 'same-octave 0)) + (Staff ,(make-accidental-rule 'same-octave 1) + ,teaching-accidental-rule)) ;; do not set localAlterations when a note alterated differently from ;; localAlterations is found. @@ -1843,22 +1836,41 @@ as a context." ;; remembered for the duration of a measure. ;; accidentals not being remembered, causing accidentals always to ;; be typeset relative to the time signature - ((equal? style 'forget) - (set-accidentals-properties '() - `(Staff ,(make-accidental-rule 'same-octave -1)) - '() - context)) + (forget () + (Staff ,(make-accidental-rule 'same-octave -1)) + ()) ;; Do not reset the key at the start of a measure. Accidentals will be ;; printed only once and are in effect until overridden, possibly many ;; measures later. - ((equal? style 'no-reset) - (set-accidentals-properties '() - `(Staff ,(make-accidental-rule 'same-octave #t)) - '() - context)) - (else - (ly:warning (_ "unknown accidental style: ~S") style) - (make-sequential-music '()))))) + (no-reset () + (Staff ,(make-accidental-rule 'same-octave #t)) + ()) + )) + +(define-public (set-accidental-style style . rest) + "Set accidental style to @var{style}. Optionally take a context +argument, e.g. @code{'Staff} or @code{'Voice}. The context defaults +to @code{Staff}, except for piano styles, which use @code{GrandStaff} +as a context." + (let ((spec (assoc-get style accidental-styles))) + (if spec + (let ((extra-natural (first spec)) + (auto-accs (second spec)) + (auto-cauts (third spec)) + (context (cond ((pair? rest) (car rest)) + ((= 4 (length spec)) (fourth spec)) + (else 'Staff)))) + (context-spec-music + (make-sequential-music + (append (if (boolean? extra-natural) + (list (make-property-set 'extraNatural extra-natural)) + '()) + (list (make-property-set 'autoAccidentals auto-accs) + (make-property-set 'autoCautionaries auto-cauts)))) + context)) + (begin + (ly:warning (_ "unknown accidental style: ~S") style) + (make-sequential-music '()))))) (define-public (invalidate-alterations context) "Invalidate alterations in @var{context}. @@ -2006,7 +2018,7 @@ type symbol or a list of alternatives) inside of @var{music}, not recursing into matches themselves." (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." @@ -2026,10 +2038,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}." @@ -2042,6 +2055,21 @@ are expanded using the default settings of the parser." (map (lambda (x) (ly:music-property x 'pitch)) (event-chord-notes event-chord))) +(define-public (music-pitches music) + "Return a list of all pitches from @var{music}." + ;; Opencoded for efficiency. + (reverse! + (let loop ((music music) (pitches '())) + (let ((p (ly:music-property music 'pitch))) + (if (ly:pitch? p) + (cons p pitches) + (let ((elt (ly:music-property music 'element))) + (fold loop + (if (ly:music? elt) + (loop elt pitches) + pitches) + (ly:music-property music 'elements)))))))) + (define-public (event-chord-reduce music) "Reduces event chords in @var{music} to their first note event, retaining only the chord articulations. Returns the modified music." @@ -2288,10 +2316,11 @@ list or if there is a type-mismatch, @var{arg} will be returned." arg offsets)) (else arg))) -(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-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 @@ -2317,12 +2346,28 @@ Offsets are restricted to immutable properties and values of type @code{number}, (if (procedure? part) (apply part grob rest) part))) - (else target))) - (can-type-be-offset? - (or (number? vals) - (number-pair? vals) - (number-pair-list? vals)))) + (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 (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 @@ -2361,16 +2406,7 @@ Offsets are restricted to immutable properties and values of type @code{number}, (begin (ly:warning "the property '~a of ~a cannot be offset" property 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) + (grob-transformer property offset-fun)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; \magnifyMusic and \magnifyStaff