+
+(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 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 ,@variables)
+ (lambda ,variables ,music)
+ (lambda ,variables ,reference))
+ 'element ,music))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; 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
+ (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
+ #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)))
+ (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"
+ (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))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; 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)
projects / lilypond.git / blobdiff