1 ;;;; This file is part of LilyPond, the GNU music typesetter.
3 ;;;; Copyright (C) 2009--2012 Marc Hohl <marc@hohlart.de>
5 ;;;; LilyPond is free software: you can redistribute it and/or modify
6 ;;;; it under the terms of the GNU General Public License as published by
7 ;;;; the Free Software Foundation, either version 3 of the License, or
8 ;;;; (at your option) any later version.
10 ;;;; LilyPond is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 ;;;; GNU General Public License for more details.
15 ;;;; You should have received a copy of the GNU General Public License
16 ;;;; along with LilyPond. If not, see <http://www.gnu.org/licenses/>.
20 (define (get-staff-symbol grob)
21 (if (grob::has-interface grob 'staff-symbol-interface)
23 (ly:grob-object grob 'staff-symbol)))
25 (define (layout-blot-diameter grob)
26 (let* ((layout (ly:grob-layout grob))
27 (blot (ly:output-def-lookup layout 'blot-diameter)))
31 (define (layout-line-thickness grob)
32 (let* ((layout (ly:grob-layout grob))
33 (line-thickness (ly:output-def-lookup layout 'line-thickness)))
37 (define (staff-symbol-line-count grob)
41 (let ((line-pos (ly:grob-property grob 'line-positions '())))
43 (set! line-count (if (pair? line-pos)
45 (ly:grob-property grob 'line-count 0)))))
49 (define (staff-symbol-line-span grob)
50 (let ((line-pos (ly:grob-property grob 'line-positions '()))
55 (set! iv (cons (min (car iv) x)
58 (let ((line-count (ly:grob-property grob 'line-count 0)))
60 (set! iv (cons (- 1 line-count)
64 (define (staff-symbol-line-positions grob)
65 (let ((line-pos (ly:grob-property grob 'line-positions '())))
67 (if (not (pair? line-pos))
68 (let* ((line-count (ly:grob-property grob 'line-count 0))
69 (height (- line-count 1.0)))
71 (set! line-pos (map (lambda (x)
76 ;; functions used by external routines
78 (define-public (span-bar::notify-grobs-of-my-existence grob)
79 (let* ((elts (ly:grob-array->list (ly:grob-object grob 'elements)))
80 (sorted-elts (sort elts ly:grob-vertical<?))
81 (last-pos (1- (length sorted-elts)))
85 (ly:grob-set-property!
88 (cons (if (eq? idx last-pos)
97 ;; How should a bar line behave at a break?
98 ;; the following alist has the form
99 ;; ( unbroken-bar-glyph . ( bar-glyph-at-end-of-line . bar-glyph-at-begin-of-line ))
101 (define bar-glyph-alist
102 '((":|:" . (":|" . "|:"))
103 (":|.|:" . (":|" . "|:"))
104 (":|.:" . (":|" . "|:"))
105 ("||:" . ("||" . "|:"))
106 ("dashed" . ("dashed" . '()))
109 ("|:" . ("|" . "|:"))
112 ;; hmm... should we end with a bar line here?
113 (".|" . ("|" . ".|"))
116 (".|." . (".|." . ()))
117 ("|.|" . ("|.|" . ()))
122 ("empty" . (() . ()))
123 ("brace" . (() . "brace"))
124 ("bracket" . (() . "bracket"))
130 (":|S" . (":|" . "S"))
131 (":|S." . (":|S" . ()))
132 ("S|:" . ("S" . "|:"))
133 (".S|:" . ("|" . "S|:"))
134 (":|S|:" . (":|" . "S|:"))
135 (":|S.|:" . (":|S" . "|:"))
138 ("kievan" . ("kievan" . ""))))
140 ;; drawing functions for various bar line types
142 (define (make-empty-bar-line grob extent)
143 (ly:make-stencil "" (cons 0 0) extent))
145 (define (make-simple-bar-line grob width extent rounded)
146 (let ((blot (if rounded
147 (layout-blot-diameter grob)
150 (ly:round-filled-box (cons 0 width)
154 (define (make-tick-bar-line grob height rounded)
155 (let ((half-staff (* 1/2 (ly:staff-symbol-staff-space grob)))
156 (staff-line-thickness (ly:staff-symbol-line-thickness grob))
158 (layout-blot-diameter grob)
161 (ly:round-filled-box (cons 0 staff-line-thickness)
162 (cons (- height half-staff) (+ height half-staff))
165 (define (make-colon-bar-line grob)
166 (let* ((staff-space (ly:staff-symbol-staff-space grob))
167 (line-thickness (ly:staff-symbol-line-thickness grob))
168 (dot (ly:font-get-glyph (ly:grob-default-font grob) "dots.dot"))
169 (dot-y-length (interval-length (ly:stencil-extent dot Y)))
170 (stencil empty-stencil)
171 ;; the two dots of the repeat sign should be centred at the middle of
172 ;; the staff and neither should collide with staff lines
174 ;; the default distance between centre of dots is composed of
175 ;; - a staffline (with width line-thickness)
176 ;; - some space below and above dot
178 ;; and we need to measure it as line positions,
179 ;; i.e. in half staff spaces.
181 ;; space between dot and staffline should be comparable to staffline
182 ;; width so that a relatively common idiom
183 ;; (0.5 staff-size combined with set-layout-staff-size 10) works ok -
184 ;; that makes the choice of 1 staffline too big.
185 ;; 0.1 will be used if to be positioned between staff lines,
186 ;; dot diameter if outside staff.
188 (dist (* 4 dot-y-length)))
190 (if (> staff-space 0)
192 (set! dist (/ dist staff-space))
193 (let ((staff-symbol (get-staff-symbol grob)))
195 (if (ly:grob? staff-symbol)
196 (let ((line-pos (staff-symbol-line-positions staff-symbol)))
201 (interval-center (staff-symbol-line-span
203 ;; fold the staff into two at center and find the
204 ;; first gap big enough to hold a dot and some space
207 (sort (append (map (lambda (lp)
211 (gap-to-find (/ (+ dot-y-length
212 (* 1.2 line-thickness))
216 ;; initialize dist for the case when both dots should
217 ;; be outside the staff
218 (set! dist (+ (* 2 (car (reverse half-staff)))
219 (/ (* 4 dot-y-length) staff-space)))
221 (reduce (lambda (x y) (if (and (> (- x y) gap-to-find)
225 (set! dist (+ x y))))
229 (set! staff-space 1.0))
231 (let* ((stencil empty-stencil)
232 (stencil (ly:stencil-add stencil dot))
233 (stencil (ly:stencil-translate-axis
234 stencil (* dist (/ staff-space 2)) Y))
235 (stencil (ly:stencil-add stencil dot))
236 (stencil (ly:stencil-translate-axis
237 stencil (* (- center (/ dist 2))
238 (/ staff-space 2)) Y)))
241 (define (make-dotted-bar-line grob extent)
242 (let* ((position (round (* (interval-end extent) 2)))
243 (correction (if (even? position) 0.5 0.0))
244 (dot (ly:font-get-glyph (ly:grob-default-font grob) "dots.dot"))
245 (i (round (+ (interval-start extent)
246 (- 0.5 correction))))
247 (e (round (+ (interval-end extent)
248 (- 0.5 correction))))
249 (counting (interval-length (cons i e)))
252 (ly:stencil-translate-axis
253 dot (+ x correction) Y))
254 (iota counting i 1))))
256 (define (add-stencils! stil l)
260 (ly:stencil-add stil (car l))
261 (add-stencils! (ly:stencil-add stil (car l)) (cdr l)))))
263 (add-stencils! empty-stencil stil-list)))
265 (define (make-dashed-bar-line grob extent thickness)
266 (let* ((height (interval-length extent))
267 (staff-symbol (get-staff-symbol grob))
268 (staff-space (ly:staff-symbol-staff-space grob))
269 (line-thickness (layout-line-thickness grob))
270 (dash-size (- 1.0 (ly:grob-property grob 'gap 0.3)))
271 (line-count (staff-symbol-line-count staff-symbol)))
273 (if (< (abs (+ line-thickness
274 (* (1- line-count) staff-space)
277 (let ((blot (layout-blot-diameter grob))
278 (half-space (/ staff-space 2.0))
279 (half-thick (/ line-thickness 2.0))
280 (stencil empty-stencil))
283 (let ((top-y (min (* (+ i dash-size) half-space)
284 (+ (* (1- line-count) half-space)
286 (bot-y (max (* (- i dash-size) half-space)
287 (- 0 (* (1- line-count) half-space)
293 (ly:round-filled-box (cons 0 thickness)
296 (iota line-count (1- line-count) (- 2)))
298 (let* ((dashes (/ height staff-space))
299 (total-dash-size (/ height dashes))
300 (factor (/ (- dash-size thickness) staff-space)))
302 (ly:stencil-translate-axis
303 (ly:make-stencil (list 'dashed-line
305 (* factor total-dash-size)
306 (* (- 1 factor) total-dash-size)
309 (* factor total-dash-size 0.5))
312 (interval-start extent)
315 (define (make-segno-bar-line grob glyph extent rounded)
316 (let* ((line-thickness (layout-line-thickness grob))
317 (kern (* (ly:grob-property grob 'kern 1) line-thickness))
318 (thinkern (* (ly:grob-property grob 'thin-kern 1) line-thickness))
319 (hair (* (ly:grob-property grob 'hair-thickness 1) line-thickness))
320 (fatline (* (ly:grob-property grob 'thick-thickness 1) line-thickness))
321 (thin-stil (make-simple-bar-line grob hair extent rounded))
322 (thick-stil (make-simple-bar-line grob fatline extent rounded))
323 (colon-stil (make-colon-bar-line grob))
324 (segno-stil (ly:stencil-add
325 (ly:stencil-combine-at-edge
326 (ly:stencil-combine-at-edge
327 '() X LEFT thin-stil thinkern)
328 X RIGHT thin-stil thinkern)
329 (ly:font-get-glyph (ly:grob-default-font grob) "scripts.varsegno")))
331 ((string=? glyph "|S") "S")
332 ((string=? glyph "S|") "S")
335 ((or (string=? glyph "S|:")
336 (string=? glyph ".S|:"))
337 (ly:stencil-combine-at-edge
338 (ly:stencil-combine-at-edge
339 (ly:stencil-combine-at-edge
340 thick-stil X RIGHT thin-stil kern)
341 X RIGHT colon-stil kern)
342 X LEFT segno-stil thinkern))
343 ((or (string=? glyph ":|S")
344 (string=? glyph ":|S."))
345 (ly:stencil-combine-at-edge
346 (ly:stencil-combine-at-edge
347 (ly:stencil-combine-at-edge
348 thick-stil X LEFT thin-stil kern)
349 X LEFT colon-stil kern)
350 X RIGHT segno-stil thinkern))
351 ((or (string=? glyph ":|S|:")
352 (string=? glyph ":|S.|:"))
353 (ly:stencil-combine-at-edge
354 (ly:stencil-combine-at-edge
355 (ly:stencil-combine-at-edge
356 (ly:stencil-combine-at-edge
357 (ly:stencil-combine-at-edge
358 (ly:stencil-combine-at-edge
359 thick-stil X LEFT thin-stil kern)
360 X LEFT colon-stil kern)
361 X RIGHT segno-stil thinkern)
362 X RIGHT thick-stil thinkern)
363 X RIGHT thin-stil kern)
364 X RIGHT colon-stil kern))
365 ((string=? glyph "|._.|")
366 (ly:stencil-combine-at-edge
367 (ly:stencil-combine-at-edge
368 (ly:stencil-combine-at-edge
369 thick-stil X LEFT thin-stil kern)
370 X RIGHT thick-stil (+ (interval-length
371 (ly:stencil-extent segno-stil X))
373 X RIGHT thin-stil kern))
378 (define (make-kievan-bar-line grob)
379 (let* ((font (ly:grob-default-font grob))
380 (stencil (stencil-whiteout
381 (ly:font-get-glyph font "scripts.barline.kievan"))))
383 ;; the kievan bar line has mo staff lines underneath,
384 ;; so we whiteout them and move ithe grob to a higher layer
385 (ly:grob-set-property! grob 'layer 1)
388 ;; bar line callbacks
390 (define-public (ly:bar-line::calc-bar-extent grob)
391 (let ((staff-symbol (get-staff-symbol grob))
392 (staff-extent (cons 0 0)))
394 (if (ly:grob? staff-symbol)
395 (let* ((bar-line-color (ly:grob-property grob 'color))
396 (staff-color (ly:grob-property staff-symbol 'color))
397 (radius (ly:staff-symbol-staff-radius grob))
398 (staff-line-thickness (ly:staff-symbol-line-thickness grob)))
400 ;; Due to rounding problems, bar lines extending to the outermost edges
401 ;; of the staff lines appear wrongly in on-screen display
402 ;; (and, to a lesser extent, in print) - they stick out a pixel.
403 ;; The solution is to extend bar lines only to the middle
404 ;; of the staff line - unless they have different colors,
405 ;;when it would be undesirable.
406 (set! staff-extent (ly:staff-symbol::height staff-symbol))
407 (if (and (eq? bar-line-color staff-color)
410 (interval-scale staff-extent
411 (- 1 (* 1/2 (/ staff-line-thickness radius))))))))
414 (define (bar-line::bar-y-extent grob refpoint)
415 (let* ((extent (ly:grob-property grob 'bar-extent '(0 . 0)))
416 (rel-y (ly:grob-relative-coordinate grob refpoint Y))
417 (y-extent (coord-translate extent rel-y)))
421 (define-public (ly:bar-line::print grob)
422 (let ((glyph (ly:grob-property grob 'glyph-name))
423 (extent (ly:grob-property grob 'bar-extent '(0 . 0))))
425 (if (and (not (eq? glyph '()))
426 (> (interval-length extent) 0))
427 (bar-line::compound-bar-line grob glyph extent #f)
430 (define-public (bar-line::compound-bar-line grob glyph extent rounded)
431 (let* ((line-thickness (layout-line-thickness grob))
432 (height (interval-length extent))
433 (kern (* (ly:grob-property grob 'kern 1) line-thickness))
434 (thinkern (* (ly:grob-property grob 'thin-kern 1) line-thickness))
435 (hair (* (ly:grob-property grob 'hair-thickness 1) line-thickness))
436 (fatline (* (ly:grob-property grob 'thick-thickness 1) line-thickness))
437 (thin-stil (make-simple-bar-line grob hair extent rounded))
438 (thick-stil (make-simple-bar-line grob fatline extent rounded))
439 (colon-stil (make-colon-bar-line grob))
442 ((string=? glyph "||:") "|:")
443 ;; bar-line::compound-bar-line is called only if
444 ;; height > 0, but just in case ...
445 ((and (string=? glyph ":|")
446 (zero? height)) "|.")
447 ((and (string=? glyph "|:")
448 (zero? height)) ".|")
451 ((string=? glyph "|") thin-stil)
452 ((string=? glyph ".") thick-stil)
453 ((string=? glyph "||")
454 (ly:stencil-combine-at-edge
455 (ly:stencil-combine-at-edge
456 '() X LEFT thin-stil thinkern)
457 X RIGHT thin-stil thinkern))
458 ((string=? glyph "|.")
459 (ly:stencil-combine-at-edge
460 thick-stil X LEFT thin-stil kern))
461 ((string=? glyph ".|")
462 (ly:stencil-combine-at-edge
463 thick-stil X RIGHT thin-stil kern))
464 ((string=? glyph "|:")
465 (ly:stencil-combine-at-edge
466 (ly:stencil-combine-at-edge
467 thick-stil X RIGHT thin-stil kern)
468 X RIGHT colon-stil kern))
469 ((string=? glyph ":|")
470 (ly:stencil-combine-at-edge
471 (ly:stencil-combine-at-edge
472 thick-stil X LEFT thin-stil kern)
473 X LEFT colon-stil kern))
474 ((string=? glyph ":|:")
475 (ly:stencil-combine-at-edge
476 (ly:stencil-combine-at-edge
477 (ly:stencil-combine-at-edge
478 (ly:stencil-combine-at-edge
479 '() X LEFT thick-stil thinkern)
480 X LEFT colon-stil kern)
481 X RIGHT thick-stil kern)
482 X RIGHT colon-stil kern))
483 ((string=? glyph ":|.|:")
484 (ly:stencil-combine-at-edge
485 (ly:stencil-combine-at-edge
486 (ly:stencil-combine-at-edge
487 (ly:stencil-combine-at-edge
488 thick-stil X LEFT thin-stil kern)
489 X LEFT colon-stil kern)
490 X RIGHT thin-stil kern)
491 X RIGHT colon-stil kern))
492 ((string=? glyph ":|.:")
493 (ly:stencil-combine-at-edge
494 (ly:stencil-combine-at-edge
495 (ly:stencil-combine-at-edge
496 thick-stil X LEFT thin-stil kern)
497 X LEFT colon-stil kern)
498 X RIGHT colon-stil kern))
499 ((string=? glyph ".|.")
500 (ly:stencil-combine-at-edge
501 (ly:stencil-combine-at-edge
502 '() X LEFT thick-stil thinkern)
503 X RIGHT thick-stil kern))
504 ((string=? glyph "|.|")
505 (ly:stencil-combine-at-edge
506 (ly:stencil-combine-at-edge
507 thick-stil X LEFT thin-stil kern)
508 X RIGHT thin-stil kern))
509 ((string=? glyph ":")
510 (make-dotted-bar-line grob extent))
511 ((or (string=? glyph "|._.|")
512 (string-contains glyph "S"))
513 (make-segno-bar-line grob glyph extent rounded))
514 ((string=? glyph "'")
515 (make-tick-bar-line grob (interval-end extent) rounded))
516 ((string=? glyph "dashed")
517 (make-dashed-bar-line grob extent hair))
518 ((string=? glyph "kievan")
519 (make-kievan-bar-line grob))
520 (else (make-empty-bar-line grob extent)))))
523 (define-public (ly:bar-line::calc-anchor grob)
524 (let* ((line-thickness (layout-line-thickness grob))
525 (kern (* (ly:grob-property grob 'kern 1) line-thickness))
526 (glyph (ly:grob-property grob 'glyph-name ""))
527 (x-extent (ly:grob-extent grob grob X))
528 (dot-width (+ (interval-length
531 (ly:grob-default-font grob)
537 (if (> (interval-length x-extent) 0)
539 (set! anchor (interval-center x-extent))
540 (cond ((string=? glyph "|:")
541 (set! anchor (+ anchor (/ dot-width -2.0))))
542 ((string=? glyph ":|")
543 (set! anchor (+ anchor (/ dot-width 2.0)))))))
546 (define-public (bar-line::calc-glyph-name grob)
547 (let* ((glyph (ly:grob-property grob 'glyph))
548 (dir (ly:item-break-dir grob))
549 (result (assoc-get glyph bar-glyph-alist))
550 (glyph-name (if (= dir CENTER)
553 (string? (index-cell result dir)))
554 (index-cell result dir)
558 (define-public (bar-line::calc-break-visibility grob)
559 (let* ((glyph (ly:grob-property grob 'glyph))
560 (result (assoc-get glyph bar-glyph-alist)))
563 (vector (string? (car result)) #t (string? (cdr result)))
566 ;; which span bar belongs to a bar line?
568 (define-public span-bar-glyph-alist
588 ;; span bar callbacks
590 (define-public (ly:span-bar::calc-glyph-name grob)
591 (let* ((elts (ly:grob-object grob 'elements))
592 (pos (1- (ly:grob-array-length elts)))
595 (while (and (eq? glyph '())
597 (begin (set! glyph (ly:grob-property (ly:grob-array-ref elts pos)
599 (set! pos (1- pos))))
601 (begin (ly:grob-suicide! grob)
603 (assoc-get glyph span-bar-glyph-alist glyph)))
605 (define-public (ly:span-bar::width grob)
606 (let ((width (cons 0 0)))
608 (if (grob::is-live? grob)
609 (let* ((glyph (ly:grob-property grob 'glyph-name))
610 (stencil (bar-line::compound-bar-line grob glyph (cons -1 1) #f)))
612 (set! width (ly:stencil-extent stencil X))))
615 (define-public (ly:span-bar::before-line-breaking grob)
616 (let ((elts (ly:grob-object grob 'elements)))
618 (if (zero? (ly:grob-array-length elts))
619 (ly:grob-suicide! grob))))
621 ;; The method used in the following routine depends on bar_engraver
622 ;; not being removed from staff context. If bar_engraver is removed,
623 ;; the size of the staff lines is evaluated as 0, which results in a
624 ;; solid span bar line with faulty y coordinate.
626 ;; This routine was originally by Juergen Reuter, but it was a on the
627 ;; bulky side. Rewritten by Han-Wen. Ported from c++ to Scheme by Marc Hohl.
628 (define-public (ly:span-bar::print grob)
629 (let* ((elts-array (ly:grob-object grob 'elements))
630 (refp (ly:grob-common-refpoint-of-array grob elts-array Y))
631 (elts (reverse (sort (ly:grob-array->list elts-array)
632 ly:grob-vertical<?)))
633 ;; Elements must be ordered according to their y coordinates
634 ;; relative to their common axis group parent.
635 ;; Otherwise, the computation goes mad.
636 (glyph (ly:grob-property grob 'glyph-name))
637 (span-bar empty-stencil))
644 ;; we compute the extents of each system and store them
645 ;; in a list; dito for the 'allow-span-bar property.
646 ;; model-bar takes the bar grob, if given.
648 (let* ((ext (bar-line::bar-y-extent bar refp))
649 (staff-symbol (ly:grob-object bar 'staff-symbol)))
651 (if (ly:grob? staff-symbol)
652 (let ((refp-extent (ly:grob-extent staff-symbol refp Y)))
654 (set! ext (interval-union ext refp-extent))
656 (if (> (interval-length ext) 0)
658 (set! extents (append extents (list ext)))
661 (append make-span-bars
662 (list (ly:grob-property bar 'allow-span-bar #t))))))))))
664 ;; if there is no bar grob, we use the callback argument
666 (set! model-bar grob))
667 ;; we discard the first entry in make-span-bars, because its corresponding
668 ;; bar line is the uppermost and therefore not connected to another bar line
669 (if (pair? make-span-bars)
670 (set! make-span-bars (cdr make-span-bars)))
671 ;; the span bar reaches from the lower end of the upper staff
672 ;; to the upper end of the lower staff - when allow-span-bar is #t
673 (reduce (lambda (curr prev)
675 (allow-span-bar (car make-span-bars)))
677 (set! make-span-bars (cdr make-span-bars))
678 (if (> (interval-length prev) 0)
680 (set! l (cons (cdr prev) (car curr)))
681 (if (or (zero? (interval-length l))
682 (not allow-span-bar))
684 ;; there is overlap between the bar lines
685 ;; or 'allow-span-bar = #f.
689 (ly:stencil-add span-bar
690 (bar-line::compound-bar-line
697 (set! span-bar (ly:stencil-translate-axis
699 (- (ly:grob-relative-coordinate grob refp Y))