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 (dot (ly:font-get-glyph (ly:grob-default-font grob) "dots.dot"))
168 (staff-symbol (get-staff-symbol grob))
169 (lines (staff-symbol-line-count staff-symbol))
170 (stencil empty-stencil)
171 (dist (* (if (or (odd? lines)
174 (if (< staff-space 2)
179 (if (zero? staff-space)
180 (set! staff-space 1.0))
182 (let* ((stencil (ly:stencil-add stencil dot))
183 (stencil (ly:stencil-translate-axis
185 (stencil (ly:stencil-add stencil dot))
186 (stencil (ly:stencil-translate-axis
187 stencil (/ dist -2) Y)))
190 (define (make-dotted-bar-line grob extent)
191 (let* ((position (round (* (interval-end extent) 2)))
192 (correction (if (even? position) 0.5 0.0))
193 (dot (ly:font-get-glyph (ly:grob-default-font grob) "dots.dot"))
194 (i (round (+ (interval-start extent)
195 (- 0.5 correction))))
196 (e (round (+ (interval-end extent)
197 (- 0.5 correction))))
198 (counting (interval-length (cons i e)))
201 (ly:stencil-translate-axis
202 dot (+ x correction) Y))
203 (iota counting i 1))))
205 (define (add-stencils! stil l)
209 (ly:stencil-add stil (car l))
210 (add-stencils! (ly:stencil-add stil (car l)) (cdr l)))))
212 (add-stencils! empty-stencil stil-list)))
214 (define (make-dashed-bar-line grob extent thickness)
215 (let* ((height (interval-length extent))
216 (staff-symbol (get-staff-symbol grob))
217 (staff-space (ly:staff-symbol-staff-space grob))
218 (line-thickness (layout-line-thickness grob))
219 (dash-size (- 1.0 (ly:grob-property grob 'gap 0.3)))
220 (line-count (staff-symbol-line-count staff-symbol)))
222 (if (< (abs (+ line-thickness
223 (* (1- line-count) staff-space)
226 (let ((blot (layout-blot-diameter grob))
227 (half-space (/ staff-space 2.0))
228 (half-thick (/ line-thickness 2.0))
229 (stencil empty-stencil))
232 (let ((top-y (min (* (+ i dash-size) half-space)
233 (+ (* (1- line-count) half-space)
235 (bot-y (max (* (- i dash-size) half-space)
236 (- 0 (* (1- line-count) half-space)
242 (ly:round-filled-box (cons 0 thickness)
245 (iota line-count (1- line-count) (- 2)))
247 (let* ((dashes (/ height staff-space))
248 (total-dash-size (/ height dashes))
249 (factor (/ (- dash-size thickness) staff-space)))
251 (ly:stencil-translate-axis
252 (ly:make-stencil (list 'dashed-line
254 (* factor total-dash-size)
255 (* (- 1 factor) total-dash-size)
258 (* factor total-dash-size 0.5))
261 (interval-start extent)
264 (define (make-segno-bar-line grob glyph extent rounded)
265 (let* ((line-thickness (layout-line-thickness grob))
266 (kern (* (ly:grob-property grob 'kern 1) line-thickness))
267 (thinkern (* (ly:grob-property grob 'thin-kern 1) line-thickness))
268 (hair (* (ly:grob-property grob 'hair-thickness 1) line-thickness))
269 (fatline (* (ly:grob-property grob 'thick-thickness 1) line-thickness))
270 (thin-stil (make-simple-bar-line grob hair extent rounded))
271 (thick-stil (make-simple-bar-line grob fatline extent rounded))
272 (colon-stil (make-colon-bar-line grob))
273 (segno-stil (ly:stencil-add
274 (ly:stencil-combine-at-edge
275 (ly:stencil-combine-at-edge
276 '() X LEFT thin-stil thinkern)
277 X RIGHT thin-stil thinkern)
278 (ly:font-get-glyph (ly:grob-default-font grob) "scripts.varsegno")))
280 ((string=? glyph "|S") "S")
281 ((string=? glyph "S|") "S")
284 ((or (string=? glyph "S|:")
285 (string=? glyph ".S|:"))
286 (ly:stencil-combine-at-edge
287 (ly:stencil-combine-at-edge
288 (ly:stencil-combine-at-edge
289 thick-stil X RIGHT thin-stil kern)
290 X RIGHT colon-stil kern)
291 X LEFT segno-stil thinkern))
292 ((or (string=? glyph ":|S")
293 (string=? glyph ":|S."))
294 (ly:stencil-combine-at-edge
295 (ly:stencil-combine-at-edge
296 (ly:stencil-combine-at-edge
297 thick-stil X LEFT thin-stil kern)
298 X LEFT colon-stil kern)
299 X RIGHT segno-stil thinkern))
300 ((or (string=? glyph ":|S|:")
301 (string=? glyph ":|S.|:"))
302 (ly:stencil-combine-at-edge
303 (ly:stencil-combine-at-edge
304 (ly:stencil-combine-at-edge
305 (ly:stencil-combine-at-edge
306 (ly:stencil-combine-at-edge
307 (ly:stencil-combine-at-edge
308 thick-stil X LEFT thin-stil kern)
309 X LEFT colon-stil kern)
310 X RIGHT segno-stil thinkern)
311 X RIGHT thick-stil thinkern)
312 X RIGHT thin-stil kern)
313 X RIGHT colon-stil kern))
314 ((string=? glyph "|._.|")
315 (ly:stencil-combine-at-edge
316 (ly:stencil-combine-at-edge
317 (ly:stencil-combine-at-edge
318 thick-stil X LEFT thin-stil kern)
319 X RIGHT thick-stil (+ (interval-length
320 (ly:stencil-extent segno-stil X))
322 X RIGHT thin-stil kern))
327 (define (make-kievan-bar-line grob)
328 (let* ((font (ly:grob-default-font grob))
329 (stencil (stencil-whiteout
330 (ly:font-get-glyph font "scripts.barline.kievan"))))
332 ;; the kievan bar line has mo staff lines underneath,
333 ;; so we whiteout them and move ithe grob to a higher layer
334 (ly:grob-set-property! grob 'layer 1)
337 ;; bar line callbacks
339 (define-public (ly:bar-line::calc-bar-extent grob)
340 (let ((staff-symbol (get-staff-symbol grob))
341 (staff-extent (cons 0 0)))
343 (if (ly:grob? staff-symbol)
344 (let* ((bar-line-color (ly:grob-property grob 'color))
345 (staff-color (ly:grob-property staff-symbol 'color))
346 (radius (ly:staff-symbol-staff-radius grob))
347 (staff-line-thickness (ly:staff-symbol-line-thickness grob)))
349 ;; Due to rounding problems, bar lines extending to the outermost edges
350 ;; of the staff lines appear wrongly in on-screen display
351 ;; (and, to a lesser extent, in print) - they stick out a pixel.
352 ;; The solution is to extend bar lines only to the middle
353 ;; of the staff line - unless they have different colors,
354 ;;when it would be undesirable.
355 (set! staff-extent (ly:staff-symbol::height staff-symbol))
356 (if (and (eq? bar-line-color staff-color)
359 (interval-scale staff-extent
360 (- 1 (* 1/2 (/ staff-line-thickness radius))))))))
363 (define (bar-line::bar-y-extent grob refpoint)
364 (let* ((extent (ly:grob-property grob 'bar-extent '(0 . 0)))
365 (rel-y (ly:grob-relative-coordinate grob refpoint Y))
366 (y-extent (coord-translate extent rel-y)))
370 (define-public (ly:bar-line::print grob)
371 (let ((glyph (ly:grob-property grob 'glyph-name))
372 (extent (ly:grob-property grob 'bar-extent '(0 . 0))))
374 (if (and (not (eq? glyph '()))
375 (> (interval-length extent) 0))
376 (bar-line::compound-bar-line grob glyph extent #f)
379 (define-public (bar-line::compound-bar-line grob glyph extent rounded)
380 (let* ((line-thickness (layout-line-thickness grob))
381 (height (interval-length extent))
382 (kern (* (ly:grob-property grob 'kern 1) line-thickness))
383 (thinkern (* (ly:grob-property grob 'thin-kern 1) line-thickness))
384 (hair (* (ly:grob-property grob 'hair-thickness 1) line-thickness))
385 (fatline (* (ly:grob-property grob 'thick-thickness 1) line-thickness))
386 (thin-stil (make-simple-bar-line grob hair extent rounded))
387 (thick-stil (make-simple-bar-line grob fatline extent rounded))
388 (colon-stil (make-colon-bar-line grob))
391 ((string=? glyph "||:") "|:")
392 ;; bar-line::compound-bar-line is called only if
393 ;; height > 0, but just in case ...
394 ((and (string=? glyph ":|")
395 (zero? height)) "|.")
396 ((and (string=? glyph "|:")
397 (zero? height)) ".|")
400 ((string=? glyph "|") thin-stil)
401 ((string=? glyph ".") thick-stil)
402 ((string=? glyph "||")
403 (ly:stencil-combine-at-edge
404 (ly:stencil-combine-at-edge
405 '() X LEFT thin-stil thinkern)
406 X RIGHT thin-stil thinkern))
407 ((string=? glyph "|.")
408 (ly:stencil-combine-at-edge
409 thick-stil X LEFT thin-stil kern))
410 ((string=? glyph ".|")
411 (ly:stencil-combine-at-edge
412 thick-stil X RIGHT thin-stil kern))
413 ((string=? glyph "|:")
414 (ly:stencil-combine-at-edge
415 (ly:stencil-combine-at-edge
416 thick-stil X RIGHT thin-stil kern)
417 X RIGHT colon-stil kern))
418 ((string=? glyph ":|")
419 (ly:stencil-combine-at-edge
420 (ly:stencil-combine-at-edge
421 thick-stil X LEFT thin-stil kern)
422 X LEFT colon-stil kern))
423 ((string=? glyph ":|:")
424 (ly:stencil-combine-at-edge
425 (ly:stencil-combine-at-edge
426 (ly:stencil-combine-at-edge
427 (ly:stencil-combine-at-edge
428 '() X LEFT thick-stil thinkern)
429 X LEFT colon-stil kern)
430 X RIGHT thick-stil kern)
431 X RIGHT colon-stil kern))
432 ((string=? glyph ":|.|:")
433 (ly:stencil-combine-at-edge
434 (ly:stencil-combine-at-edge
435 (ly:stencil-combine-at-edge
436 (ly:stencil-combine-at-edge
437 thick-stil X LEFT thin-stil kern)
438 X LEFT colon-stil kern)
439 X RIGHT thin-stil kern)
440 X RIGHT colon-stil kern))
441 ((string=? glyph ":|.:")
442 (ly:stencil-combine-at-edge
443 (ly:stencil-combine-at-edge
444 (ly:stencil-combine-at-edge
445 thick-stil X LEFT thin-stil kern)
446 X LEFT colon-stil kern)
447 X RIGHT colon-stil kern))
448 ((string=? glyph ".|.")
449 (ly:stencil-combine-at-edge
450 (ly:stencil-combine-at-edge
451 '() X LEFT thick-stil thinkern)
452 X RIGHT thick-stil kern))
453 ((string=? glyph "|.|")
454 (ly:stencil-combine-at-edge
455 (ly:stencil-combine-at-edge
456 thick-stil X LEFT thin-stil kern)
457 X RIGHT thin-stil kern))
458 ((string=? glyph ":")
459 (make-dotted-bar-line grob extent))
460 ((or (string=? glyph "|._.|")
461 (string-contains glyph "S"))
462 (make-segno-bar-line grob glyph extent rounded))
463 ((string=? glyph "'")
464 (make-tick-bar-line grob (interval-end extent) rounded))
465 ((string=? glyph "dashed")
466 (make-dashed-bar-line grob extent hair))
467 ((string=? glyph "kievan")
468 (make-kievan-bar-line grob))
469 (else (make-empty-bar-line grob extent)))))
472 (define-public (ly:bar-line::calc-anchor grob)
473 (let* ((line-thickness (layout-line-thickness grob))
474 (kern (* (ly:grob-property grob 'kern 1) line-thickness))
475 (glyph (ly:grob-property grob 'glyph-name ""))
476 (x-extent (ly:grob-extent grob grob X))
477 (dot-width (+ (interval-length
480 (ly:grob-default-font grob)
486 (if (> (interval-length x-extent) 0)
488 (set! anchor (interval-center x-extent))
489 (cond ((string=? glyph "|:")
490 (set! anchor (+ anchor (/ dot-width -2.0))))
491 ((string=? glyph ":|")
492 (set! anchor (+ anchor (/ dot-width 2.0)))))))
495 (define-public (bar-line::calc-glyph-name grob)
496 (let* ((glyph (ly:grob-property grob 'glyph))
497 (dir (ly:item-break-dir grob))
498 (result (assoc-get glyph bar-glyph-alist))
499 (glyph-name (if (= dir CENTER)
502 (string? (index-cell result dir)))
503 (index-cell result dir)
507 (define-public (bar-line::calc-break-visibility grob)
508 (let* ((glyph (ly:grob-property grob 'glyph))
509 (result (assoc-get glyph bar-glyph-alist)))
512 (vector (string? (car result)) #t (string? (cdr result)))
515 ;; which span bar belongs to a bar line?
517 (define-public span-bar-glyph-alist
537 ;; span bar callbacks
539 (define-public (ly:span-bar::calc-glyph-name grob)
540 (let* ((elts (ly:grob-object grob 'elements))
541 (pos (1- (ly:grob-array-length elts)))
544 (while (and (eq? glyph '())
546 (begin (set! glyph (ly:grob-property (ly:grob-array-ref elts pos)
548 (set! pos (1- pos))))
550 (begin (ly:grob-suicide! grob)
552 (assoc-get glyph span-bar-glyph-alist glyph)))
554 (define-public (ly:span-bar::width grob)
555 (let ((width (cons 0 0)))
557 (if (grob::is-live? grob)
558 (let* ((glyph (ly:grob-property grob 'glyph-name))
559 (stencil (bar-line::compound-bar-line grob glyph (cons -1 1) #f)))
561 (set! width (ly:stencil-extent stencil X))))
564 (define-public (ly:span-bar::before-line-breaking grob)
565 (let ((elts (ly:grob-object grob 'elements)))
567 (if (zero? (ly:grob-array-length elts))
568 (ly:grob-suicide! grob))))
570 ;; The method used in the following routine depends on bar_engraver
571 ;; not being removed from staff context. If bar_engraver is removed,
572 ;; the size of the staff lines is evaluated as 0, which results in a
573 ;; solid span bar line with faulty y coordinate.
575 ;; This routine was originally by Juergen Reuter, but it was a on the
576 ;; bulky side. Rewritten by Han-Wen. Ported from c++ to Scheme by Marc Hohl.
577 (define-public (ly:span-bar::print grob)
578 (let* ((elts-array (ly:grob-object grob 'elements))
579 (refp (ly:grob-common-refpoint-of-array grob elts-array Y))
580 (elts (reverse (sort (ly:grob-array->list elts-array)
581 ly:grob-vertical<?)))
582 ;; Elements must be ordered according to their y coordinates
583 ;; relative to their common axis group parent.
584 ;; Otherwise, the computation goes mad.
585 (glyph (ly:grob-property grob 'glyph-name))
586 (span-bar empty-stencil))
593 ;; we compute the extents of each system and store them
594 ;; in a list; dito for the 'allow-span-bar property.
595 ;; model-bar takes the bar grob, if given.
597 (let* ((ext (bar-line::bar-y-extent bar refp))
598 (staff-symbol (ly:grob-object bar 'staff-symbol)))
600 (if (ly:grob? staff-symbol)
601 (let ((refp-extent (ly:grob-extent staff-symbol refp Y)))
603 (set! ext (interval-union ext refp-extent))
605 (if (> (interval-length ext) 0)
607 (set! extents (append extents (list ext)))
610 (append make-span-bars
611 (list (ly:grob-property bar 'allow-span-bar #t))))))))))
613 ;; if there is no bar grob, we use the callback argument
615 (set! model-bar grob))
616 ;; we discard the first entry in make-span-bars, because its corresponding
617 ;; bar line is the uppermost and therefore not connected to another bar line
618 (if (pair? make-span-bars)
619 (set! make-span-bars (cdr make-span-bars)))
620 ;; the span bar reaches from the lower end of the upper staff
621 ;; to the upper end of the lower staff - when allow-span-bar is #t
622 (reduce (lambda (curr prev)
624 (allow-span-bar (car make-span-bars)))
626 (set! make-span-bars (cdr make-span-bars))
627 (if (> (interval-length prev) 0)
629 (set! l (cons (cdr prev) (car curr)))
630 (if (or (zero? (interval-length l))
631 (not allow-span-bar))
633 ;; there is overlap between the bar lines
634 ;; or 'allow-span-bar = #f.
638 (ly:stencil-add span-bar
639 (bar-line::compound-bar-line
646 (set! span-bar (ly:stencil-translate-axis
648 (- (ly:grob-relative-coordinate grob refp Y))