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
175 ;; middle of the staff and neither should collide with staff
177 ;; the required space is measured in line positions,
178 ;; i.e. in half staff spaces.
180 ;; dots are to fall into distict spaces, except when there's
181 ;; only one space (and it's big enough to hold two dots and
182 ;; some space between them)
184 ;; choose defaults working without any staff
186 (dist (* 4 dot-y-length)))
188 (if (> staff-space 0)
190 (set! dist (/ dist staff-space))
191 (let ((staff-symbol (get-staff-symbol grob)))
193 (if (ly:grob? staff-symbol)
194 (let ((line-pos (staff-symbol-line-positions staff-symbol)))
199 (interval-center (staff-symbol-line-span
201 ;; fold the staff into two at center
203 (sort (map (lambda (lp) (abs (- lp center)))
205 (gap-to-find (/ (+ dot-y-length line-thickness)
207 (first (car folded-staff))
210 ;; find the first space big enough
211 ;; to hold a dot and a staff line
212 ;; (a space in the folded staff may be
213 ;; narrower but can't be wider than the
214 ;; corresponding original spaces)
215 (reduce (lambda (x y) (if (and (> (- x y) gap-to-find)
219 (set! dist (+ x y))))
225 (set! dist (if (< gap-to-find first)
226 ;; there's a central space big
227 ;; enough to hold both dots
230 ;; dots should go outside
232 (reverse folded-staff)))
233 (/ (* 4 dot-y-length)
234 staff-space))))))))))))
235 (set! staff-space 1.0))
237 (let* ((stencil empty-stencil)
238 (stencil (ly:stencil-add stencil dot))
239 (stencil (ly:stencil-translate-axis
240 stencil (* dist (/ staff-space 2)) Y))
241 (stencil (ly:stencil-add stencil dot))
242 (stencil (ly:stencil-translate-axis
243 stencil (* (- center (/ dist 2))
244 (/ staff-space 2)) Y)))
247 (define (make-dotted-bar-line grob extent)
248 (let* ((position (round (* (interval-end extent) 2)))
249 (correction (if (even? position) 0.5 0.0))
250 (dot (ly:font-get-glyph (ly:grob-default-font grob) "dots.dot"))
251 (i (round (+ (interval-start extent)
252 (- 0.5 correction))))
253 (e (round (+ (interval-end extent)
254 (- 0.5 correction))))
255 (counting (interval-length (cons i e)))
258 (ly:stencil-translate-axis
259 dot (+ x correction) Y))
260 (iota counting i 1))))
262 (define (add-stencils! stil l)
266 (ly:stencil-add stil (car l))
267 (add-stencils! (ly:stencil-add stil (car l)) (cdr l)))))
269 (add-stencils! empty-stencil stil-list)))
271 (define (make-dashed-bar-line grob extent thickness)
272 (let* ((height (interval-length extent))
273 (staff-symbol (get-staff-symbol grob))
274 (staff-space (ly:staff-symbol-staff-space grob))
275 (line-thickness (layout-line-thickness grob))
276 (dash-size (- 1.0 (ly:grob-property grob 'gap 0.3)))
277 (line-count (staff-symbol-line-count staff-symbol)))
279 (if (< (abs (+ line-thickness
280 (* (1- line-count) staff-space)
283 (let ((blot (layout-blot-diameter grob))
284 (half-space (/ staff-space 2.0))
285 (half-thick (/ line-thickness 2.0))
286 (stencil empty-stencil))
289 (let ((top-y (min (* (+ i dash-size) half-space)
290 (+ (* (1- line-count) half-space)
292 (bot-y (max (* (- i dash-size) half-space)
293 (- 0 (* (1- line-count) half-space)
299 (ly:round-filled-box (cons 0 thickness)
302 (iota line-count (1- line-count) (- 2)))
304 (let* ((dashes (/ height staff-space))
305 (total-dash-size (/ height dashes))
306 (factor (/ (- dash-size thickness) staff-space)))
308 (ly:stencil-translate-axis
309 (ly:make-stencil (list 'dashed-line
311 (* factor total-dash-size)
312 (* (- 1 factor) total-dash-size)
315 (* factor total-dash-size 0.5))
318 (interval-start extent)
321 (define (make-segno-bar-line grob glyph extent rounded)
322 (let* ((line-thickness (layout-line-thickness grob))
323 (kern (* (ly:grob-property grob 'kern 1) line-thickness))
324 (thinkern (* (ly:grob-property grob 'thin-kern 1) line-thickness))
325 (hair (* (ly:grob-property grob 'hair-thickness 1) line-thickness))
326 (fatline (* (ly:grob-property grob 'thick-thickness 1) line-thickness))
327 (thin-stil (make-simple-bar-line grob hair extent rounded))
328 (thick-stil (make-simple-bar-line grob fatline extent rounded))
329 (colon-stil (make-colon-bar-line grob))
330 (segno-stil (ly:stencil-add
331 (ly:stencil-combine-at-edge
332 (ly:stencil-combine-at-edge
333 '() X LEFT thin-stil thinkern)
334 X RIGHT thin-stil thinkern)
335 (ly:font-get-glyph (ly:grob-default-font grob) "scripts.varsegno")))
337 ((string=? glyph "|S") "S")
338 ((string=? glyph "S|") "S")
341 ((or (string=? glyph "S|:")
342 (string=? glyph ".S|:"))
343 (ly:stencil-combine-at-edge
344 (ly:stencil-combine-at-edge
345 (ly:stencil-combine-at-edge
346 thick-stil X RIGHT thin-stil kern)
347 X RIGHT colon-stil kern)
348 X LEFT segno-stil thinkern))
349 ((or (string=? glyph ":|S")
350 (string=? glyph ":|S."))
351 (ly:stencil-combine-at-edge
352 (ly:stencil-combine-at-edge
353 (ly:stencil-combine-at-edge
354 thick-stil X LEFT thin-stil kern)
355 X LEFT colon-stil kern)
356 X RIGHT segno-stil thinkern))
357 ((or (string=? glyph ":|S|:")
358 (string=? glyph ":|S.|:"))
359 (ly:stencil-combine-at-edge
360 (ly:stencil-combine-at-edge
361 (ly:stencil-combine-at-edge
362 (ly:stencil-combine-at-edge
363 (ly:stencil-combine-at-edge
364 (ly:stencil-combine-at-edge
365 thick-stil X LEFT thin-stil kern)
366 X LEFT colon-stil kern)
367 X RIGHT segno-stil thinkern)
368 X RIGHT thick-stil thinkern)
369 X RIGHT thin-stil kern)
370 X RIGHT colon-stil kern))
371 ((string=? glyph "|._.|")
372 (ly:stencil-combine-at-edge
373 (ly:stencil-combine-at-edge
374 (ly:stencil-combine-at-edge
375 thick-stil X LEFT thin-stil kern)
376 X RIGHT thick-stil (+ (interval-length
377 (ly:stencil-extent segno-stil X))
379 X RIGHT thin-stil kern))
384 (define (make-kievan-bar-line grob)
385 (let* ((font (ly:grob-default-font grob))
386 (stencil (stencil-whiteout
387 (ly:font-get-glyph font "scripts.barline.kievan"))))
389 ;; the kievan bar line has mo staff lines underneath,
390 ;; so we whiteout them and move ithe grob to a higher layer
391 (ly:grob-set-property! grob 'layer 1)
394 ;; bar line callbacks
396 (define-public (ly:bar-line::calc-bar-extent grob)
397 (let ((staff-symbol (get-staff-symbol grob))
398 (staff-extent (cons 0 0)))
400 (if (ly:grob? staff-symbol)
401 (let* ((bar-line-color (ly:grob-property grob 'color))
402 (staff-color (ly:grob-property staff-symbol 'color))
403 (staff-line-thickness (ly:staff-symbol-line-thickness grob))
404 (staff-space (ly:staff-symbol-staff-space grob)))
406 (set! staff-extent (ly:staff-symbol::height staff-symbol))
408 (if (zero? staff-space)
409 (set! staff-space 1.0))
411 (if (< (interval-length staff-extent) staff-space)
412 ;; staff is too small (perhaps consists of a single line);
413 ;; extend the bar line to make it visible
415 (interval-widen staff-extent staff-space))
416 ;; Due to rounding problems, bar lines extending to the outermost edges
417 ;; of the staff lines appear wrongly in on-screen display
418 ;; (and, to a lesser extent, in print) - they stick out a pixel.
419 ;; The solution is to extend bar lines only to the middle
420 ;; of the staff line - unless they have different colors,
421 ;; when it would be undesirable.
423 ;; This reduction should not influence whether bar is to be
424 ;; expanded later, so length is not updated on purpose.
425 (if (eq? bar-line-color staff-color)
427 (interval-widen staff-extent
428 (* -1/2 staff-line-thickness)))))))
431 (define (bar-line::bar-y-extent grob refpoint)
432 (let* ((extent (ly:grob-property grob 'bar-extent '(0 . 0)))
433 (rel-y (ly:grob-relative-coordinate grob refpoint Y))
434 (y-extent (coord-translate extent rel-y)))
438 (define-public (ly:bar-line::print grob)
439 (let ((glyph (ly:grob-property grob 'glyph-name))
440 (extent (ly:grob-property grob 'bar-extent '(0 . 0))))
442 (if (and (not (eq? glyph '()))
443 (> (interval-length extent) 0))
444 (bar-line::compound-bar-line grob glyph extent #f)
447 (define-public (bar-line::compound-bar-line grob glyph extent rounded)
448 (let* ((line-thickness (layout-line-thickness grob))
449 (height (interval-length extent))
450 (kern (* (ly:grob-property grob 'kern 1) line-thickness))
451 (thinkern (* (ly:grob-property grob 'thin-kern 1) line-thickness))
452 (hair (* (ly:grob-property grob 'hair-thickness 1) line-thickness))
453 (fatline (* (ly:grob-property grob 'thick-thickness 1) line-thickness))
454 (thin-stil (make-simple-bar-line grob hair extent rounded))
455 (thick-stil (make-simple-bar-line grob fatline extent rounded))
456 (colon-stil (make-colon-bar-line grob))
459 ((string=? glyph "||:") "|:")
460 ;; bar-line::compound-bar-line is called only if
461 ;; height > 0, but just in case ...
462 ((and (string=? glyph ":|")
463 (zero? height)) "|.")
464 ((and (string=? glyph "|:")
465 (zero? height)) ".|")
468 ((string=? glyph "|") thin-stil)
469 ((string=? glyph ".") thick-stil)
470 ((string=? glyph "||")
471 (ly:stencil-combine-at-edge
472 (ly:stencil-combine-at-edge
473 '() X LEFT thin-stil thinkern)
474 X RIGHT thin-stil thinkern))
475 ((string=? glyph "|.")
476 (ly:stencil-combine-at-edge
477 thick-stil X LEFT thin-stil kern))
478 ((string=? glyph ".|")
479 (ly:stencil-combine-at-edge
480 thick-stil X RIGHT thin-stil kern))
481 ((string=? glyph "|:")
482 (ly:stencil-combine-at-edge
483 (ly:stencil-combine-at-edge
484 thick-stil X RIGHT thin-stil kern)
485 X RIGHT colon-stil kern))
486 ((string=? glyph ":|")
487 (ly:stencil-combine-at-edge
488 (ly:stencil-combine-at-edge
489 thick-stil X LEFT thin-stil kern)
490 X LEFT colon-stil kern))
491 ((string=? glyph ":|:")
492 (ly:stencil-combine-at-edge
493 (ly:stencil-combine-at-edge
494 (ly:stencil-combine-at-edge
495 (ly:stencil-combine-at-edge
496 '() X LEFT thick-stil thinkern)
497 X LEFT colon-stil kern)
498 X RIGHT thick-stil kern)
499 X RIGHT colon-stil kern))
500 ((string=? glyph ":|.|:")
501 (ly:stencil-combine-at-edge
502 (ly:stencil-combine-at-edge
503 (ly:stencil-combine-at-edge
504 (ly:stencil-combine-at-edge
505 thick-stil X LEFT thin-stil kern)
506 X LEFT colon-stil kern)
507 X RIGHT thin-stil kern)
508 X RIGHT colon-stil kern))
509 ((string=? glyph ":|.:")
510 (ly:stencil-combine-at-edge
511 (ly:stencil-combine-at-edge
512 (ly:stencil-combine-at-edge
513 thick-stil X LEFT thin-stil kern)
514 X LEFT colon-stil kern)
515 X RIGHT colon-stil kern))
516 ((string=? glyph ".|.")
517 (ly:stencil-combine-at-edge
518 (ly:stencil-combine-at-edge
519 '() X LEFT thick-stil thinkern)
520 X RIGHT thick-stil kern))
521 ((string=? glyph "|.|")
522 (ly:stencil-combine-at-edge
523 (ly:stencil-combine-at-edge
524 thick-stil X LEFT thin-stil kern)
525 X RIGHT thin-stil kern))
526 ((string=? glyph ":")
527 (make-dotted-bar-line grob extent))
528 ((or (string=? glyph "|._.|")
529 (string-contains glyph "S"))
530 (make-segno-bar-line grob glyph extent rounded))
531 ((string=? glyph "'")
532 (make-tick-bar-line grob (interval-end extent) rounded))
533 ((string=? glyph "dashed")
534 (make-dashed-bar-line grob extent hair))
535 ((string=? glyph "kievan")
536 (make-kievan-bar-line grob))
537 (else (make-empty-bar-line grob extent)))))
540 (define-public (ly:bar-line::calc-anchor grob)
541 (let* ((line-thickness (layout-line-thickness grob))
542 (kern (* (ly:grob-property grob 'kern 1) line-thickness))
543 (glyph (ly:grob-property grob 'glyph-name ""))
544 (x-extent (ly:grob-extent grob grob X))
545 (dot-width (+ (interval-length
548 (ly:grob-default-font grob)
554 (if (> (interval-length x-extent) 0)
556 (set! anchor (interval-center x-extent))
557 (cond ((string=? glyph "|:")
558 (set! anchor (+ anchor (/ dot-width -2.0))))
559 ((string=? glyph ":|")
560 (set! anchor (+ anchor (/ dot-width 2.0)))))))
563 (define-public (bar-line::calc-glyph-name grob)
564 (let* ((glyph (ly:grob-property grob 'glyph))
565 (dir (ly:item-break-dir grob))
566 (result (assoc-get glyph bar-glyph-alist))
567 (glyph-name (if (= dir CENTER)
570 (string? (index-cell result dir)))
571 (index-cell result dir)
575 (define-public (bar-line::calc-break-visibility grob)
576 (let* ((glyph (ly:grob-property grob 'glyph))
577 (result (assoc-get glyph bar-glyph-alist)))
580 (vector (string? (car result)) #t (string? (cdr result)))
583 ;; which span bar belongs to a bar line?
585 (define-public span-bar-glyph-alist
605 ;; span bar callbacks
607 (define-public (ly:span-bar::calc-glyph-name grob)
608 (let* ((elts (ly:grob-object grob 'elements))
609 (pos (1- (ly:grob-array-length elts)))
612 (while (and (eq? glyph '())
614 (begin (set! glyph (ly:grob-property (ly:grob-array-ref elts pos)
616 (set! pos (1- pos))))
618 (begin (ly:grob-suicide! grob)
620 (assoc-get glyph span-bar-glyph-alist glyph)))
622 (define-public (ly:span-bar::width grob)
623 (let ((width (cons 0 0)))
625 (if (grob::is-live? grob)
626 (let* ((glyph (ly:grob-property grob 'glyph-name))
627 (stencil (bar-line::compound-bar-line grob glyph (cons -1 1) #f)))
629 (set! width (ly:stencil-extent stencil X))))
632 (define-public (ly:span-bar::before-line-breaking grob)
633 (let ((elts (ly:grob-object grob 'elements)))
635 (if (zero? (ly:grob-array-length elts))
636 (ly:grob-suicide! grob))))
638 ;; The method used in the following routine depends on bar_engraver
639 ;; not being removed from staff context. If bar_engraver is removed,
640 ;; the size of the staff lines is evaluated as 0, which results in a
641 ;; solid span bar line with faulty y coordinate.
643 ;; This routine was originally by Juergen Reuter, but it was a on the
644 ;; bulky side. Rewritten by Han-Wen. Ported from c++ to Scheme by Marc Hohl.
645 (define-public (ly:span-bar::print grob)
646 (let* ((elts-array (ly:grob-object grob 'elements))
647 (refp (ly:grob-common-refpoint-of-array grob elts-array Y))
648 (elts (reverse (sort (ly:grob-array->list elts-array)
649 ly:grob-vertical<?)))
650 ;; Elements must be ordered according to their y coordinates
651 ;; relative to their common axis group parent.
652 ;; Otherwise, the computation goes mad.
653 (glyph (ly:grob-property grob 'glyph-name))
654 (span-bar empty-stencil))
661 ;; we compute the extents of each system and store them
662 ;; in a list; dito for the 'allow-span-bar property.
663 ;; model-bar takes the bar grob, if given.
665 (let* ((ext (bar-line::bar-y-extent bar refp))
666 (staff-symbol (ly:grob-object bar 'staff-symbol)))
668 (if (ly:grob? staff-symbol)
669 (let ((refp-extent (ly:grob-extent staff-symbol refp Y)))
671 (set! ext (interval-union ext refp-extent))
673 (if (> (interval-length ext) 0)
675 (set! extents (append extents (list ext)))
678 (append make-span-bars
679 (list (ly:grob-property bar 'allow-span-bar #t))))))))))
681 ;; if there is no bar grob, we use the callback argument
683 (set! model-bar grob))
684 ;; we discard the first entry in make-span-bars, because its corresponding
685 ;; bar line is the uppermost and therefore not connected to another bar line
686 (if (pair? make-span-bars)
687 (set! make-span-bars (cdr make-span-bars)))
688 ;; the span bar reaches from the lower end of the upper staff
689 ;; to the upper end of the lower staff - when allow-span-bar is #t
690 (reduce (lambda (curr prev)
692 (allow-span-bar (car make-span-bars)))
694 (set! make-span-bars (cdr make-span-bars))
695 (if (> (interval-length prev) 0)
697 (set! l (cons (cdr prev) (car curr)))
698 (if (or (zero? (interval-length l))
699 (not allow-span-bar))
701 ;; there is overlap between the bar lines
702 ;; or 'allow-span-bar = #f.
706 (ly:stencil-add span-bar
707 (bar-line::compound-bar-line
714 (set! span-bar (ly:stencil-translate-axis
716 (- (ly:grob-relative-coordinate grob refp Y))