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 (car line-pos) (car line-pos)))
57 (set! iv (cons (min (car iv) x)
61 (let ((line-count (ly:grob-property grob 'line-count 0)))
63 (set! iv (cons (- 1 line-count)
67 (define (staff-symbol-line-positions grob)
68 (let ((line-pos (ly:grob-property grob 'line-positions '())))
70 (if (not (pair? line-pos))
71 (let* ((line-count (ly:grob-property grob 'line-count 0))
72 (height (- line-count 1.0)))
74 (set! line-pos (map (lambda (x)
79 ;; functions used by external routines
81 (define-public (span-bar::notify-grobs-of-my-existence grob)
82 (let* ((elts (ly:grob-array->list (ly:grob-object grob 'elements)))
83 (sorted-elts (sort elts ly:grob-vertical<?))
84 (last-pos (1- (length sorted-elts)))
88 (ly:grob-set-property!
91 (cons (if (eq? idx last-pos)
100 ;; How should a bar line behave at a break?
101 ;; the following alist has the form
102 ;; ( unbroken-bar-glyph . ( bar-glyph-at-end-of-line . bar-glyph-at-begin-of-line ))
104 (define bar-glyph-alist
105 '((":|:" . (":|" . "|:"))
106 (":|.|:" . (":|" . "|:"))
107 (":|.:" . (":|" . "|:"))
108 ("||:" . ("||" . "|:"))
109 ("dashed" . ("dashed" . '()))
112 ("|:" . ("|" . "|:"))
115 ;; hmm... should we end with a bar line here?
116 (".|" . ("|" . ".|"))
119 (".|." . (".|." . ()))
120 ("|.|" . ("|.|" . ()))
125 ("empty" . (() . ()))
126 ("brace" . (() . "brace"))
127 ("bracket" . (() . "bracket"))
133 (":|S" . (":|" . "S"))
134 (":|S." . (":|S" . ()))
135 ("S|:" . ("S" . "|:"))
136 (".S|:" . ("|" . "S|:"))
137 (":|S|:" . (":|" . "S|:"))
138 (":|S.|:" . (":|S" . "|:"))
141 ("kievan" . ("kievan" . ""))))
143 ;; drawing functions for various bar line types
145 (define (make-empty-bar-line grob extent)
146 (ly:make-stencil "" (cons 0 0) extent))
148 (define (make-simple-bar-line grob width extent rounded)
149 (let ((blot (if rounded
150 (layout-blot-diameter grob)
153 (ly:round-filled-box (cons 0 width)
157 (define (make-tick-bar-line grob height rounded)
158 (let ((half-staff (* 1/2 (ly:staff-symbol-staff-space grob)))
159 (staff-line-thickness (ly:staff-symbol-line-thickness grob))
161 (layout-blot-diameter grob)
164 (ly:round-filled-box (cons 0 staff-line-thickness)
165 (cons (- height half-staff) (+ height half-staff))
168 (define (make-colon-bar-line grob)
169 (let* ((staff-space (ly:staff-symbol-staff-space grob))
170 (line-thickness (ly:staff-symbol-line-thickness grob))
171 (dot (ly:font-get-glyph (ly:grob-default-font grob) "dots.dot"))
172 (dot-y-length (interval-length (ly:stencil-extent dot Y)))
173 (stencil empty-stencil)
174 ;; the two dots of the repeat sign should be centred at the middle of
175 ;; the staff and neither should collide with staff lines
177 ;; the default distance between centre of dots is composed of
178 ;; - a staffline (with width line-thickness)
179 ;; - some space below and above dot
181 ;; and we need to measure it as line positions,
182 ;; i.e. in half staff spaces.
184 ;; space between dot and staffline should be comparable to staffline
185 ;; width so that a relatively common idiom
186 ;; (0.5 staff-size combined with set-layout-staff-size 10) works ok -
187 ;; that makes the choice of 1 staffline too big.
188 ;; 0.1 will be used if to be positioned between staff lines,
189 ;; dot diameter if outside staff.
191 (dist (* 4 dot-y-length)))
193 (if (> staff-space 0)
195 (set! dist (/ dist staff-space))
196 (let ((staff-symbol (get-staff-symbol grob)))
198 (if (ly:grob? staff-symbol)
199 (let ((line-pos (staff-symbol-line-positions staff-symbol)))
204 (interval-center (staff-symbol-line-span
206 ;; fold the staff into two at center and find the
207 ;; first gap big enough to hold a dot and some space
210 (sort (append (map (lambda (lp)
214 (gap-to-find (/ (+ dot-y-length
215 (* 1.2 line-thickness))
219 ;; initialize dist for the case when both dots should
220 ;; be outside the staff
221 (set! dist (+ (* 2 (car (reverse half-staff)))
222 (/ (* 4 dot-y-length) staff-space)))
224 (reduce (lambda (x y) (if (and (> (- x y) gap-to-find)
228 (set! dist (+ x y))))
232 (set! staff-space 1.0))
234 (let* ((stencil empty-stencil)
235 (stencil (ly:stencil-add stencil dot))
236 (stencil (ly:stencil-translate-axis
237 stencil (* dist (/ staff-space 2)) Y))
238 (stencil (ly:stencil-add stencil dot))
239 (stencil (ly:stencil-translate-axis
240 stencil (* (- center (/ dist 2))
241 (/ staff-space 2)) Y)))
244 (define (make-dotted-bar-line grob extent)
245 (let* ((position (round (* (interval-end extent) 2)))
246 (correction (if (even? position) 0.5 0.0))
247 (dot (ly:font-get-glyph (ly:grob-default-font grob) "dots.dot"))
248 (i (round (+ (interval-start extent)
249 (- 0.5 correction))))
250 (e (round (+ (interval-end extent)
251 (- 0.5 correction))))
252 (counting (interval-length (cons i e)))
255 (ly:stencil-translate-axis
256 dot (+ x correction) Y))
257 (iota counting i 1))))
259 (define (add-stencils! stil l)
263 (ly:stencil-add stil (car l))
264 (add-stencils! (ly:stencil-add stil (car l)) (cdr l)))))
266 (add-stencils! empty-stencil stil-list)))
268 (define (make-dashed-bar-line grob extent thickness)
269 (let* ((height (interval-length extent))
270 (staff-symbol (get-staff-symbol grob))
271 (staff-space (ly:staff-symbol-staff-space grob))
272 (line-thickness (layout-line-thickness grob))
273 (dash-size (- 1.0 (ly:grob-property grob 'gap 0.3)))
274 (line-count (staff-symbol-line-count staff-symbol)))
276 (if (< (abs (+ line-thickness
277 (* (1- line-count) staff-space)
280 (let ((blot (layout-blot-diameter grob))
281 (half-space (/ staff-space 2.0))
282 (half-thick (/ line-thickness 2.0))
283 (stencil empty-stencil))
286 (let ((top-y (min (* (+ i dash-size) half-space)
287 (+ (* (1- line-count) half-space)
289 (bot-y (max (* (- i dash-size) half-space)
290 (- 0 (* (1- line-count) half-space)
296 (ly:round-filled-box (cons 0 thickness)
299 (iota line-count (1- line-count) (- 2)))
301 (let* ((dashes (/ height staff-space))
302 (total-dash-size (/ height dashes))
303 (factor (/ (- dash-size thickness) staff-space)))
305 (ly:stencil-translate-axis
306 (ly:make-stencil (list 'dashed-line
308 (* factor total-dash-size)
309 (* (- 1 factor) total-dash-size)
312 (* factor total-dash-size 0.5))
315 (interval-start extent)
318 (define (make-segno-bar-line grob glyph extent rounded)
319 (let* ((line-thickness (layout-line-thickness grob))
320 (kern (* (ly:grob-property grob 'kern 1) line-thickness))
321 (thinkern (* (ly:grob-property grob 'thin-kern 1) line-thickness))
322 (hair (* (ly:grob-property grob 'hair-thickness 1) line-thickness))
323 (fatline (* (ly:grob-property grob 'thick-thickness 1) line-thickness))
324 (thin-stil (make-simple-bar-line grob hair extent rounded))
325 (thick-stil (make-simple-bar-line grob fatline extent rounded))
326 (colon-stil (make-colon-bar-line grob))
327 (segno-stil (ly:stencil-add
328 (ly:stencil-combine-at-edge
329 (ly:stencil-combine-at-edge
330 '() X LEFT thin-stil thinkern)
331 X RIGHT thin-stil thinkern)
332 (ly:font-get-glyph (ly:grob-default-font grob) "scripts.varsegno")))
334 ((string=? glyph "|S") "S")
335 ((string=? glyph "S|") "S")
338 ((or (string=? glyph "S|:")
339 (string=? glyph ".S|:"))
340 (ly:stencil-combine-at-edge
341 (ly:stencil-combine-at-edge
342 (ly:stencil-combine-at-edge
343 thick-stil X RIGHT thin-stil kern)
344 X RIGHT colon-stil kern)
345 X LEFT segno-stil thinkern))
346 ((or (string=? glyph ":|S")
347 (string=? glyph ":|S."))
348 (ly:stencil-combine-at-edge
349 (ly:stencil-combine-at-edge
350 (ly:stencil-combine-at-edge
351 thick-stil X LEFT thin-stil kern)
352 X LEFT colon-stil kern)
353 X RIGHT segno-stil thinkern))
354 ((or (string=? glyph ":|S|:")
355 (string=? glyph ":|S.|:"))
356 (ly:stencil-combine-at-edge
357 (ly:stencil-combine-at-edge
358 (ly:stencil-combine-at-edge
359 (ly:stencil-combine-at-edge
360 (ly:stencil-combine-at-edge
361 (ly:stencil-combine-at-edge
362 thick-stil X LEFT thin-stil kern)
363 X LEFT colon-stil kern)
364 X RIGHT segno-stil thinkern)
365 X RIGHT thick-stil thinkern)
366 X RIGHT thin-stil kern)
367 X RIGHT colon-stil kern))
368 ((string=? glyph "|._.|")
369 (ly:stencil-combine-at-edge
370 (ly:stencil-combine-at-edge
371 (ly:stencil-combine-at-edge
372 thick-stil X LEFT thin-stil kern)
373 X RIGHT thick-stil (+ (interval-length
374 (ly:stencil-extent segno-stil X))
376 X RIGHT thin-stil kern))
381 (define (make-kievan-bar-line grob)
382 (let* ((font (ly:grob-default-font grob))
383 (stencil (stencil-whiteout
384 (ly:font-get-glyph font "scripts.barline.kievan"))))
386 ;; the kievan bar line has mo staff lines underneath,
387 ;; so we whiteout them and move ithe grob to a higher layer
388 (ly:grob-set-property! grob 'layer 1)
391 ;; bar line callbacks
393 (define-public (ly:bar-line::calc-bar-extent grob)
394 (let ((staff-symbol (get-staff-symbol grob))
395 (staff-extent (cons 0 0)))
397 (if (ly:grob? staff-symbol)
398 (let* ((bar-line-color (ly:grob-property grob 'color))
399 (staff-color (ly:grob-property staff-symbol 'color))
400 (staff-line-thickness (ly:staff-symbol-line-thickness grob))
401 (staff-space (ly:staff-symbol-staff-space grob)))
403 (set! staff-extent (ly:staff-symbol::height staff-symbol))
405 (if (zero? staff-space)
406 (set! staff-space 1.0))
408 (if (< (interval-length staff-extent) staff-space)
409 ;; staff is too small (perhaps consists of a single line);
410 ;; extend the bar line to make it visible
412 (interval-widen staff-extent staff-space))
413 ;; Due to rounding problems, bar lines extending to the outermost edges
414 ;; of the staff lines appear wrongly in on-screen display
415 ;; (and, to a lesser extent, in print) - they stick out a pixel.
416 ;; The solution is to extend bar lines only to the middle
417 ;; of the staff line - unless they have different colors,
418 ;; when it would be undesirable.
420 ;; This reduction should not influence whether bar is to be
421 ;; expanded later, so length is not updated on purpose.
422 (if (eq? bar-line-color staff-color)
424 (interval-widen staff-extent
425 (* -1/2 staff-line-thickness)))))))
428 (define (bar-line::bar-y-extent grob refpoint)
429 (let* ((extent (ly:grob-property grob 'bar-extent '(0 . 0)))
430 (rel-y (ly:grob-relative-coordinate grob refpoint Y))
431 (y-extent (coord-translate extent rel-y)))
435 (define-public (ly:bar-line::print grob)
436 (let ((glyph (ly:grob-property grob 'glyph-name))
437 (extent (ly:grob-property grob 'bar-extent '(0 . 0))))
439 (if (and (not (eq? glyph '()))
440 (> (interval-length extent) 0))
441 (bar-line::compound-bar-line grob glyph extent #f)
444 (define-public (bar-line::compound-bar-line grob glyph extent rounded)
445 (let* ((line-thickness (layout-line-thickness grob))
446 (height (interval-length extent))
447 (kern (* (ly:grob-property grob 'kern 1) line-thickness))
448 (thinkern (* (ly:grob-property grob 'thin-kern 1) line-thickness))
449 (hair (* (ly:grob-property grob 'hair-thickness 1) line-thickness))
450 (fatline (* (ly:grob-property grob 'thick-thickness 1) line-thickness))
451 (thin-stil (make-simple-bar-line grob hair extent rounded))
452 (thick-stil (make-simple-bar-line grob fatline extent rounded))
453 (colon-stil (make-colon-bar-line grob))
456 ((string=? glyph "||:") "|:")
457 ;; bar-line::compound-bar-line is called only if
458 ;; height > 0, but just in case ...
459 ((and (string=? glyph ":|")
460 (zero? height)) "|.")
461 ((and (string=? glyph "|:")
462 (zero? height)) ".|")
465 ((string=? glyph "|") thin-stil)
466 ((string=? glyph ".") thick-stil)
467 ((string=? glyph "||")
468 (ly:stencil-combine-at-edge
469 (ly:stencil-combine-at-edge
470 '() X LEFT thin-stil thinkern)
471 X RIGHT thin-stil thinkern))
472 ((string=? glyph "|.")
473 (ly:stencil-combine-at-edge
474 thick-stil X LEFT thin-stil kern))
475 ((string=? glyph ".|")
476 (ly:stencil-combine-at-edge
477 thick-stil X RIGHT thin-stil kern))
478 ((string=? glyph "|:")
479 (ly:stencil-combine-at-edge
480 (ly:stencil-combine-at-edge
481 thick-stil X RIGHT thin-stil kern)
482 X RIGHT colon-stil kern))
483 ((string=? glyph ":|")
484 (ly:stencil-combine-at-edge
485 (ly:stencil-combine-at-edge
486 thick-stil X LEFT thin-stil kern)
487 X LEFT colon-stil kern))
488 ((string=? glyph ":|:")
489 (ly:stencil-combine-at-edge
490 (ly:stencil-combine-at-edge
491 (ly:stencil-combine-at-edge
492 (ly:stencil-combine-at-edge
493 '() X LEFT thick-stil thinkern)
494 X LEFT colon-stil kern)
495 X RIGHT thick-stil kern)
496 X RIGHT colon-stil kern))
497 ((string=? glyph ":|.|:")
498 (ly:stencil-combine-at-edge
499 (ly:stencil-combine-at-edge
500 (ly:stencil-combine-at-edge
501 (ly:stencil-combine-at-edge
502 thick-stil X LEFT thin-stil kern)
503 X LEFT colon-stil kern)
504 X RIGHT thin-stil kern)
505 X RIGHT colon-stil kern))
506 ((string=? glyph ":|.:")
507 (ly:stencil-combine-at-edge
508 (ly:stencil-combine-at-edge
509 (ly:stencil-combine-at-edge
510 thick-stil X LEFT thin-stil kern)
511 X LEFT colon-stil kern)
512 X RIGHT colon-stil kern))
513 ((string=? glyph ".|.")
514 (ly:stencil-combine-at-edge
515 (ly:stencil-combine-at-edge
516 '() X LEFT thick-stil thinkern)
517 X RIGHT thick-stil kern))
518 ((string=? glyph "|.|")
519 (ly:stencil-combine-at-edge
520 (ly:stencil-combine-at-edge
521 thick-stil X LEFT thin-stil kern)
522 X RIGHT thin-stil kern))
523 ((string=? glyph ":")
524 (make-dotted-bar-line grob extent))
525 ((or (string=? glyph "|._.|")
526 (string-contains glyph "S"))
527 (make-segno-bar-line grob glyph extent rounded))
528 ((string=? glyph "'")
529 (make-tick-bar-line grob (interval-end extent) rounded))
530 ((string=? glyph "dashed")
531 (make-dashed-bar-line grob extent hair))
532 ((string=? glyph "kievan")
533 (make-kievan-bar-line grob))
534 (else (make-empty-bar-line grob extent)))))
537 (define-public (ly:bar-line::calc-anchor grob)
538 (let* ((line-thickness (layout-line-thickness grob))
539 (kern (* (ly:grob-property grob 'kern 1) line-thickness))
540 (glyph (ly:grob-property grob 'glyph-name ""))
541 (x-extent (ly:grob-extent grob grob X))
542 (dot-width (+ (interval-length
545 (ly:grob-default-font grob)
551 (if (> (interval-length x-extent) 0)
553 (set! anchor (interval-center x-extent))
554 (cond ((string=? glyph "|:")
555 (set! anchor (+ anchor (/ dot-width -2.0))))
556 ((string=? glyph ":|")
557 (set! anchor (+ anchor (/ dot-width 2.0)))))))
560 (define-public (bar-line::calc-glyph-name grob)
561 (let* ((glyph (ly:grob-property grob 'glyph))
562 (dir (ly:item-break-dir grob))
563 (result (assoc-get glyph bar-glyph-alist))
564 (glyph-name (if (= dir CENTER)
567 (string? (index-cell result dir)))
568 (index-cell result dir)
572 (define-public (bar-line::calc-break-visibility grob)
573 (let* ((glyph (ly:grob-property grob 'glyph))
574 (result (assoc-get glyph bar-glyph-alist)))
577 (vector (string? (car result)) #t (string? (cdr result)))
580 ;; which span bar belongs to a bar line?
582 (define-public span-bar-glyph-alist
602 ;; span bar callbacks
604 (define-public (ly:span-bar::calc-glyph-name grob)
605 (let* ((elts (ly:grob-object grob 'elements))
606 (pos (1- (ly:grob-array-length elts)))
609 (while (and (eq? glyph '())
611 (begin (set! glyph (ly:grob-property (ly:grob-array-ref elts pos)
613 (set! pos (1- pos))))
615 (begin (ly:grob-suicide! grob)
617 (assoc-get glyph span-bar-glyph-alist glyph)))
619 (define-public (ly:span-bar::width grob)
620 (let ((width (cons 0 0)))
622 (if (grob::is-live? grob)
623 (let* ((glyph (ly:grob-property grob 'glyph-name))
624 (stencil (bar-line::compound-bar-line grob glyph (cons -1 1) #f)))
626 (set! width (ly:stencil-extent stencil X))))
629 (define-public (ly:span-bar::before-line-breaking grob)
630 (let ((elts (ly:grob-object grob 'elements)))
632 (if (zero? (ly:grob-array-length elts))
633 (ly:grob-suicide! grob))))
635 ;; The method used in the following routine depends on bar_engraver
636 ;; not being removed from staff context. If bar_engraver is removed,
637 ;; the size of the staff lines is evaluated as 0, which results in a
638 ;; solid span bar line with faulty y coordinate.
640 ;; This routine was originally by Juergen Reuter, but it was a on the
641 ;; bulky side. Rewritten by Han-Wen. Ported from c++ to Scheme by Marc Hohl.
642 (define-public (ly:span-bar::print grob)
643 (let* ((elts-array (ly:grob-object grob 'elements))
644 (refp (ly:grob-common-refpoint-of-array grob elts-array Y))
645 (elts (reverse (sort (ly:grob-array->list elts-array)
646 ly:grob-vertical<?)))
647 ;; Elements must be ordered according to their y coordinates
648 ;; relative to their common axis group parent.
649 ;; Otherwise, the computation goes mad.
650 (glyph (ly:grob-property grob 'glyph-name))
651 (span-bar empty-stencil))
658 ;; we compute the extents of each system and store them
659 ;; in a list; dito for the 'allow-span-bar property.
660 ;; model-bar takes the bar grob, if given.
662 (let* ((ext (bar-line::bar-y-extent bar refp))
663 (staff-symbol (ly:grob-object bar 'staff-symbol)))
665 (if (ly:grob? staff-symbol)
666 (let ((refp-extent (ly:grob-extent staff-symbol refp Y)))
668 (set! ext (interval-union ext refp-extent))
670 (if (> (interval-length ext) 0)
672 (set! extents (append extents (list ext)))
675 (append make-span-bars
676 (list (ly:grob-property bar 'allow-span-bar #t))))))))))
678 ;; if there is no bar grob, we use the callback argument
680 (set! model-bar grob))
681 ;; we discard the first entry in make-span-bars, because its corresponding
682 ;; bar line is the uppermost and therefore not connected to another bar line
683 (if (pair? make-span-bars)
684 (set! make-span-bars (cdr make-span-bars)))
685 ;; the span bar reaches from the lower end of the upper staff
686 ;; to the upper end of the lower staff - when allow-span-bar is #t
687 (reduce (lambda (curr prev)
689 (allow-span-bar (car make-span-bars)))
691 (set! make-span-bars (cdr make-span-bars))
692 (if (> (interval-length prev) 0)
694 (set! l (cons (cdr prev) (car curr)))
695 (if (or (zero? (interval-length l))
696 (not allow-span-bar))
698 ;; there is overlap between the bar lines
699 ;; or 'allow-span-bar = #f.
703 (ly:stencil-add span-bar
704 (bar-line::compound-bar-line
711 (set! span-bar (ly:stencil-translate-axis
713 (- (ly:grob-relative-coordinate grob refp Y))