scm/bar-line.scm

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