"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
(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.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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}."
(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.
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
'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
(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))
;; 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)
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))
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
(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.
;; 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}.
(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)
"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."
(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}."
(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."
(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)
(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)
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))
(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
projects / lilypond.git / blobdiff