@var{music}."
(let ((es (ly:music-property music 'elements))
(e (ly:music-property music 'element)))
- (set! (ly:music-property music 'elements)
- (map (lambda (y) (music-map function y)) es))
+ (if (pair? es)
+ (set! (ly:music-property music 'elements)
+ (map (lambda (y) (music-map function y)) es)))
(if (ly:music? e)
(set! (ly:music-property music 'element)
(music-map function e)))
(ly:duration? obj)
`(ly:make-duration ,(ly:duration-log obj)
,(ly:duration-dot-count obj)
- ,(car (ly:duration-factor obj))
- ,(cdr (ly:duration-factor obj))))
+ ,(ly:duration-scale obj)))
(;; note pitch
(ly:pitch? obj)
`(ly:make-pitch ,(ly:pitch-octave obj)
The number of dots in the shifted music may not be less than zero."
(let ((d (ly:music-property music 'duration)))
(if (ly:duration? d)
- (let* ((cp (ly:duration-factor d))
+ (let* ((cp (ly:duration-scale d))
(nd (ly:make-duration
(+ shift (ly:duration-log d))
(max 0 (+ dot (ly:duration-dot-count d)))
- (car cp)
- (cdr cp))))
+ cp)))
(set! (ly:music-property music 'duration) nd)))
music))
1))
(tremolo-type (ash 1 duration-log)))
(set! (ly:music-property r 'tremolo-type) tremolo-type)
- (if (not (integer? mult))
- (ly:warning (_ "invalid tremolo repeat count: ~a") times))
+ (if (not (and (integer? mult) (= (logcount mult) 1)))
+ (ly:music-warning
+ main
+ (ly:format (_ "invalid tremolo repeat count: ~a") times)))
;; Adjust the time of the notes
(ly:music-compress r (ly:make-moment 1 children))
;; Adjust the displayed note durations
calculate the number of slashes based on the durations. Returns @code{0}
if durations in @var{music} vary, allowing slash beats and double-percent
beats to be distinguished."
- (let* ((durs (map (lambda (elt)
- (duration-of-note elt))
+ (let* ((durs (map duration-of-note
(extract-named-music music '(EventChord NoteEvent
RestEvent SkipEvent))))
(first-dur (car durs)))
(let ((es (ly:music-property music 'elements))
(e (ly:music-property music 'element)))
- (if (memq 'repeated-music (ly:music-property music 'types))
+ (if (music-is-of-type? music 'repeated-music)
(let* ((props (ly:music-mutable-properties music))
(old-name (ly:music-property music 'name))
(flattened (flatten-alist props)))
(set! music (apply make-music (cons 'UnfoldedRepeatedMusic
flattened)))
- (if (equal? old-name 'TremoloRepeatedMusic)
- (let* ((seq-arg? (memq 'sequential-music
- (ly:music-property e 'types)))
- (count (ly:music-property music 'repeat-count))
- (dot-shift (if (= 0 (remainder count 3))
- -1 0))
- (child-count (if seq-arg?
- (length (ly:music-property e 'elements))
- 0)))
-
- (if (= 0 -1)
- (set! count (* 2 (quotient count 3))))
-
- (shift-duration-log music (+ (if (= 2 child-count)
- 1 0)
- (ly:intlog2 count)) dot-shift)
-
- (if seq-arg?
- (ly:music-compress e (ly:make-moment child-count 1)))))))
+ (if (and (equal? old-name 'TremoloRepeatedMusic)
+ (pair? (extract-named-music e '(EventChord NoteEvent))))
+ ;; This works for single-note and multi-note tremolos!
+ (let* ((children (if (music-is-of-type? e 'sequential-music)
+ ;; \repeat tremolo n { ... }
+ (length (extract-named-music e '(EventChord
+ NoteEvent)))
+ ;; \repeat tremolo n c4
+ 1))
+ (times (ly:music-property music 'repeat-count))
+
+ ;; # of dots is equal to the 1 in bitwise representation (minus 1)!
+ (dots (1- (logcount (* times children))))
+ ;; The remaining missing multiplicator to scale the notes by
+ ;; times * children
+ (mult (/ (* times children (ash 1 dots)) (1- (ash 2 dots))))
+ (shift (- (ly:intlog2 (floor mult)))))
+
+ ;; Adjust the time of the notes
+ (ly:music-compress music (ly:make-moment children 1))
+ ;; Adjust the displayed note durations
+ (shift-duration-log music (- shift) (- dots))))))
(if (pair? es)
(set! (ly:music-property music 'elements)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; property setting music objs.
+(define-safe-public (check-grob-path path #:optional parser location
+ #:key
+ (start 0)
+ default
+ (min 1)
+ max)
+ "Check a grob path specification @var{path}, a symbol list (or a
+single symbol), for validity and possibly complete it. Returns the
+completed specification, or @code{#f} if invalid. If optional
+@var{parser} is given, a syntax error is raised in that case,
+optionally using @var{location}. If an optional keyword argument
+@code{#:start @var{start}} is given, the parsing starts at the given
+index in the sequence @samp{Context.Grob.property.sub-property...},
+with the default of @samp{0} implying the full path.
+
+If there is no valid first element of @var{path} fitting at the given
+path location, an optionally given @code{#:default @var{default}} is
+used as the respective element instead without checking it for
+validity at this position.
+
+The resulting path after possibly prepending @var{default} can be
+constrained in length by optional arguments @code{#:min @var{min}} and
+@code{#:max @var{max}}, defaulting to @samp{1} and unlimited,
+respectively."
+ (let ((path (if (symbol? path) (list path) path)))
+ ;; A Guile 1.x bug specific to optargs precludes moving the
+ ;; defines out of the let
+ (define (unspecial? s)
+ (not (or (object-property s 'is-grob?)
+ (object-property s 'backend-type?))))
+ (define (grob? s)
+ (object-property s 'is-grob?))
+ (define (property? s)
+ (object-property s 'backend-type?))
+ (define (check c p) (c p))
+
+ (let* ((checkers
+ (and (< start 3)
+ (drop (list unspecial? grob? property?) start)))
+ (res
+ (cond
+ ((null? path)
+ ;; tricky. Should we make use of the default when the
+ ;; list is empty? In most cases, this question should be
+ ;; academical as an empty list can only be generated by
+ ;; Scheme and is likely an error. We consider this a case
+ ;; of "no valid first element, and default given".
+ ;; Usually, invalid use cases should be caught later using
+ ;; the #:min argument, and if the user explicitly does not
+ ;; catch this, we just follow through.
+ (if default (list default) '()))
+ ((not checkers)
+ ;; no checkers, so we have a valid first element and just
+ ;; take the path as-is.
+ path)
+ (default
+ (if ((car checkers) (car path))
+ (and (every check (cdr checkers) (cdr path))
+ path)
+ (and (every check (cdr checkers) path)
+ (cons default path))))
+ (else
+ (and (every check checkers path)
+ path)))))
+ (if (and res
+ (if max (<= min (length res) max)
+ (<= min (length res))))
+ res
+ (begin
+ (if parser
+ (ly:parser-error parser
+ (format #f (_ "bad grob property path ~a")
+ path)
+ location))
+ #f)))))
+
(define-public (make-grob-property-set grob gprop val)
"Make a @code{Music} expression that sets @var{gprop} to @var{val} in
@var{grob}. Does a pop first, i.e., this is not an override."
(make-sequential-music
(append
(map (lambda (x) (make-grob-property-set x 'direction
- (if (odd? n) -1 1)))
+ (if (odd? n) -1 1)))
direction-polyphonic-grobs)
(list
(make-property-set 'graceSettings
(make-grob-property-set 'NoteColumn 'horizontal-shift (quotient n 2))
(make-grob-property-set 'MultiMeasureRest 'staff-position (if (odd? n) -4 4))))))
+(define-safe-public (make-voice-props-override n)
+ (make-sequential-music
+ (append
+ (map (lambda (x) (make-grob-property-override x 'direction
+ (if (odd? n) -1 1)))
+ direction-polyphonic-grobs)
+ (list
+ (make-property-set 'graceSettings
+ ;; TODO: take this from voicedGraceSettings or similar.
+ '((Voice Stem font-size -3)
+ (Voice Flag font-size -3)
+ (Voice NoteHead font-size -3)
+ (Voice TabNoteHead font-size -4)
+ (Voice Dots font-size -3)
+ (Voice Stem length-fraction 0.8)
+ (Voice Stem no-stem-extend #t)
+ (Voice Beam beam-thickness 0.384)
+ (Voice Beam length-fraction 0.8)
+ (Voice Accidental font-size -4)
+ (Voice AccidentalCautionary font-size -4)
+ (Voice Script font-size -3)
+ (Voice Fingering font-size -8)
+ (Voice StringNumber font-size -8)))
+
+ (make-grob-property-override 'NoteColumn 'horizontal-shift (quotient n 2))
+ (make-grob-property-override 'MultiMeasureRest 'staff-position (if (odd? n) -4 4))))))
+
(define-safe-public (make-voice-props-revert)
(make-sequential-music
(append
;; found in the repeated chord. We don't need to look for
;; articulations on individual events since they can't actually get
;; into a repeat chord given its input syntax.
- (for-each (lambda (e)
- (for-each (lambda (x)
- (set! event-types (delq x event-types)))
- (ly:music-property e 'types)))
- (ly:music-property repeat-chord 'elements))
+
+ (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)
+
+ (for-each
+ (lambda (field)
+ (for-each (lambda (e)
+ (for-each (lambda (x)
+ (set! event-types (delq x event-types)))
+ (ly:music-property e 'types)))
+ (ly:music-property repeat-chord field)))
+ '(elements articulations))
+
;; now treat the elements
(set! (ly:music-property repeat-chord 'elements)
- (append!
- (filter-map
- (lambda (m)
- (and (any (lambda (t) (music-is-of-type? m t)) event-types)
- (begin
- (set! m (ly:music-deep-copy m))
- (if (pair? (ly:music-property m 'articulations))
- (set! (ly:music-property m 'articulations)
- (filter
- (lambda (a)
- (any (lambda (t) (music-is-of-type? a t))
- event-types))
- (ly:music-property m 'articulations))))
- (if (ly:duration? (ly:music-property m 'duration))
- (set! (ly:music-property m 'duration) duration))
- m)))
- (ly:music-property original-chord 'elements))
- (ly:music-property repeat-chord 'elements))))
+ (let ((elts
+ (set-origin! (ly:music-deep-copy
+ (filter keep-element?
+ (ly:music-property original-chord
+ 'elements))))))
+ (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))))
+ (if (ly:duration? (ly:music-property m 'duration))
+ (set! (ly:music-property m 'duration) duration))))
+ elts)
+ (append! elts (ly:music-property repeat-chord 'elements))))
+ (let ((arts (filter keep-element?
+ (ly:music-property original-chord
+ 'articulations))))
+ (if (pair? arts)
+ (set! (ly:music-property repeat-chord 'articulations)
+ (append!
+ (set-origin! (ly:music-deep-copy arts))
+ (ly:music-property repeat-chord 'articulations))))))
+
(define-public (expand-repeat-chords! event-types music)
"Walks through @var{music} and fills repeated chords (notable by
(let ((chord-repeat (ly:music-property music 'duration)))
(cond
((not (ly:duration? chord-repeat))
- music)
+ (if (any (lambda (m) (ly:duration?
+ (ly:music-property m 'duration)))
+ (ly:music-property music 'elements))
+ music
+ last-chord))
(last-chord
(set! (ly:music-property music 'duration) '())
(copy-repeat-chord last-chord music chord-repeat event-types)
(defmacro-public define-syntax-function (type args signature . body)
"Helper macro for `ly:make-music-function'.
Syntax:
- (define-syntax-function (result-type? parser location arg1 arg2 ...) (result-type? arg1-type arg2-type ...)
+ (define-syntax-function result-type? (parser location arg1 arg2 ...) (arg1-type arg2-type ...)
...function body...)
argX-type can take one of the forms @code{predicate?} for mandatory
(if (vector? (ly:music-property quote-music 'quoted-events))
(let* ((dir (ly:music-property quote-music 'quoted-voice-direction))
- (clef (ly:music-property quote-music 'quoted-music-clef))
- (main-voice (if (eq? 1 dir) 1 0))
- (cue-voice (if (eq? 1 dir) 0 1))
+ (clef (ly:music-property quote-music 'quoted-music-clef #f))
+ (main-voice (case dir ((1) 1) ((-1) 0) (else #f)))
+ (cue-voice (and main-voice (- 1 main-voice)))
(main-music (ly:music-property quote-music 'element))
(return-value quote-music))
- (if (or (eq? 1 dir) (eq? -1 dir))
-
- ;; if we have stem dirs, change both quoted and main music
- ;; to have opposite stems.
- (begin
- (set! return-value
- ;; cannot context-spec Quote-music, since context
- ;; for the quotes is determined in the iterator.
- (make-sequential-music
- (list
- (if (null? clef)
- (make-music 'Music)
- (make-cue-clef-set clef))
- (context-spec-music (make-voice-props-set cue-voice) 'CueVoice "cue")
- quote-music
- (context-spec-music (make-voice-props-revert) 'CueVoice "cue")
- (if (null? clef)
- (make-music 'Music)
- (make-cue-clef-unset)))))
- (set! main-music
- (make-sequential-music
- (list
- (make-voice-props-set main-voice)
- main-music
- (make-voice-props-revert))))
- (set! (ly:music-property quote-music 'element) main-music)))
-
- return-value)
+ (if main-voice
+ (set! (ly:music-property quote-music 'element)
+ (make-sequential-music
+ (list
+ (make-voice-props-override main-voice)
+ main-music
+ (make-voice-props-revert)))))
+
+ ;; if we have stem dirs, change both quoted and main music
+ ;; to have opposite stems.
+
+ ;; cannot context-spec Quote-music, since context
+ ;; for the quotes is determined in the iterator.
+
+ (make-sequential-music
+ (delq! #f
+ (list
+ (and clef (make-cue-clef-set clef))
+
+ ;; Need to establish CueVoice context even in #CENTER case
+ (context-spec-music
+ (if cue-voice
+ (make-voice-props-override cue-voice)
+ (make-music 'Music))
+ 'CueVoice "cue")
+ quote-music
+ (and cue-voice
+ (context-spec-music
+ (make-voice-props-revert) 'CueVoice "cue"))
+ (and clef (make-cue-clef-unset))))))
quote-music))
(define-public ((quote-substitute quote-tab) music)
(check-pitch-against-signature context pitch barnum laziness octaveness))
(define (key-entry-notename entry)
- "Return the pitch of an entry in localKeySignature. The entry is either of the form
- '(notename . alter) or '((octave . notename) . (alter barnum . measurepos))."
- (if (number? (car entry))
- (car entry)
- (cdar entry)))
+ "Return the pitch of an @var{entry} in @code{localKeySignature}.
+The @samp{car} of the entry is either of the form @code{notename} or
+of the form @code{(octave . notename)}. The latter form is used for special
+key signatures or to indicate an explicit accidental.
+
+The @samp{cdr} of the entry is either a rational @code{alter} indicating
+a key signature alteration, or of the form
+@code{(alter . (barnum . measurepos))} indicating an alteration caused by
+an accidental in music."
+ (if (pair? (car entry))
+ (cdar entry)
+ (car entry)))
(define (key-entry-octave entry)
- "Return the octave of an entry in localKeySignature (or #f if the entry does not have
- an octave)."
+ "Return the octave of an entry in @code{localKeySignature}
+or @code{#f} if the entry does not have an octave.
+See @code{key-entry-notename} for details."
(and (pair? (car entry)) (caar entry)))
(define (key-entry-bar-number entry)
- "Return the bar number of an entry in localKeySignature (or #f if the entry does not
- have a bar number)."
- (and (pair? (car entry)) (caddr entry)))
+ "Return the bar number of an entry in @code{localKeySignature}
+or @code {#f} if the entry does not have a bar number.
+See @code{key-entry-notename} for details."
+ (and (pair? (cdr entry)) (caddr entry)))
(define (key-entry-measure-position entry)
- "Return the measure position of an entry in localKeySignature (or #f if the entry does
- not have a measure position)."
- (and (pair? (car entry)) (cdddr entry)))
+ "Return the measure position of an entry in @code{localKeySignature}
+or @code {#f} if the entry does not have a measure position.
+See @code{key-entry-notename} for details."
+ (and (pair? (cdr entry)) (cdddr entry)))
(define (key-entry-alteration entry)
"Return the alteration of an entry in localKeySignature.
For convenience, returns @code{0} if entry is @code{#f}."
(if entry
- (if (number? (car entry))
+ (if (number? (cdr entry))
(cdr entry)
(cadr entry))
0))
(let* ((entry (car keysig))
(entryoct (key-entry-octave entry))
(entrynn (key-entry-notename entry))
- (oct (ly:pitch-octave pitch))
(nn (ly:pitch-notename pitch)))
(if (and (equal? nn entrynn)
- (or (and accept-global (not entryoct))
- (and accept-local (equal? oct entryoct))))
+ (or (not entryoct)
+ (= entryoct (ly:pitch-octave pitch)))
+ (if (key-entry-bar-number entry)
+ accept-local
+ accept-global))
entry
(find-pitch-entry (cdr keysig) pitch accept-global accept-local)))))
(entry (find-pitch-entry keysig pitch #t #t)))
(if (not entry)
(cons #f #f)
- (let* ((global-entry (find-pitch-entry keysig pitch #f #f))
- (key-acc (key-entry-alteration global-entry))
- (acc (ly:pitch-alteration pitch))
- (entrymp (key-entry-measure-position entry))
+ (let* ((entrymp (key-entry-measure-position entry))
(entrybn (key-entry-bar-number entry)))
- (cons #f (not (or (equal? acc key-acc)
- (and (equal? entrybn barnum) (equal? entrymp measurepos)))))))))
+ (cons #f (not (and (equal? entrybn barnum) (equal? entrymp measurepos))))))))
(define-public (set-accidentals-properties extra-natural
auto-accs auto-cauts
(set! (ly:context-property context 'localKeySignature)
(map-in-order
(lambda (entry)
- (let* ((localalt (key-entry-alteration entry))
- (localoct (key-entry-octave entry)))
+ (let* ((localalt (key-entry-alteration entry)))
(if (or (accidental-invalid? localalt)
- (not localoct)
+ (not (key-entry-bar-number entry))
(= localalt
(key-entry-alteration
(find-pitch-entry
keysig
- (ly:make-pitch localoct
+ (ly:make-pitch (key-entry-octave entry)
(key-entry-notename entry)
0)
#t #t))))
(ly:music-property (car evs) 'pitch))))
(define-public (duration-of-note event-chord)
- (let ((evs (filter (lambda (x)
- (music-has-type x 'rhythmic-event))
- (cons event-chord
- (ly:music-property event-chord 'elements)))))
-
- (and (pair? evs)
- (ly:music-property (car evs) 'duration))))
+ (cond
+ ((pair? event-chord)
+ (or (duration-of-note (car event-chord))
+ (duration-of-note (cdr event-chord))))
+ ((ly:music? event-chord)
+ (let ((dur (ly:music-property event-chord 'duration)))
+ (if (ly:duration? dur)
+ dur
+ (duration-of-note (ly:music-property event-chord 'elements)))))
+ (else #f)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define-public (map-some-music map? music)
+ "Walk through @var{music}, transform all elements calling @var{map?}
+and only recurse if this returns @code{#f}."
+ (let loop ((music music))
+ (or (map? music)
+ (let ((elt (ly:music-property music 'element))
+ (elts (ly:music-property music 'elements))
+ (arts (ly:music-property music 'articulations)))
+ (if (ly:music? elt)
+ (set! (ly:music-property music 'element)
+ (loop elt)))
+ (if (pair? elts)
+ (set! (ly:music-property music 'elements)
+ (map loop elts)))
+ (if (pair? arts)
+ (set! (ly:music-property music 'articulations)
+ (map loop arts)))
+ music))))
+
+(define-public (for-some-music stop? music)
+ "Walk through @var{music}, process all elements calling @var{stop?}
+and only recurse if this returns @code{#f}."
+ (let loop ((music music))
+ (if (not (stop? music))
+ (let ((elt (ly:music-property music 'element)))
+ (if (ly:music? elt)
+ (loop elt))
+ (for-each loop (ly:music-property music 'elements))
+ (for-each loop (ly:music-property music 'articulations))))))
+
+(define-public (fold-some-music pred? proc init music)
+ "This works recursively on music like @code{fold} does on a list,
+calling @samp{(@var{pred?} music)} on every music element. If
+@code{#f} is returned for an element, it is processed recursively
+with the same initial value of @samp{previous}, otherwise
+@samp{(@var{proc} music previous)} replaces @samp{previous}
+and no recursion happens.
+The top @var{music} is processed using @var{init} for @samp{previous}."
+ (let loop ((music music) (previous init))
+ (if (pred? music)
+ (proc music previous)
+ (fold loop
+ (fold loop
+ (let ((elt (ly:music-property music 'element)))
+ (if (null? elt)
+ previous
+ (loop elt previous)))
+ (ly:music-property music 'elements))
+ (ly:music-property music 'articulations)))))
+
+(define-public (extract-music music pred?)
+ "Return a flat list of all music matching @var{pred?} inside of
+@var{music}, not recursing into matches themselves."
+ (reverse! (fold-some-music pred? cons '() music)))
+
(define-public (extract-named-music music music-name)
- "Return a flat list of all music named @var{music-name} from @var{music}."
- (if (not (list? music-name))
- (set! music-name (list music-name)))
- (if (ly:music? music)
- (if (memq (ly:music-property music 'name) music-name)
- (list music)
- (let ((arts (ly:music-property music 'articulations)))
- (append-map!
- (lambda (x) (extract-named-music x music-name))
- (if (pair? arts)
- arts
- (cons (ly:music-property music 'element)
- (ly:music-property music 'elements))))))
- '()))
+ "Return a flat list of all music named @var{music-name} (either a
+single event symbol or a list of alternatives) inside of @var{music},
+not recursing into matches themselves."
+ (extract-music
+ music
+ (if (cheap-list? music-name)
+ (lambda (m) (memq (ly:music-property m 'name) music-name))
+ (lambda (m) (eq? (ly:music-property m 'name) music-name)))))
(define-public (extract-typed-music music type)
- "Return a flat list of all music with @var{type} from @var{music}."
- (if (ly:music? music)
- (if (music-is-of-type? music type)
- (list music)
- (let ((arts (ly:music-property music 'articulations)))
- (append-map!
- (lambda (x) (extract-typed-music x type))
- (if (pair? arts)
- arts
- (cons (ly:music-property music 'element)
- (ly:music-property music 'elements))))))
- '()))
+ "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)))))
+
+(define*-public (event-chord-wrap! music #:optional parser)
+ "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."
+ (map-some-music
+ (lambda (m)
+ (cond ((music-is-of-type? m 'event-chord)
+ (if (pair? (ly:music-property m 'articulations))
+ (begin
+ (set! (ly:music-property m 'elements)
+ (append (ly:music-property m 'elements)
+ (ly:music-property m 'articulations)))
+ (set! (ly:music-property m 'articulations) '())))
+ m)
+ ((music-is-of-type? m 'rhythmic-event)
+ (let ((arts (ly:music-property m 'articulations)))
+ (if (pair? arts)
+ (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)))
(define-public (event-chord-notes event-chord)
"Return a list of all notes from @var{event-chord}."
"Return a list of all pitches from @var{event-chord}."
(map (lambda (x) (ly:music-property x 'pitch))
(event-chord-notes event-chord)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; The following functions are all associated with the crossStaff
+; function
+
+(define (close-enough? x y)
+ "Values are close enough to ignore the difference"
+ (< (abs (- x y)) 0.0001))
+
+(define (extent-combine extents)
+ "Combine a list of extents"
+ (if (pair? (cdr extents))
+ (interval-union (car extents) (extent-combine (cdr extents)))
+ (car extents)))
+
+(define ((stem-connectable? ref root) stem)
+ "Check if the stem is connectable to the root"
+ ; The root is always connectable to itself
+ (or (eq? root stem)
+ (and
+ ; Horizontal positions of the stems must be almost the same
+ (close-enough? (car (ly:grob-extent root ref X))
+ (car (ly:grob-extent stem ref X)))
+ ; The stem must be in the direction away from the root's notehead
+ (positive? (* (ly:grob-property root 'direction)
+ (- (car (ly:grob-extent stem ref Y))
+ (car (ly:grob-extent root ref Y))))))))
+
+(define (stem-span-stencil span)
+ "Connect stems if we have at least one stem connectable to the root"
+ (let* ((system (ly:grob-system span))
+ (root (ly:grob-parent span X))
+ (stems (filter (stem-connectable? system root)
+ (ly:grob-object span 'stems))))
+ (if (<= 2 (length stems))
+ (let* ((yextents (map (lambda (st)
+ (ly:grob-extent st system Y)) stems))
+ (yextent (extent-combine yextents))
+ (layout (ly:grob-layout root))
+ (blot (ly:output-def-lookup layout 'blot-diameter)))
+ ; Hide spanned stems
+ (map (lambda (st)
+ (set! (ly:grob-property st 'transparent) #t))
+ stems)
+ ; Draw a nice looking stem with rounded corners
+ (ly:round-filled-box (ly:grob-extent root root X) yextent blot))
+ ; Nothing to connect, don't draw the span
+ #f)))
+
+(define ((make-stem-span! stems trans) root)
+ "Create a stem span as a child of the cross-staff stem (the root)"
+ (let ((span (ly:engraver-make-grob trans 'Stem '())))
+ (ly:grob-set-parent! span X root)
+ (set! (ly:grob-object span 'stems) stems)
+ ; Suppress positioning, the stem code is confused by this weird stem
+ (set! (ly:grob-property span 'X-offset) 0)
+ (set! (ly:grob-property span 'stencil) stem-span-stencil)))
+
+(define-public (cross-staff-connect stem)
+ "Set cross-staff property of the stem to this function to connect it to
+other stems automatically"
+ #t)
+
+(define (stem-is-root? stem)
+ "Check if automatic connecting of the stem was requested. Stems connected
+to cross-staff beams are cross-staff, but they should not be connected to
+other stems just because of that."
+ (eq? cross-staff-connect (ly:grob-property-data stem 'cross-staff)))
+
+(define (make-stem-spans! ctx stems trans)
+ "Create stem spans for cross-staff stems"
+ ; Cannot do extensive checks here, just make sure there are at least
+ ; two stems at this musical moment
+ (if (<= 2 (length stems))
+ (let ((roots (filter stem-is-root? stems)))
+ (map (make-stem-span! stems trans) roots))))
+
+(define-public (Span_stem_engraver ctx)
+ "Connect cross-staff stems to the stems above in the system"
+ (let ((stems '()))
+ (make-engraver
+ ; Record all stems for the given moment
+ (acknowledgers
+ ((stem-interface trans grob source)
+ (set! stems (cons grob stems))))
+ ; Process stems and reset the stem list to empty
+ ((process-acknowledged trans)
+ (make-stem-spans! ctx stems trans)
+ (set! stems '())))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; The following is used by the alterBroken function.
+
+(define-public ((value-for-spanner-piece arg) grob)
+ "Associate a piece of broken spanner @var{grob} with an element
+of list @var{arg}."
+ (let* ((orig (ly:grob-original grob))
+ (siblings (ly:spanner-broken-into orig)))
+
+ (define (helper sibs arg)
+ (if (null? arg)
+ arg
+ (if (eq? (car sibs) grob)
+ (car arg)
+ (helper (cdr sibs) (cdr arg)))))
+
+ (if (>= (length siblings) 2)
+ (helper siblings arg)
+ (car arg))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; measure counter
+
+(define (measure-counter-stencil grob)
+ "Print a number for a measure count. The number is centered using
+the extents of @code{BreakAlignment} grobs associated with
+@code{NonMusicalPaperColumn} grobs. In the case of an unbroken measure, these
+columns are the left and right bounds of a @code{MeasureCounter} spanner.
+Broken measures are numbered in parentheses."
+ (let* ((orig (ly:grob-original grob))
+ (siblings (ly:spanner-broken-into orig)) ; have we been split?
+ (bounds (ly:grob-array->list (ly:grob-object grob 'columns)))
+ (refp (ly:grob-system grob))
+ ; we use the first and/or last NonMusicalPaperColumn grob(s) of
+ ; a system in the event that a MeasureCounter spanner is broken
+ (all-cols (ly:grob-array->list (ly:grob-object refp 'columns)))
+ (all-cols
+ (filter
+ (lambda (col) (eq? #t (ly:grob-property col 'non-musical)))
+ all-cols))
+ (left-bound
+ (if (or (null? siblings) ; spanner is unbroken
+ (eq? grob (car siblings))) ; or the first piece
+ (car bounds)
+ (car all-cols)))
+ (right-bound
+ (if (or (null? siblings)
+ (eq? grob (car (reverse siblings))))
+ (car (reverse bounds))
+ (car (reverse all-cols))))
+ (elts-L (ly:grob-array->list (ly:grob-object left-bound 'elements)))
+ (elts-R (ly:grob-array->list (ly:grob-object right-bound 'elements)))
+ (break-alignment-L
+ (filter
+ (lambda (elt) (grob::has-interface elt 'break-alignment-interface))
+ elts-L))
+ (break-alignment-R
+ (filter
+ (lambda (elt) (grob::has-interface elt 'break-alignment-interface))
+ elts-R))
+ (break-alignment-L-ext (ly:grob-extent (car break-alignment-L) refp X))
+ (break-alignment-R-ext (ly:grob-extent (car break-alignment-R) refp X))
+ (num (markup (number->string (ly:grob-property grob 'count-from))))
+ (num
+ (if (or (null? siblings)
+ (eq? grob (car siblings)))
+ num
+ (make-parenthesize-markup num)))
+ (num (grob-interpret-markup grob num))
+ (num (ly:stencil-aligned-to num X (ly:grob-property grob 'self-alignment-X)))
+ (num
+ (ly:stencil-translate-axis
+ num
+ (+ (interval-length break-alignment-L-ext)
+ (* 0.5
+ (- (car break-alignment-R-ext)
+ (cdr break-alignment-L-ext))))
+ X)))
+ num))
projects / lilypond.git / blobdiff