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 ;; helper functions
  19
  20 (define (get-staff-symbol grob)
  21   (if (grob::has-interface grob 'staff-symbol-interface)
  22       grob
  23       (ly:grob-object grob 'staff-symbol)))
  24
  25 (define (layout-blot-diameter grob)
  26   (let* ((layout (ly:grob-layout grob))
  27          (blot (ly:output-def-lookup layout 'blot-diameter)))
  28
  29         blot))
  30
  31 (define (layout-line-thickness grob)
  32   (let* ((layout (ly:grob-layout grob))
  33          (line-thickness (ly:output-def-lookup layout 'line-thickness)))
  34
  35         line-thickness))
  36
  37 (define (staff-symbol-line-count grob)
  38   (let ((line-count 0))
  39
  40        (if (ly:grob? grob)
  41            (let ((line-pos (ly:grob-property grob 'line-positions '())))
  42
  43                 (set! line-count (if (pair? line-pos)
  44                                      (length line-pos)
  45                                      (ly:grob-property grob 'line-count 0)))))
  46
  47          line-count))
  48
  49 (define (staff-symbol-line-span grob)
  50   (let ((line-pos (ly:grob-property grob 'line-positions '()))
  51         (iv (cons 0.0 0.0)))
  52
  53        (if (pair? line-pos)
  54            (begin
  55              (set! iv (cons (car line-pos) (car line-pos)))
  56              (map (lambda (x)
  57                     (set! iv (cons (min (car iv) x)
  58                                    (max (cdr iv) x))))
  59                   (cdr line-pos)))
  60
  61            (let ((line-count (ly:grob-property grob 'line-count 0)))
  62
  63                 (set! iv (cons (- 1 line-count)
  64                                (- line-count 1)))))
  65        iv))
  66
  67 (define (staff-symbol-line-positions grob)
  68   (let ((line-pos (ly:grob-property grob 'line-positions '())))
  69
  70        (if (not (pair? line-pos))
  71            (let* ((line-count (ly:grob-property grob 'line-count 0))
  72                   (height (- line-count 1.0)))
  73
  74                  (set! line-pos (map (lambda (x)
  75                                              (- height (* x 2)))
  76                                      (iota line-count)))))
  77        line-pos))
  78
  79 ;; functions used by external routines
  80
  81 (define-public (span-bar::notify-grobs-of-my-existence grob)
  82   (let* ((elts (ly:grob-array->list (ly:grob-object grob 'elements)))
  83          (sorted-elts (sort elts ly:grob-vertical<?))
  84          (last-pos (1- (length sorted-elts)))
  85          (idx 0))
  86
  87         (map (lambda (g)
  88                      (ly:grob-set-property!
  89                        g
  90                        'has-span-bar
  91                        (cons (if (eq? idx last-pos)
  92                                  #f
  93                                  grob)
  94                              (if (zero? idx)
  95                                  #f
  96                                  grob)))
  97                       (set! idx (1+ idx)))
  98              sorted-elts)))
  99
 100 ;; How should a bar line behave at a break?
 101 ;; the following alist has the form
 102 ;; ( unbroken-bar-glyph . ( bar-glyph-at-end-of-line . bar-glyph-at-begin-of-line ))
 103
 104 (define bar-glyph-alist
 105   '((":|:" . (":|" . "|:"))
 106     (":|.|:" . (":|" . "|:"))
 107     (":|.:" . (":|" . "|:"))
 108     ("||:" . ("||" . "|:"))
 109     ("dashed" . ("dashed" . '()))
 110     ("|" . ("|" . ()))
 111     ("|s" . (() . "|"))
 112     ("|:" . ("|" . "|:"))
 113     ("|." . ("|." . ()))
 114
 115     ;; hmm... should we end with a bar line here?
 116     (".|" . ("|" . ".|"))
 117     (":|" . (":|" . ()))
 118     ("||" . ("||" . ()))
 119     (".|." . (".|." . ()))
 120     ("|.|" . ("|.|" . ()))
 121     ("" . ("" . ""))
 122     (":" . (":" . ""))
 123     ("." . ("." . ()))
 124     ("'" . ("'" . ()))
 125     ("empty" . (() . ()))
 126     ("brace" . (() . "brace"))
 127     ("bracket" . (() . "bracket"))
 128
 129     ;; segno bar lines
 130     ("S" . ("||" . "S"))
 131     ("|S" . ("|" . "S"))
 132     ("S|" . ("S" . ()))
 133     (":|S" . (":|" . "S"))
 134     (":|S." . (":|S" . ()))
 135     ("S|:" . ("S" . "|:"))
 136     (".S|:" . ("|" . "S|:"))
 137     (":|S|:" . (":|" . "S|:"))
 138     (":|S.|:" . (":|S" . "|:"))
 139
 140     ;; ancient bar lines
 141     ("kievan" . ("kievan" . ""))))
 142
 143 ;; drawing functions for various bar line types
 144
 145 (define (make-empty-bar-line grob extent)
 146   (ly:make-stencil "" (cons 0 0) extent))
 147
 148 (define (make-simple-bar-line grob width extent rounded)
 149   (let ((blot (if rounded
 150                   (layout-blot-diameter grob)
 151                   0)))
 152
 153         (ly:round-filled-box (cons 0 width)
 154                              extent
 155                              blot)))
 156
 157 (define (make-tick-bar-line grob height rounded)
 158   (let ((half-staff (* 1/2 (ly:staff-symbol-staff-space grob)))
 159         (staff-line-thickness (ly:staff-symbol-line-thickness grob))
 160         (blot (if rounded
 161                   (layout-blot-diameter grob)
 162                   0)))
 163
 164        (ly:round-filled-box (cons 0 staff-line-thickness)
 165                             (cons (- height half-staff) (+ height half-staff))
 166                             blot)))
 167
 168 (define (make-colon-bar-line grob)
 169   (let* ((staff-space (ly:staff-symbol-staff-space grob))
 170          (line-thickness (ly:staff-symbol-line-thickness grob))
 171          (dot (ly:font-get-glyph (ly:grob-default-font grob) "dots.dot"))
 172          (dot-y-length (interval-length (ly:stencil-extent dot Y)))
 173          (stencil empty-stencil)
 174          ;; the two dots of the repeat sign should be centred at the middle of
 175          ;; the staff and neither should collide with staff lines
 176          ;;
 177          ;; the default distance between centre of dots is composed of
 178          ;; - a staffline (with width line-thickness)
 179          ;; - some space below and above dot
 180          ;; - two half-dots
 181          ;; and we need to measure it as line positions,
 182          ;; i.e. in half staff spaces.
 183          ;;
 184          ;; space between dot and staffline should be comparable to staffline
 185          ;; width so that a relatively common idiom
 186          ;; (0.5 staff-size combined with set-layout-staff-size 10) works ok -
 187          ;; that makes the choice of 1 staffline too big.
 188          ;; 0.1 will be used if to be positioned between staff lines,
 189          ;; dot diameter if outside staff.
 190          (center 0.0)
 191          (dist (* 4 dot-y-length)))
 192
 193     (if (> staff-space 0)
 194         (begin
 195           (set! dist (/ dist staff-space))
 196           (let ((staff-symbol (get-staff-symbol grob)))
 197
 198             (if (ly:grob? staff-symbol)
 199                 (let ((line-pos (staff-symbol-line-positions staff-symbol)))
 200
 201                   (if (pair? line-pos)
 202                       (begin
 203                         (set! center
 204                               (interval-center (staff-symbol-line-span
 205                                                 staff-symbol)))
 206                         ;; fold the staff into two at center and find the
 207                         ;; first gap big enough to hold a dot and some space
 208                         ;; below and above
 209                         (let* ((half-staff
 210                                 (sort (append (map (lambda (lp)
 211                                                      (abs (- lp center)))
 212                                                    line-pos)
 213                                               '(0.0)) <))
 214                                (gap-to-find (/ (+ dot-y-length
 215                                                   (* 1.2 line-thickness))
 216                                                (/ staff-space 2)))
 217                                (found #f))
 218
 219                           ;; initialize dist for the case when both dots should
 220                           ;; be outside the staff
 221                           (set! dist (+ (* 2 (car (reverse half-staff)))
 222                                         (/ (* 4 dot-y-length) staff-space)))
 223
 224                           (reduce (lambda (x y) (if (and (> (- x y) gap-to-find)
 225                                                          (not found))
 226                                                     (begin
 227                                                       (set! found #t)
 228                                                       (set! dist (+ x y))))
 229                                           x)
 230                                   ""
 231                                   half-staff))))))))
 232         (set! staff-space 1.0))
 233
 234     (let* ((stencil empty-stencil)
 235            (stencil (ly:stencil-add stencil dot))
 236            (stencil (ly:stencil-translate-axis
 237                      stencil (* dist (/ staff-space 2)) Y))
 238            (stencil (ly:stencil-add stencil dot))
 239            (stencil (ly:stencil-translate-axis
 240                      stencil (* (- center (/ dist 2))
 241                                 (/ staff-space 2)) Y)))
 242       stencil)))
 243
 244 (define (make-dotted-bar-line grob extent)
 245   (let* ((position (round (* (interval-end extent) 2)))
 246          (correction (if (even? position) 0.5 0.0))
 247          (dot (ly:font-get-glyph (ly:grob-default-font grob) "dots.dot"))
 248          (i (round (+ (interval-start extent)
 249                       (- 0.5 correction))))
 250          (e (round (+ (interval-end extent)
 251                       (- 0.5 correction))))
 252          (counting (interval-length (cons i e)))
 253          (stil-list (map
 254                       (lambda (x)
 255                               (ly:stencil-translate-axis
 256                                 dot (+ x correction) Y))
 257                       (iota counting i 1))))
 258
 259         (define (add-stencils! stil l)
 260           (if (null? l)
 261               stil
 262               (if (null? (cdr l))
 263                   (ly:stencil-add stil (car l))
 264                   (add-stencils! (ly:stencil-add stil (car l)) (cdr l)))))
 265
 266         (add-stencils! empty-stencil stil-list)))
 267
 268 (define (make-dashed-bar-line grob extent thickness)
 269   (let* ((height (interval-length extent))
 270          (staff-symbol (get-staff-symbol grob))
 271          (staff-space (ly:staff-symbol-staff-space grob))
 272          (line-thickness (layout-line-thickness grob))
 273          (dash-size (- 1.0 (ly:grob-property grob 'gap 0.3)))
 274          (line-count (staff-symbol-line-count staff-symbol)))
 275
 276         (if (< (abs (+ line-thickness
 277                        (* (1- line-count) staff-space)
 278                        (- height)))
 279                0.1)
 280             (let ((blot (layout-blot-diameter grob))
 281                   (half-space (/ staff-space 2.0))
 282                   (half-thick (/ line-thickness 2.0))
 283                   (stencil empty-stencil))
 284
 285                  (map (lambda (i)
 286                       (let ((top-y (min (* (+ i dash-size) half-space)
 287                                         (+ (* (1- line-count) half-space)
 288                                            half-thick)))
 289                             (bot-y (max (* (- i dash-size) half-space)
 290                                         (- 0 (* (1- line-count) half-space)
 291                                            half-thick))))
 292
 293                            (set! stencil
 294                                  (ly:stencil-add
 295                                    stencil
 296                                    (ly:round-filled-box (cons 0 thickness)
 297                                                         (cons bot-y top-y)
 298                                                         blot)))))
 299                       (iota line-count (1- line-count) (- 2)))
 300             stencil)
 301             (let* ((dashes (/ height staff-space))
 302                    (total-dash-size (/ height dashes))
 303                    (factor (/ (- dash-size thickness) staff-space)))
 304
 305                   (ly:stencil-translate-axis
 306                     (ly:make-stencil (list 'dashed-line
 307                                            thickness
 308                                            (* factor total-dash-size)
 309                                            (* (- 1 factor) total-dash-size)
 310                                            0
 311                                            height
 312                                            (* factor total-dash-size 0.5))
 313                                            (cons 0 thickness)
 314                                            (cons 0 height))
 315                                            (interval-start extent)
 316                                            Y)))))
 317
 318 (define (make-segno-bar-line grob glyph extent rounded)
 319   (let* ((line-thickness (layout-line-thickness grob))
 320          (kern (* (ly:grob-property grob 'kern 1) line-thickness))
 321          (thinkern (* (ly:grob-property grob 'thin-kern 1) line-thickness))
 322          (hair (* (ly:grob-property grob 'hair-thickness 1) line-thickness))
 323          (fatline (* (ly:grob-property grob 'thick-thickness 1) line-thickness))
 324          (thin-stil (make-simple-bar-line grob hair extent rounded))
 325          (thick-stil (make-simple-bar-line grob fatline extent rounded))
 326          (colon-stil (make-colon-bar-line grob))
 327          (segno-stil (ly:stencil-add
 328                        (ly:stencil-combine-at-edge
 329                          (ly:stencil-combine-at-edge
 330                            '() X LEFT thin-stil thinkern)
 331                          X RIGHT thin-stil thinkern)
 332                        (ly:font-get-glyph (ly:grob-default-font grob) "scripts.varsegno")))
 333          (glyph (cond
 334                   ((string=? glyph "|S") "S")
 335                   ((string=? glyph "S|") "S")
 336                   (else glyph)))
 337          (stencil (cond
 338                     ((or (string=? glyph "S|:")
 339                          (string=? glyph ".S|:"))
 340                      (ly:stencil-combine-at-edge
 341                        (ly:stencil-combine-at-edge
 342                          (ly:stencil-combine-at-edge
 343                            thick-stil X RIGHT thin-stil kern)
 344                          X RIGHT colon-stil kern)
 345                        X LEFT segno-stil thinkern))
 346                     ((or (string=? glyph ":|S")
 347                          (string=? glyph ":|S."))
 348                      (ly:stencil-combine-at-edge
 349                        (ly:stencil-combine-at-edge
 350                          (ly:stencil-combine-at-edge
 351                            thick-stil X LEFT thin-stil kern)
 352                          X LEFT colon-stil kern)
 353                        X RIGHT segno-stil thinkern))
 354                     ((or (string=? glyph ":|S|:")
 355                          (string=? glyph ":|S.|:"))
 356                      (ly:stencil-combine-at-edge
 357                        (ly:stencil-combine-at-edge
 358                          (ly:stencil-combine-at-edge
 359                            (ly:stencil-combine-at-edge
 360                              (ly:stencil-combine-at-edge
 361                                (ly:stencil-combine-at-edge
 362                                  thick-stil X LEFT thin-stil kern)
 363                                X LEFT colon-stil kern)
 364                              X RIGHT segno-stil thinkern)
 365                            X RIGHT thick-stil thinkern)
 366                          X RIGHT thin-stil kern)
 367                        X RIGHT colon-stil kern))
 368                     ((string=? glyph "|._.|")
 369                      (ly:stencil-combine-at-edge
 370                        (ly:stencil-combine-at-edge
 371                          (ly:stencil-combine-at-edge
 372                            thick-stil X LEFT thin-stil kern)
 373                          X RIGHT thick-stil (+ (interval-length
 374                                                  (ly:stencil-extent segno-stil X))
 375                                                (* 2 thinkern)))
 376                        X RIGHT thin-stil kern))
 377                     (else segno-stil))))
 378
 379        stencil))
 380
 381 (define (make-kievan-bar-line grob)
 382   (let* ((font (ly:grob-default-font grob))
 383          (stencil (stencil-whiteout
 384                     (ly:font-get-glyph font "scripts.barline.kievan"))))
 385
 386         ;; the kievan bar line has mo staff lines underneath,
 387         ;; so we whiteout them and move ithe grob to a higher layer
 388         (ly:grob-set-property! grob 'layer 1)
 389         stencil))
 390
 391 ;; bar line callbacks
 392
 393 (define-public (ly:bar-line::calc-bar-extent grob)
 394   (let ((staff-symbol (get-staff-symbol grob))
 395         (staff-extent (cons 0 0)))
 396
 397        (if (ly:grob? staff-symbol)
 398            (let* ((bar-line-color (ly:grob-property grob 'color))
 399                   (staff-color (ly:grob-property staff-symbol 'color))
 400                   (staff-line-thickness (ly:staff-symbol-line-thickness grob))
 401                   (staff-space (ly:staff-symbol-staff-space grob)))
 402
 403                  (set! staff-extent (ly:staff-symbol::height staff-symbol))
 404
 405                  (if (zero? staff-space)
 406                      (set! staff-space 1.0))
 407
 408                  (if (< (interval-length staff-extent) staff-space)
 409                      ;; staff is too small (perhaps consists of a single line);
 410                      ;; extend the bar line to make it visible
 411                      (set! staff-extent
 412                            (interval-widen staff-extent staff-space))
 413                      ;; Due to rounding problems, bar lines extending to the outermost edges
 414                      ;; of the staff lines appear wrongly in on-screen display
 415                      ;; (and, to a lesser extent, in print) - they stick out a pixel.
 416                      ;; The solution is to extend bar lines only to the middle
 417                      ;; of the staff line - unless they have different colors,
 418                      ;; when it would be undesirable.
 419                      ;;
 420                      ;; This reduction should not influence whether bar is to be
 421                      ;; expanded later, so length is not updated on purpose.
 422                      (if (eq? bar-line-color staff-color)
 423                          (set! staff-extent
 424                                (interval-widen staff-extent
 425                                                (* -1/2 staff-line-thickness)))))))
 426        staff-extent))
 427
 428 (define (bar-line::bar-y-extent grob refpoint)
 429   (let* ((extent (ly:grob-property grob 'bar-extent '(0 . 0)))
 430          (rel-y (ly:grob-relative-coordinate grob refpoint Y))
 431          (y-extent (coord-translate extent rel-y)))
 432
 433         y-extent))
 434
 435 (define-public (ly:bar-line::print grob)
 436   (let ((glyph (ly:grob-property grob 'glyph-name))
 437         (extent (ly:grob-property grob 'bar-extent '(0 . 0))))
 438
 439        (if (and (not (eq? glyph '()))
 440                 (> (interval-length extent) 0))
 441            (bar-line::compound-bar-line grob glyph extent #f)
 442            #f)))
 443
 444 (define-public (bar-line::compound-bar-line grob glyph extent rounded)
 445   (let* ((line-thickness (layout-line-thickness grob))
 446          (height (interval-length extent))
 447          (kern (* (ly:grob-property grob 'kern 1) line-thickness))
 448          (thinkern (* (ly:grob-property grob 'thin-kern 1) line-thickness))
 449          (hair (* (ly:grob-property grob 'hair-thickness 1) line-thickness))
 450          (fatline (* (ly:grob-property grob 'thick-thickness 1) line-thickness))
 451          (thin-stil (make-simple-bar-line grob hair extent rounded))
 452          (thick-stil (make-simple-bar-line grob fatline extent rounded))
 453          (colon-stil (make-colon-bar-line grob))
 454          (glyph (cond
 455                   ((not glyph) "")
 456                   ((string=? glyph "||:") "|:")
 457                   ;; bar-line::compound-bar-line is called only if
 458                   ;; height > 0, but just in case ...
 459                   ((and (string=? glyph ":|")
 460                         (zero? height)) "|.")
 461                   ((and (string=? glyph "|:")
 462                         (zero? height)) ".|")
 463                   (else glyph)))
 464          (stencil (cond
 465                     ((string=? glyph "|") thin-stil)
 466                     ((string=? glyph ".") thick-stil)
 467                     ((string=? glyph "||")
 468                      (ly:stencil-combine-at-edge
 469                        (ly:stencil-combine-at-edge
 470                          '() X LEFT thin-stil thinkern)
 471                        X RIGHT thin-stil thinkern))
 472                     ((string=? glyph "|.")
 473                      (ly:stencil-combine-at-edge
 474                        thick-stil X LEFT thin-stil kern))
 475                     ((string=? glyph ".|")
 476                      (ly:stencil-combine-at-edge
 477                        thick-stil X RIGHT thin-stil kern))
 478                     ((string=? glyph "|:")
 479                      (ly:stencil-combine-at-edge
 480                        (ly:stencil-combine-at-edge
 481                          thick-stil X RIGHT thin-stil kern)
 482                        X RIGHT colon-stil kern))
 483                     ((string=? glyph ":|")
 484                      (ly:stencil-combine-at-edge
 485                        (ly:stencil-combine-at-edge
 486                          thick-stil X LEFT thin-stil kern)
 487                        X LEFT colon-stil kern))
 488                     ((string=? glyph ":|:")
 489                      (ly:stencil-combine-at-edge
 490                        (ly:stencil-combine-at-edge
 491                          (ly:stencil-combine-at-edge
 492                            (ly:stencil-combine-at-edge
 493                              '() X LEFT thick-stil thinkern)
 494                            X LEFT colon-stil kern)
 495                          X RIGHT thick-stil kern)
 496                        X RIGHT colon-stil kern))
 497                     ((string=? glyph ":|.|:")
 498                      (ly:stencil-combine-at-edge
 499                        (ly:stencil-combine-at-edge
 500                          (ly:stencil-combine-at-edge
 501                            (ly:stencil-combine-at-edge
 502                              thick-stil X LEFT thin-stil kern)
 503                            X LEFT colon-stil kern)
 504                          X RIGHT thin-stil kern)
 505                        X RIGHT colon-stil kern))
 506                     ((string=? glyph ":|.:")
 507                      (ly:stencil-combine-at-edge
 508                        (ly:stencil-combine-at-edge
 509                          (ly:stencil-combine-at-edge
 510                            thick-stil X LEFT thin-stil kern)
 511                          X LEFT colon-stil kern)
 512                        X RIGHT colon-stil kern))
 513                     ((string=? glyph ".|.")
 514                      (ly:stencil-combine-at-edge
 515                        (ly:stencil-combine-at-edge
 516                          '() X LEFT thick-stil thinkern)
 517                        X RIGHT thick-stil kern))
 518                     ((string=? glyph "|.|")
 519                      (ly:stencil-combine-at-edge
 520                        (ly:stencil-combine-at-edge
 521                          thick-stil X LEFT thin-stil kern)
 522                        X RIGHT thin-stil kern))
 523                     ((string=? glyph ":")
 524                      (make-dotted-bar-line grob extent))
 525                     ((or (string=? glyph "|._.|")
 526                          (string-contains glyph "S"))
 527                      (make-segno-bar-line grob glyph extent rounded))
 528                     ((string=? glyph "'")
 529                      (make-tick-bar-line grob (interval-end extent) rounded))
 530                     ((string=? glyph "dashed")
 531                      (make-dashed-bar-line grob extent hair))
 532                     ((string=? glyph "kievan")
 533                      (make-kievan-bar-line grob))
 534                     (else (make-empty-bar-line grob extent)))))
 535          stencil))
 536
 537 (define-public (ly:bar-line::calc-anchor grob)
 538   (let* ((line-thickness (layout-line-thickness grob))
 539          (kern (* (ly:grob-property grob 'kern 1) line-thickness))
 540          (glyph (ly:grob-property grob 'glyph-name ""))
 541          (x-extent (ly:grob-extent grob grob X))
 542          (dot-width (+ (interval-length
 543                          (ly:stencil-extent
 544                            (ly:font-get-glyph
 545                              (ly:grob-default-font grob)
 546                              "dots.dot")
 547                            X))
 548                        kern))
 549          (anchor 0.0))
 550
 551         (if (> (interval-length x-extent) 0)
 552             (begin
 553               (set! anchor (interval-center x-extent))
 554               (cond ((string=? glyph "|:")
 555                      (set! anchor (+ anchor (/ dot-width -2.0))))
 556                     ((string=? glyph ":|")
 557                      (set! anchor (+ anchor (/ dot-width 2.0)))))))
 558         anchor))
 559
 560 (define-public (bar-line::calc-glyph-name grob)
 561   (let* ((glyph (ly:grob-property grob 'glyph))
 562          (dir (ly:item-break-dir grob))
 563          (result (assoc-get glyph bar-glyph-alist))
 564          (glyph-name (if (= dir CENTER)
 565                          glyph
 566                          (if (and result
 567                                   (string? (index-cell result dir)))
 568                             (index-cell result dir)
 569                             #f))))
 570         glyph-name))
 571
 572 (define-public (bar-line::calc-break-visibility grob)
 573   (let* ((glyph (ly:grob-property grob 'glyph))
 574          (result (assoc-get glyph bar-glyph-alist)))
 575
 576     (if result
 577         (vector (string? (car result)) #t (string? (cdr result)))
 578         all-invisible)))
 579
 580 ;; which span bar belongs to a bar line?
 581
 582 (define-public span-bar-glyph-alist
 583   '(("|:" . ".|")
 584     ("||:" . ".|")
 585     (":|" . "|.")
 586     (":|.:" . "|.")
 587     (":|:" . ".|.")
 588     (":|.|:" . "|.|")
 589     (":|.|" . "|.")
 590     ("S" . "||" )
 591     ("S|" . "||")
 592     ("|S" . "||")
 593     ("S|:" . ".|")
 594     (".S|:" . ".|")
 595     (":|S" . "|.")
 596     (":|S." . "|.")
 597     (":|S|:" . "|._.|")
 598     (":|S.|:" . "|._.|")
 599     ("kievan" . "")
 600     ("'" . "")))
 601
 602 ;; span bar callbacks
 603
 604 (define-public (ly:span-bar::calc-glyph-name grob)
 605   (let* ((elts (ly:grob-object grob 'elements))
 606          (pos (1- (ly:grob-array-length elts)))
 607          (glyph '()))
 608
 609         (while (and (eq? glyph '())
 610                     (> pos -1))
 611                (begin (set! glyph (ly:grob-property (ly:grob-array-ref elts pos)
 612                                                     'glyph-name))
 613                       (set! pos (1- pos))))
 614          (if (eq? glyph '())
 615              (begin (ly:grob-suicide! grob)
 616                     (set! glyph "")))
 617         (assoc-get glyph span-bar-glyph-alist glyph)))
 618
 619 (define-public (ly:span-bar::width grob)
 620   (let ((width (cons 0 0)))
 621
 622        (if (grob::is-live? grob)
 623            (let* ((glyph (ly:grob-property grob 'glyph-name))
 624                   (stencil (bar-line::compound-bar-line grob glyph (cons -1 1) #f)))
 625
 626                  (set! width (ly:stencil-extent stencil X))))
 627        width))
 628
 629 (define-public (ly:span-bar::before-line-breaking grob)
 630   (let ((elts (ly:grob-object grob 'elements)))
 631
 632        (if (zero? (ly:grob-array-length elts))
 633            (ly:grob-suicide! grob))))
 634
 635 ;; The method used in the following routine depends on bar_engraver
 636 ;; not being removed from staff context.  If bar_engraver is removed,
 637 ;; the size of the staff lines is evaluated as 0, which results in a
 638 ;; solid span bar line with faulty y coordinate.
 639 ;;
 640 ;; This routine was originally by Juergen Reuter, but it was a on the
 641 ;; bulky side. Rewritten by Han-Wen. Ported from c++ to Scheme by Marc Hohl.
 642 (define-public (ly:span-bar::print grob)
 643   (let* ((elts-array (ly:grob-object grob 'elements))
 644          (refp (ly:grob-common-refpoint-of-array grob elts-array Y))
 645          (elts (reverse (sort (ly:grob-array->list elts-array)
 646                               ly:grob-vertical<?)))
 647          ;; Elements must be ordered according to their y coordinates
 648          ;; relative to their common axis group parent.
 649          ;; Otherwise, the computation goes mad.
 650          (glyph (ly:grob-property grob 'glyph-name))
 651          (span-bar empty-stencil))
 652
 653         (if (string? glyph)
 654             (let* ((extents '())
 655                    (make-span-bars '())
 656                    (model-bar #f))
 657
 658                   ;; we compute the extents of each system and store them
 659                   ;; in a list; dito for the 'allow-span-bar property.
 660                   ;; model-bar takes the bar grob, if given.
 661                   (map (lambda (bar)
 662                        (let* ((ext (bar-line::bar-y-extent bar refp))
 663                               (staff-symbol (ly:grob-object bar 'staff-symbol)))
 664
 665                              (if (ly:grob? staff-symbol)
 666                                  (let ((refp-extent (ly:grob-extent staff-symbol refp Y)))
 667
 668                                       (set! ext (interval-union ext refp-extent))
 669
 670                                       (if (> (interval-length ext) 0)
 671                                           (begin
 672                                             (set! extents (append extents (list ext)))
 673                                             (set! model-bar bar)
 674                                             (set! make-span-bars
 675                                               (append make-span-bars
 676                                                       (list (ly:grob-property bar 'allow-span-bar #t))))))))))
 677                        elts)
 678                   ;; if there is no bar grob, we use the callback argument
 679                   (if (not model-bar)
 680                       (set! model-bar grob))
 681                   ;; we discard the first entry in make-span-bars, because its corresponding
 682                   ;; bar line is the uppermost and therefore not connected to another bar line
 683                   (if (pair? make-span-bars)
 684                       (set! make-span-bars (cdr make-span-bars)))
 685                   ;; the span bar reaches from the lower end of the upper staff
 686                   ;; to the upper end of the lower staff - when allow-span-bar is #t
 687                   (reduce (lambda (curr prev)
 688                                   (let ((l (cons 0 0))
 689                                         (allow-span-bar (car make-span-bars)))
 690
 691                                        (set! make-span-bars (cdr make-span-bars))
 692                                        (if (> (interval-length prev) 0)
 693                                            (begin
 694                                              (set! l (cons (cdr prev) (car curr)))
 695                                              (if (or (zero? (interval-length l))
 696                                                      (not allow-span-bar))
 697                                                  (begin
 698                                                    ;; there is overlap between the bar lines
 699                                                    ;; or 'allow-span-bar = #f.
 700                                                    ;; Do nothing.
 701                                                  )
 702                                                  (set! span-bar
 703                                                        (ly:stencil-add span-bar
 704                                                                        (bar-line::compound-bar-line
 705                                                                          model-bar
 706                                                                          glyph
 707                                                                          l
 708                                                                          #f))))))
 709                                        curr))
 710                           "" extents)
 711                   (set! span-bar (ly:stencil-translate-axis
 712                                    span-bar
 713                                    (- (ly:grob-relative-coordinate grob refp Y))
 714                                    Y))))
 715         span-bar))