(use-modules (scm safe-utility-defs))
(use-modules (ice-9 optargs))
+(use-modules (srfi srfi-11))
;;; ly:music-property with setter
;;; (ly:music-property my-music 'elements)
(string-length "-markup")))))))
(define (transform-arg arg)
(cond ((and (pair? arg) (markup? (car arg))) ;; a markup list
- (apply append (map inner-markup->make-markup arg)))
+ (append-map inner-markup->make-markup arg))
((and (not (string? arg)) (markup? arg)) ;; a markup
(inner-markup->make-markup arg))
(else ;; scheme arg
(ly:music? obj)
`(make-music
',(ly:music-property obj 'name)
- ,@(apply append (map (lambda (prop)
- `(',(car prop)
- ,(music->make-music (cdr prop))))
- (remove (lambda (prop)
- (eqv? (car prop) 'origin))
- (ly:music-mutable-properties obj))))))
+ ,@(append-map (lambda (prop)
+ `(',(car prop)
+ ,(music->make-music (cdr prop))))
+ (remove (lambda (prop)
+ (eqv? (car prop) 'origin))
+ (ly:music-mutable-properties obj)))))
(;; moment
(ly:moment? obj)
`(ly:make-moment ,(ly:moment-main-numerator obj)
(unfold-repeats e)))
music))
+(define-public (unfold-repeats-fully music)
+ "Unfolds repeats and expands the resulting @code{unfolded-repeated-music}."
+ (map-some-music
+ (lambda (m)
+ (and (music-is-of-type? m 'unfolded-repeated-music)
+ (make-sequential-music
+ (ly:music-deep-copy
+ (let loop ((n (ly:music-property m 'repeat-count))
+ (alts (ly:music-property m 'elements))
+ (body (ly:music-property m 'element)))
+ (cond ((<= n 0) '())
+ ((null? alts)
+ (cons body (loop (1- n) alts body)))
+ (else
+ (cons* body (car alts)
+ (loop (1- n)
+ (if (pair? (cdr alts))
+ (cdr alts)
+ alts)
+ body)))))))))
+ (unfold-repeats music)))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; property setting music objs.
(make-music 'PropertyUnset
'symbol sym))
-(define-safe-public (make-articulation name)
- (make-music 'ArticulationEvent
- 'articulation-type name))
+(define-safe-public (make-articulation name . properties)
+ (apply make-music 'ArticulationEvent
+ 'articulation-type name
+ properties))
(define-public (make-lyric-event string duration)
(make-music 'LyricEvent
(set! (ly:music-property repeat-chord 'articulations)
(append!
(set-origin! (ly:music-deep-copy arts))
- (ly:music-property repeat-chord 'articulations))))))
+ (ly:music-property repeat-chord 'articulations)))))
+ repeat-chord)
(define-public (expand-repeat-chords! event-types music)
last-chord))
(last-chord
(set! (ly:music-property music 'duration) '())
- (copy-repeat-chord last-chord music chord-repeat event-types)
- music)
+ (copy-repeat-chord last-chord music chord-repeat event-types))
(else
(ly:music-warning music (_ "Bad chord repetition"))
#f)))
(ly:music-property music 'elements)))))
music)
+;;; This does _not_ copy any articulations. Rationale: one main
+;;; incentive for pitch-repeating durations is after ties, such that
+;;; 4~2~8. can stand in for a 15/16 note in \partial 4 position. In
+;;; this use case, any repeated articulations will be a nuisance.
+;;;
+;;; String assignments in TabStaff might seem like a worthwhile
+;;; exception, but they would be better tackled by the respective
+;;; engravers themselves (see issue 3662).
+;;;
+;;; Repeating chords as well seems problematic for things like
+;;; \score {
+;;; <<
+;;; \new Staff { c4 c c <c e> }
+;;; \new RhythmicStaff { 4 4 4 4 }
+;;; >>
+;;; }
+;;;
+;;; However, because of MIDI it is not advisable to use RhythmicStaff
+;;; without any initial pitch/drum-type. For music functions taking
+;;; pure rhythms as an argument, the running of expand-repeat-notes!
+;;; at scorification time is irrelevant: at that point of time, the
+;;; music function has already run.
+
+(define-public (expand-repeat-notes! music)
+ "Walks through @var{music} and gives pitchless notes (not having a
+pitch in code{pitch} or a drum type in @code{drum-type}) the pitch(es)
+from the predecessor note/chord if available."
+ (let ((last-pitch #f))
+ (map-some-music
+ (lambda (m)
+ (define (set-and-ret last)
+ (set! last-pitch last)
+ m)
+ (cond
+ ((music-is-of-type? m 'event-chord)
+ (set-and-ret m))
+ ((music-is-of-type? m 'note-event)
+ (cond
+ ((or (ly:music-property m 'pitch #f)
+ (ly:music-property m 'drum-type #f))
+ => set-and-ret)
+ ;; ok, naked rhythm. Go through the various cases of
+ ;; last-pitch
+ ;; nothing available: just keep as-is
+ ((not last-pitch) m)
+ ((ly:pitch? last-pitch)
+ (set! (ly:music-property m 'pitch) last-pitch)
+ m)
+ ((symbol? last-pitch)
+ (set! (ly:music-property m 'drum-type) last-pitch)
+ m)
+ ;; Ok, this is the big bad one: the reference is a chord.
+ ;; For now, we use the repeat chord logic. That's not
+ ;; really efficient as cleaning out all articulations is
+ ;; quite simpler than what copy-repeat-chord does.
+ (else
+ (copy-repeat-chord last-pitch
+ (make-music 'EventChord
+ 'elements
+ (ly:music-property m 'articulations)
+ 'origin
+ (ly:music-property m 'origin))
+ (ly:music-property m 'duration)
+ '(rhythmic-event)))))
+ (else #f)))
+ music)))
+
;;; splitting chords into voices.
(define (voicify-list lst number)
"Make a list of Musics.
predicates, to be used in case of a type error in arguments or
result."
+ (define (currying-lambda args doc-string? body)
+ (if (and (pair? args)
+ (pair? (car args)))
+ (currying-lambda (car args) doc-string?
+ `((lambda ,(cdr args) ,@body)))
+ (if doc-string?
+ `(lambda ,args ,doc-string? ,@body)
+ `(lambda ,args ,@body))))
+
(set! signature (map (lambda (pred)
(if (pair? pred)
`(cons ,(car pred)
,(and (pair? (cdr pred)) (cadr pred)))
pred))
(cons type signature)))
- (if (and (pair? body) (pair? (car body)) (eqv? '_i (caar body)))
- ;; When the music function definition contains a i10n doc string,
- ;; (_i "doc string"), keep the literal string only
- (let ((docstring (cadar body))
- (body (cdr body)))
- `(ly:make-music-function (list ,@signature)
- (lambda ,args
- ,docstring
- ,@body)))
- `(ly:make-music-function (list ,@signature)
- (lambda ,args
- ,@body))))
+
+ (let ((docstring
+ (and (pair? body) (pair? (cdr body))
+ (if (string? (car body))
+ (car body)
+ (and (pair? (car body))
+ (eq? '_i (caar body))
+ (pair? (cdar body))
+ (string? (cadar body))
+ (null? (cddar body))
+ (cadar body))))))
+ ;; When the music function definition contains an i10n doc string,
+ ;; (_i "doc string"), keep the literal string only
+ `(ly:make-music-function
+ (list ,@signature)
+ ,(currying-lambda args docstring (if docstring (cdr body) body)))))
(defmacro-public define-music-function rest
"Defining macro returning music functions.
(else music))))
-(define-public toplevel-music-functions
+(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))
(map (lambda (x) (ly:music-property x 'pitch))
(event-chord-notes event-chord)))
-(defmacro-public make-relative (pitches last-pitch music)
- "The list of pitch-carrying variables in @var{pitches} is used as a
-sequence for creating relativable music from @var{music}.
-The variables in @var{pitches} are, when considered inside of
-@code{\\relative}, all considered to be specifications to the preceding
-variable. The first variable is relative to the preceding musical
-context, and @var{last-pitch} specifies the pitch passed as relative
-base onto the following musical context."
+(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."
+ (map-some-music
+ (lambda (m)
+ (and (music-is-of-type? m 'event-chord)
+ (let*-values (((notes arts) (partition
+ (lambda (mus)
+ (music-is-of-type? mus 'rhythmic-event))
+ (ly:music-property m 'elements)))
+ ((dur) (ly:music-property m 'duration))
+ ((full-arts) (append arts
+ (ly:music-property m 'articulations)))
+ ((first-note) (and (pair? notes) (car notes))))
+ (cond (first-note
+ (set! (ly:music-property first-note 'articulations)
+ full-arts)
+ first-note)
+ ((ly:duration? dur)
+ ;; A repeat chord. Produce an unpitched note.
+ (make-music 'NoteEvent
+ 'duration dur
+ 'articulations full-arts))
+ (else
+ (ly:music-error m (_ "Missing duration"))
+ (make-music 'NoteEvent
+ 'duration (ly:make-duration 2 0 0)
+ 'articulations full-arts))))))
+ music))
+
+
+(defmacro-public make-relative (variables reference music)
+ "The list of pitch or music variables in @var{variables} is used as
+a sequence for creating relativable music from @var{music}.
+
+When the constructed music is used outside of @code{\\relative}, it
+just reflects plugging in the @var{variables} into @var{music}.
+
+The action inside of @code{\\relative}, however, is determined by
+first relativizing the surrogate @var{reference} with the variables
+plugged in and then using the variables relativized as a side effect
+of relativizing @var{reference} for evaluating @var{music}.
+
+Since pitches don't have the object identity required for tracing the
+effect of the reference call, they are replaced @emph{only} for the
+purpose of evaluating @var{reference} with simple pitched note events.
+
+The surrogate @var{reference} expression has to be written with that
+in mind. In addition, it must @emph{not} contain @emph{copies} of
+music that is supposed to be relativized but rather the
+@emph{originals}. This @emph{includes} the pitch expressions. As a
+rule, inside of @code{#@{@dots{}#@}} variables must @emph{only} be
+introduced using @code{#}, never via the copying construct @code{$}.
+The reference expression will usually just be a sequential or chord
+expression naming all variables in sequence, implying that following
+music will be relativized according to the resulting pitch of the last
+or first variable, respectively.
+
+Since the usual purpose is to create more complex music from general
+arguments and since music expression parts must not occur more than
+once, one @emph{does} generally need to use copying operators in the
+@emph{replacement} expression @var{music} when using an argument more
+than once there. Using an argument more than once in @var{reference},
+in contrast, does not make sense.
+
+There is another fine point to mind: @var{music} must @emph{only}
+contain freshly constructed elements or copied constructs. This will
+be the case anyway for regular LilyPond code inside of
+@code{#@{@dots{}#@}}, but any other elements (apart from the
+@var{variables} themselves which are already copied) must be created
+or copied as well.
+
+The reason is that it is usually permitted to change music in-place as
+long as one does a @var{ly:music-deep-copy} on it, and such a copy of
+the whole resulting expression will @emph{not} be able to copy
+variables/values inside of closures where the information for
+relativization is being stored.
+"
;; pitch and music generator might be stored instead in music
;; properties, and it might make sense to create a music type of its
;; own for this kind of construct rather than using
;; RelativeOctaveMusic
- (define ((make-relative::to-relative-callback pitches p->m p->p) music pitch)
- (let* ((chord (make-event-chord
- (map
- (lambda (p)
- (make-music 'NoteEvent
- 'pitch p))
- pitches)))
- (pitchout (begin
- (ly:make-music-relative! chord pitch)
- (event-chord-pitches chord))))
- (set! (ly:music-property music 'element)
- (apply p->m pitchout))
- (apply p->p pitchout)))
+ (define ((make-relative::to-relative-callback variables music-call ref-call)
+ music pitch)
+ (let* ((ref-vars (map (lambda (v)
+ (if (ly:pitch? v)
+ (make-music 'NoteEvent 'pitch v)
+ (ly:music-deep-copy v)))
+ variables))
+ (after-pitch (ly:make-music-relative! (apply ref-call ref-vars) pitch))
+ (actual-vars (map (lambda (v r)
+ (if (ly:pitch? v)
+ (ly:music-property r 'pitch)
+ r))
+ variables ref-vars))
+ (rel-music (apply music-call actual-vars)))
+ (set! (ly:music-property music 'element) rel-music)
+ after-pitch))
`(make-music 'RelativeOctaveMusic
'to-relative-callback
(,make-relative::to-relative-callback
- (list ,@pitches)
- (lambda ,pitches ,music)
- (lambda ,pitches ,last-pitch))
+ (list ,@variables)
+ (lambda ,variables ,music)
+ (lambda ,variables ,reference))
'element ,music))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(layout (ly:grob-layout root))
(blot (ly:output-def-lookup layout 'blot-diameter)))
;; Hide spanned stems
- (map (lambda (st)
- (set! (ly:grob-property st 'stencil) #f))
- stems)
+ (for-each (lambda (st)
+ (set! (ly:grob-property st 'stencil) #f))
+ 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
;; two stems at this musical moment
(if (<= 2 (length stems))
(let ((roots (filter stem-is-root? stems)))
- (map (make-stem-span! stems trans) roots))))
+ (for-each (make-stem-span! stems trans) roots))))
(define-public (Span_stem_engraver ctx)
"Connect cross-staff stems to the stems above in the system"
(cdr break-alignment-L-ext))))
X)))
num))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; The following are used by the \offset function
+
+(define (find-value-to-offset prop self alist)
+ "Return the first value of the property @var{prop} in the property
+alist @var{alist} -- after having found @var{self}. If @var{self} is
+not found, return the first value of @var{prop}."
+ (let ((segment (member (cons prop self) alist)))
+ (if (not segment)
+ (assoc-get prop alist)
+ (assoc-get prop (cdr segment)))))
+
+(define (offset-multiple-types arg offsets)
+ "Displace @var{arg} by @var{offsets} if @var{arg} is a number, a
+number pair, or a list of number pairs. If @var{offsets} is an empty
+list or if there is a type-mismatch, @var{arg} will be returned."
+ (cond
+ ((and (number? arg) (number? offsets))
+ (+ arg offsets))
+ ((and (number-pair? arg)
+ (or (number? offsets)
+ (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))
+ (else arg)))
+
+(define-public (offsetter property offsets)
+ "Apply @var{offsets} to the default values of @var{property} of @var{grob}.
+Offsets are restricted to immutable properties and values of type @code{number},
+@code{number-pair}, or @code{number-pair-list}."
+ (define (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))))
+
+ (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.
+ (if (equal? empty-interval vals)
+ (ly:warning "default '~a of ~a is ~a and can't be offset"
+ property grob vals)
+ (let* ((orig (ly:grob-original grob))
+ (siblings
+ (if (ly:spanner? grob)
+ (ly:spanner-broken-into orig)
+ '()))
+ (total-found (length siblings))
+ ; Since there is some flexibility in input syntax,
+ ; structure of `offsets' is normalized.
+ (offsets
+ (if (or (not (pair? offsets))
+ (number-pair? offsets)
+ (and (number-pair-list? offsets)
+ (number-pair-list? vals)))
+ (list offsets)
+ offsets)))
+
+ (define (helper sibs offs)
+ ; apply offsets to the siblings of broken spanners
+ (if (pair? offs)
+ (if (eq? (car sibs) grob)
+ (offset-multiple-types vals (car offs))
+ (helper (cdr sibs) (cdr offs)))
+ vals))
+
+ (if (>= total-found 2)
+ (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)