\version "2.15.34"

#(define (bar-line::calc-bar-extent grob)
  (let ((staff-symbol (ly:grob-object grob 'staff-symbol))
        (staff-extent (cons 0 0)))
       
       (if (ly:grob? staff-symbol)
           (let* ((bar-line-color (ly:grob-property grob 'color))
                  (staff-color (ly:grob-property staff-symbol 'color))
                  (radius (ly:staff-symbol-staff-radius grob))
                  (line-thickness (ly:staff-symbol-line-thickness grob)))
                 
                 (set! staff-extent (ly:staff-symbol::height staff-symbol))
                 (if (and (eq? bar-line-color staff-color)
                          radius)
                     (interval-widen staff-extent
                       (- 1 (* 1/2 (/ line-thickness radius)))))))
       staff-extent))

#(define (bar-line::bar-y-extent grob refpoint)
   (let* ((extent (ly:grob-property grob 'bar-extent '(0 . 0)))
          (rel-y (ly:grob-relative-coordinate grob refpoint Y))
          (y-extent (coord-translate extent rel-y)))
         
         y-extent))

#(define-public (bar-line::print grob)
   (let ((glyph (ly:grob-property grob 'glyph-name))
         (extent (ly:grob-property grob 'bar-extent '(0 . 0))))

        (if (and (not (eq? glyph '()))
                 (> (interval-length extent) 0))
            (bar-line::compound-bar-line grob glyph extent #f)
            #f)))

#(define-public custom-bar-print-alist
  ;; this alist can contain one ore more entries
  ;; like ("glyph-string" . ,print-procedure)
  `())

#(define-public custom-bar-glyph-alist
  ;; this alist can contain one ore more entries
  ;; like (glyph-string . (glyph-at-end-of-line . glyph-at-begin-of-line))
  `())

#(define-public (bar-line::custom-print grob)
   (let* ((glyph (ly:grob-property 'glyph-name))
          (custom-proc (assoc-get glyph custom-bar-print-alist)))
         
         (if (procedure? custom-proc)
             (custom-proc grob)
             (bar-line::print grob))))

#(define-public (bar-line::custom-calc-glyph-name grob)
   (let* ((glyph (ly:grob-property grob 'glyph))
          (dir (ly:item-break-dir grob))
          (result (assoc-get glyph custom-bar-glyph-alist)))
         
         (if (= dir CENTER)
             glyph
             (if result
                 (and (string? (index-cell result dir))
                      (index-cell result dir))
                 (bar-line::calc-glyph-name grob)))))

% bar line helper functions
%
#(define-public (bar-line::simple-bar-line grob width extent rounded)
  (let ((blot (if rounded
                  (ly:output-def-lookup layout 'blot-diameter)
                  0)))

        (ly:round-filled-box (cons 0 width)
                             extent
                             blot)))

#(define-public (bar-line::tick-bar-line grob height rounded)
  (let ((half-staff (* 1/2 (ly:staff-symbol-staff-space grob)))
        (stafflinethick (ly:staff-symbol-line-thickness grob))
        (blot (if rounded
                  (ly:output-def-lookup layout 'blot-diameter)
                  0)))

       (ly:round-filled-box (cons 0 stafflinethick)
                            (cons (- height half-staff) (+ height half-staff))
                            blot)))

#(define-public (bar-line::colon-bar-line grob)
   (let* ((staff-symbol (ly:grob-object grob 'staff-symbol))
          (line-count (if (ly:grob? staff-symbol)
                          (ly:grob-property staff-symbol 'line-count)
                          0))
          (staff-space (ly:staff-symbol-staff-space grob))
          (dist (cond ((odd? line-count) 1)
                      ((zero? line-count) 1)
                      ((< staff-space 2) (* 2 staff-space))
                      (else (* 0.5 staff-space))))
          (dot (ly:font-get-glyph (ly:grob-default-font grob) "dots.dot"))
          (stencil empty-stencil))
         
         (set! stencil (ly:stencil-add stencil dot))
         (set! stencil (ly:stencil-translate-axis stencil dist Y))
         (set! stencil (ly:stencil-add stencil dot))
         (set! stencil (ly:stencil-translate-axis stencil (/ dist -2) Y))
         stencil))

#(define-public (bar-line::dotted-bar-line grob extent)
   (let* ((position (round (* (interval-end extent) 2)))
          (correction (if (even? position) 0.5 0.0))
          (dot (ly:font-get-glyph (ly:grob-default-font grob) "dots.dot"))
          (stencil empty-stencil)
          (e (round (+ (interval-end extent)
                       (- 0.5 correction)))))
         
         (do ((i (round (+ (interval-start extent)
                           (- 0.5 correction)))
                 (1+ i)))
             ((>= i e))
             (set! stencil
                   (ly:stencil-add stencil
                                   (ly:stencil-translate-axis dot (+ i correction) Y))))
         stencil))
       
#(define-public (bar-line::dashed-bar-line grob extent thickness)
   (let* ((height (interval-length extent))
          (staff-symbol (ly:grob-object grob 'staff-symbol))
          (staff-space (ly:staff-symbol-staff-space grob))
          (line-thickness (ly:staff-symbol-line-thickness grob))
          (dash-size (- 1.0 (ly:grob-property grob 'gap 0.3)))
          (line-count (if (ly:grob? staff-symbol)
                          (ly:grob-property staff-symbol 'line-count)
                          0)))
         
         (if (< (abs (+ line-thickness
                        (* (1- line-count) staff-space)
                        (- height)))
                0.1)
             (let ((blot (ly:output-def-lookup (ly:grob-layout grob) 'blot-diameter))
                   (half-space (/ staff-space 2.0))
                   (half-thick (/ line-thickness 2.0))
                   (stencil empty-stencil))
                  
                  (do ((i (1- line-count) (- i 2)))
                      ((< i (- 1 line-count)))
                      (let ((top-y (min (* (+ i dash-size) half-space)
                                        (+ (* (1- line-count) half-space) half-thick)))
                            (bot-y (max (* (- i dash-size) half-space)
                                        (- 0 (* (1- line-count) half-space) half-thick))))
                           
                           (set! stencil
                                 (ly:stencil-add stencil
                                                 (ly:round-filled-box (cons 0 thickness)
                                                                      (cons bot-y top-y)
                                                                      blot)))))
             stencil)
             (let* ((dashes (/ height staff-space))
                    (total-dash-size (/ height dashes))
                    (factor (/ (- dash-size thickness) staff-space)))
                   
                   (ly:make-stencil (list 'dashed-line
                                          thickness
                                          (* factor total-dash-size)
                                          (* (- 1 factor) total-dash-size)
                                          0
                                          height
                                          (* factor total-dash-size 0.5))
                                    (cons 0 0)
                                    (cons (/ thickness -2) (/ thickness 2)))))))                                                   

#(define-public (bar-line::segno-bar-line grob glyph extent rounded)
   (let* ((staff-line-thickness (ly:staff-symbol-line-thickness grob))
          (kern (* (ly:grob-property grob 'kern 1) staff-line-thickness))
          (thinkern (* (ly:grob-property grob 'thin-kern 1) staff-line-thickness))
          (hair (* (ly:grob-property grob 'hair-thickness 1) staff-line-thickness))
          (fatline (* (ly:grob-property grob 'thick-thickness 1) staff-line-thickness))
          (thin-stil (bar-line::simple-bar-line grob hair extent rounded))
          (thick-stil (bar-line::simple-bar-line grob fatline extent rounded))
          (colon-stil (bar-line::colon-bar-line grob))
          (segno-stil (ly:stencil-add
                        (ly:stencil-combine-at-edge 
                          (ly:stencil-combine-at-edge
                            '() X LEFT thin-stil thinkern)
                          X RIGHT thin-stil thinkern)
                        (ly:font-get-glyph (ly:grob-default-font grob) "scripts.varsegno")))
          (glyph (cond
                   ((string=? glyph "|S") "S")
                   ((string=? glyph "S|") "S")
                   (else glyph)))
          (stencil (cond          
                     ((or (string=? glyph "S|:")
                          (string=? glyph ".S|:"))
                      (ly:stencil-combine-at-edge
                        (ly:stencil-combine-at-edge
                          (ly:stencil-combine-at-edge
                            thick-stil X RIGHT thin-stil kern)
                          X RIGHT colon-stil kern)
                        X LEFT segno-stil thinkern))
                     ((or (string=? glyph ":|S")
                          (string=? glyph ":|S."))
                      (ly:stencil-combine-at-edge
                        (ly:stencil-combine-at-edge
                          (ly:stencil-combine-at-edge
                            thick-stil X LEFT thin-stil kern)
                          X LEFT colon-stil kern)
                        X RIGHT segno-stil thinkern))
                     ((or (string=? glyph ":|S|:")
                          (string=? glyph ":|S.|:"))
                      (ly:stencil-combine-at-edge
                        (ly:stencil-combine-at-edge
                          (ly:stencil-combine-at-edge
                            (ly:stencil-combine-at-edge
                              (ly:stencil-combine-at-edge
                                (ly:stencil-combine-at-edge
                                  thick-stil X LEFT thin-stil kern)
                                X LEFT colon-stil kern)
                              X RIGHT segno-stil thinkern)
                            X RIGHT thick-stil thinkern)
                          X RIGHT thin-stil kern)
                        X RIGHT colon-stil kern))
                     ((string=? glyph "|._.|")
                      (ly:stencil-combine-at-edge
                        (ly:stencil-combine-at-edge
                          (ly:stencil-combine-at-edge
                            thick-stil X LEFT thin-stil kern)
                          X RIGHT thick-stil (+ (interval-length
                                                  (ly:stencil-extent segno-stil X))
                                                (* 2 thinkern)))
                        X RIGHT thin-stil kern))
                     (else segno-stil)))
        )
        stencil))

#(define-public (bar-line::kievan-bar-line grob)
   (let* ((font (ly:grob-default-font grob))
          (stencil (ly:font-get-glyph font "scripts.barline.kievan")))
         stencil))

#(define-public (bar-line::compound-bar-line grob glyph extent rounded)
   (let* ((staff-line-thickness (ly:staff-symbol-line-thickness grob))
          (height (interval-length extent))
          (kern (* (ly:grob-property grob 'kern 1) staff-line-thickness))
          (thinkern (* (ly:grob-property grob 'thin-kern 1) staff-line-thickness))
          (hair (* (ly:grob-property grob 'hair-thickness 1) staff-line-thickness))
          (fatline (* (ly:grob-property grob 'thick-thickness 1) staff-line-thickness))
          (thin-stil (bar-line::simple-bar-line grob hair extent rounded))
          (thick-stil (bar-line::simple-bar-line grob fatline extent rounded))
          (colon-stil (bar-line::colon-bar-line grob))
          (glyph (cond
                   ((string=? glyph "||:") "|:")
                   ;; bar-line::compound-bar-line is called only if
                   ;; height > 0, but just in case ...
                   ((and (string=? glyph ":|")
                         (zero? height)) "|.")
                   ((and (string=? glyph "|:")
                         (zero? height)) ".|")
                   (else glyph)))
          (stencil (cond
                     ((string=? glyph "|") thin-stil)
                     ((string=? glyph ".") thick-stil)
                     ((string=? glyph "||")
                      (ly:stencil-combine-at-edge 
                        (ly:stencil-combine-at-edge
                          '() X LEFT thin-stil thinkern)
                        X RIGHT thin-stil thinkern))
                     ((string=? glyph "|.")
                      (ly:stencil-combine-at-edge
                        thick-stil X LEFT thin-stil kern))
                     ((string=? glyph ".|")
                      (ly:stencil-combine-at-edge
                        thick-stil X RIGHT thin-stil kern))
                     ((string=? glyph "|:")
                      (ly:stencil-combine-at-edge
                        (ly:stencil-combine-at-edge
                          thick-stil X RIGHT thin-stil kern)
                        X RIGHT colon-stil kern))
                     ((string=? glyph ":|")
                      (ly:stencil-combine-at-edge
                        (ly:stencil-combine-at-edge
                          thick-stil X LEFT thin-stil kern)
                        X LEFT colon-stil kern))
                     ((string=? glyph ":|:")
                      (ly:stencil-combine-at-edge
                        (ly:stencil-combine-at-edge
                          (ly:stencil-combine-at-edge
                            (ly:stencil-combine-at-edge 
                              '() X LEFT thick-stil thinkern)
                            X LEFT colon-stil kern)
                          X RIGHT thick-stil kern)
                        X RIGHT colon-stil kern))
                     ((string=? glyph ":|.|:")
                      (ly:stencil-combine-at-edge
                        (ly:stencil-combine-at-edge
                          (ly:stencil-combine-at-edge
                            (ly:stencil-combine-at-edge
                              thick-stil X LEFT thin-stil kern)
                            X LEFT colon-stil kern)
                          X RIGHT thin-stil kern)
                        X RIGHT colon-stil kern))
                     ((string=? glyph ":|.:")
                      (ly:stencil-combine-at-edge
                        (ly:stencil-combine-at-edge 
                          (ly:stencil-combine-at-edge
                            thick-stil X LEFT thin-stil kern)
                          X LEFT colon-stil kern)
                        X RIGHT colon-stil kern))
                     ((string=? glyph ".|.")
                      (ly:stencil-combine-at-edge
                        (ly:stencil-combine-at-edge
                          '() X LEFT thick-stil thinkern)
                        X RIGHT thick-stil kern))
                     ((string=? glyph "|.|")
                      (ly:stencil-combine-at-edge
                        (ly:stencil-combine-at-edge
                          thick-stil X LEFT thin-stil kern)
                        X RIGHT thin-stil kern))
                     ((string=? glyph ":")
                      (bar-line::dotted-bar-line grob extent))
                     ((or (string=? glyph "|._.|")
                          (string-contains glyph "S"))
                      (bar-line::segno-bar-line grob glyph extent rounded))
                     ((string=? glyph "'")
                      (bar-line::tick-bar-line grob (interval-end extent) rounded))
                     ((string=? glyph "dashed")
                      (bar-line::dashed-bar-line grob extent hair))
                     ((string=? glyph "kievan")
                      (bar-line::kievan-bar-line grob))
                     (else (make-filled-box-stencil (cons 0 0) (cons 0 height))))))

         stencil
         ))

#(define-public (bar-line::calc-anchor grob)
   (let* ((staff-line-thickness (ly:staff-symbol-line-thickness grob))
          (kern (* (ly:grob-property grob 'kern 1) staff-line-thickness))
          (glyph (ly:grob-property grob 'glyph-name ""))
          (x-extent (ly:stencil-extent grob X))
          (dot-width (+ (ly:stencil-extent
                          (ly:font-get-glyph
                            (ly:grob-default-font grob)
                            "dots.dot")
                          X)
                        kern))
          (anchor 0.0))

         (if (> (interval-length x-extent) 0)
             (begin
               (set! anchor (interval-center x-extent))
               (cond ((string=? glyph "|:")
                      (set! anchor (+ anchor (/ dot-width -2.0))))
                     ((string=? glyph ":|")
                      (set! anchor (+ anchor (/ dot-width 2.0)))))))
         anchor))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

#(define-public span-bar-glyph-alist
  '(("|:" . ".|")
    ("||:" . ".|")
    (":|" . "|.")
    (":|.:" . "|.")
    (":|:" . ".|.")
    (":|.|:" . "|.|")
    (":|.|" . "|.")
    ("S" . "||" )
    ("S|" . "||")
    ("|S" . "||")
    ("S|:" . ".|")
    (".S|:" . ".|")
    (":|S" . "|.")
    (":|S." . "|.")
    (":|S|:" . "|._.|")
    (":|S.|:" . "|._.|")
    ("kievan" . "")
    ("'" . "")))

#(define-public (span-bar::calc-glyph-name grob)
   (let* ((elts (ly:grob-object grob 'elements))
          (pos (1- (ly:grob-array-length elts)))
          (glyph '()))
         
         (while (and (eq? glyph '())
                     (> pos -1))
                (begin (set! glyph (ly:grob-property (ly:grob-array-ref elts pos)
                                                     'glyph-name))
                       (set! pos (1- pos))))
          (if (eq? glyph '())
              (begin (ly:grob-suicide! grob)
                     (set! glyph "")))
         (assoc-get glyph span-bar-glyph-alist glyph)))

#(define-public (span-bar::width grob)
   (let ((width (cons 0 0)))
        
        (if (grob::is-live? grob)
            (let* ((glyph (ly:grob-property grob 'glyph-name))
                   (stencil (bar-line::compound-bar-line grob glyph (cons -1 1) #f)))
                  
                  (set! width (ly:stencil-extent stencil X))))
        width))

#(define-public (span-bar::before-line-breaking grob)
   (let ((elts (ly:grob-object grob 'elements)))
        
        (if (zero? (ly:grob-array-length elts))
            (ly:grob-suicide! grob))))
                   
#(define-public custom-span-bar-print-alist
  ;; this alist can contain one ore more entries
  ;; like ("glyph-string" . ,print-procedure)
  `())

#(define-public custom-span-bar-glyph-alist
  ;; this alist can contain one ore more entries
  ;; like (glyph-string . (glyph-at-end-of-line . glyph-at-begin-of-line))
  `())

#(define-public (span-bar::custom-print grob)
   (let* ((glyph (ly:grob-property grob 'glyph-name))
          (custom-proc (assoc-get glyph custom-span-bar-print-alist)))
         
         (if (procedure? custom-proc)
             (custom-proc grob)
             (span-bar::print grob))))

% defined in scm/music-functions.scm
#(define-public (vector-extend v x)
  "Make a new vector consisting of V, with X added to the end."
  (let* ((n (vector-length v))
         (nv (make-vector (+ n 1) '())))
    (vector-move-left! v 0 n nv 0)
    (vector-set! nv n x)
    nv))

#(define-public (span-bar::print grob)
   (let* ((elts (ly:grob-object grob 'elements))
          (refp (ly:grob-common-refpoint-of-array grob elts Y))
          (glyph (ly:grob-property grob 'glyph-name))
          (span-bar empty-stencil))
         
         (if (string? glyph)
             (let* ((extents (make-vector 0 '()))
                    (make-span-bar (make-vector 0 '()))
                    (model-bar #f)
                    (elts-size (ly:grob-array-length elts)))
                   
                   (do ((i (1- elts-size) (1- i)))
                       ((< i 0))
                       (let* ((bar (ly:grob-array-ref elts i))
                              (ext (bar-line::bar-y-extent bar refp))
                              (staff-symbol (ly:grob-object bar 'staff-symbol)))

                             (if (ly:grob? staff-symbol)
                                 (let ((refp-extent (ly:grob-extent staff-symbol refp Y)))
                                      
                                      (set! ext (cons (min (car ext) (car refp-extent))
                                                      (max (cdr ext) (cdr refp-extent))))
 
                                      (if (> (interval-length ext) 0)
                                          (begin
                                            (set! extents (vector-extend extents ext))
                                            (set! make-span-bar (vector-extend make-span-bar 
                                                           (ly:grob-property bar 'allow-span-bar)))
                                            (set! model-bar bar)))))))
                   
                   (if (not model-bar)
                       (set! model-bar grob))
                   
                   (do ((i 1 (1+ i)))
                       ((> i (1- (vector-length extents))))
                       (let ((prev-extent (vector-ref extents (1- i)))
                             (curr-extent (vector-ref extents i))
                             (l (cons 0 0)))
                            
                            (if (> (interval-length prev-extent) 0)
                                (begin 
                                  (set! l (cons (cdr prev-extent)
                                                (car curr-extent)))
                                  (if (or (zero? (interval-length l))
                                          (not (vector-ref make-span-bar i)))
                                      (begin
                                        ;; There is overlap between the bar lines. Do nothing.
                                        )
                                      (set! span-bar
                                        (ly:stencil-add
                                          span-bar
                                          (bar-line::compound-bar-line model-bar glyph l #f))))))))
                   (set! span-bar (ly:stencil-translate-axis
                                    span-bar 
                                    (- (ly:grob-relative-coordinate grob refp Y))
                                    Y))))
         span-bar))


music = \relative f {
  c'4 c c c |
  c c c c \bar "|"
  c c c c \bar "."
  c c c c \bar "||"
  c c c c \bar "|:"
  c c c c \bar ":|"
  c c c c \bar ":|:" c c c c \break
  c c c c \bar ":|.|:"
  c c c c \bar ":|.:"
  c c c c \bar ".|."
  c c c c \bar "|.|"
  c c c c \bar "|." c c c c \break
  c c c c \bar ".|"
  c c c c \bar ":"
  c c c c \bar "S|:"
  c c c c \bar ":|S"
  c c c c \bar ":|S|:"
  c c c c \bar "'"
  c c c c \bar "S"
  c c c c \bar "kievan" 
  c c c c \bar "dashed" c c c c
}

\markup {Bars (original C++ routines):}

\score {
  \new Staff {
     \new Voice { \music }
  }
}

\markup {Bars (Scheme routines):}

\score {
  \new Staff {
     \new Voice { 
       \override Staff.BarLine #'bar-extent = #bar-line::calc-bar-extent
       \override Staff.BarLine #'break-align-anchor = #bar-line::calc-anchor
       \override Staff.BarLine #'stencil = #bar-line::print
       \music
     }
  }
}

\pageBreak

\markup {Span Bars (original C++ routines):}

\score {
  \new StaffGroup <<
     \new Staff {
       \new Voice { 
         \music
       }
     }
     \new Staff {
       \new Voice { 
         \music
       }
     }
 >>
}

\markup {Span Bars (Scheme routines):}
\score {
  \new StaffGroup <<
     \new Staff {
       \new Voice { 
         \music
       }
     }
     \new Staff {
       \new Voice { 
         \music
       }
     }
 >>
   
   \layout {
     \context {
       \Staff
       \override BarLine #'bar-extent = #bar-line::calc-bar-extent
       \override BarLine #'break-align-anchor = #bar-line::calc-anchor
       \override BarLine #'stencil = #bar-line::print
     }
     \context {
       \Score
       \override SpanBar #'glyph-name = #span-bar::calc-glyph-name
       \override SpanBar #'X-extent = #span-bar::width
       \override SpanBar #'stencil = #span-bar::print
       \override SpanBar #'before-line-breaking = #span-bar::before-line-breaking
     }
   }
}