1 ;;;; This file is part of LilyPond, the GNU music typesetter.
3 ;;;; Copyright (C) 1998--2012 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::x-parent-width grob)
30 (ly:grob-property (ly:grob-parent grob X) 'X-extent))
32 (define-public (make-stencil-boxer thickness padding callback)
33 "Return function that adds a box around the grob passed as argument."
35 (box-stencil (callback grob) thickness padding)))
37 (define-public (make-stencil-circler thickness padding callback)
38 "Return function that adds a circle around the grob passed as argument."
40 (circle-stencil (callback grob) thickness padding)))
42 (define-public (print-circled-text-callback grob)
43 (grob-interpret-markup grob (make-circle-markup
44 (ly:grob-property grob 'text))))
46 (define-public (event-cause grob)
47 (let ((cause (ly:grob-property grob 'cause)))
50 ((ly:stream-event? cause) cause)
51 ((ly:grob? cause) (event-cause cause))
54 (define-public (grob-interpret-markup grob text)
55 (let* ((layout (ly:grob-layout grob))
56 (defs (ly:output-def-lookup layout 'text-font-defaults))
57 (props (ly:grob-alist-chain grob defs)))
59 (ly:text-interface::interpret-markup layout props text)))
61 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
64 ;; even though kievan noteheads do not have stems, their
65 ;; invisible stems help with beam placement
66 ;; this assures that invisible stems for kievan notes are aligned
67 ;; to the center of kievan noteheads. that is thus where the beams'
68 ;; x extrema will fall
69 (define-public (stem::kievan-offset-callback grob)
70 (let* ((note-heads (ly:grob-object grob 'note-heads))
71 (note-heads-grobs (if (not (null? note-heads))
72 (ly:grob-array->list note-heads)
74 (first-note-head (if (not (null? note-heads-grobs))
75 (car note-heads-grobs)
77 (note-head-w (if (not (null? first-note-head))
78 (ly:grob-extent first-note-head first-note-head X)
80 (interval-center note-head-w)))
83 ;; sets position of beams for Kievan notation
84 (define-public (beam::get-kievan-positions grob)
85 (let* ((stems (ly:grob-object grob 'stems))
86 (stems-grobs (if (not (null? stems))
87 (ly:grob-array->list stems)
89 (first-stem (if (not (null? stems-grobs))
92 (note-heads (if (not (null? first-stem))
93 (ly:grob-object first-stem 'note-heads)
95 (note-heads-grobs (if (not (null? note-heads))
96 (ly:grob-array->list note-heads)
98 (first-note-head (if (not (null? note-heads-grobs))
99 (car note-heads-grobs)
101 (next-stem (if (not (null? stems))
104 (next-note-heads (if (not (null? next-stem))
105 (ly:grob-object next-stem 'note-heads)
107 (next-note-heads-grobs (if (not (null? next-note-heads))
108 (ly:grob-array->list next-note-heads)
110 (next-note-head (if (not (null? next-note-heads-grobs))
111 (car next-note-heads-grobs)
113 (left-pos (ly:grob-property first-note-head 'Y-offset))
114 (right-pos (ly:grob-property next-note-head 'Y-offset))
115 (direction (ly:grob-property grob 'direction))
116 (first-nh-height (ly:grob::stencil-height first-note-head))
117 (next-nh-height (ly:grob::stencil-height next-note-head))
118 (left-height (if (= direction DOWN)
119 (+ (car first-nh-height) 0.75)
120 (- (cdr first-nh-height) 0.75)))
121 (right-height (if (= direction DOWN)
122 (+ (car next-nh-height) 0.75)
123 (- (cdr next-nh-height) 0.75))))
124 (cons (+ left-pos left-height) (+ right-pos right-height))))
126 (define-public (beam::get-kievan-quantized-positions grob)
127 (let* ((pos (ly:grob-property grob 'positions))
128 (stems (ly:grob-object grob 'stems))
129 (stems-grobs (if (not (null? stems))
130 (ly:grob-array->list stems)
134 (ly:grob-set-property! g 'stem-begin-position 0)
135 (ly:grob-set-property! g 'length 0))
139 ;; calculates each slope of a broken beam individually
140 (define-public (beam::place-broken-parts-individually grob)
141 (ly:beam::quanting grob '(+inf.0 . -inf.0) #f))
143 ;; calculates the slope of a beam as a single unit,
144 ;; even if it is broken. this assures that the beam
145 ;; will pick up where it left off after a line break
146 (define-public (beam::align-with-broken-parts grob)
147 (ly:beam::quanting grob '(+inf.0 . -inf.0) #t))
149 ;; uses the broken beam style from edition peters combines the
150 ;; values of place-broken-parts-individually and align-with-broken-parts above,
151 ;; favoring place-broken-parts-individually when the beam naturally has a steeper
152 ;; incline and align-with-broken-parts when the beam is flat
153 (define-public (beam::slope-like-broken-parts grob)
155 (/ (- (cdr y) (car y)) (- (cdr x) (car x))))
156 (let* ((quant1 (ly:beam::quanting grob '(+inf.0 . -inf.0) #t))
157 (original (ly:grob-original grob))
158 (siblings (if (ly:grob? original)
159 (ly:spanner-broken-into original)
163 (let* ((quant2 (ly:beam::quanting grob '(+inf.0 . -inf.0) #f))
164 (x-span (ly:grob-property grob 'X-positions))
165 (slope1 (slope quant1 x-span))
166 (slope2 (slope quant2 x-span))
167 (quant2 (if (not (= (sign slope1) (sign slope2)))
170 (factor (/ (atan (abs slope1)) PI-OVER-TWO))
173 (+ (* (x quant1) (- 1 factor))
174 (* (x quant2) factor)))
176 (ly:beam::quanting grob base #f)))))
178 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
181 (define-public (script-or-side-position-cross-staff g)
183 (ly:script-interface::calc-cross-staff g)
184 (ly:side-position-interface::calc-cross-staff g)))
187 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
188 ;; side-position stuff
190 (define-public (only-if-beamed g)
194 (ly:grob? (ly:grob-object x 'beam)))
195 (ly:grob-array->list (ly:grob-object g
196 'side-support-elements)))))
198 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
201 (define-public (stem::calc-duration-log grob)
203 (ly:event-property (event-cause grob) 'duration)))
205 (define (stem-stub::do-calculations grob)
206 (and (ly:grob-property (ly:grob-parent grob X) 'cross-staff)
207 (not (ly:grob-property (ly:grob-parent grob X) 'transparent))))
209 (define-public (stem-stub::pure-height grob beg end)
210 (if (stem-stub::do-calculations grob)
214 (define-public (stem-stub::width grob)
215 (if (stem-stub::do-calculations grob)
216 (grob::x-parent-width grob)
219 (define-public (stem-stub::extra-spacing-height grob)
220 (if (stem-stub::do-calculations grob)
221 (let* ((dad (ly:grob-parent grob X))
222 (refp (ly:grob-common-refpoint grob dad Y))
223 (stem_ph (ly:grob-pure-height dad refp 0 1000000))
224 (my_ph (ly:grob-pure-height grob refp 0 1000000))
225 ;; only account for distance if stem is on different staff than stub
226 (dist (if (grob::has-interface refp 'hara-kiri-group-spanner-interface)
228 (- (car my_ph) (car stem_ph)))))
229 (if (interval-empty? (interval-intersection stem_ph my_ph)) #f (coord-translate stem_ph dist)))
232 (define-public (note-head::calc-kievan-duration-log grob)
235 (ly:event-property (event-cause grob) 'duration))))
237 (define-public (note-head::calc-duration-log grob)
240 (ly:event-property (event-cause grob) 'duration))))
242 (define-public (dots::calc-dot-count grob)
243 (ly:duration-dot-count
244 (ly:event-property (event-cause grob) 'duration)))
246 (define-public (dots::calc-staff-position grob)
247 (let* ((head (ly:grob-parent grob Y))
248 (log (ly:grob-property head 'duration-log)))
251 ((or (not (grob::has-interface head 'rest-interface))
252 (not (integer? log))) 0)
260 ;; Kept separate from note-head::calc-glyph-name to allow use by
261 ;; markup commands \note and \note-by-number
262 (define-public (select-head-glyph style log)
263 "Select a note head glyph string based on note head style @var{style}
264 and duration-log @var{log}."
266 ;; "default" style is directly handled in note-head.cc as a
267 ;; special case (HW says, mainly for performance reasons).
268 ;; Therefore, style "default" does not appear in this case
270 ((xcircle) "2xcircle")
271 ((harmonic) "0harmonic")
272 ((harmonic-black) "2harmonic")
273 ((harmonic-mixed) (if (<= log 1) "0harmonic"
276 ;; Oops, I actually would not call this "baroque", but, for
277 ;; backwards compatibility to 1.4, this is supposed to take
278 ;; brevis, longa and maxima from the neo-mensural font and all
279 ;; other note heads from the default font. -- jr
281 (string-append (number->string log) "neomensural")
282 (number->string log)))
284 ;; Like default, but brevis is drawn with double vertical lines
286 (string-append (number->string log) "double")
287 (number->string log)))
289 (string-append (number->string log) (symbol->string style)))
292 (string-append (number->string log) "mensural")
293 (string-append (number->string log) (symbol->string style))))
296 (string-append (number->string log) "blackmensural")
297 (string-append (number->string log) (symbol->string style))))
300 (string-append (number->string log) "semimensural")
301 (string-append (number->string log) "petrucci")))
303 (string-append (number->string log) (symbol->string style)))
305 (string-append (number->string log) "kievan"))
307 (if (string-match "vaticana*|hufnagel*|medicaea*" (symbol->string style))
308 (symbol->string style)
309 (string-append (number->string (max 0 log))
310 (symbol->string style))))))
312 (define-public (note-head::calc-glyph-name grob)
313 (let* ((style (ly:grob-property grob 'style))
314 (log (if (string-match "kievan*" (symbol->string style))
315 (min 3 (ly:grob-property grob 'duration-log))
316 (min 2 (ly:grob-property grob 'duration-log)))))
317 (select-head-glyph style log)))
319 (define-public (note-head::brew-ez-stencil grob)
320 (let* ((log (ly:grob-property grob 'duration-log))
321 (pitch (ly:event-property (event-cause grob) 'pitch))
322 (pitch-index (ly:pitch-notename pitch))
323 (note-names (ly:grob-property grob 'note-names))
324 (pitch-string (if (and (vector? note-names)
325 (> (vector-length note-names) pitch-index))
326 (vector-ref note-names pitch-index)
329 (+ (modulo (+ pitch-index 2) 7)
330 (char->integer #\A))))))
331 (staff-space (ly:staff-symbol-staff-space grob))
332 (line-thickness (ly:staff-symbol-line-thickness grob))
333 (stem (ly:grob-object grob 'stem))
334 (stem-thickness (* (if (ly:grob? stem)
335 (ly:grob-property stem 'thickness)
338 (radius (/ (+ staff-space line-thickness) 2))
339 (letter (markup #:center-align #:vcenter pitch-string))
340 (filled-circle (markup #:draw-circle radius 0 #t)))
342 (ly:stencil-translate-axis
343 (grob-interpret-markup
348 (make-with-color-markup white letter))
352 (make-with-color-markup white (make-draw-circle-markup
353 (- radius stem-thickness) 0 #t)))
357 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
360 (define-public (make-rhythmic-location bar-num num den)
362 bar-num (ly:make-moment num den)))
364 (define-public (rhythmic-location? a)
367 (ly:moment? (cdr a))))
369 (define-public (make-graceless-rhythmic-location loc)
370 (make-rhythmic-location
372 (ly:moment-main-numerator (rhythmic-location-measure-position loc))
373 (ly:moment-main-denominator (rhythmic-location-measure-position loc))))
375 (define-public rhythmic-location-measure-position cdr)
376 (define-public rhythmic-location-bar-number car)
378 (define-public (rhythmic-location<? a b)
380 ((< (car a) (car b)) #t)
381 ((> (car a) (car b)) #f)
383 (ly:moment<? (cdr a) (cdr b)))))
385 (define-public (rhythmic-location<=? a b)
386 (not (rhythmic-location<? b a)))
387 (define-public (rhythmic-location>=? a b)
388 (not (rhythmic-location<? a b)))
389 (define-public (rhythmic-location>? a b)
390 (rhythmic-location<? b a))
392 (define-public (rhythmic-location=? a b)
393 (and (rhythmic-location<=? a b)
394 (rhythmic-location<=? b a)))
396 (define-public (rhythmic-location->file-string a)
397 (ly:format "~a.~a.~a"
399 (ly:moment-main-numerator (cdr a))
400 (ly:moment-main-denominator (cdr a))))
402 (define-public (rhythmic-location->string a)
403 (ly:format "bar ~a ~a"
405 (ly:moment->string (cdr a))))
407 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
410 (define-public all-visible #(#t #t #t))
411 (define-public begin-of-line-invisible #(#t #t #f))
412 (define-public center-invisible #(#t #f #t))
413 (define-public end-of-line-invisible #(#f #t #t))
414 (define-public begin-of-line-visible #(#f #f #t))
415 (define-public center-visible #(#f #t #f))
416 (define-public end-of-line-visible #(#t #f #f))
417 (define-public all-invisible #(#f #f #f))
418 (define-public (inherit-x-parent-visibility grob)
419 (let ((parent (ly:grob-parent grob X)))
420 (ly:grob-property parent 'break-visibility all-invisible)))
421 (define-public (inherit-y-parent-visibility grob)
422 (let ((parent (ly:grob-parent grob X)))
423 (ly:grob-property parent 'break-visibility)))
426 (define-public spanbar-begin-of-line-invisible #(#t #f #f))
429 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
430 ;; neighbor-interface routines
433 (define-public (shift-right-at-line-begin g)
434 "Shift an item to the right, but only at the start of the line."
435 (if (and (ly:item? g)
436 (equal? (ly:item-break-dir g) RIGHT))
437 (ly:grob-translate-axis! g 3.5 X)))
439 (define-public (pure-from-neighbor-interface::extra-spacing-height-at-beginning-of-line grob)
440 (if (= 1 (ly:item-break-dir grob))
441 (pure-from-neighbor-interface::extra-spacing-height grob)
444 (define-public (pure-from-neighbor-interface::extra-spacing-height grob)
445 (let* ((height (ly:grob-pure-height grob grob 0 10000000))
446 (from-neighbors (interval-union
448 (ly:axis-group-interface::pure-height
452 (coord-operation - from-neighbors height)))
454 (define-public (pure-from-neighbor-interface::account-for-span-bar grob)
455 (let* ((esh (pure-from-neighbor-interface::extra-spacing-height grob))
456 (hsb (ly:grob-property grob 'has-span-bar))
457 (ii (interval-intersection esh (cons -1.01 1.01))))
459 (cons (car (if (and (car hsb)
460 (ly:grob-property grob 'allow-span-bar))
462 (cdr (if (cdr hsb) esh ii)))
465 (define-public (pure-from-neighbor-interface::extra-spacing-height-including-staff grob)
466 (let ((esh (pure-from-neighbor-interface::extra-spacing-height grob))
467 (to-staff (coord-operation -
470 (ly:staff-symbol-staff-radius grob))
471 (ly:grob::stencil-height grob))))
472 (interval-union esh to-staff)))
475 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
478 (define-public (tuplet-number::calc-direction grob)
479 (ly:tuplet-bracket::calc-direction (ly:grob-object grob 'bracket)))
481 (define-public (tuplet-number::calc-denominator-text grob)
482 (number->string (ly:event-property (event-cause grob) 'denominator)))
484 (define-public (tuplet-number::calc-fraction-text grob)
485 (let ((ev (event-cause grob)))
488 (ly:event-property ev 'denominator)
489 (ly:event-property ev 'numerator))))
491 ;; a formatter function, which is simply a wrapper around an existing
492 ;; tuplet formatter function. It takes the value returned by the given
493 ;; function and appends a note of given length.
494 (define-public ((tuplet-number::append-note-wrapper function note) grob)
495 (let ((txt (if function (function grob) #f)))
498 (markup txt #:fontsize -5 #:note note UP)
499 (markup #:fontsize -5 #:note note UP))))
501 ;; Print a tuplet denominator with a different number than the one derived from
502 ;; the actual tuplet fraction
503 (define-public ((tuplet-number::non-default-tuplet-denominator-text denominator)
505 (number->string (if denominator
507 (ly:event-property (event-cause grob) 'denominator))))
509 ;; Print a tuplet fraction with different numbers than the ones derived from
510 ;; the actual tuplet fraction
511 (define-public ((tuplet-number::non-default-tuplet-fraction-text
512 denominator numerator) grob)
513 (let* ((ev (event-cause grob))
514 (den (if denominator denominator (ly:event-property ev 'denominator)))
515 (num (if numerator numerator (ly:event-property ev 'numerator))))
517 (format #f "~a:~a" den num)))
519 ;; Print a tuplet fraction with note durations appended to the numerator and the
521 (define-public ((tuplet-number::fraction-with-notes
522 denominatornote numeratornote) grob)
523 (let* ((ev (event-cause grob))
524 (denominator (ly:event-property ev 'denominator))
525 (numerator (ly:event-property ev 'numerator)))
527 ((tuplet-number::non-default-fraction-with-notes
528 denominator denominatornote numerator numeratornote) grob)))
530 ;; Print a tuplet fraction with note durations appended to the numerator and the
532 (define-public ((tuplet-number::non-default-fraction-with-notes
533 denominator denominatornote numerator numeratornote) grob)
534 (let* ((ev (event-cause grob))
535 (den (if denominator denominator (ly:event-property ev 'denominator)))
536 (num (if numerator numerator (ly:event-property ev 'numerator))))
538 (make-concat-markup (list
539 (make-simple-markup (format #f "~a" den))
540 (markup #:fontsize -5 #:note denominatornote UP)
541 (make-simple-markup " : ")
542 (make-simple-markup (format #f "~a" num))
543 (markup #:fontsize -5 #:note numeratornote UP)))))
546 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
549 (define-public (color? x)
552 (apply eq? #t (map number? x))
553 (apply eq? #t (map (lambda (y) (<= 0 y 1)) x))))
555 (define-public (rgb-color r g b) (list r g b))
558 (define-public black '(0.0 0.0 0.0))
559 (define-public white '(1.0 1.0 1.0))
560 (define-public red '(1.0 0.0 0.0))
561 (define-public green '(0.0 1.0 0.0))
562 (define-public blue '(0.0 0.0 1.0))
563 (define-public cyan '(0.0 1.0 1.0))
564 (define-public magenta '(1.0 0.0 1.0))
565 (define-public yellow '(1.0 1.0 0.0))
567 (define-public grey '(0.5 0.5 0.5))
568 (define-public darkred '(0.5 0.0 0.0))
569 (define-public darkgreen '(0.0 0.5 0.0))
570 (define-public darkblue '(0.0 0.0 0.5))
571 (define-public darkcyan '(0.0 0.5 0.5))
572 (define-public darkmagenta '(0.5 0.0 0.5))
573 (define-public darkyellow '(0.5 0.5 0.0))
576 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
579 (define-public (key-signature-interface::alteration-positions
580 entry c0-position grob)
581 (let ((step (car entry))
584 (list (+ (cdr step) (* (car step) 7) c0-position))
585 (let* ((c-position (modulo c0-position 7))
588 ;; See (flat|sharp)-positions in define-grob-properties.scm
589 (ly:grob-property grob 'flat-positions '(3))
590 (ly:grob-property grob 'sharp-positions '(3))))
591 (p (list-ref positions
592 (if (< c-position (length positions))
594 (max-position (if (pair? p) (cdr p) p))
595 (min-position (if (pair? p) (car p) (- max-position 6)))
596 (first-position (+ (modulo (- (+ c-position step)
600 (define (prepend x l) (if (> x max-position)
602 (prepend (+ x 7) (cons x l))))
603 (prepend first-position '())))))
605 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
608 (define-public (numbered-footnotes int)
609 (markup #:tiny (number->string (+ 1 int))))
611 (define-public (symbol-footnotes int)
612 (define (helper symbols out idx n)
616 (string-append out (list-ref symbols idx))
619 (markup #:tiny (helper '("*" "†" "‡" "§" "¶")
622 (+ 1 (quotient int 5)))))
624 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
627 (define-public (accidental-interface::calc-alteration grob)
628 (ly:pitch-alteration (ly:event-property (event-cause grob) 'pitch)))
630 (define-public (accidental-interface::glyph-name grob)
631 (assoc-get (ly:grob-property grob 'alteration)
632 standard-alteration-glyph-name-alist))
634 (define-public cancellation-glyph-name-alist
635 '((0 . "accidentals.natural")))
637 (define-public standard-alteration-glyph-name-alist
639 ;; ordered for optimal performance.
640 (0 . "accidentals.natural")
641 (-1/2 . "accidentals.flat")
642 (1/2 . "accidentals.sharp")
644 (1 . "accidentals.doublesharp")
645 (-1 . "accidentals.flatflat")
647 (3/4 . "accidentals.sharp.slashslash.stemstemstem")
648 (1/4 . "accidentals.sharp.slashslash.stem")
649 (-1/4 . "accidentals.mirroredflat")
650 (-3/4 . "accidentals.mirroredflat.flat")))
652 ;; FIXME: standard vs default, alteration-FOO vs FOO-alteration
653 (define-public alteration-default-glyph-name-alist
654 standard-alteration-glyph-name-alist)
656 (define-public makam-alteration-glyph-name-alist
657 '((1 . "accidentals.doublesharp")
658 (8/9 . "accidentals.sharp.slashslashslash.stemstem")
659 (5/9 . "accidentals.sharp.slashslashslash.stem")
660 (4/9 . "accidentals.sharp")
661 (1/9 . "accidentals.sharp.slashslash.stem")
662 (0 . "accidentals.natural")
663 (-1/9 . "accidentals.mirroredflat")
664 (-4/9 . "accidentals.flat.slash")
665 (-5/9 . "accidentals.flat")
666 (-8/9 . "accidentals.flat.slashslash")
667 (-1 . "accidentals.flatflat")))
669 (define-public alteration-hufnagel-glyph-name-alist
670 '((-1/2 . "accidentals.hufnagelM1")
671 (0 . "accidentals.vaticana0")
672 (1/2 . "accidentals.mensural1")))
674 (define-public alteration-medicaea-glyph-name-alist
675 '((-1/2 . "accidentals.medicaeaM1")
676 (0 . "accidentals.vaticana0")
677 (1/2 . "accidentals.mensural1")))
679 (define-public alteration-vaticana-glyph-name-alist
680 '((-1/2 . "accidentals.vaticanaM1")
681 (0 . "accidentals.vaticana0")
682 (1/2 . "accidentals.mensural1")))
684 (define-public alteration-mensural-glyph-name-alist
685 '((-1/2 . "accidentals.mensuralM1")
686 (0 . "accidentals.vaticana0")
687 (1/2 . "accidentals.mensural1")))
689 (define-public alteration-kievan-glyph-name-alist
690 '((-1/2 . "accidentals.kievanM1")
691 (1/2 . "accidentals.kievan1")))
693 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
694 ;; * Pitch Trill Heads
697 (define-public (parentheses-item::calc-parenthesis-stencils grob)
698 (let* ((font (ly:grob-default-font grob))
699 (lp (ly:font-get-glyph font "accidentals.leftparen"))
700 (rp (ly:font-get-glyph font "accidentals.rightparen")))
704 (define-public (parentheses-item::calc-angled-bracket-stencils grob)
705 (let* ((parent (ly:grob-parent grob Y))
706 (y-extent (ly:grob-extent parent parent Y))
707 (half-thickness 0.05) ; should it be a property?
708 (width 0.5) ; should it be a property?
709 (angularity 1.5) ; makes angle brackets
710 (white-padding 0.1) ; should it be a property?
711 (lp (ly:stencil-aligned-to
712 (ly:stencil-aligned-to
713 (make-parenthesis-stencil y-extent
720 (interval-widen (ly:stencil-extent lp X) white-padding))
721 (rp (ly:stencil-aligned-to
722 (ly:stencil-aligned-to
723 (make-parenthesis-stencil y-extent
730 (interval-widen (ly:stencil-extent rp X) white-padding)))
731 (set! lp (ly:make-stencil (ly:stencil-expr lp)
733 (ly:stencil-extent lp Y)))
734 (set! rp (ly:make-stencil (ly:stencil-expr rp)
736 (ly:stencil-extent rp Y)))
737 (list (stencil-whiteout lp)
738 (stencil-whiteout rp))))
740 (define (parenthesize-elements grob . rest)
741 (let* ((refp (if (null? rest)
744 (elts (ly:grob-object grob 'elements))
745 (x-ext (ly:relative-group-extent elts refp X))
746 (stencils (ly:grob-property grob 'stencils))
749 (padding (ly:grob-property grob 'padding 0.1)))
752 (ly:stencil-translate-axis lp (- (car x-ext) padding) X)
753 (ly:stencil-translate-axis rp (+ (cdr x-ext) padding) X))))
756 (define-public (parentheses-item::print me)
757 (let* ((elts (ly:grob-object me 'elements))
758 (y-ref (ly:grob-common-refpoint-of-array me elts Y))
759 (x-ref (ly:grob-common-refpoint-of-array me elts X))
760 (stencil (parenthesize-elements me x-ref))
761 (elt-y-ext (ly:relative-group-extent elts y-ref Y))
762 (y-center (interval-center elt-y-ext)))
764 (ly:stencil-translate
767 (- (ly:grob-relative-coordinate me x-ref X))
768 (- y-center (ly:grob-relative-coordinate me y-ref Y))))))
772 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
775 (define-public (chain-grob-member-functions grob value . funcs)
778 (set! value (func grob value)))
784 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
787 (define-public (bend::print spanner)
789 (< (abs (- a b)) 0.01))
791 (let* ((delta-y (* 0.5 (ly:grob-property spanner 'delta-position)))
792 (left-span (ly:spanner-bound spanner LEFT))
793 (dots (if (and (grob::has-interface left-span 'note-head-interface)
794 (ly:grob? (ly:grob-object left-span 'dot)))
795 (ly:grob-object left-span 'dot) #f))
797 (right-span (ly:spanner-bound spanner RIGHT))
798 (thickness (* (ly:grob-property spanner 'thickness)
799 (ly:output-def-lookup (ly:grob-layout spanner)
801 (padding (ly:grob-property spanner 'padding 0.5))
802 (common (ly:grob-common-refpoint right-span
803 (ly:grob-common-refpoint spanner
806 (common-y (ly:grob-common-refpoint spanner left-span Y))
807 (minimum-length (ly:grob-property spanner 'minimum-length 0.5))
811 (interval-end (ly:grob-robust-relative-extent
816 (ly:grob-relative-coordinate dots common-y Y)
817 (ly:grob-relative-coordinate spanner common-y Y)))
819 (ly:grob-robust-relative-extent dots common X))
820 ;; TODO: use real infinity constant.
822 (right-x (max (- (interval-start
823 (ly:grob-robust-relative-extent right-span common X))
825 (+ left-x minimum-length)))
826 (self-x (ly:grob-relative-coordinate spanner common X))
827 (dx (- right-x left-x))
828 (exp (list 'path thickness
836 ,dx ,(* 0.66 delta-y)
841 (cons (- left-x self-x) (- right-x self-x))
842 (cons (min 0 delta-y)
846 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
849 (define-public (grace-spacing::calc-shortest-duration grob)
850 (let* ((cols (ly:grob-object grob 'columns))
853 (ly:moment-sub (ly:grob-property
854 (ly:grob-array-ref cols (1+ idx)) 'when)
856 (ly:grob-array-ref cols idx) 'when))))
858 (moment-min (lambda (x y)
861 (if (ly:moment<? x y)
867 (fold moment-min #f (map get-difference
868 (iota (1- (ly:grob-array-length cols)))))))
871 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
874 (define-public (fingering::calc-text grob)
875 (let* ((event (event-cause grob))
876 (digit (ly:event-property event 'digit)))
878 (number->string digit 10)))
880 (define-public (string-number::calc-text grob)
881 (let ((digit (ly:event-property (event-cause grob) 'string-number)))
883 (number->string digit 10)))
885 (define-public (stroke-finger::calc-text grob)
886 (let* ((digit (ly:event-property (event-cause grob) 'digit))
887 (text (ly:event-property (event-cause grob) 'text)))
891 (vector-ref (ly:grob-property grob 'digit-names)
892 (1- (max (min 5 digit) 1))))))
895 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
898 (define-public (hairpin::calc-grow-direction grob)
899 (if (ly:in-event-class? (event-cause grob) 'decrescendo-event)
903 (define-public (dynamic-text-spanner::before-line-breaking grob)
904 "Monitor left bound of @code{DynamicTextSpanner} for absolute dynamics.
905 If found, ensure @code{DynamicText} does not collide with spanner text by
906 changing @code{'attach-dir} and @code{'padding}. Reads the
907 @code{'right-padding} property of @code{DynamicText} to fine tune space
908 between the two text elements."
909 (let ((left-bound (ly:spanner-bound grob LEFT)))
910 (if (grob::has-interface left-bound 'dynamic-text-interface)
911 (let* ((details (ly:grob-property grob 'bound-details))
912 (left-details (ly:assoc-get 'left details))
913 (my-padding (ly:assoc-get 'padding left-details))
914 (script-padding (ly:grob-property left-bound 'right-padding 0)))
916 (and (number? my-padding)
917 (ly:grob-set-nested-property! grob
918 '(bound-details left attach-dir)
920 (ly:grob-set-nested-property! grob
921 '(bound-details left padding)
922 (+ my-padding script-padding)))))))
925 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
928 (define-public (lyric-text::print grob)
929 "Allow interpretation of tildes as lyric tieing marks."
931 (let ((text (ly:grob-property grob 'text)))
933 (grob-interpret-markup grob (if (string? text)
934 (make-tied-lyric-markup text)
937 (define-public ((grob::calc-property-by-copy prop) grob)
938 (ly:event-property (event-cause grob) prop))
940 (define-public ((grob::calc-property-by-non-event-cause prop) grob)
941 (ly:grob-property (non-event-cause grob) prop))
944 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
947 (define-public (fret-board::calc-stencil grob)
948 (grob-interpret-markup
950 (make-fret-diagram-verbose-markup
951 (ly:grob-property grob 'dot-placement-list))))
954 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
957 (define-public (script-interface::calc-x-offset grob)
958 (ly:grob-property grob 'positioning-done)
959 (let* ((shift (ly:grob-property grob 'toward-stem-shift 0.0))
961 (ly:self-alignment-interface::centered-on-x-parent grob))
962 (note-head-grob (ly:grob-parent grob X))
963 (stem-grob (ly:grob-object note-head-grob 'stem)))
965 (+ note-head-location
966 ;; If the property 'toward-stem-shift is defined and the script
967 ;; has the same direction as the stem, move the script accordingly.
968 ;; Since scripts can also be over skips, we need to check whether
969 ;; the grob has a stem at all.
970 (if (ly:grob? stem-grob)
971 (let ((dir1 (ly:grob-property grob 'direction))
972 (dir2 (ly:grob-property stem-grob 'direction)))
973 (if (equal? dir1 dir2)
974 (let* ((common-refp (ly:grob-common-refpoint grob stem-grob X))
976 (ly:grob-relative-coordinate stem-grob common-refp X)))
977 (* shift (- stem-location note-head-location)))
982 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
985 (define-public (system-start-text::print grob)
986 (let* ((left-bound (ly:spanner-bound grob LEFT))
987 (left-mom (ly:grob-property left-bound 'when))
988 (name (if (moment<=? left-mom ZERO-MOMENT)
989 (ly:grob-property grob 'long-text)
990 (ly:grob-property grob 'text))))
992 (if (and (markup? name)
993 (!= (ly:item-break-dir left-bound) CENTER))
995 (grob-interpret-markup grob name)
996 (ly:grob-suicide! grob))))
998 (define-public (system-start-text::calc-x-offset grob)
999 (let* ((left-bound (ly:spanner-bound grob LEFT))
1000 (left-mom (ly:grob-property left-bound 'when))
1001 (layout (ly:grob-layout grob))
1002 (indent (ly:output-def-lookup layout
1003 (if (moment<=? left-mom ZERO-MOMENT)
1007 (system (ly:grob-system grob))
1008 (my-extent (ly:grob-extent grob system X))
1009 (elements (ly:grob-object system 'elements))
1010 (common (ly:grob-common-refpoint-of-array system elements X))
1011 (total-ext empty-interval)
1012 (align-x (ly:grob-property grob 'self-alignment-X 0))
1013 (padding (min 0 (- (interval-length my-extent) indent)))
1014 (right-padding (- padding
1015 (/ (* padding (1+ align-x)) 2))))
1017 ;; compensate for the variation in delimiter extents by
1018 ;; calculating an X-offset correction based on united extents
1019 ;; of all delimiters in this system
1020 (let unite-delims ((l (ly:grob-array-length elements)))
1022 (let ((elt (ly:grob-array-ref elements (1- l))))
1024 (if (grob::has-interface elt 'system-start-delimiter-interface)
1025 (let ((dims (ly:grob-extent elt common X)))
1026 (if (interval-sane? dims)
1027 (set! total-ext (interval-union total-ext dims)))))
1028 (unite-delims (1- l)))))
1031 (ly:side-position-interface::x-aligned-side grob)
1033 (- (interval-length total-ext)))))
1035 (define-public (system-start-text::calc-y-offset grob)
1037 (define (live-elements-list me)
1038 (let ((elements (ly:grob-object me 'elements)))
1040 (filter! grob::is-live?
1041 (ly:grob-array->list elements))))
1043 (let* ((left-bound (ly:spanner-bound grob LEFT))
1044 (live-elts (live-elements-list grob))
1045 (system (ly:grob-system grob))
1046 (extent empty-interval))
1048 (if (and (pair? live-elts)
1049 (interval-sane? (ly:grob-extent grob system Y)))
1050 (let get-extent ((lst live-elts))
1052 (let ((axis-group (car lst)))
1054 (if (and (ly:spanner? axis-group)
1055 (equal? (ly:spanner-bound axis-group LEFT)
1057 (set! extent (add-point extent
1058 (ly:grob-relative-coordinate
1059 axis-group system Y))))
1060 (get-extent (cdr lst)))))
1061 ;; no live axis group(s) for this instrument name -> remove from system
1062 (ly:grob-suicide! grob))
1065 (ly:self-alignment-interface::y-aligned-on-self grob)
1066 (interval-center extent))))
1069 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1072 (define-public (ambitus::print grob)
1073 (let ((heads (ly:grob-object grob 'note-heads)))
1075 (if (and (ly:grob-array? heads)
1076 (= (ly:grob-array-length heads) 2))
1077 (let* ((common (ly:grob-common-refpoint-of-array grob heads Y))
1078 (head-down (ly:grob-array-ref heads 0))
1079 (head-up (ly:grob-array-ref heads 1))
1080 (gap (ly:grob-property grob 'gap 0.35))
1081 (point-min (+ (interval-end (ly:grob-extent head-down common Y))
1083 (point-max (- (interval-start (ly:grob-extent head-up common Y))
1086 (if (< point-min point-max)
1087 (let* ((layout (ly:grob-layout grob))
1088 (line-thick (ly:output-def-lookup layout 'line-thickness))
1089 (blot (ly:output-def-lookup layout 'blot-diameter))
1090 (grob-thick (ly:grob-property grob 'thickness 2))
1091 (width (* line-thick grob-thick))
1092 (x-ext (symmetric-interval (/ width 2)))
1093 (y-ext (cons point-min point-max))
1094 (line (ly:round-filled-box x-ext y-ext blot))
1095 (y-coord (ly:grob-relative-coordinate grob common Y)))
1097 (ly:stencil-translate-axis line (- y-coord) Y))
1100 (ly:grob-suicide! grob)
1103 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1104 ;; laissez-vibrer tie
1106 ;; needed so we can make laissez-vibrer a pure print
1108 (define-public (laissez-vibrer::print grob)
1109 (ly:tie::print grob))