(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
(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)
;; 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-override 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-override 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)
(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!
- (let loop ((music music) (res '()))
- (if (pred? music)
- (cons music res)
- (fold loop
- (fold loop
- (let ((elt (ly:music-property music 'element)))
- (if (null? elt)
- res
- (loop elt res)))
- (ly:music-property music 'elements))
- (ly:music-property music 'articulations))))))
+ (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} (either a
"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))))
projects / lilypond.git / blobdiff