1 ;;;; This file is part of LilyPond, the GNU music typesetter.
3 ;;;; Copyright (C) 1998--2015 Jan Nieuwenhuizen <janneke@gnu.org>
4 ;;;; Han-Wen Nienhuys <hanwen@xs4all.nl>
6 ;;;; LilyPond is free software: you can redistribute it and/or modify
7 ;;;; it under the terms of the GNU General Public License as published by
8 ;;;; the Free Software Foundation, either version 3 of the License, or
9 ;;;; (at your option) any later version.
11 ;;;; LilyPond is distributed in the hope that it will be useful,
12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ;;;; GNU General Public License for more details.
16 ;;;; You should have received a copy of the GNU General Public License
17 ;;;; along with LilyPond. If not, see <http://www.gnu.org/licenses/>.
20 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
23 (define-public (grob::has-interface grob iface)
24 (memq iface (ly:grob-interfaces grob)))
26 (define-public (grob::is-live? grob)
27 (pair? (ly:grob-basic-properties grob)))
29 (define-public (grob::name grob)
30 "Return the name of the grob @var{grob} as a symbol."
31 (assq-ref (ly:grob-property grob 'meta) 'name))
33 (define-public (grob::rhythmic-location grob)
34 "Return a pair consisting of the measure number and moment within
35 the measure of grob @var{grob}."
36 (let* (; all grobs support either spanner- or item-interface
37 (item (if (grob::has-interface grob 'spanner-interface)
38 (ly:spanner-bound grob LEFT)
40 (col (ly:item-get-column item)))
42 (ly:grob-property col 'rhythmic-location)
45 (define-public (grob::when grob)
46 "Return the global timestep (a moment) of grob @var{grob}."
47 (let* (; all grobs support either spanner- or item-interface
48 (item (if (grob::has-interface grob 'spanner-interface)
49 (ly:spanner-bound grob LEFT)
51 (col (ly:item-get-column item)))
53 (ly:grob-property col 'when)
56 (define-public (make-stencil-boxer thickness padding callback)
57 "Return function that adds a box around the grob passed as argument."
59 (box-stencil (callback grob) thickness padding)))
61 (define-public (make-stencil-circler thickness padding callback)
62 "Return function that adds a circle around the grob passed as argument."
64 (circle-stencil (callback grob) thickness padding)))
66 (define-public (print-circled-text-callback grob)
67 (grob-interpret-markup grob (make-circle-markup
68 (ly:grob-property grob 'text))))
70 (define-public (event-cause grob)
71 (let ((cause (ly:grob-property grob 'cause)))
74 ((ly:stream-event? cause) cause)
75 ((ly:grob? cause) (event-cause cause))
78 (define-public (grob-interpret-markup grob text)
79 (let* ((layout (ly:grob-layout grob))
80 (defs (ly:output-def-lookup layout 'text-font-defaults))
81 (props (ly:grob-alist-chain grob defs)))
83 (ly:text-interface::interpret-markup layout props text)))
85 (define-public (grob::unpure-Y-extent-from-stencil pure-function)
86 "The unpure height will come from a stencil whereas the pure
87 height will come from @code{pure-function}."
88 (ly:make-unpure-pure-container ly:grob::stencil-height pure-function))
90 (define-public grob::unpure-horizontal-skylines-from-stencil
91 (ly:make-unpure-pure-container
92 ly:grob::horizontal-skylines-from-stencil
93 ly:grob::pure-simple-horizontal-skylines-from-extents))
95 (define-public grob::always-horizontal-skylines-from-stencil
96 (ly:make-unpure-pure-container
97 ly:grob::horizontal-skylines-from-stencil))
99 (define-public grob::unpure-vertical-skylines-from-stencil
100 (ly:make-unpure-pure-container
101 ly:grob::vertical-skylines-from-stencil
102 ly:grob::pure-simple-vertical-skylines-from-extents))
104 (define-public grob::always-vertical-skylines-from-stencil
105 (ly:make-unpure-pure-container
106 ly:grob::vertical-skylines-from-stencil))
108 (define-public grob::always-vertical-skylines-from-element-stencils
109 (ly:make-unpure-pure-container
110 ly:grob::vertical-skylines-from-element-stencils
111 ly:grob::pure-vertical-skylines-from-element-stencils))
113 (define-public grob::always-horizontal-skylines-from-element-stencils
114 (ly:make-unpure-pure-container
115 ly:grob::horizontal-skylines-from-element-stencils
116 ly:grob::pure-horizontal-skylines-from-element-stencils))
118 ;; Using this as a callback for a grob's Y-extent promises
119 ;; that the grob's stencil does not depend on line-spacing.
120 ;; We use this promise to figure the space required by Clefs
121 ;; and such at the note-spacing stage.
123 (define-public grob::always-Y-extent-from-stencil
124 (ly:make-unpure-pure-container ly:grob::stencil-height))
126 (define-public (layout-line-thickness grob)
127 "Get the line thickness of the @var{grob}'s corresponding layout."
128 (let* ((layout (ly:grob-layout grob))
129 (line-thickness (ly:output-def-lookup layout 'line-thickness)))
133 (define (grob::objects-from-interface grob iface)
134 "For grob @var{grob} return the name and contents of all properties
135 within interface @var{iface} having type @code{ly:grob?} or
136 @code{ly:grob-array?}."
137 (let* ((iface-entry (hashq-ref (ly:all-grob-interfaces) iface))
138 (props (if iface-entry (last iface-entry) '()))
142 (let ((type (object-property prop 'backend-type?)))
143 (or (eq? type ly:grob?)
144 (eq? type ly:grob-array?))))
146 (if (null? pointer-props)
150 (lambda (prop) (list prop (ly:grob-object grob prop)))
153 (define-public (grob::all-objects grob)
154 "Return a list of the names and contents of all properties having type
155 @code{ly:grob?} or @code{ly:grob-array?} for all interfaces supported by
157 (let loop ((ifaces (ly:grob-interfaces grob)) (result '()))
159 (cons grob (list result))
160 (let ((entry (grob::objects-from-interface grob (car ifaces))))
162 (loop (cdr ifaces) (append result (list entry)))
163 (loop (cdr ifaces) result))))))
165 (use-modules (ice-9 pretty-print))
166 (define-public (grob::display-objects grob)
167 "Display all objects stored in properties of grob @var{grob}."
168 (pretty-print (grob::all-objects grob))
171 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
174 ;; even though kievan noteheads do not have stems, their
175 ;; invisible stems help with beam placement
176 ;; this assures that invisible stems for kievan notes are aligned
177 ;; to the center of kievan noteheads. that is thus where the beams'
178 ;; x extrema will fall
179 (define-public (stem::kievan-offset-callback grob)
180 (let* ((note-heads (ly:grob-object grob 'note-heads))
181 (note-heads-grobs (if (not (null? note-heads))
182 (ly:grob-array->list note-heads)
184 (first-note-head (if (not (null? note-heads-grobs))
185 (car note-heads-grobs)
187 (note-head-w (if (not (null? first-note-head))
188 (ly:grob-extent first-note-head first-note-head X)
190 (interval-center note-head-w)))
193 ;; sets position of beams for Kievan notation
194 (define-public (beam::get-kievan-positions grob)
195 (let* ((stems (ly:grob-object grob 'stems))
196 (stems-grobs (if (not (null? stems))
197 (ly:grob-array->list stems)
199 (first-stem (if (not (null? stems-grobs))
202 (note-heads (if (not (null? first-stem))
203 (ly:grob-object first-stem 'note-heads)
205 (note-heads-grobs (if (not (null? note-heads))
206 (ly:grob-array->list note-heads)
208 (first-note-head (if (not (null? note-heads-grobs))
209 (car note-heads-grobs)
211 (next-stem (if (not (null? stems))
214 (next-note-heads (if (not (null? next-stem))
215 (ly:grob-object next-stem 'note-heads)
217 (next-note-heads-grobs (if (not (null? next-note-heads))
218 (ly:grob-array->list next-note-heads)
220 (next-note-head (if (not (null? next-note-heads-grobs))
221 (car next-note-heads-grobs)
223 (left-pos (ly:grob-property first-note-head 'Y-offset))
224 (right-pos (ly:grob-property next-note-head 'Y-offset))
225 (direction (ly:grob-property grob 'direction))
226 (first-nh-height (ly:grob::stencil-height first-note-head))
227 (next-nh-height (ly:grob::stencil-height next-note-head))
228 (left-height (if (= direction DOWN)
229 (+ (car first-nh-height) 0.75)
230 (- (cdr first-nh-height) 0.75)))
231 (right-height (if (= direction DOWN)
232 (+ (car next-nh-height) 0.75)
233 (- (cdr next-nh-height) 0.75))))
234 (cons (+ left-pos left-height) (+ right-pos right-height))))
236 (define-public (beam::get-kievan-quantized-positions grob)
237 (let* ((pos (ly:grob-property grob 'positions))
238 (stems (ly:grob-object grob 'stems))
239 (stems-grobs (if (not (null? stems))
240 (ly:grob-array->list stems)
244 (ly:grob-set-property! g 'stem-begin-position 0)
245 (ly:grob-set-property! g 'length 0))
249 ;; calculates each slope of a broken beam individually
250 (define-public (beam::place-broken-parts-individually grob)
251 (ly:beam::quanting grob '(+inf.0 . -inf.0) #f))
253 ;; calculates the slope of a beam as a single unit,
254 ;; even if it is broken. this assures that the beam
255 ;; will pick up where it left off after a line break
256 (define-public (beam::align-with-broken-parts grob)
257 (ly:beam::quanting grob '(+inf.0 . -inf.0) #t))
259 ;; uses the broken beam style from edition peters combines the
260 ;; values of place-broken-parts-individually and align-with-broken-parts above,
261 ;; favoring place-broken-parts-individually when the beam naturally has a steeper
262 ;; incline and align-with-broken-parts when the beam is flat
263 (define-public (beam::slope-like-broken-parts grob)
265 (/ (- (cdr y) (car y)) (- (cdr x) (car x))))
266 (let* ((quant1 (ly:beam::quanting grob '(+inf.0 . -inf.0) #t))
267 (original (ly:grob-original grob))
268 (siblings (if (ly:grob? original)
269 (ly:spanner-broken-into original)
273 (let* ((quant2 (ly:beam::quanting grob '(+inf.0 . -inf.0) #f))
274 (x-span (ly:grob-property grob 'X-positions))
275 (slope1 (slope quant1 x-span))
276 (slope2 (slope quant2 x-span))
277 (quant2 (if (not (= (sign slope1) (sign slope2)))
280 (factor (/ (atan (abs slope1)) PI-OVER-TWO))
283 (+ (* (x quant1) (- 1 factor))
284 (* (x quant2) factor)))
286 (ly:beam::quanting grob base #f)))))
288 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
291 (define-public (script-or-side-position-cross-staff g)
293 (ly:script-interface::calc-cross-staff g)
294 (ly:side-position-interface::calc-cross-staff g)))
297 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
298 ;; side-position stuff
300 (define-public (only-if-beamed g)
301 (any (lambda (x) (ly:grob? (ly:grob-object x 'beam)))
302 (ly:grob-array->list (ly:grob-object g 'side-support-elements))))
304 (define-public side-position-interface::y-aligned-side
305 (ly:make-unpure-pure-container
306 ly:side-position-interface::y-aligned-side
307 ly:side-position-interface::pure-y-aligned-side))
309 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
310 ;; self-alignment stuff
312 (define-public self-alignment-interface::y-aligned-on-self
313 (ly:make-unpure-pure-container
314 ly:self-alignment-interface::y-aligned-on-self
315 ly:self-alignment-interface::pure-y-aligned-on-self))
317 (define-public (self-alignment-interface::self-aligned-on-breakable grob)
318 "Return the @code{X-offset} that places @var{grob} according to its
319 @code{self-alignment-X} over the reference point defined by the
320 @code{break-align-anchor-alignment} of a @code{break-aligned} item
321 such as a @code{Clef}."
322 (+ (ly:break-alignable-interface::self-align-callback grob)
323 (ly:self-alignment-interface::x-aligned-on-self grob)))
325 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
328 (define staff-symbol-referencer::callback
329 (ly:make-unpure-pure-container ly:staff-symbol-referencer::callback))
331 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
334 (define-public (stem::calc-duration-log grob)
336 (ly:event-property (event-cause grob) 'duration)))
338 (define (stem-stub::do-calculations grob)
339 (and (ly:grob-property (ly:grob-parent grob X) 'cross-staff)
340 (not (ly:grob-property (ly:grob-parent grob X) 'transparent))))
342 (define-public (stem-stub::pure-height grob beg end)
343 (if (stem-stub::do-calculations grob)
347 (define-public (stem-stub::width grob)
348 (if (stem-stub::do-calculations grob)
349 (grob::x-parent-width grob)
352 (define-public (stem-stub::extra-spacing-height grob)
353 (if (stem-stub::do-calculations grob)
354 (let* ((dad (ly:grob-parent grob X))
355 (refp (ly:grob-common-refpoint grob dad Y))
356 (stem_ph (ly:grob-pure-height dad refp 0 INFINITY-INT))
357 (my_ph (ly:grob-pure-height grob refp 0 INFINITY-INT))
358 ;; only account for distance if stem is on different staff than stub
359 (dist (if (grob::has-interface refp 'hara-kiri-group-spanner-interface)
361 (- (car my_ph) (car stem_ph)))))
362 (if (interval-empty? (interval-intersection stem_ph my_ph)) #f (coord-translate stem_ph dist)))
365 (define-public (note-head::calc-kievan-duration-log grob)
368 (ly:event-property (event-cause grob) 'duration))))
370 (define-public (note-head::calc-duration-log grob)
373 (ly:event-property (event-cause grob) 'duration))))
375 (define-public (dots::calc-dot-count grob)
376 (ly:duration-dot-count
377 (ly:event-property (event-cause grob) 'duration)))
379 (define-public (dots::calc-staff-position grob)
380 (let* ((head (ly:grob-parent grob Y))
381 (log (ly:grob-property head 'duration-log)))
384 ((or (not (grob::has-interface head 'rest-interface))
385 (not (integer? log))) 0)
393 ;; Kept separate from note-head::calc-glyph-name to allow use by
394 ;; markup commands \note and \note-by-number
395 (define-public (select-head-glyph style log)
396 "Select a note head glyph string based on note head style @var{style}
397 and duration-log @var{log}."
400 ;; "default" style is directly handled in note-head.cc as a
401 ;; special case (HW says, mainly for performance reasons).
402 ;; Therefore, style "default" does not appear in this case
404 ;; Though we not to care if style is '(), see below. -- harm
405 ((xcircle) "2xcircle")
406 ((harmonic) "0harmonic")
407 ((harmonic-black) "2harmonic")
408 ((harmonic-mixed) (if (<= log 1) "0harmonic"
411 ;; Oops, I actually would not call this "baroque", but, for
412 ;; backwards compatibility to 1.4, this is supposed to take
413 ;; brevis, longa and maxima from the neo-mensural font and all
414 ;; other note heads from the default font. -- jr
416 (string-append (number->string log) "neomensural")
417 (number->string log)))
419 ;; Like default, but brevis is drawn with double vertical lines
421 (string-append (number->string log) "double")
422 (number->string log)))
424 (string-append (number->string log) (symbol->string style)))
427 (string-append (number->string log) "mensural")
428 (string-append (number->string log) (symbol->string style))))
431 (string-append (number->string log) "blackmensural")
432 (string-append (number->string log) (symbol->string style))))
435 (string-append (number->string log) "semimensural")
436 (string-append (number->string log) "petrucci")))
438 (string-append (number->string log) (symbol->string style)))
440 (string-append (number->string log) "kievan"))
442 (if (string-match "vaticana*|hufnagel*|medicaea*"
443 (symbol->string style))
444 (symbol->string style)
445 (string-append (number->string (max 0 log))
446 (symbol->string style)))))
447 ;; 'vaticana-ligature-interface has a 'glyph-name-property for NoteHead.
448 ;; Probably best to return an empty list here, if called in a context
449 ;; without setting 'style, i.e. 'style is '(), to avoid a scheme-error.
452 (define-public (note-head::calc-glyph-name grob)
453 (let* ((style (ly:grob-property grob 'style))
454 (log (if (and (symbol? style)
455 (string-match "kievan*" (symbol->string style)))
456 (min 3 (ly:grob-property grob 'duration-log))
457 (min 2 (ly:grob-property grob 'duration-log)))))
458 (select-head-glyph style log)))
460 (define-public (note-head::brew-ez-stencil grob)
461 (let* ((log (ly:grob-property grob 'duration-log))
462 (pitch (ly:event-property (event-cause grob) 'pitch))
463 (pitch-index (ly:pitch-notename pitch))
464 (note-names (ly:grob-property grob 'note-names))
465 (pitch-string (if (and (vector? note-names)
466 (> (vector-length note-names) pitch-index))
467 (vector-ref note-names pitch-index)
470 (+ (modulo (+ pitch-index 2) 7)
471 (char->integer #\A))))))
472 (staff-space (ly:staff-symbol-staff-space grob))
473 (line-thickness (ly:staff-symbol-line-thickness grob))
474 (stem (ly:grob-object grob 'stem))
475 (stem-thickness (* (if (ly:grob? stem)
476 (ly:grob-property stem 'thickness)
479 (radius (/ (+ staff-space line-thickness) 2))
480 (letter (make-center-align-markup (make-vcenter-markup pitch-string)))
481 (filled-circle (make-draw-circle-markup radius 0 #t)))
483 (ly:stencil-translate-axis
484 (grob-interpret-markup
489 (make-with-color-markup white letter))
493 (make-with-color-markup white (make-draw-circle-markup
494 (- radius stem-thickness) 0 #t)))
498 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
501 (define-public (make-rhythmic-location bar-num num den)
503 bar-num (ly:make-moment num den)))
505 (define-public (rhythmic-location? a)
508 (ly:moment? (cdr a))))
510 (define-public (make-graceless-rhythmic-location loc)
511 (make-rhythmic-location
513 (ly:moment-main-numerator (rhythmic-location-measure-position loc))
514 (ly:moment-main-denominator (rhythmic-location-measure-position loc))))
516 (define-public rhythmic-location-measure-position cdr)
517 (define-public rhythmic-location-bar-number car)
519 (define-public (rhythmic-location<? a b)
521 ((< (car a) (car b)) #t)
522 ((> (car a) (car b)) #f)
524 (ly:moment<? (cdr a) (cdr b)))))
526 (define-public (rhythmic-location<=? a b)
527 (not (rhythmic-location<? b a)))
528 (define-public (rhythmic-location>=? a b)
529 (not (rhythmic-location<? a b)))
530 (define-public (rhythmic-location>? a b)
531 (rhythmic-location<? b a))
533 (define-public (rhythmic-location=? a b)
534 (and (rhythmic-location<=? a b)
535 (rhythmic-location<=? b a)))
537 (define-public (rhythmic-location->file-string a)
538 (ly:format "~a.~a.~a"
540 (ly:moment-main-numerator (cdr a))
541 (ly:moment-main-denominator (cdr a))))
543 (define-public (rhythmic-location->string a)
544 (ly:format "bar ~a ~a"
546 (ly:moment->string (cdr a))))
548 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
551 (define-public all-visible #(#t #t #t))
552 (define-public begin-of-line-invisible #(#t #t #f))
553 (define-public center-invisible #(#t #f #t))
554 (define-public end-of-line-invisible #(#f #t #t))
555 (define-public begin-of-line-visible #(#f #f #t))
556 (define-public center-visible #(#f #t #f))
557 (define-public end-of-line-visible #(#t #f #f))
558 (define-public all-invisible #(#f #f #f))
560 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
561 ;; neighbor-interface routines
564 (define-public (shift-right-at-line-begin g)
565 "Shift an item to the right, but only at the start of the line."
566 (if (and (ly:item? g)
567 (equal? (ly:item-break-dir g) RIGHT))
568 (ly:grob-translate-axis! g 3.5 X)))
570 (define-public (pure-from-neighbor-interface::extra-spacing-height-at-beginning-of-line grob)
571 (if (= 1 (ly:item-break-dir grob))
572 (pure-from-neighbor-interface::extra-spacing-height grob)
575 (define-public (pure-from-neighbor-interface::extra-spacing-height grob)
576 (let* ((height (ly:grob-pure-height grob grob 0 INFINITY-INT))
577 (from-neighbors (interval-union
579 (ly:axis-group-interface::pure-height
583 (coord-operation - from-neighbors height)))
585 ;; If there are neighbors, we place the height at their midpoint
586 ;; to avoid protrusion of this pure height out of the vertical
587 ;; axis group on either side. This will minimize the impact of the
588 ;; grob on pure minimum translations.
590 ;; TODO - there is a double call to axis-group-interface::pure-height
591 ;; here and then in the extra-spacing-height function above. Can/should this
592 ;; be rolled into one?
593 (define-public (pure-from-neighbor-interface::pure-height grob beg end)
594 (let* ((height (ly:axis-group-interface::pure-height
598 (c (interval-center height)))
599 (if (interval-empty? height) empty-interval (cons c c))))
601 ;; Minimizes the impact of the height on vertical spacing while allowing
602 ;; it to appear in horizontal skylines of paper columns if necessary.
603 (define-public pure-from-neighbor-interface::height-if-pure
604 (ly:make-unpure-pure-container #f pure-from-neighbor-interface::pure-height))
606 (define-public (pure-from-neighbor-interface::account-for-span-bar grob)
607 (let* ((esh (pure-from-neighbor-interface::extra-spacing-height grob))
608 (hsb (ly:grob-property grob 'has-span-bar))
609 (ii (interval-intersection esh (cons -1.01 1.01))))
611 (cons (car (if (and (car hsb)
612 (ly:grob-property grob 'allow-span-bar))
614 (cdr (if (cdr hsb) esh ii)))
617 (define-public (pure-from-neighbor-interface::extra-spacing-height-including-staff grob)
618 (let ((esh (pure-from-neighbor-interface::extra-spacing-height grob))
619 (to-staff (coord-operation -
622 (ly:staff-symbol-staff-radius grob))
623 (ly:grob::stencil-height grob))))
624 (interval-union esh to-staff)))
627 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
630 (define-public (tuplet-number::calc-direction grob)
631 (ly:tuplet-bracket::calc-direction (ly:grob-object grob 'bracket)))
633 (define-public (tuplet-number::calc-denominator-text grob)
634 (number->string (ly:event-property (event-cause grob) 'denominator)))
636 (define-public (tuplet-number::calc-fraction-text grob)
637 (let ((ev (event-cause grob)))
640 (ly:event-property ev 'denominator)
641 (ly:event-property ev 'numerator))))
643 ;; a formatter function, which is simply a wrapper around an existing
644 ;; tuplet formatter function. It takes the value returned by the given
645 ;; function and appends a note of given length.
646 (define ((tuplet-number::append-note-wrapper function note) grob)
647 (let ((txt (and function (function grob))))
651 (list txt (make-fontsize-markup -5 (make-note-markup note UP))))
652 (make-fontsize-markup -5 (make-note-markup note UP)))))
653 (export tuplet-number::append-note-wrapper)
655 ;; Print a tuplet denominator with a different number than the one derived from
656 ;; the actual tuplet fraction
657 (define ((tuplet-number::non-default-tuplet-denominator-text denominator)
659 (number->string (if denominator
661 (ly:event-property (event-cause grob) 'denominator))))
662 (export tuplet-number::non-default-tuplet-denominator-text)
664 ;; Print a tuplet fraction with different numbers than the ones derived from
665 ;; the actual tuplet fraction
666 (define ((tuplet-number::non-default-tuplet-fraction-text
667 denominator numerator) grob)
668 (let* ((ev (event-cause grob))
669 (den (if denominator denominator (ly:event-property ev 'denominator)))
670 (num (if numerator numerator (ly:event-property ev 'numerator))))
672 (format #f "~a:~a" den num)))
673 (export tuplet-number::non-default-tuplet-fraction-text)
675 ;; Print a tuplet fraction with note durations appended to the numerator and the
677 (define ((tuplet-number::fraction-with-notes
678 denominatornote numeratornote) grob)
679 (let* ((ev (event-cause grob))
680 (denominator (ly:event-property ev 'denominator))
681 (numerator (ly:event-property ev 'numerator)))
683 ((tuplet-number::non-default-fraction-with-notes
684 denominator denominatornote numerator numeratornote) grob)))
685 (export tuplet-number::fraction-with-notes)
687 ;; Print a tuplet fraction with note durations appended to the numerator and the
689 (define ((tuplet-number::non-default-fraction-with-notes
690 denominator denominatornote numerator numeratornote) grob)
691 (let* ((ev (event-cause grob))
692 (den (if denominator denominator (ly:event-property ev 'denominator)))
693 (num (if numerator numerator (ly:event-property ev 'numerator))))
695 (make-concat-markup (list
696 (make-simple-markup (format #f "~a" den))
697 (make-fontsize-markup -5 (make-note-markup denominatornote UP))
698 (make-simple-markup " : ")
699 (make-simple-markup (format #f "~a" num))
700 (make-fontsize-markup -5 (make-note-markup numeratornote UP))))))
701 (export tuplet-number::non-default-fraction-with-notes)
704 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
707 (define-public (color? x)
711 (every (lambda (y) (<= 0 y 1)) x)))
713 (define-public (rgb-color r g b) (list r g b))
716 (define-public black '(0.0 0.0 0.0))
717 (define-public white '(1.0 1.0 1.0))
718 (define-public red '(1.0 0.0 0.0))
719 (define-public green '(0.0 1.0 0.0))
720 (define-public blue '(0.0 0.0 1.0))
721 (define-public cyan '(0.0 1.0 1.0))
722 (define-public magenta '(1.0 0.0 1.0))
723 (define-public yellow '(1.0 1.0 0.0))
725 (define-public grey '(0.5 0.5 0.5))
726 (define-public darkred '(0.5 0.0 0.0))
727 (define-public darkgreen '(0.0 0.5 0.0))
728 (define-public darkblue '(0.0 0.0 0.5))
729 (define-public darkcyan '(0.0 0.5 0.5))
730 (define-public darkmagenta '(0.5 0.0 0.5))
731 (define-public darkyellow '(0.5 0.5 0.0))
734 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
737 (define-public (key-signature-interface::alteration-positions
738 entry c0-position grob)
739 (let ((step (car entry))
742 (list (+ (cdr step) (* (car step) 7) c0-position))
743 (let* ((c-position (modulo c0-position 7))
746 ;; See (flat|sharp)-positions in define-grob-properties.scm
747 (ly:grob-property grob 'flat-positions '(3))
748 (ly:grob-property grob 'sharp-positions '(3))))
749 (p (list-ref positions
750 (if (< c-position (length positions))
752 (max-position (if (pair? p) (cdr p) p))
753 (min-position (if (pair? p) (car p) (- max-position 6)))
754 (first-position (+ (modulo (- (+ c-position step)
758 (define (prepend x l) (if (> x max-position)
760 (prepend (+ x 7) (cons x l))))
761 (prepend first-position '())))))
763 (define-public (key-signature-interface::alteration-position
764 step alter c0-position)
765 ;; Deprecated. Not a documented interface, and no longer used in LilyPond,
766 ;; but needed for a popular file, LilyJAZZ.ily for version 2.16
768 (+ (cdr step) (* (car step) 7) c0-position)
769 (let* ((c-pos (modulo c0-position 7))
772 '(2 3 4 2 1 2 1) ; position of highest flat
773 '(4 5 4 2 3 2 3)); position of highest sharp
775 (- hi (modulo (- hi (+ c-pos step)) 7)))))
777 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
780 (define-public (numbered-footnotes int)
781 (make-tiny-markup (number->string (+ 1 int))))
783 (define-public (symbol-footnotes int)
784 (define (helper symbols out idx n)
788 (string-append out (list-ref symbols idx))
791 (make-tiny-markup (helper '("*" "†" "‡" "§" "¶")
794 (+ 1 (quotient int 5)))))
796 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
799 (define-public (accidental-interface::calc-alteration grob)
800 (ly:pitch-alteration (ly:event-property (event-cause grob) 'pitch)))
802 (define-public (accidental-interface::glyph-name grob)
803 (assoc-get (ly:grob-property grob 'alteration)
804 standard-alteration-glyph-name-alist))
806 (define-public accidental-interface::height
807 (ly:make-unpure-pure-container
808 ly:accidental-interface::height))
810 (define-public cancellation-glyph-name-alist
811 '((0 . "accidentals.natural")))
813 (define-public standard-alteration-glyph-name-alist
815 ;; ordered for optimal performance.
816 (0 . "accidentals.natural")
817 (-1/2 . "accidentals.flat")
818 (1/2 . "accidentals.sharp")
820 (1 . "accidentals.doublesharp")
821 (-1 . "accidentals.flatflat")
823 (3/4 . "accidentals.sharp.slashslash.stemstemstem")
824 (1/4 . "accidentals.sharp.slashslash.stem")
825 (-1/4 . "accidentals.mirroredflat")
826 (-3/4 . "accidentals.mirroredflat.flat")))
828 ;; FIXME: standard vs default, alteration-FOO vs FOO-alteration
829 (define-public alteration-default-glyph-name-alist
830 standard-alteration-glyph-name-alist)
832 (define-public makam-alteration-glyph-name-alist
833 '((1 . "accidentals.doublesharp")
834 (8/9 . "accidentals.sharp.slashslashslash.stemstem")
835 (5/9 . "accidentals.sharp.slashslashslash.stem")
836 (4/9 . "accidentals.sharp")
837 (1/9 . "accidentals.sharp.slashslash.stem")
838 (0 . "accidentals.natural")
839 (-1/9 . "accidentals.mirroredflat")
840 (-4/9 . "accidentals.flat.slash")
841 (-5/9 . "accidentals.flat")
842 (-8/9 . "accidentals.flat.slashslash")
843 (-1 . "accidentals.flatflat")))
845 (define-public alteration-hufnagel-glyph-name-alist
846 '((-1/2 . "accidentals.hufnagelM1")
847 (0 . "accidentals.vaticana0")
848 (1/2 . "accidentals.mensural1")))
850 (define-public alteration-medicaea-glyph-name-alist
851 '((-1/2 . "accidentals.medicaeaM1")
852 (0 . "accidentals.vaticana0")
853 (1/2 . "accidentals.mensural1")))
855 (define-public alteration-vaticana-glyph-name-alist
856 '((-1/2 . "accidentals.vaticanaM1")
857 (0 . "accidentals.vaticana0")
858 (1/2 . "accidentals.mensural1")))
860 (define-public alteration-mensural-glyph-name-alist
861 '((-1/2 . "accidentals.mensuralM1")
862 (0 . "accidentals.vaticana0")
863 (1/2 . "accidentals.mensural1")))
865 (define-public alteration-kievan-glyph-name-alist
866 '((-1/2 . "accidentals.kievanM1")
867 (1/2 . "accidentals.kievan1")))
869 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
870 ;; * Pitch Trill Heads
873 (define-public (parentheses-item::calc-parenthesis-stencils grob)
874 (let* ((font (ly:grob-default-font grob))
875 (lp (ly:font-get-glyph font "accidentals.leftparen"))
876 (rp (ly:font-get-glyph font "accidentals.rightparen")))
880 (define-public (parentheses-item::calc-angled-bracket-stencils grob)
881 (let* ((parent (ly:grob-parent grob Y))
882 (y-extent (ly:grob-extent parent parent Y))
883 (half-thickness 0.05) ; should it be a property?
884 (width 0.5) ; should it be a property?
885 (angularity 1.5) ; makes angle brackets
886 (white-padding 0.1) ; should it be a property?
887 (lp (ly:stencil-aligned-to
888 (ly:stencil-aligned-to
889 (make-parenthesis-stencil y-extent
897 (interval-widen (ly:stencil-extent lp X) white-padding))
898 (rp (ly:stencil-aligned-to
899 (ly:stencil-aligned-to
900 (make-parenthesis-stencil y-extent
908 (interval-widen (ly:stencil-extent rp X) white-padding)))
909 (set! lp (ly:make-stencil (ly:stencil-expr lp)
911 (ly:stencil-extent lp Y)))
912 (set! rp (ly:make-stencil (ly:stencil-expr rp)
914 (ly:stencil-extent rp Y)))
915 (list (stencil-whiteout-box lp)
916 (stencil-whiteout-box rp))))
918 (define-public (parentheses-item::y-extent grob) (ly:grob::stencil-height grob))
920 (define (parenthesize-elements grob . rest)
921 (let* ((refp (if (null? rest)
924 (elts (ly:grob-array->list (ly:grob-object grob 'elements)))
927 (let ((syms (ly:grob-property g 'parenthesis-friends '()))
928 (get-friend (lambda (s)
929 (let ((f (ly:grob-object g s)))
931 ((ly:grob? f) (list f))
932 ((ly:grob-array? f) (ly:grob-array->list f))
934 (apply append (map get-friend syms)))))
935 (friends (apply append elts (map get-friends elts)))
936 (x-ext (ly:relative-group-extent friends refp X))
937 (stencils (ly:grob-property grob 'stencils))
940 (padding (ly:grob-property grob 'padding 0.1)))
943 (ly:stencil-translate-axis lp (- (car x-ext) padding) X)
944 (ly:stencil-translate-axis rp (+ (cdr x-ext) padding) X))))
947 (define-public (parentheses-item::print me)
948 (let* ((elts (ly:grob-object me 'elements))
949 (y-ref (ly:grob-common-refpoint-of-array me elts Y))
950 (x-ref (ly:grob-common-refpoint-of-array me elts X))
951 (stencil (parenthesize-elements me x-ref))
952 (elt-y-ext (ly:relative-group-extent elts y-ref Y))
953 (y-center (interval-center elt-y-ext)))
955 (ly:stencil-translate
958 (- (ly:grob-relative-coordinate me x-ref X))
959 (- y-center (ly:grob-relative-coordinate me y-ref Y))))))
962 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
965 (define-public (pure-chain-offset-callback grob start end prev-offset)
966 "Sometimes, a chained offset callback is unpure and there is
967 no way to write a pure function that estimates its behavior.
968 In this case, we use a pure equivalent that will simply pass
969 the previous calculated offset value."
972 (define-public (scale-by-font-size x)
973 (ly:make-unpure-pure-container
975 (* x (magstep (ly:grob-property grob 'font-size 0))))))
977 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
980 (define-public (grob::compose-function func data)
981 "This creates a callback entity to be stored in a grob property,
982 based on the grob property data @var{data} (which can be plain data, a
983 callback itself, or an unpure-pure-container).
985 Function or unpure-pure-container @var{func} accepts a grob and a
986 value and returns another value. Depending on the type of @var{data},
987 @var{func} is used for building a grob callback or an
988 unpure-pure-container."
989 (if (or (ly:unpure-pure-container? func)
990 (ly:unpure-pure-container? data))
991 (ly:make-unpure-pure-container
992 (lambda (grob) (ly:unpure-call func grob (ly:unpure-call data grob)))
993 (lambda (grob start end)
994 (ly:pure-call func grob start end
995 (ly:pure-call data grob start end))))
996 (lambda (grob) (ly:unpure-call func grob (ly:unpure-call data grob)))))
998 (define*-public (grob::offset-function func data
1000 "This creates a callback entity to be stored in a grob property,
1001 based on the grob property data @var{data} (which can be plain data, a
1002 callback itself, or an unpure-pure-container).
1004 Function @var{func} accepts a grob and returns a value that is added
1005 to the value resulting from @var{data}. Optional argument @var{plus}
1006 defaults to @code{+} but may be changed to allow for using a different
1007 underlying accumulation.
1009 If @var{data} is @code{#f} or @code{'()}, it is not included in the sum."
1010 (cond ((or (not data) (null? data))
1012 ((or (ly:unpure-pure-container? func)
1013 (ly:unpure-pure-container? data))
1014 (ly:make-unpure-pure-container
1016 (plus (apply ly:unpure-call func rest)
1017 (apply ly:unpure-call data rest)))
1019 (plus (apply ly:pure-call func rest)
1020 (apply ly:pure-call data rest)))))
1021 ((or (procedure? func)
1024 (plus (apply ly:unpure-call func rest)
1025 (apply ly:unpure-call data rest))))
1026 (else (plus func data))))
1028 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1031 (define-public (bend::print spanner)
1033 (< (abs (- a b)) 0.01))
1035 (let* ((delta-y (* 0.5 (ly:grob-property spanner 'delta-position)))
1036 (left-span (ly:spanner-bound spanner LEFT))
1037 (dots (if (and (grob::has-interface left-span 'note-head-interface)
1038 (ly:grob? (ly:grob-object left-span 'dot)))
1039 (ly:grob-object left-span 'dot) #f))
1041 (right-span (ly:spanner-bound spanner RIGHT))
1042 (thickness (* (ly:grob-property spanner 'thickness)
1043 (ly:output-def-lookup (ly:grob-layout spanner)
1045 (padding (ly:grob-property spanner 'padding 0.5))
1046 (common (ly:grob-common-refpoint right-span
1047 (ly:grob-common-refpoint spanner
1050 (common-y (ly:grob-common-refpoint spanner left-span Y))
1051 (minimum-length (ly:grob-property spanner 'minimum-length 0.5))
1055 (interval-end (ly:generic-bound-extent
1060 (ly:grob-relative-coordinate dots common-y Y)
1061 (ly:grob-relative-coordinate spanner common-y Y)))
1063 (ly:grob-robust-relative-extent dots common X))
1064 (- INFINITY-INT)))))
1065 (right-x (max (- (interval-start
1066 (ly:generic-bound-extent right-span common))
1068 (+ left-x minimum-length)))
1069 (self-x (ly:grob-relative-coordinate spanner common X))
1070 (dx (- right-x left-x))
1071 (exp (list 'path thickness
1074 ,(- left-x self-x) 0
1079 ,dx ,(* 0.66 delta-y)
1084 (cons (- left-x self-x) (- right-x self-x))
1085 (cons (min 0 delta-y)
1089 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1092 (define-public (grace-spacing::calc-shortest-duration grob)
1093 (let* ((cols (ly:grob-object grob 'columns))
1096 (ly:moment-sub (ly:grob-property
1097 (ly:grob-array-ref cols (1+ idx)) 'when)
1099 (ly:grob-array-ref cols idx) 'when))))
1101 (moment-min (lambda (x y)
1104 (if (ly:moment<? x y)
1110 (fold moment-min #f (map get-difference
1111 (iota (1- (ly:grob-array-length cols)))))))
1114 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1117 (define-public (fingering::calc-text grob)
1118 (let ((event (event-cause grob)))
1119 (or (ly:event-property event 'text #f)
1120 (number->string (ly:event-property event 'digit) 10))))
1122 (define-public (string-number::calc-text grob)
1123 (let ((event (event-cause grob)))
1124 (or (ly:event-property event 'text #f)
1126 (ly:grob-property grob 'number-type)
1127 (ly:event-property event 'string-number)))))
1129 (define-public (stroke-finger::calc-text grob)
1130 (let ((event (event-cause grob)))
1131 (or (ly:event-property event 'text #f)
1132 (let ((digit-names (ly:grob-property grob 'digit-names)))
1133 (vector-ref digit-names
1135 (min (vector-length digit-names)
1136 (ly:event-property event 'digit)))))))))
1139 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1142 (define-public (hairpin::calc-grow-direction grob)
1143 (if (ly:in-event-class? (event-cause grob) 'decrescendo-event)
1147 (define-public (dynamic-text-spanner::before-line-breaking grob)
1148 "Monitor left bound of @code{DynamicTextSpanner} for absolute dynamics.
1149 If found, ensure @code{DynamicText} does not collide with spanner text by
1150 changing @code{'attach-dir} and @code{'padding}. Reads the
1151 @code{'right-padding} property of @code{DynamicText} to fine tune space
1152 between the two text elements."
1153 (let ((left-bound (ly:spanner-bound grob LEFT)))
1154 (if (grob::has-interface left-bound 'dynamic-text-interface)
1155 (let* ((details (ly:grob-property grob 'bound-details))
1156 (left-details (ly:assoc-get 'left details))
1157 (my-padding (ly:assoc-get 'padding left-details))
1158 (script-padding (ly:grob-property left-bound 'right-padding 0)))
1160 (and (number? my-padding)
1161 (ly:grob-set-nested-property! grob
1162 '(bound-details left attach-dir)
1164 (ly:grob-set-nested-property! grob
1165 '(bound-details left padding)
1166 (+ my-padding script-padding)))))))
1168 (define-public (make-connected-line points grob)
1169 "Takes a list of points, @var{points}.
1170 Returns a line connecting @var{points}, using @code{ly:line-interface::line},
1171 gets layout information from @var{grob}"
1172 (define (connected-points grob ls pts)
1173 (if (not (pair? (cdr pts)))
1174 (reduce ly:stencil-add empty-stencil ls)
1178 (ly:line-interface::line
1186 (if (< (length points) 2)
1189 "´make-connected-line´ needs at least two points: ~a"
1192 (connected-points grob '() points)))
1194 (define ((elbowed-hairpin coords mirrored?) grob)
1195 "Create hairpin based on a list of @var{coords} in @code{(cons x y)}
1196 form. @code{x} is the portion of the width consumed for a given line
1197 and @code{y} is the portion of the height. For example,
1198 @code{'((0 . 0) (0.3 . 0.7) (0.8 . 0.9) (1.0 . 1.0))} means that at the point
1199 where the hairpin has consumed 30% of its width, it must
1200 be at 70% of its height. Once it is to 80% width, it
1201 must be at 90% height. It finishes at 100% width and 100% height.
1202 If @var{coords} does not begin with @code{'(0 . 0)} the final hairpin may have
1203 an open tip. For example '(0 . 0.5) will cause an open end of 50% of the usual
1205 @var{mirrored?} indicates if the hairpin is mirrored over the Y-axis or if
1206 just the upper part is drawn.
1207 Returns a function that accepts a hairpin grob as an argument
1208 and draws the stencil based on its coordinates.
1210 @lilypond[verbatim,quote]
1211 #(define simple-hairpin
1212 (elbowed-hairpin '((0 . 0)(1.0 . 1.0)) #t))
1215 \\override Hairpin #'stencil = #simple-hairpin
1220 (define (scale-coords coords-list x y)
1222 (lambda (coord) (cons (* x (car coord)) (* y (cdr coord))))
1225 (define (hairpin::print-part points decresc? me)
1226 (let ((stil (make-connected-line points me)))
1227 (if decresc? (ly:stencil-scale stil -1 1) stil)))
1229 ;; outer let to trigger suicide
1230 (let ((sten (ly:hairpin::print grob)))
1231 (if (grob::is-live? grob)
1232 (let* ((decresc? (eqv? (ly:grob-property grob 'grow-direction) LEFT))
1233 (xex (ly:stencil-extent sten X))
1234 (lenx (interval-length xex))
1235 (yex (ly:stencil-extent sten Y))
1236 (leny (interval-length yex))
1237 (xtrans (+ (car xex) (if decresc? lenx 0)))
1239 (uplist (scale-coords coords lenx (/ leny 2)))
1240 (downlist (scale-coords coords lenx (/ leny -2)))
1242 (ly:stencil-aligned-to
1243 (ly:stencil-translate
1245 (hairpin::print-part uplist decresc? grob)
1247 (hairpin::print-part downlist decresc? grob)
1249 (cons xtrans ytrans))
1251 (stil-y-extent (ly:stencil-extent stil Y)))
1252 ;; Return a final stencil properly aligned in Y-axis direction and with
1253 ;; proper extents. Otherwise stencil-operations like 'box-stencil' will
1254 ;; return badly. Extent in X-axis direction is taken from the original,
1255 ;; in Y-axis direction from the new stencil.
1256 (ly:make-stencil (ly:stencil-expr stil) xex stil-y-extent))
1257 ;; return empty, if no Hairpin.stencil present.
1259 (export elbowed-hairpin)
1261 (define-public flared-hairpin
1262 (elbowed-hairpin '((0 . 0) (0.95 . 0.4) (1.0 . 1.0)) #t))
1264 (define-public constante-hairpin
1265 (elbowed-hairpin '((0 . 0) (1.0 . 0.0) (1.0 . 1.0)) #f))
1267 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1270 (define-public (lyric-text::print grob)
1271 "Allow interpretation of tildes as lyric tieing marks."
1273 (let ((text (ly:grob-property grob 'text)))
1275 (grob-interpret-markup grob (if (string? text)
1276 (make-tied-lyric-markup text)
1279 (define ((grob::calc-property-by-copy prop) grob)
1280 (ly:event-property (event-cause grob) prop))
1281 (export grob::calc-property-by-copy)
1283 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1284 ;; general inheritance
1286 (define ((grob::inherit-parent-property axis property . default) grob)
1287 "@var{grob} callback generator for inheriting a @var{property} from
1288 an @var{axis} parent, defaulting to @var{default} if there is no
1289 parent or the parent has no setting."
1290 (let ((parent (ly:grob-parent grob axis)))
1293 (apply ly:grob-property parent property default))
1294 ((pair? default) (car default))
1296 (export grob::inherit-parent-property)
1298 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1301 (define-public (fret-board::calc-stencil grob)
1302 (grob-interpret-markup
1304 (make-fret-diagram-verbose-markup
1305 (ly:grob-property grob 'dot-placement-list))))
1308 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1311 (define-public slur::height
1312 (ly:make-unpure-pure-container
1314 ly:slur::pure-height))
1316 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1319 (define-public (script-interface::calc-x-offset grob)
1320 (ly:grob-property grob 'positioning-done)
1321 (let* ((shift-when-alone (ly:grob-property grob 'toward-stem-shift 0.0))
1322 (shift-in-column (ly:grob-property grob 'toward-stem-shift-in-column))
1323 (script-column (ly:grob-object grob 'script-column))
1325 (if (and (ly:grob? script-column)
1326 (number? shift-in-column)
1327 ;; ScriptColumn can contain grobs other than Script.
1328 ;; These should not result in a shift.
1330 (and (not (eq? s grob))
1331 (grob::has-interface s 'script-interface)
1332 (not (grob::has-interface s
1333 'accidental-suggestion-interface))))
1334 (ly:grob-array->list
1335 (ly:grob-object script-column 'scripts))))
1336 shift-in-column shift-when-alone))
1338 (ly:self-alignment-interface::aligned-on-x-parent grob))
1339 (note-head-grob (ly:grob-parent grob X))
1340 (stem-grob (ly:grob-object note-head-grob 'stem)))
1342 (+ note-head-location
1343 ;; If the script has the same direction as the stem, move the script
1344 ;; in accordance with the value of 'shift'. Since scripts can also be
1345 ;; over skips, we need to check whether the grob has a stem at all.
1346 (if (ly:grob? stem-grob)
1347 (let ((dir1 (ly:grob-property grob 'direction))
1348 (dir2 (ly:grob-property stem-grob 'direction)))
1349 (if (equal? dir1 dir2)
1350 (let* ((common-refp (ly:grob-common-refpoint grob stem-grob X))
1352 (ly:grob-relative-coordinate stem-grob common-refp X)))
1353 (* shift (- stem-location note-head-location)))
1358 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1361 (define-public (system-start-text::print grob)
1362 (let* ((left-bound (ly:spanner-bound grob LEFT))
1363 (left-mom (ly:grob-property left-bound 'when))
1364 (name (if (moment<=? left-mom ZERO-MOMENT)
1365 (ly:grob-property grob 'long-text)
1366 (ly:grob-property grob 'text))))
1368 (if (and (markup? name)
1369 (!= (ly:item-break-dir left-bound) CENTER))
1371 (grob-interpret-markup grob name)
1372 (ly:grob-suicide! grob))))
1374 (define-public (system-start-text::calc-x-offset grob)
1375 (let* ((left-bound (ly:spanner-bound grob LEFT))
1376 (left-mom (ly:grob-property left-bound 'when))
1377 (layout (ly:grob-layout grob))
1378 (indent (ly:output-def-lookup layout
1379 (if (moment<=? left-mom ZERO-MOMENT)
1383 (system (ly:grob-system grob))
1384 (my-extent (ly:grob-extent grob system X))
1385 (elements (ly:grob-object system 'elements))
1386 (common (ly:grob-common-refpoint-of-array system elements X))
1387 (total-ext empty-interval)
1388 (align-x (ly:grob-property grob 'self-alignment-X 0))
1389 (padding (min 0 (- (interval-length my-extent) indent)))
1390 (right-padding (- padding
1391 (/ (* padding (1+ align-x)) 2))))
1393 ;; compensate for the variation in delimiter extents by
1394 ;; calculating an X-offset correction based on united extents
1395 ;; of all delimiters in this system
1396 (let unite-delims ((l (ly:grob-array-length elements)))
1398 (let ((elt (ly:grob-array-ref elements (1- l))))
1400 (if (grob::has-interface elt 'system-start-delimiter-interface)
1401 (let ((dims (ly:grob-extent elt common X)))
1402 (if (interval-sane? dims)
1403 (set! total-ext (interval-union total-ext dims)))))
1404 (unite-delims (1- l)))))
1407 (ly:side-position-interface::x-aligned-side grob)
1409 (- (interval-length total-ext)))))
1411 (define-public (system-start-text::calc-y-offset grob)
1413 (define (live-elements-list me)
1414 (let ((elements (ly:grob-object me 'elements)))
1416 (filter! grob::is-live?
1417 (ly:grob-array->list elements))))
1419 (let* ((left-bound (ly:spanner-bound grob LEFT))
1420 (live-elts (live-elements-list grob))
1421 (system (ly:grob-system grob))
1422 (extent empty-interval))
1424 (if (and (pair? live-elts)
1425 (interval-sane? (ly:grob-extent grob system Y)))
1426 (let get-extent ((lst live-elts))
1428 (let ((axis-group (car lst)))
1430 (if (and (ly:spanner? axis-group)
1431 (equal? (ly:spanner-bound axis-group LEFT)
1433 (set! extent (add-point extent
1434 (ly:grob-relative-coordinate
1435 axis-group system Y))))
1436 (get-extent (cdr lst)))))
1437 ;; no live axis group(s) for this instrument name -> remove from system
1438 (ly:grob-suicide! grob))
1441 (ly:self-alignment-interface::y-aligned-on-self grob)
1442 (interval-center extent))))
1445 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1446 ;; axis group interface
1448 (define-public axis-group-interface::height
1449 (ly:make-unpure-pure-container
1450 ly:axis-group-interface::height
1451 ly:axis-group-interface::pure-height))
1453 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1456 ;; Calculate the gaps between ambitus heads and ends of ambitus line.
1457 ;; Start by determining desired length of the ambitus line (based on
1458 ;; length-fraction property), calc gap from that and make sure that
1459 ;; it doesn't exceed maximum allowed value.
1461 (define-public (ambitus-line::calc-gap grob)
1462 (let ((heads (ly:grob-object grob 'note-heads)))
1464 (if (and (ly:grob-array? heads)
1465 (= (ly:grob-array-length heads) 2))
1466 (let* ((common (ly:grob-common-refpoint-of-array grob heads Y))
1467 (head-down (ly:grob-array-ref heads 0))
1468 (head-up (ly:grob-array-ref heads 1))
1469 (fraction (ly:grob-property grob 'length-fraction 0.7))
1470 (max-gap (ly:grob-property grob 'maximum-gap 0.45))
1471 ;; distance between noteheads:
1472 (distance (- (interval-start (ly:grob-extent head-up common Y))
1473 (interval-end (ly:grob-extent head-down common Y))))
1474 (gap (* 0.5 distance (- 1 fraction))))
1479 ;; Print a line connecting ambitus heads:
1481 (define-public (ambitus::print grob)
1482 (let ((heads (ly:grob-object grob 'note-heads)))
1484 (if (and (ly:grob-array? heads)
1485 (= (ly:grob-array-length heads) 2))
1486 (let* ((common (ly:grob-common-refpoint-of-array grob heads Y))
1487 (head-down (ly:grob-array-ref heads 0))
1488 (head-up (ly:grob-array-ref heads 1))
1489 ;; The value used when 'gap' property cannot be read is small
1490 ;; to make sure that ambitus of a fifth will have a visible line.
1491 (gap (ly:grob-property grob 'gap 0.25))
1492 (point-min (+ (interval-end (ly:grob-extent head-down common Y))
1494 (point-max (- (interval-start (ly:grob-extent head-up common Y))
1497 (if (< (+ point-min 0.1) point-max) ; don't print lines shorter than 0.1ss
1498 (let* ((layout (ly:grob-layout grob))
1499 (line-thick (ly:output-def-lookup layout 'line-thickness))
1500 (blot (ly:output-def-lookup layout 'blot-diameter))
1501 (grob-thick (ly:grob-property grob 'thickness 2))
1502 (width (* line-thick grob-thick))
1503 (x-ext (symmetric-interval (/ width 2)))
1504 (y-ext (cons point-min point-max))
1505 (line (ly:round-filled-box x-ext y-ext blot))
1506 (y-coord (ly:grob-relative-coordinate grob common Y)))
1508 (ly:stencil-translate-axis line (- y-coord) Y))
1511 (ly:grob-suicide! grob)
1514 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1515 ;; laissez-vibrer tie
1517 ;; needed so we can make laissez-vibrer a pure print
1519 (define-public (laissez-vibrer::print grob)
1520 (ly:tie::print grob))
1522 (define-public (semi-tie::calc-cross-staff grob)
1523 (let* ((note-head (ly:grob-object grob 'note-head))
1524 (stem (ly:grob-object note-head 'stem)))
1525 (and (ly:grob? stem)
1526 (ly:grob-property stem 'cross-staff #f))))
1528 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1531 (define-public (volta-bracket-interface::pure-height grob start end)
1532 (let ((edge-height (ly:grob-property grob 'edge-height)))
1533 (if (number-pair? edge-height)
1534 (let ((smaller (min (car edge-height) (cdr edge-height)))
1535 (larger (max (car edge-height) (cdr edge-height))))
1536 (interval-union '(0 . 0) (cons smaller larger)))
1539 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1542 (define-public (measure-counter-stencil grob)
1543 "Print a number for a measure count. Broken measures are numbered in
1545 (let* ((num (make-simple-markup
1546 (number->string (ly:grob-property grob 'count-from))))
1547 (orig (ly:grob-original grob))
1548 (siblings (ly:spanner-broken-into orig)) ; have we been split?
1550 (if (or (null? siblings)
1551 (eq? grob (car siblings)))
1553 (make-parenthesize-markup num)))
1554 (num (grob-interpret-markup grob num))
1555 (num (ly:stencil-aligned-to
1556 num X (ly:grob-property grob 'self-alignment-X)))
1557 (left-bound (ly:spanner-bound grob LEFT))
1558 (right-bound (ly:spanner-bound grob RIGHT))
1559 (refp (ly:grob-common-refpoint left-bound right-bound X))
1561 (ly:grob-property grob
1563 '(break-alignment . break-alignment)))
1564 (ext-L (ly:paper-column::break-align-width left-bound
1565 (car spacing-pair)))
1566 (ext-R (ly:paper-column::break-align-width right-bound
1567 (cdr spacing-pair)))
1569 (ly:stencil-translate-axis
1571 (+ (* 0.5 (- (car ext-R)
1574 (ly:grob-relative-coordinate grob refp X)))
1578 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1579 ;; HorizontalBracketText
1581 (define-public (ly:horizontal-bracket-text::print grob)
1582 (let ((text (ly:grob-property grob 'text)))
1583 (if (or (null? text)
1585 (equal? text empty-markup))
1587 (ly:grob-suicide! grob)
1589 (let* ((orig (ly:grob-original grob))
1590 (siblings (ly:spanner-broken-into orig))
1592 (if (or (null? siblings)
1593 (eq? grob (car siblings)))
1596 (string-append "(" text ")")
1597 (make-parenthesize-markup text)))))
1598 (grob-interpret-markup grob text)))))
1600 (define-public (ly:horizontal-bracket-text::calc-direction grob)
1601 (let* ((bracket (ly:grob-object grob 'bracket))
1602 (bracket-dir (ly:grob-property bracket 'direction DOWN)))
1605 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1606 ;; make-engraver helper macro
1608 (defmacro-public make-engraver forms
1609 "Helper macro for creating Scheme engravers.
1611 The usual form for an engraver is an association list (or alist)
1612 mapping symbols to either anonymous functions or to another such
1615 @code{make-engraver} accepts forms where the first element is either
1616 an argument list starting with the respective symbol, followed by the
1617 function body (comparable to the way @code{define} is used for
1618 defining functions), or a single symbol followed by subordinate forms
1619 in the same manner. You can also just make an alist pair
1620 literally (the @samp{car} is quoted automatically) as long as the
1621 unevaluated @samp{cdr} is not a pair. This is useful if you already
1622 have defined your engraver functions separately.
1624 Symbols mapping to a function would be @code{initialize},
1625 @code{start-translation-timestep}, @code{process-music},
1626 @code{process-acknowledged}, @code{stop-translation-timestep}, and
1627 @code{finalize}. Symbols mapping to another alist specified in the
1628 same manner are @code{listeners} with the subordinate symbols being
1629 event classes, and @code{acknowledgers} and @code{end-acknowledgers}
1630 with the subordinate symbols being interfaces."
1631 (let loop ((forms forms))
1632 (if (or (null? forms) (pair? forms))
1634 ,@(map (lambda (form)
1635 (if (pair? (car form))
1636 `(cons ',(caar form) (lambda ,(cdar form) ,@(cdr form)))
1637 `(cons ',(car form) ,(loop (cdr form)))))