]> git.donarmstrong.com Git - lilypond.git/blob - scm/bar-line.scm
Merge branch 'translation' into staging
[lilypond.git] / scm / bar-line.scm
1 ;;;; This file is part of LilyPond, the GNU music typesetter.
2 ;;;;
3 ;;;; Copyright (C) 2009--2012 Marc Hohl <marc@hohlart.de>
4 ;;;;
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.
9 ;;;;
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.
14 ;;;;
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/>.
17
18
19
20 ;; TODO:
21 ;; (1) Dashed bar lines may stick out above and below the staff lines
22 ;;
23 ;; (2) Dashed and dotted lines look ugly in combination with span bars
24 ;;
25 ;; (This was the case in the c++-version of (span) bar stuff)
26
27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28 ;; helper functions for staff and layout properties
29
30 (define (calc-blot thickness extent grob)
31   "Calculate the blot diameter by taking @code{'rounded}
32 and the dimensions of the extent into account."
33   (let* ((rounded (ly:grob-property grob 'rounded #f))
34          (blot (if rounded
35                    (let ((blot-diameter (layout-blot-diameter grob))
36                          (height (interval-length extent)))
37
38                         (cond ((< thickness blot-diameter) thickness)
39                               ((< height blot-diameter) height)
40                               (else blot-diameter)))
41                    0)))
42
43         blot))
44
45 (define (get-span-glyph bar-glyph)
46   "Get the corresponding span glyph from the @code{span-glyph-bar-alist}.
47 Pad the string with @code{annotation-char}s to the length of the
48 @var{bar-glyph} string."
49   (let ((span-glyph (assoc-get bar-glyph span-bar-glyph-alist bar-glyph)))
50
51        (if (string? span-glyph)
52            (set! span-glyph (string-pad-right
53                           span-glyph
54                           (string-length bar-glyph)
55                           replacement-char)))
56        span-glyph))
57
58 (define (get-staff-symbol grob)
59   "Return the staff symbol corresponding to Grob @var{grob}."
60   (if (grob::has-interface grob 'staff-symbol-interface)
61       grob
62       (ly:grob-object grob 'staff-symbol)))
63
64 (define (layout-blot-diameter grob)
65   "Get the blot diameter of the @var{grob}'s corresponding layout."
66   (let* ((layout (ly:grob-layout grob))
67          (blot-diameter (ly:output-def-lookup layout 'blot-diameter)))
68
69         blot-diameter))
70
71 (define (layout-line-thickness grob)
72   "Get the line thickness of the @var{grob}'s corresponding layout."
73   (let* ((layout (ly:grob-layout grob))
74          (line-thickness (ly:output-def-lookup layout 'line-thickness)))
75
76         line-thickness))
77
78 (define (staff-symbol-line-count staff)
79   "Get or compute the number of lines of staff @var{staff}."
80   (let ((line-count 0))
81
82        (if (ly:grob? staff)
83            (let ((line-pos (ly:grob-property staff 'line-positions '())))
84
85                 (set! line-count (if (pair? line-pos)
86                                      (length line-pos)
87                                      (ly:grob-property staff 'line-count 0)))))
88
89          line-count))
90
91 (define (staff-symbol-line-span grob)
92   (let ((line-pos (ly:grob-property grob 'line-positions '()))
93         (iv (cons 0.0 0.0)))
94
95        (if (pair? line-pos)
96            (begin
97              (set! iv (cons (car line-pos) (car line-pos)))
98              (map (lambda (x)
99                     (set! iv (cons (min (car iv) x)
100                                    (max (cdr iv) x))))
101                   (cdr line-pos)))
102
103            (let ((line-count (ly:grob-property grob 'line-count 0)))
104
105                 (set! iv (cons (- 1 line-count)
106                                (- line-count 1)))))
107        iv))
108
109 (define (staff-symbol-line-positions grob)
110   "Get or compute the @code{'line-positions} list from @var{grob}."
111   (let ((line-pos (ly:grob-property grob 'line-positions '())))
112
113        (if (not (pair? line-pos))
114            (let* ((line-count (ly:grob-property grob 'line-count 0))
115                   (height (- line-count 1.0)))
116
117                  (set! line-pos (map (lambda (x)
118                                              (- height (* x 2)))
119                                      (iota line-count)))))
120        line-pos))
121
122 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
123 ;; internal helper functions
124
125 (define annotation-char #\-)
126 (define replacement-char #\ )
127
128 (define dummy-extent (cons -1 1))
129
130
131 (define (glyph->stencil glyph grob extent)
132   "Return a stencil computed by the procedure associated with
133 glyph @var{glyph}. The arguments @var{grob} and @var{extent} are
134 mandatory to the procedures stored in @code{bar-glyph-print-procedures}."
135   (let ((proc (assoc-get glyph bar-glyph-print-procedures))
136         (stencil empty-stencil))
137
138        (if (procedure? proc)
139            (set! stencil (proc grob extent))
140            (ly:warning (_ "Bar glyph ~a not known. Ignoring.") glyph))
141        stencil))
142
143 (define (string->string-list str)
144   "Convert a string into a list of strings with length 1.
145 @code{"aBc"} will be converted to @code{("a" "B" "c")}.
146 An empty string will be converted to a list containing @code{""}."
147   (if (and (string? str)
148            (not (zero? (string-length str))))
149       (map (lambda (s)
150                    (string s))
151            (string->list str))
152       (list "")))
153
154 (define (strip-string-annotation str)
155   "Strip annotations starting with and including the
156 annotation char from string @var{str}."
157   (let ((pos (string-index str annotation-char)))
158
159        (if pos
160            (substring str 0 pos)
161            str)))
162
163 (define (check-for-annotation str)
164   "Check whether the annotation char is present in string @var{str}."
165   (if (string? str)
166       (if (string-index str annotation-char)
167           (ly:warning
168             (_ "Annotation '~a' is allowed in the first argument of a bar line definition only.")
169             str))))
170
171 (define (check-for-replacement str)
172   "Check whether the replacement char is present in string @var{str}."
173   (if (string? str)
174       (if (string-index str replacement-char)
175           (ly:warning
176             (_ "Replacement '~a' is allowed in the last argument of a bar line definition only.")
177             str))))
178
179 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
180 ;; functions used by external routines
181
182 (define-public (span-bar::notify-grobs-of-my-existence grob)
183   "Set the @code{'has-span-bar} property for all elements of Grob @var{grob}."
184   (let* ((elts (ly:grob-array->list (ly:grob-object grob 'elements)))
185          (sorted-elts (sort elts ly:grob-vertical<?))
186          (last-pos (1- (length sorted-elts)))
187          (idx 0))
188
189         (map (lambda (g)
190                      (ly:grob-set-property!
191                        g
192                        'has-span-bar
193                        (cons (if (eq? idx last-pos)
194                                  #f
195                                  grob)
196                              (if (zero? idx)
197                                  #f
198                                  grob)))
199                       (set! idx (1+ idx)))
200              sorted-elts)))
201
202 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
203 ;; Line break decisions.
204
205 (define-public (define-bar-line bar-glyph eol-glyph bol-glyph span-glyph)
206   "Define a bar glyph @var{bar-glyph} and its substitute at the end of a line
207 (@var{eol-glyph}), at the beginning of a new line (@var{bol-glyph})
208 and as a span bar (@var{span-glyph}) respectively."
209   ;; the last argument may not include annotations
210   (check-for-annotation span-glyph)
211   ;; only the last argument may call for replacements
212   (for-each (lambda (s)
213                     (check-for-replacement s))
214             (list bar-glyph eol-glyph bol-glyph))
215   ;; the bar-glyph-alist has entries like
216   ;; (bar-glyph . ( eol-glyph . bol-glyph))
217   (set! bar-glyph-alist
218     (acons bar-glyph (cons eol-glyph bol-glyph) bar-glyph-alist))
219
220   ;; the span-bar-glyph-alist has entries like
221   ;; (bar-glyph . span-glyph)
222   (set! span-bar-glyph-alist
223     (acons bar-glyph span-glyph span-bar-glyph-alist)))
224
225 (define-session-public bar-glyph-alist '())
226
227 (define-session-public span-bar-glyph-alist '())
228
229 (define-public (add-bar-glyph-print-procedure glyph proc)
230   "Specify the single glyph @var{glyph} that calls print procedure @var{proc}.
231 The procedure @var{proc} has to be defined in the form
232 @code{(make-...-bar-line grob extent)} even if the @var{extent}
233 is not used within the routine."
234   (if (or (not (string? glyph))
235           (> (string-length glyph) 1))
236       (ly:warning
237         (_ "add-bar-glyph-print-procedure: glyph '~a' has to be a single ASCII character.")
238         glyph)
239       (set! bar-glyph-print-procedures
240         (acons glyph proc bar-glyph-print-procedures))))
241
242 (define-session-public bar-glyph-print-procedures `())
243
244 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
245 ;; drawing functions for various bar line types
246 ;; to include them and other user-defined functions,
247 ;; all of them have the form
248 ;; (make-...-bar-line grob extent)
249 ;; even if the extent is not used.
250
251 (define (make-empty-bar-line grob extent)
252   "Draw an empty bar line."
253   (ly:make-stencil "" (cons 0 0) extent))
254
255 (define (make-simple-bar-line grob extent)
256   "Draw a simple bar line."
257   (let* ((line-thickness (layout-line-thickness grob))
258          (thickness (* (ly:grob-property grob 'hair-thickness 1)
259                        line-thickness))
260          (blot (calc-blot thickness extent grob))
261          (extent (bar-line::widen-bar-extent-on-span grob extent)))
262
263         (ly:round-filled-box (cons 0 thickness)
264                              extent
265                              blot)))
266
267 (define (make-thick-bar-line grob extent)
268   "Draw a thick bar line."
269   (let* ((line-thickness (layout-line-thickness grob))
270          (thickness (* (ly:grob-property grob 'thick-thickness 1)
271                        line-thickness))
272          (blot (calc-blot thickness extent grob))
273          (extent (bar-line::widen-bar-extent-on-span grob extent)))
274
275         (ly:round-filled-box (cons 0 thickness)
276                              extent
277                              blot)))
278
279 (define (make-tick-bar-line grob extent)
280   "Draw a tick bar line."
281   (let* ((half-staff (* 1/2 (ly:staff-symbol-staff-space grob)))
282          (staff-line-thickness (ly:staff-symbol-line-thickness grob))
283          (height (interval-end extent))
284          (blot (calc-blot staff-line-thickness extent grob)))
285
286         (ly:round-filled-box (cons 0 staff-line-thickness)
287                              (cons (- height half-staff) (+ height half-staff))
288                              blot)))
289
290 (define (make-colon-bar-line grob extent)
291   "Draw repeat dots."
292   (let* ((staff-space (ly:staff-symbol-staff-space grob))
293          (line-thickness (ly:staff-symbol-line-thickness grob))
294          (dot (ly:font-get-glyph (ly:grob-default-font grob) "dots.dot"))
295          (dot-y-length (interval-length (ly:stencil-extent dot Y)))
296          (stencil empty-stencil)
297          ;; the two dots of the repeat sign should be centred at the
298          ;; middle of the staff and neither should collide with staff
299          ;; lines.
300          ;; the required space is measured in line positions,
301          ;; i.e. in half staff spaces.
302
303          ;; dots are to fall into distict spaces, except when there's
304          ;; only one space (and it's big enough to hold two dots and
305          ;; some space between them)
306
307          ;; choose defaults working without any staff
308          (center 0.0)
309          (dist (* 4 dot-y-length)))
310
311     (if (> staff-space 0)
312         (begin
313           (set! dist (/ dist staff-space))
314           (let ((staff-symbol (get-staff-symbol grob)))
315
316             (if (ly:grob? staff-symbol)
317                 (let ((line-pos (staff-symbol-line-positions staff-symbol)))
318
319                   (if (pair? line-pos)
320                       (begin
321                         (set! center
322                               (interval-center (staff-symbol-line-span
323                                                 staff-symbol)))
324                         ;; fold the staff into two at center
325                         (let* ((folded-staff
326                                 (sort (map (lambda (lp) (abs (- lp center)))
327                                            line-pos) <))
328                                (gap-to-find (/ (+ dot-y-length line-thickness)
329                                                (/ staff-space 2)))
330                                (first (car folded-staff))
331                                (found #f))
332
333                           ;; find the first space big enough
334                           ;; to hold a dot and a staff line
335                           ;; (a space in the folded staff may be
336                           ;; narrower but can't be wider than the
337                           ;; corresponding original spaces)
338                           (reduce (lambda (x y) (if (and (> (- x y) gap-to-find)
339                                                          (not found))
340                                                     (begin
341                                                       (set! found #t)
342                                                       (set! dist (+ x y))))
343                                           x)
344                                   ""
345                                   folded-staff)
346
347                           (if (not found)
348                               (set! dist (if (< gap-to-find first)
349                                              ;; there's a central space big
350                                              ;; enough to hold both dots
351                                              first
352
353                                              ;; dots should go outside
354                                              (+ (* 2 (car
355                                                       (reverse folded-staff)))
356                                                 (/ (* 4 dot-y-length)
357                                                    staff-space))))))))))))
358         (set! staff-space 1.0))
359
360     (let* ((stencil empty-stencil)
361            (stencil (ly:stencil-add stencil dot))
362            (stencil (ly:stencil-translate-axis
363                      stencil (* dist (/ staff-space 2)) Y))
364            (stencil (ly:stencil-add stencil dot))
365            (stencil (ly:stencil-translate-axis
366                      stencil (* (- center (/ dist 2))
367                                 (/ staff-space 2)) Y)))
368       stencil)))
369
370
371 (define (make-dotted-bar-line grob extent)
372   "Draw a dotted bar line."
373   (let* ((position (round (* (interval-end extent) 2)))
374          (correction (if (even? position) 0.5 0.0))
375          (dot (ly:font-get-glyph (ly:grob-default-font grob) "dots.dot"))
376          (i (round (+ (interval-start extent)
377                       (- 0.5 correction))))
378          (e (round (+ (interval-end extent)
379                       (- 0.5 correction))))
380          (counting (interval-length (cons i e)))
381          (stil-list (map
382                       (lambda (x)
383                               (ly:stencil-translate-axis
384                                 dot (+ x correction) Y))
385                       (iota counting i 1))))
386
387         (define (add-stencils! stil l)
388           (if (null? l)
389               stil
390               (if (null? (cdr l))
391                   (ly:stencil-add stil (car l))
392                   (add-stencils! (ly:stencil-add stil (car l)) (cdr l)))))
393
394         (add-stencils! empty-stencil stil-list)))
395
396 (define (make-dashed-bar-line grob extent)
397   "Draw a dashed bar line."
398   (let* ((height (interval-length extent))
399          (staff-symbol (get-staff-symbol grob))
400          (staff-space (ly:staff-symbol-staff-space grob))
401          (line-thickness (layout-line-thickness grob))
402          (thickness (* (ly:grob-property grob 'hair-thickness 1)
403                        line-thickness))
404          (dash-size (- 1.0 (ly:grob-property grob 'gap 0.3)))
405          (line-count (staff-symbol-line-count staff-symbol)))
406
407         (if (< (abs (+ line-thickness
408                        (* (1- line-count) staff-space)
409                        (- height)))
410                0.1)
411             (let ((blot (layout-blot-diameter grob))
412                   (half-space (/ staff-space 2.0))
413                   (half-thick (/ line-thickness 2.0))
414                   (stencil empty-stencil))
415
416                  (map (lambda (i)
417                       (let ((top-y (min (* (+ i dash-size) half-space)
418                                         (+ (* (1- line-count) half-space)
419                                            half-thick)))
420                             (bot-y (max (* (- i dash-size) half-space)
421                                         (- 0 (* (1- line-count) half-space)
422                                            half-thick))))
423
424                            (set! stencil
425                                  (ly:stencil-add
426                                    stencil
427                                    (ly:round-filled-box (cons 0 thickness)
428                                                         (cons bot-y top-y)
429                                                         blot)))))
430                       (iota line-count (1- line-count) (- 2)))
431             stencil)
432             (let* ((dashes (/ height staff-space))
433                    (total-dash-size (/ height dashes))
434                    (factor (/ (- dash-size thickness) staff-space))
435                    (stencil (ly:stencil-translate-axis
436                               (ly:make-stencil (list 'dashed-line
437                                                      thickness
438                                                      (* factor total-dash-size)
439                                                      (* (- 1 factor) total-dash-size)
440                                                      0
441                                                      height
442                                                      (* factor total-dash-size 0.5))
443                                                (cons (/ thickness -2) (/ thickness 2))
444                                                (cons 0 height))
445                             (interval-start extent)
446                             Y)))
447
448                  (ly:stencil-translate-axis stencil (/ thickness 2) X)))))
449
450
451 (define ((make-segno-bar-line show-segno) grob extent)
452   "Draw a segno bar line. If @var{show-segno} is set to @code{#t},
453 the segno sign is drawn over the double bar line; otherwise, it
454 draws the span bar variant, i.e. without the segno sign."
455   (let* ((line-thickness (layout-line-thickness grob))
456          (thinkern (* (ly:grob-property grob 'thin-kern 1) line-thickness))
457          (thin-stil (make-simple-bar-line grob extent))
458          (double-line-stil (ly:stencil-combine-at-edge
459                              thin-stil
460                              X
461                              LEFT
462                              thin-stil
463                              thinkern))
464          (segno (ly:font-get-glyph (ly:grob-default-font grob)
465                                    "scripts.varsegno"))
466          (stencil (ly:stencil-add
467                     (if show-segno
468                         segno
469                         (ly:make-stencil
470                           ""
471                           (ly:stencil-extent segno X)
472                           (cons 0 0)))
473                     (ly:stencil-translate-axis
474                       double-line-stil
475                       (* 1/2 thinkern)
476                       X))))
477
478        stencil))
479
480 (define (make-kievan-bar-line grob extent)
481   "Draw a kievan bar line."
482   (let* ((font (ly:grob-default-font grob))
483          (stencil (stencil-whiteout
484                     (ly:font-get-glyph font "scripts.barline.kievan"))))
485
486         ;; the kievan bar line has no staff lines underneath,
487         ;; so we whiteout them and move the grob to a higher layer
488         (ly:grob-set-property! grob 'layer 1)
489         stencil))
490
491 (define ((make-bracket-bar-line dir) grob extent)
492   "Draw a bracket-style bar line. If @var{dir} is set to @code{LEFT}, the
493 opening bracket will be drawn, for @code{RIGHT} we get the closing bracket."
494   (let* ((thick-stil (make-thick-bar-line grob extent))
495          (brackettips-up (ly:font-get-glyph (ly:grob-default-font grob)
496                                             "brackettips.up"))
497          (brackettips-down (ly:font-get-glyph (ly:grob-default-font grob)
498                                               "brackettips.down"))
499          ;; the x-extent of the brackettips must not be taken into account
500          ;; for bar line constructs like "[|:", so we set new bounds:
501          (tip-up-stil (ly:make-stencil (ly:stencil-expr brackettips-up)
502                                        (cons 0 0)
503                                        (ly:stencil-extent brackettips-up Y)))
504          (tip-down-stil (ly:make-stencil (ly:stencil-expr brackettips-down)
505                                        (cons 0 0)
506                                        (ly:stencil-extent brackettips-down Y)))
507          (stencil (ly:stencil-add
508                     thick-stil
509                     (ly:stencil-translate-axis tip-up-stil
510                                                (interval-end extent)
511                                                Y)
512                     (ly:stencil-translate-axis tip-down-stil
513                                                (interval-start extent)
514                                                Y))))
515
516         (if (eq? dir LEFT)
517             stencil
518             (ly:stencil-scale stencil -1 1))))
519
520 (define ((make-spacer-bar-line glyph) grob extent)
521   "Draw an invisible bar line which has the same dimensions as the one
522 drawn by the procedure associated with glyph @var{glyph}."
523   (let* ((stil (glyph->stencil glyph grob extent))
524          (stil-x-extent (ly:stencil-extent stil X)))
525
526         (ly:make-stencil "" stil-x-extent extent)))
527
528 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
529 ;; bar line callbacks
530
531 (define-public (ly:bar-line::calc-bar-extent grob)
532   (let ((staff-symbol (get-staff-symbol grob))
533         (staff-extent (cons 0 0)))
534
535        (if (ly:grob? staff-symbol)
536            (let ((bar-line-color (ly:grob-property grob 'color))
537                  (staff-color (ly:grob-property staff-symbol 'color))
538                  (half-staff-line-thickness (/ (ly:staff-symbol-line-thickness grob) 2))
539                  (staff-space (ly:staff-symbol-staff-space grob)))
540
541                 (set! staff-extent (ly:staff-symbol::height staff-symbol))
542
543                 (if (zero? staff-space)
544                     (set! staff-space 1.0))
545
546                 (if (< (interval-length staff-extent) staff-space)
547                     ;; staff is too small (perhaps consists of a single line);
548                     ;; extend the bar line to make it visible
549                     (set! staff-extent
550                           (interval-widen staff-extent staff-space))
551                     ;; Due to rounding problems, bar lines extending to the outermost edges
552                     ;; of the staff lines appear wrongly in on-screen display
553                     ;; (and, to a lesser extent, in print) - they stick out a pixel.
554                     ;; The solution is to extend bar lines only to the middle
555                     ;; of the staff line - unless they have different colors,
556                     ;; when it would be undesirable.
557                     ;;
558                     ;; This reduction should not influence whether the bar is to be
559                     ;; expanded later, so length is not updated on purpose.
560                     (if (eq? bar-line-color staff-color)
561                         (set! staff-extent
562                               (interval-widen staff-extent
563                                               (- half-staff-line-thickness)))))))
564        staff-extent))
565
566 ;; this function may come in handy when defining new bar line glyphs, so
567 ;; we make it public.
568 ;; This code should not be included in ly:bar-line::calc-bar-extent, because
569 ;; this may confuse the drawing functions for dashed and dotted bar lines.
570 (define-public (bar-line::widen-bar-extent-on-span grob extent)
571   "Widens the bar line @var{extent} towards span bars adjacent to grob @var{grob}."
572   (let ((staff-symbol (get-staff-symbol grob))
573         (has-span-bar (ly:grob-property grob 'has-span-bar #f)))
574
575        (if (and (ly:grob? staff-symbol)
576                 (pair? has-span-bar))
577            (let ((bar-line-color (ly:grob-property grob 'color))
578                  (staff-color (ly:grob-property staff-symbol 'color))
579                  (half-staff-line-thickness (/ (ly:staff-symbol-line-thickness grob) 2)))
580                 (if (eq? bar-line-color staff-color)
581                     ;; if the colors are equal, ly:bar-line::calc-bar-extent has
582                     ;; shortened the bar line extent by a half-staff-line-thickness
583                     ;; this is reverted on the interval bounds where span bars appear:
584                     (begin
585                       (and (ly:grob? (car has-span-bar))
586                            (set! extent (cons (- (car extent) half-staff-line-thickness)
587                                               (cdr extent))))
588                       (and (ly:grob? (cdr has-span-bar))
589                            (set! extent (cons (car extent)
590                                               (+ (cdr extent) half-staff-line-thickness))))))))
591    extent))
592
593 (define (bar-line::bar-y-extent grob refpoint)
594   "Compute the y-extent of the bar line relative to @var{refpoint}."
595   (let* ((extent (ly:grob-property grob 'bar-extent '(0 . 0)))
596          (rel-y (ly:grob-relative-coordinate grob refpoint Y))
597          (y-extent (coord-translate extent rel-y)))
598
599         y-extent))
600
601 (define-public (ly:bar-line::print grob)
602   "The print routine for bar lines."
603   (let ((glyph-name (ly:grob-property grob 'glyph-name))
604         (extent (ly:grob-property grob 'bar-extent '(0 . 0))))
605
606        (if (and glyph-name
607                 (> (interval-length extent) 0))
608            (bar-line::compound-bar-line grob glyph-name extent)
609            #f)))
610
611 (define-public (bar-line::compound-bar-line grob bar-glyph extent)
612   "Build the bar line stencil."
613   (let* ((line-thickness (layout-line-thickness grob))
614          (kern (* (ly:grob-property grob 'kern 1) line-thickness))
615          (bar-glyph-list (string->string-list
616                            (strip-string-annotation bar-glyph)))
617          (span-glyph (get-span-glyph bar-glyph))
618          (span-glyph-list (string->string-list span-glyph))
619          (neg-stencil empty-stencil)
620          (stencil empty-stencil)
621          (is-first-neg-stencil #t)
622          (is-first-stencil #t))
623
624         ;; We build up two separate stencils first:
625         ;; (1) the neg-stencil is built from all glyphs that have
626         ;;     a replacement-char in the span bar
627         ;; (2) the main stencil is built from all remaining glyphs
628         ;;
629         ;; Afterwards the neg-stencil is attached left to the
630         ;; stencil; this ensures that the main stencil starts
631         ;; at x = 0.
632         ;;
633         ;; For both routines holds:
634         ;; we stack the stencils obtained by the corresponding
635         ;; single glyphs with spacing 'kern' except for the
636         ;; first stencil
637         ;; (Thanks to Harm who came up with this idea!)
638         (for-each (lambda (bar span)
639                           (if (and (string=? span (string replacement-char))
640                                    is-first-stencil)
641                               (begin
642                                 (set! neg-stencil
643                                       (ly:stencil-combine-at-edge
644                                         neg-stencil
645                                         X
646                                         RIGHT
647                                         (glyph->stencil bar grob extent)
648                                         (if is-first-neg-stencil 0 kern)))
649                                 (set! is-first-neg-stencil #f))
650                               (begin
651                                 (set! stencil
652                                       (ly:stencil-combine-at-edge
653                                         stencil
654                                         X
655                                         RIGHT
656                                         (glyph->stencil bar grob extent)
657                                         (if is-first-stencil 0 kern)))
658                                 (set! is-first-stencil #f))))
659                   bar-glyph-list span-glyph-list)
660         ;; if we have a non-empty neg-stencil,
661         ;; we attach it to the left side of the stencil
662         (and (not is-first-neg-stencil)
663              (set! stencil
664                    (ly:stencil-combine-at-edge
665                      stencil
666                      X
667                      LEFT
668                      neg-stencil
669                      kern)))
670         stencil))
671
672 (define-public (ly:bar-line::calc-anchor grob)
673   "Calculate the anchor position of a bar line. The anchor is used for
674 the correct placement of bar numbers etc."
675   (let* ((bar-glyph (ly:grob-property grob 'glyph-name ""))
676          (bar-glyph-list (string->string-list (strip-string-annotation bar-glyph)))
677          (span-glyph (assoc-get bar-glyph span-bar-glyph-alist bar-glyph))
678          (x-extent (ly:grob-extent grob grob X))
679          (anchor 0.0))
680
681         (and (> (interval-length x-extent) 0)
682              (if (or (= (length bar-glyph-list) 1)
683                      (string=? bar-glyph span-glyph)
684                      (string=? span-glyph ""))
685                  ;; We use the x-extent of the stencil if either
686                  ;; - we have a single bar-glyph
687                  ;; - bar-glyph and span-glyph are identical
688                  ;; - we have no span-glyph
689                  (set! anchor (interval-center x-extent))
690                  ;; If the conditions above do not hold,the anchor is the
691                  ;; center of the corresponding span bar stencil extent
692                  (set! anchor (interval-center
693                                 (ly:stencil-extent
694                                   (span-bar::compound-bar-line grob bar-glyph dummy-extent)
695                                   X)))))
696          anchor))
697
698 (define-public (bar-line::calc-glyph-name grob)
699   "Determine the @code{glyph-name} of the bar line depending on the
700 line break status."
701   (let* ((glyph (ly:grob-property grob 'glyph))
702          (dir (ly:item-break-dir grob))
703          (result (assoc-get glyph bar-glyph-alist))
704          (glyph-name (if (= dir CENTER)
705                          glyph
706                          (if (and result
707                                   (string? (index-cell result dir)))
708                             (index-cell result dir)
709                             #f))))
710         glyph-name))
711
712 (define-public (bar-line::calc-break-visibility grob)
713   "Calculate the visibility of a bar line at line breaks."
714   (let* ((glyph (ly:grob-property grob 'glyph))
715          (result (assoc-get glyph bar-glyph-alist)))
716
717     (if result
718         (vector (string? (car result)) #t (string? (cdr result)))
719         all-invisible)))
720
721 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
722 ;; span bar callbacks
723
724 (define-public (ly:span-bar::calc-glyph-name grob)
725   "Return the @code{'glyph-name} of the corresponding BarLine grob.
726 The corresponding SpanBar glyph is computed within
727 @code{span-bar::compound-bar-line}."
728   (let* ((elts (ly:grob-object grob 'elements))
729          (pos (1- (ly:grob-array-length elts)))
730          (glyph-name '()))
731
732         (while (and (eq? glyph-name '())
733                     (> pos -1))
734                (begin (set! glyph-name
735                             (ly:grob-property (ly:grob-array-ref elts pos)
736                                               'glyph-name))
737                       (set! pos (1- pos))))
738          (if (eq? glyph-name '())
739              (begin (ly:grob-suicide! grob)
740                     (set! glyph-name "")))
741         glyph-name))
742
743 (define-public (ly:span-bar::width grob)
744   "Compute the width of the SpanBar stencil."
745   (let ((width (cons 0 0)))
746
747        (if (grob::is-live? grob)
748            (let* ((glyph-name (ly:grob-property grob 'glyph-name))
749                   (stencil (span-bar::compound-bar-line grob
750                                                         glyph-name
751                                                         dummy-extent)))
752
753                  (set! width (ly:stencil-extent stencil X))))
754        width))
755
756 (define-public (ly:span-bar::before-line-breaking grob)
757   "A dummy callback that kills the Grob @var{grob} if it contains
758 no elements."
759   (let ((elts (ly:grob-object grob 'elements)))
760
761        (if (zero? (ly:grob-array-length elts))
762            (ly:grob-suicide! grob))))
763
764 (define-public (span-bar::compound-bar-line grob bar-glyph extent)
765   "Build the stencil of the span bar."
766   (let* ((line-thickness (layout-line-thickness grob))
767          (kern (* (ly:grob-property grob 'kern 1) line-thickness))
768          (bar-glyph-list (string->string-list
769                            (strip-string-annotation bar-glyph)))
770          (span-glyph (assoc-get bar-glyph span-bar-glyph-alist 'undefined))
771          (stencil empty-stencil))
772
773         (if (string? span-glyph)
774             (let ((span-glyph-list (string->string-list span-glyph))
775                   (is-first-stencil #t))
776
777                  (for-each (lambda (bar span)
778                            ;; the stencil stack routine is similar to the one
779                            ;; used in bar-line::compound-bar-line, but here,
780                            ;; leading replacement-chars are discarded.
781                            (if (not (and (string=? span (string replacement-char))
782                                          is-first-stencil))
783                                (begin
784                                  (set! stencil
785                                        (ly:stencil-combine-at-edge
786                                          stencil
787                                          X
788                                          RIGHT
789                                          ;; if the current glyph is the replacement-char,
790                                          ;; we take the corresponding glyph from the
791                                          ;; bar-glyph-list and insert an empty stencil
792                                          ;; with the appropriate width.
793                                          ;; (this method would fail if the bar-glyph-list
794                                          ;; were shorter than the span-glyph-list,
795                                          ;; but this makes hardly any sense from a
796                                          ;; typographical point of view
797                                          (if (string=? span (string replacement-char))
798                                              ((make-spacer-bar-line bar) grob extent)
799                                              (glyph->stencil span grob extent))
800                                          (if is-first-stencil 0 kern)))
801                                  (set! is-first-stencil #f))))
802                    bar-glyph-list span-glyph-list))
803             ;; if span-glyph is not a string, it may be #f or 'undefined;
804             ;; the latter signals that the span bar for the current bar-glyph
805             ;; is undefined, so we raise a warning.
806             (if (eq? span-glyph 'undefined)
807                 (ly:warning
808                   (_ "No span bar glyph defined for bar glyph '~a'; ignoring.")
809                   bar-glyph)))
810         stencil))
811
812 ;; The method used in the following routine depends on bar_engraver
813 ;; not being removed from staff context.  If bar_engraver is removed,
814 ;; the size of the staff lines is evaluated as 0, which results in a
815 ;; solid span bar line with faulty y coordinate.
816 ;;
817 ;; This routine was originally by Juergen Reuter, but it was a on the
818 ;; bulky side. Rewritten by Han-Wen. Ported from c++ to Scheme by Marc Hohl.
819 (define-public (ly:span-bar::print grob)
820   "The print routine for span bars."
821   (let* ((elts-array (ly:grob-object grob 'elements))
822          (refp (ly:grob-common-refpoint-of-array grob elts-array Y))
823          (elts (reverse (sort (ly:grob-array->list elts-array)
824                               ly:grob-vertical<?)))
825          ;; Elements must be ordered according to their y coordinates
826          ;; relative to their common axis group parent.
827          ;; Otherwise, the computation goes mad.
828          (bar-glyph (ly:grob-property grob 'glyph-name))
829          (span-bar empty-stencil))
830
831         (if (string? bar-glyph)
832             (let ((extents '())
833                   (make-span-bars '())
834                   (model-bar #f))
835
836                  ;; we compute the extents of each system and store them
837                  ;; in a list; dito for the 'allow-span-bar property.
838                  ;; model-bar takes the bar grob, if given.
839                  (map (lambda (bar)
840                       (let ((ext (bar-line::bar-y-extent bar refp))
841                             (staff-symbol (ly:grob-object bar 'staff-symbol)))
842
843                            (if (ly:grob? staff-symbol)
844                                (let ((refp-extent (ly:grob-extent staff-symbol refp Y)))
845
846                                     (set! ext (interval-union ext refp-extent))
847
848                                     (if (> (interval-length ext) 0)
849                                         (begin
850                                           (set! extents (append extents (list ext)))
851                                           (set! model-bar bar)
852                                           (set! make-span-bars
853                                             (append make-span-bars
854                                                     (list (ly:grob-property
855                                                             bar
856                                                             'allow-span-bar
857                                                             #t))))))))))
858                      elts)
859                  ;; if there is no bar grob, we use the callback argument
860                  (if (not model-bar)
861                      (set! model-bar grob))
862                  ;; we discard the first entry in make-span-bars,
863                  ;; because its corresponding bar line is the
864                  ;; uppermost and therefore not connected to
865                  ;; another bar line
866                  (if (pair? make-span-bars)
867                      (set! make-span-bars (cdr make-span-bars)))
868                  ;; the span bar reaches from the lower end of the upper staff
869                  ;; to the upper end of the lower staff - when allow-span-bar is #t
870                  (reduce (lambda (curr prev)
871                                  (let ((span-extent (cons 0 0))
872                                        (allow-span-bar (car make-span-bars)))
873
874                                       (set! make-span-bars (cdr make-span-bars))
875                                       (if (> (interval-length prev) 0)
876                                           (begin
877                                             (set! span-extent (cons (cdr prev)
878                                                                     (car curr)))
879                                             ;; draw the span bar only when the staff lines
880                                             ;; don't overlap and allow-span-bar is #t:
881                                             (and (> (interval-length span-extent) 0)
882                                                  allow-span-bar
883                                                  (set! span-bar
884                                                        (ly:stencil-add
885                                                          span-bar
886                                                          (span-bar::compound-bar-line
887                                                            model-bar
888                                                            bar-glyph
889                                                            span-extent))))))
890                                       curr))
891                          "" extents)
892                  (set! span-bar (ly:stencil-translate-axis
893                                   span-bar
894                                   (- (ly:grob-relative-coordinate grob refp Y))
895                                   Y))))
896         span-bar))
897
898 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
899 ;; volta bracket functions
900
901 (define-public (allow-volta-hook bar-glyph)
902   "Allow the volta bracket hook being drawn over bar line @var{bar-glyph}."
903   (if (string? bar-glyph)
904       (set! volta-bracket-allow-volta-hook-list
905             (append volta-bracket-allow-volta-hook-list
906                     (list bar-glyph)))
907       (ly:warning (_ ("Volta hook bar line must be a string; ignoring '~a'.")
908                   bar-glyph))))
909
910 (define-session-public volta-bracket-allow-volta-hook-list '())
911
912 (define-public (volta-bracket::calc-hook-visibility bar-glyph)
913   "Determine the visibility of the volta bracket hook. It is called in
914 @code{lily/volta-bracket.cc} and returns @code{#t} if @emph{no} hook
915 should be drawn."
916   (not (member bar-glyph volta-bracket-allow-volta-hook-list)))
917
918 (define-public (ly:volta-bracket::calc-shorten-pair grob)
919   "Calculate the @code{shorten-pair} values for an ideal placement
920 of the volta brackets relative to the bar lines."
921   (let* ((line-thickness (layout-line-thickness grob))
922          (volta-half-line-thickness (* (ly:grob-property grob 'thickness 1.6)
923                                        line-thickness
924                                        1/2))
925          (bar-array (ly:grob-object grob 'bars))
926          (bar-array-length (ly:grob-array-length bar-array))
927          ;; the bar-array starts with the uppermost bar line grob that is
928          ;; covered by the left edge of the volta bracket; more (span)
929          ;; bar line grobs from other staves may follow
930          (left-bar-line (if (> bar-array-length 0)
931                             (ly:grob-array-ref bar-array 0)
932                             '()))
933          ;; we need the vertical-axis-group-index of the left-bar-line
934          ;; to find the corresponding right-bar-line
935          (vag-index (if (null? left-bar-line)
936                         -1
937                         (ly:grob-get-vertical-axis-group-index left-bar-line)))
938          ;; the bar line corresponding to the right edge of the volta bracket
939          ;; is the last entry with the same vag-index, so we transform the array to a list,
940          ;; reverse it and search for suitable entries:
941          (filtered-grobs (filter (lambda (e)
942                                          (eq? (ly:grob-get-vertical-axis-group-index e)
943                                               vag-index))
944                                  (reverse (ly:grob-array->list bar-array))))
945          ;; we need the first one (if any)
946          (right-bar-line (if (pair? filtered-grobs)
947                              (car filtered-grobs)
948                              '()))
949          ;; the left-bar-line may be a #'<Grob Item >,
950          ;; so we add "" as a fallback return value
951          (left-bar-glyph-name (if (null? left-bar-line)
952                                   (string annotation-char)
953                                   (ly:grob-property left-bar-line 'glyph-name "")))
954          (right-bar-glyph-name (if (null? right-bar-line)
955                                    (string annotation-char)
956                                    (ly:grob-property right-bar-line 'glyph-name "")))
957          (left-bar-broken (or (null? left-bar-line)
958                               (not (zero? (ly:item-break-dir left-bar-line)))))
959          (right-bar-broken (or (null? right-bar-line)
960                                (not (zero? (ly:item-break-dir right-bar-line)))))
961          (left-span-stencil-extent (ly:stencil-extent
962                                      (span-bar::compound-bar-line
963                                        left-bar-line
964                                        left-bar-glyph-name
965                                        dummy-extent)
966                                      X))
967          (right-span-stencil-extent (ly:stencil-extent
968                                       (span-bar::compound-bar-line
969                                         right-bar-line
970                                         right-bar-glyph-name
971                                         dummy-extent)
972                                       X))
973          (left-shorten 0.0)
974          (right-shorten 0.0))
975
976         ;; since "empty" intervals may look like (1.0 . -1.0), we use the
977         ;; min/max functions to make sure that the placement is not corrupted
978         ;; in case of empty bar lines
979         (set! left-shorten
980               (if left-bar-broken
981                   (- (max 0 (interval-end left-span-stencil-extent))
982                      (max 0 (interval-end (ly:stencil-extent
983                                             (bar-line::compound-bar-line
984                                               left-bar-line
985                                               left-bar-glyph-name
986                                               dummy-extent)
987                                             X)))
988                      volta-half-line-thickness)
989                   (- (max 0 (interval-end left-span-stencil-extent))
990                      volta-half-line-thickness)))
991
992         (set! right-shorten
993               (if right-bar-broken
994                   (+ (- (max 0 (interval-end right-span-stencil-extent)))
995                      volta-half-line-thickness)
996                   (- (min 0 (interval-start right-span-stencil-extent))
997                      volta-half-line-thickness)))
998
999   (cons left-shorten right-shorten)))
1000
1001 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1002 ;; predefined bar glyph print procedures
1003
1004 (add-bar-glyph-print-procedure "" make-empty-bar-line)
1005 (add-bar-glyph-print-procedure "|" make-simple-bar-line)
1006 (add-bar-glyph-print-procedure "." make-thick-bar-line)
1007 (add-bar-glyph-print-procedure "!" make-dashed-bar-line)
1008 (add-bar-glyph-print-procedure "'" make-tick-bar-line)
1009 (add-bar-glyph-print-procedure ":" make-colon-bar-line)
1010 (add-bar-glyph-print-procedure ";" make-dotted-bar-line)
1011 (add-bar-glyph-print-procedure "k" make-kievan-bar-line)
1012 (add-bar-glyph-print-procedure "S" (make-segno-bar-line #t))
1013 (add-bar-glyph-print-procedure "=" (make-segno-bar-line #f))
1014 (add-bar-glyph-print-procedure "[" (make-bracket-bar-line LEFT))
1015 (add-bar-glyph-print-procedure "]" (make-bracket-bar-line RIGHT))
1016
1017 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1018 ;; predefined bar lines
1019 ;;
1020 ;; definition of bar lines goes as follows:
1021 ;;
1022 ;; (define-bar-line "normal bar[-annotation]" "end of line" "start of line" "span bar")
1023 ;;
1024 ;; each entry has to be a string or #f.
1025 ;; The empty string "" is allowed and yields in an invisible bar line,
1026 ;; whereas #f reads 'no stencil'.
1027 ;;
1028 ;; Convention: if two bar lines would be identical in their
1029 ;; unbroken bar glyph, we use annotations to make them distinct;
1030 ;; as a general rule of thumb the main difference in their
1031 ;; behavior at the end of a line is used as annotation, cf.
1032 ;;
1033 ;; (define-bar-line ".|:" "|" ".|:" ".|")
1034 ;; (define-bar-line ".|:-||" "||" ".|:" ".|")
1035 ;;
1036 ;; or
1037 ;;
1038 ;; (define-bar-line "S-|" "|" "S" "=")
1039 ;; (define-bar-line "S-S" "S" "" "=")
1040
1041 ;; common bar lines
1042 (define-bar-line "" "" "" #f)
1043 (define-bar-line "-" #f #f #f)
1044 (define-bar-line "|" "|" #f "|")
1045 (define-bar-line "|-s" #f "|" "|")
1046 (define-bar-line "." "." #f ".")
1047 (define-bar-line ".|" "|" ".|" ".|")
1048 (define-bar-line "|." "|." #f "|.")
1049 (define-bar-line "||" "||" #f "||")
1050 (define-bar-line ".." ".." #f "..")
1051 (define-bar-line "|.|" "|.|" #f "|.|")
1052 (define-bar-line "!" "!" #f "!")
1053 (define-bar-line ";" ";" #f ";")
1054 (define-bar-line "'" "'" #f #f)
1055
1056 ;; repeats
1057 (define-bar-line ":|.:" ":|." ".|:"  " |.")
1058 (define-bar-line ":..:" ":|." ".|:" " ..")
1059 (define-bar-line ":|.|:" ":|." ".|:" " |.|")
1060 (define-bar-line ":.|.:" ":|." ".|:" " .|.")
1061 (define-bar-line ":|." ":|." #f " |.")
1062 (define-bar-line ".|:" "|" ".|:" ".|")
1063 (define-bar-line "[|:" "|" "[|:" " |")
1064 (define-bar-line ":|]" ":|]" #f " |")
1065 (define-bar-line ":|][|:" ":|]" "[|:" " |  |")
1066 (define-bar-line ".|:-||" "||" ".|:" ".|")
1067
1068 ;; segno bar lines
1069 (define-bar-line "S" "||" "S" "=")
1070 (define-bar-line "S-|" "|" "S" "=")
1071 (define-bar-line "S-S" "S" #f "=")
1072 (define-bar-line ":|.S" ":|." "S" " |.")
1073 (define-bar-line ":|.S-S" ":|.S" "" " |.")
1074 (define-bar-line "S.|:" "|" "S.|:" " .|")
1075 (define-bar-line "S.|:-S" "S" ".|:" " .|")
1076 (define-bar-line ":|.S.|:" ":|." "S.|:" " |. .|")
1077 (define-bar-line ":|.S.|:-S" ":|.S" ".|:" " |. .|")
1078
1079 ;; ancient bar lines
1080 (define-bar-line "k" "k" #f #f) ;; kievan style
1081
1082 ;; volta hook settings
1083 (allow-volta-hook ":|.")
1084 (allow-volta-hook ".|:")
1085 (allow-volta-hook "|.")
1086 (allow-volta-hook ":..:")
1087 (allow-volta-hook ":|.|:")
1088 (allow-volta-hook ":|.:")
1089 (allow-volta-hook ".|")
1090 (allow-volta-hook ":|.S")
1091 (allow-volta-hook ":|.S-S")
1092 (allow-volta-hook ":|.S.|:")
1093 (allow-volta-hook ":|.S.|:-S")
1094 (allow-volta-hook ":|]")
1095 (allow-volta-hook ":|][|:")