X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fmusic-functions.scm;h=5bbd07ea8fae1ade4bffe1067e9d7faf6b213d69;hb=HEAD;hp=65f885bbf87e1a76921c7f3e8e98900e2b0c980c;hpb=6dbb7c4cfab2a0c2ce47f229592efc0ffc7d519a;p=lilypond.git diff --git a/scm/music-functions.scm b/scm/music-functions.scm index 65f885bbf8..5bbd07ea8f 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 @@ -74,31 +82,33 @@ First it recurses over the children, then the function is applied to (define-public (music-filter pred? music) "Filter out music expressions that do not satisfy @var{pred?}." - (define (inner-music-filter pred? music) + (define (inner-music-filter music) "Recursive function." (let* ((es (ly:music-property music 'elements)) (e (ly:music-property music 'element)) (as (ly:music-property music 'articulations)) - (filtered-as (filter ly:music? (map (lambda (y) (inner-music-filter pred? y)) as))) + (filtered-as (filter ly:music? (map inner-music-filter as))) (filtered-e (if (ly:music? e) - (inner-music-filter pred? e) + (inner-music-filter e) e)) - (filtered-es (filter ly:music? (map (lambda (y) (inner-music-filter pred? y)) es)))) + (filtered-es (filter ly:music? (map inner-music-filter es)))) (if (not (null? e)) (set! (ly:music-property music 'element) filtered-e)) (if (not (null? es)) (set! (ly:music-property music 'elements) filtered-es)) (if (not (null? as)) (set! (ly:music-property music 'articulations) filtered-as)) - ;; if filtering emptied the expression, we remove it completely. + ;; if filtering invalidated 'element, we remove the music unless + ;; there are remaining 'elements in which case we just hope and + ;; pray. (if (or (not (pred? music)) - (and (eq? filtered-es '()) (not (ly:music? e)) - (or (not (eq? es '())) - (ly:music? e)))) + (and (null? filtered-es) + (not (ly:music? filtered-e)) + (ly:music? e))) (set! music '())) music)) - (set! music (inner-music-filter pred? music)) + (set! music (inner-music-filter music)) (if (ly:music? music) music (make-music 'Music))) ;must return music. @@ -229,13 +239,13 @@ which often can be read back in order to generate an equivalent expression." (use-modules (srfi srfi-39) (scm display-lily)) -(define*-public (display-lily-music expr parser #:optional (port (current-output-port)) +(define*-public (display-lily-music expr #:optional (port (current-output-port)) #:key force-duration) "Display the music expression using LilyPond syntax" (memoize-clef-names supported-clefs) (parameterize ((*indent* 0) (*omit-duration* #f)) - (display (music->lily-string expr parser) port) + (display (music->lily-string expr) port) (newline port))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -380,19 +390,36 @@ beats to be distinguished." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; repeats. -(define-public (unfold-repeats music) - "Replace all repeats with unfolded repeats." - (let ((es (ly:music-property music 'elements)) - (e (ly:music-property music 'element))) - (if (music-is-of-type? music 'repeated-music) - (set! music (make-music 'UnfoldedRepeatedMusic music))) - (if (pair? es) - (set! (ly:music-property music 'elements) - (map unfold-repeats es))) - (if (ly:music? e) - (set! (ly:music-property music 'element) - (unfold-repeats e))) - music)) +(define-public (unfold-repeats types music) + "Replace repeats of the types given by @var{types} with unfolded repeats. +If @var{types} is an empty list, @code{repeated-music} is taken, unfolding all." + (let* ((types-list + (if (or (null? types) (not (list? types))) + (list types) + types)) + (repeat-types-alist + '((volta . volta-repeated-music) + (percent . percent-repeated-music) + (tremolo . tremolo-repeated-music) + (() . repeated-music))) + (repeat-types-hash (alist->hash-table repeat-types-alist))) + (for-each + (lambda (type) + (let ((repeat-type (hashq-ref repeat-types-hash type))) + (if repeat-type + (let ((es (ly:music-property music 'elements)) + (e (ly:music-property music 'element))) + (if (music-is-of-type? music repeat-type) + (set! music (make-music 'UnfoldedRepeatedMusic music))) + (if (pair? es) + (set! (ly:music-property music 'elements) + (map (lambda (x) (unfold-repeats types x)) es))) + (if (ly:music? e) + (set! (ly:music-property music 'element) + (unfold-repeats types e)))) + (ly:warning "unknown repeat-type ~a, ignoring." type)))) + types-list) + music)) (define-public (unfold-repeats-fully music) "Unfolds repeats and expands the resulting @code{unfolded-repeated-music}." @@ -401,12 +428,12 @@ beats to be distinguished." (and (music-is-of-type? m 'unfolded-repeated-music) (make-sequential-music (ly:music-deep-copy (make-unfolded-set m))))) - (unfold-repeats music))) + (unfold-repeats '() music))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; property setting music objs. -(define-safe-public (check-grob-path path #:optional parser location +(define-safe-public (check-grob-path path #:optional location #:key (start 0) default @@ -475,16 +502,63 @@ respectively." (<= min (length res)))) res (begin - (if parser - (ly:parser-error parser - (format #f (_ "bad grob property path ~a") - path) - location)) + (ly:parser-error + (format #f (_ "bad grob property path ~a") + path) + location) #f))))) +(define-safe-public (check-context-path path #:optional location) + "Check a context 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 'translation-type?)) + (define (unspecial? s) + (not (property? s))) + (define (check c p) (c p)) + (or (case (length path) + ((1) (and (property? (car path)) (cons 'Bottom path))) + ((2) (and (unspecial? (car path)) (property? (cadr path)) path)) + (else #f)) + (begin + (ly:parser-error + (format #f (_ "bad context property ~a") + path) + 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 @@ -492,8 +566,9 @@ respectively." '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 @@ -546,6 +621,14 @@ in @var{grob}." (Voice Slur direction ,DOWN)) general-grace-settings)) +;; Getting a unique context id name + +(define-session unique-counter -1) +(define-safe-public (get-next-unique-voice-name) + (set! unique-counter (1+ unique-counter)) + (format #f "uniqueContext~s" unique-counter)) + + (define-safe-public (make-voice-props-set n) (make-sequential-music (append @@ -575,18 +658,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)) @@ -708,14 +796,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 origin (ly:music-property repeat-chord 'origin #f)) - (define (set-origin! l) - (if origin - (for-each (lambda (m) (set! (ly:music-property m 'origin) origin)) l)) - l) + (define keep-element? (music-type-predicate event-types)) (for-each (lambda (field) @@ -729,16 +810,17 @@ duration is replaced with the specified @var{duration}." ;; now treat the elements (set! (ly:music-property repeat-chord 'elements) (let ((elts - (set-origin! (ly:music-deep-copy - (filter keep-element? - (ly:music-property original-chord - 'elements)))))) + (ly:music-deep-copy (filter keep-element? + (ly:music-property original-chord + 'elements)) + repeat-chord))) (for-each (lambda (m) (let ((arts (ly:music-property m 'articulations))) (if (pair? arts) (set! (ly:music-property m 'articulations) - (set-origin! (filter! keep-element? arts)))) + (ly:set-origin! (filter! keep-element? arts) + repeat-chord))) (if (ly:duration? (ly:music-property m 'duration)) (set! (ly:music-property m 'duration) duration)) (if (ly:music-property m 'cautionary #f) @@ -753,7 +835,7 @@ duration is replaced with the specified @var{duration}." (if (pair? arts) (set! (ly:music-property repeat-chord 'articulations) (append! - (set-origin! (ly:music-deep-copy arts)) + (ly:music-deep-copy arts repeat-chord) (ly:music-property repeat-chord 'articulations))))) repeat-chord) @@ -854,45 +936,77 @@ from the predecessor note/chord if available." music))) ;;; splitting chords into voices. -(define (voicify-list lst number) +(define (voicify-list locs lst id) "Make a list of Musics. -voicify-list :: [ [Music ] ] -> number -> [Music] +voicify-list :: [ [Music ] ] -> id -> [Music] LST is a list music-lists. -NUMBER is 0-base, i.e., Voice=1 (upstems) has number 0. +id is 1-based, i.e., Voice=1 (upstems) has number 1. + +id may be a symbol or string giving a specific voice id: in this +case, no \voiceXXX style is selected, merely the context given. + +locs is a list of music expressions suitable for giving +error locations (enclosing expression for the first element, +preceding \\\\ separator for the others) " - (if (null? lst) - '() - (cons (context-spec-music - (make-sequential-music - (list (make-voice-props-set number) - (make-simultaneous-music (car lst)))) - 'Bottom (number->string (1+ number))) - (voicify-list (cdr lst) (1+ number))))) - -(define (voicify-chord ch) + (define (voicify-sublist loc sublist id) + (cond ((string? id) + (context-spec-music + (make-simultaneous-music sublist) + 'Bottom id)) + ((symbol? id) + (voicify-sublist loc sublist (symbol->string id))) + ((and (integer? id) (exact? id) (positive? id)) + (context-spec-music + (make-sequential-music + (list (make-voice-props-set (1- id)) + (make-simultaneous-music sublist))) + 'Bottom (number->string id))) + (else + (ly:music-warning loc (_ "Bad voice id: ~a") id) + (context-spec-music (make-simultaneous-music sublist) 'Bottom)))) + + (cond ((null? lst) '()) + ((number? id) + (cons (voicify-sublist (car locs) (car lst) id) + (voicify-list (cdr locs) (cdr lst) (1+ id)))) + ((pair? id) + (cons (voicify-sublist (car locs) (car lst) (car id)) + (voicify-list (cdr locs) (cdr lst) (cdr id)))) + ((null? id) + (ly:music-warning (car locs) (_ "\\voices needs more ids")) + (voicify-list locs lst 1)))) + +(define (voicify-chord ch id) "Split the parts of a chord into different Voices using separator" (let ((es (ly:music-property ch 'elements))) (set! (ly:music-property ch 'elements) - (voicify-list (split-list-by-separator es music-separator?) 0)) + (voicify-list (cons ch (filter music-separator? es)) + (split-list-by-separator es music-separator?) + id)) ch)) -(define-public (voicify-music m) - "Recursively split chords that are separated with @code{\\\\}." - (if (not (ly:music? m)) - (ly:error (_ "music expected: ~S") m)) - (let ((es (ly:music-property m 'elements)) - (e (ly:music-property m 'element))) - - (if (pair? es) - (set! (ly:music-property m 'elements) (map voicify-music es))) - (if (ly:music? e) - (set! (ly:music-property m 'element) (voicify-music e))) - (if (and (equal? (ly:music-property m 'name) 'SimultaneousMusic) - (any music-separator? es)) - (set! m (context-spec-music (voicify-chord m) 'Staff))) - m)) +(define*-public (voicify-music m #:optional (id 1)) + "Recursively split chords that are separated with @code{\\\\}. +Optional @var{id} can be a list of context ids to use. If numeric, +they also indicate a voice type override. If @var{id} is just a single +number, that's where numbering starts." + (let loop ((m m)) + (if (not (ly:music? m)) + (ly:error (_ "music expected: ~S") m)) + (let ((es (ly:music-property m 'elements)) + (e (ly:music-property m 'element))) + + (if (pair? es) + (set! (ly:music-property m 'elements) (map loop es))) + (if (ly:music? e) + (set! (ly:music-property m 'element) (loop e))) + (if (and (equal? (ly:music-property m 'name) 'SimultaneousMusic) + (any music-separator? es)) + (context-spec-music (voicify-chord m id) 'Staff) + m)))) (define-public (empty-music) (make-music 'Music)) @@ -926,9 +1040,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 @@ -1040,10 +1151,9 @@ actually fully cloned." (defmacro-public def-grace-function (start stop . docstring) "Helper macro for defining grace music" - `(define-music-function (parser location music) (ly:music?) + `(define-music-function (music) (ly:music?) ,@docstring (make-music 'GraceMusic - 'origin location 'element (make-music 'SequentialMusic 'elements (list (ly:music-deep-copy ,start) music @@ -1052,7 +1162,7 @@ actually fully cloned." (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 ...) (arg1-type arg2-type ...) + (define-syntax-function result-type? (arg1 arg2 ...) (arg1-type arg2-type ...) ...function body...) argX-type can take one of the forms @code{predicate?} for mandatory @@ -1067,21 +1177,28 @@ parameter of different type. predicates, to be used in case of a type error in arguments or result." + (define (has-parser/location? arg where) + (let loop ((arg arg)) + (if (list? arg) + (any loop arg) + (memq arg where)))) (define (currying-lambda args doc-string? body) (if (and (pair? args) (pair? (car args))) (currying-lambda (car args) doc-string? `((lambda ,(cdr args) ,@body))) - `(lambda ,args - ,(format #f "~a\n~a" (cddr args) (or doc-string? "")) - ,@body))) - - (set! signature (map (lambda (pred) - (if (pair? pred) - `(cons ,(car pred) - ,(and (pair? (cdr pred)) (cadr pred))) - pred)) - (cons type signature))) + (let* ((compatibility? (if (list? args) + (= (length args) (+ 2 (length signature))) + (and (pair? args) (pair? (cdr args)) + (eq? (car args) 'parser)))) + (realargs (if compatibility? (cddr args) args))) + `(lambda ,realargs + ,(format #f "~a\n~a" realargs (or doc-string? "")) + ,@(if (and compatibility? + (has-parser/location? body (take args 2))) + `((let ((,(car args) (*parser*)) (,(cadr args) (*location*))) + ,@body)) + body))))) (let ((docstring (and (pair? body) (pair? (cdr body)) @@ -1096,13 +1213,18 @@ result." ;; When the music function definition contains an i10n doc string, ;; (_i "doc string"), keep the literal string only `(ly:make-music-function - (list ,@signature) + (list ,@(map (lambda (pred) + (if (pair? pred) + `(cons ,(car pred) + ,(and (pair? (cdr pred)) (cadr pred))) + pred)) + (cons type signature))) ,(currying-lambda args docstring (if docstring (cdr body) body))))) (defmacro-public define-music-function rest "Defining macro returning music functions. Syntax: - (define-music-function (parser location arg1 arg2 ...) (arg1-type? arg2-type? ...) + (define-music-function (arg1 arg2 ...) (arg1-type? arg2-type? ...) ...function body...) argX-type can take one of the forms @code{predicate?} for mandatory @@ -1122,7 +1244,7 @@ set to the @code{location} parameter." (defmacro-public define-scheme-function rest "Defining macro returning Scheme functions. Syntax: - (define-scheme-function (parser location arg1 arg2 ...) (arg1-type? arg2-type? ...) + (define-scheme-function (arg1 arg2 ...) (arg1-type? arg2-type? ...) ...function body...) argX-type can take one of the forms @code{predicate?} for mandatory @@ -1150,7 +1272,7 @@ the return value." (defmacro-public define-event-function rest "Defining macro returning event functions. Syntax: - (define-event-function (parser location arg1 arg2 ...) (arg1-type? arg2-type? ...) + (define-event-function (arg1 arg2 ...) (arg1-type? arg2-type? ...) ...function body...) argX-type can take one of the forms @code{predicate?} for mandatory @@ -1276,7 +1398,7 @@ then revert skipTypesetting." (context-spec-music (make-property-set 'skipTypesetting (not bool)) 'Score)))) -(define (skip-as-needed music parser) +(define (skip-as-needed music) "Replace MUSIC by << { \\set skipTypesetting = ##f LENGTHOF(\\showFirstLength) @@ -1289,8 +1411,8 @@ then revert skipTypesetting." the 'length property of the music is overridden to speed up compiling." (let* - ((show-last (ly:parser-lookup parser 'showLastLength)) - (show-first (ly:parser-lookup parser 'showFirstLength)) + ((show-last (ly:parser-lookup 'showLastLength)) + (show-first (ly:parser-lookup 'showFirstLength)) (show-last-length (and (ly:music? show-last) (ly:music-length show-last))) (show-first-length (and (ly:music? show-first) @@ -1340,24 +1462,21 @@ then revert skipTypesetting." (define-session-public toplevel-music-functions (list - (lambda (music parser) (expand-repeat-chords! - (cons 'rhythmic-event - (ly:parser-lookup parser '$chord-repeat-events)) - music)) - (lambda (music parser) (expand-repeat-notes! music)) - (lambda (music parser) (voicify-music music)) - (lambda (x parser) (music-map music-check-error x)) - (lambda (x parser) (music-map precompute-music-length x)) - (lambda (music parser) - - (music-map (quote-substitute (ly:parser-lookup parser 'musicQuotes)) music)) + (lambda (music) (expand-repeat-chords! + (cons 'rhythmic-event + (ly:parser-lookup '$chord-repeat-events)) + music)) + expand-repeat-notes! + voicify-music + (lambda (x) (music-map music-check-error x)) + (lambda (x) (music-map precompute-music-length x)) + (lambda (music) + (music-map (quote-substitute (ly:parser-lookup 'musicQuotes)) music)) ;; switch-on-debugging - (lambda (x parser) (music-map cue-substitute x)) + (lambda (x) (music-map cue-substitute x)) - (lambda (x parser) - (skip-as-needed x parser) - ))) + skip-as-needed)) ;;;;;;;;;; ;;; general purpose music functions @@ -1631,173 +1750,161 @@ 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) + + ;; Accidentals on a choir staff for simultaneous reading of the + ;; own voice and the surrounding choir. Similar to piano, except + ;; that the first alteration within a voice is always printed. + (choral #f + (Voice ,(make-accidental-rule 'same-octave 0) + Staff + ,(make-accidental-rule 'same-octave 1) + ,(make-accidental-rule 'any-octave 0) + ,(make-accidental-rule 'same-octave 1) + ChoirStaff + ,(make-accidental-rule 'any-octave 0) + ,(make-accidental-rule 'same-octave 1)) + () + ChoirStaff) + (choral-cautionary #f + (Voice ,(make-accidental-rule 'same-octave 0) + Staff + ,(make-accidental-rule 'same-octave 0)) + (Staff ,(make-accidental-rule 'any-octave 0) + ,(make-accidental-rule 'same-octave 1) + ChoirStaff + ,(make-accidental-rule 'any-octave 0) + ,(make-accidental-rule 'same-octave 1)) + ChoirStaff) + + ;; 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. @@ -1805,22 +1912,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}. @@ -1873,7 +1999,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) @@ -1966,19 +2092,12 @@ 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 #:optional parser) +(define-public (event-chord-wrap! music) "Wrap isolated rhythmic events and non-postevent events in -@var{music} inside of an @code{EventChord}. If the optional -@var{parser} argument is given, chord repeats @samp{q} are expanded -using the default settings. Otherwise, you need to cater for them -yourself." +@var{music} inside of an @code{EventChord}. Chord repeats @samp{q} +are expanded using the default settings of the parser." (map-some-music (lambda (m) (cond ((music-is-of-type? m 'event-chord) @@ -1995,12 +2114,11 @@ yourself." (set! (ly:music-property m 'articulations) '())) (make-event-chord (cons m arts)))) (else #f))) - (if parser - (expand-repeat-chords! - (cons 'rhythmic-event - (ly:parser-lookup parser '$chord-repeat-events)) - music) - 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}." @@ -2013,6 +2131,21 @@ yourself." (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." @@ -2254,38 +2387,52 @@ list or if there is a type-mismatch, @var{arg} will be returned." (number-pair? offsets))) (coord-translate arg offsets)) ((and (number-pair-list? arg) (number-pair-list? offsets)) - (map - (lambda (x y) (coord-translate x y)) - arg offsets)) + (map coord-translate 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 caller 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 (apply caller target grob rest))) + (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-call grob)) + (lambda (grob . rest) + (apply worker self ly:pure-call 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) @@ -2295,8 +2442,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) @@ -2306,7 +2453,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)) @@ -2317,12 +2464,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