\version "2.15.36"

#(use-modules (srfi srfi-1))

% Helpers

#(define (positions-in-list obj ls)
  "Search the positions of obj in ls"
  
        (define (positions-in-list-helper obj ls ls1 bypassed)
          (if (null? ls)
              (reverse ls1)
              (if (equal? obj (car ls))
                (begin
                  (set! ls1 (cons bypassed ls1))
                  (positions-in-list-helper obj (cdr ls) ls1 (+ bypassed 1)))
                  (positions-in-list-helper obj (cdr ls) ls1 (+ bypassed 1)))))
                  
  (positions-in-list-helper obj ls '() 0))

#(define (clear-list ls)
  (remove (lambda (x) (equal? " " x)) ls))

#(define (string->string-list strg)
 
  (define (helper-1 strg ls)
    "
    Converts a string into a list of strings, 
    every string of the list has string-length 1
    e.g "1234" -> '("1" "2" "3" "4")
    "
      (if (= (string-length strg) 0)
        (begin 
          (set! ls '(""))
          ls)
        (begin
          (set! ls (cons (substring strg 0 1) ls))
          (if (>= (string-length (string-drop strg 1)) 1)
            (helper-1 (string-drop strg 1) ls)
            (clear-list (reverse ls))))))

  (helper-1 strg '()))
    
#(define (string-list->string ls)

  (define (helper-2 ls strg)
    "
    Converts a list of strings into a string, 
    every string of the list has string-length 1
    e.g '("1" "2" "3" "4") -> "1234"
    "
      (if (null? ls)
        strg 
        (begin
        (set! strg (string-append strg (car ls)))
        (if (null? (cdr ls))
          strg
          (helper-2 (cdr ls) strg)))))
     
 (helper-2 ls ""))
 
#(define (replace-list-elts ls-1 ls-2 ls-3)
"
 ls-3 is supposed to be a list containing several elements to be replaced.
 ls-1 is supposed to be a list containing the elements to be inserted into ls-3
 ls-2 is supposed to be a list containing numbers indicating which position of ls-3 
      should be replaced.
"
  (set! ls-3 
    (append (reverse (cons (car ls-1) (cdr (reverse (list-head ls-3 (+ 1 (car ls-2)))))))
        (list-tail ls-3 (+ 1 (car ls-2)))))
  (if (or (null? (cdr ls-1)) (null? (cdr ls-2)))
    ls-3
    (replace-list-elts (cdr ls-1) (cdr ls-2) ls-3)))
     

#(define (make-new-list l1 alist)
 (let ((l2 '()))
   (map
     (lambda (x) (if (equal? x (caar alist))
                   (set! l2 (cons (cdar alist) l2))
     	   (set! l2 (cons x l2))))
       l1)
   (if (null? (cdr alist))
     (reverse l2)
     (begin
       (set! l1 (reverse l2))
       (make-new-list l1 (cdr alist))))))
     
#(define (convert-strings-of-list ls)
   (map
     (lambda (z) (string-list->string z))
       (map
         (lambda (y) (make-new-list y replace-alist))
           (map (lambda (x) (string->string-list x)) ls))))
     
#(define (make-alist ls proc)
"Constructs an alist, 
 e.g. (make-alist '(1 2 3) 'x)
      -> ((1 . x) (2 . x) (3 . x))"
(cond ((string? proc)
       (map
         (lambda (x) (cons x proc))
         ls))
      ((equal? ls proc)
       (map
        (lambda (x y) (cons x y))
        ls proc))
      ((and (list? ls) (list? proc) (not (equal? ls proc)))
       (if (= (length ls) (length proc))
         (map
           (lambda (x y) (cons x y))
           ls proc)
         (display "Warning: lengths of lists doesn't fit")))
         ))
   
#(define-macro (append-to-alist! ls-1 ls-2 proc)
"Appends a new constructed alist to another list"
 `(set! ,ls-1 (append ,ls-1 (make-alist ,ls-2 ,proc))))
 
  
#(define (set-new-alist! ls-1 ls-2 proc)
  (for-each (lambda (x) (set! ls-1 (acons x proc ls-1))) ls-2) 
  ls-1)
     
#(define (insert-strg l1 strg)
  (define (helper-3 l1 l2 strg)
  "l1 is supposed to be a list of strings.
  insert-strg will return a new list, build of the 
  elements of l1, inserting strg between them.
  e.g.: (insert-strg '("a" "b" "c") "_")
        -> ("a" "_" "b" "_" "c")
  "
   (set! l2 (cons strg (cons (car l1) l2)))
    (if (= (length l1) 2)
      (reverse (cons (car (last-pair l1)) l2))
      (helper-3 (cdr l1) l2 strg)))
  (helper-3 l1 '() strg))
  
         
#(define (count-equal-signs-left strg strg-1) 
   (define (helper strg strg-1 counter)
    "
     Returns the number of equal signs at string-begin.
    "
       (if (or (= (string-length strg) 0) (not (equal? (substring strg 0 1) strg-1)))
         counter
         (begin
            (set! counter (+ 1 counter))
            (helper (string-drop strg 1) strg-1 counter))))
  (helper strg strg-1 0)) 
  
% End of Helpers

#(define (stack-simple-barlines grob stencil print-proc kern ls)
   (set! stencil (ly:stencil-combine-at-edge stencil X RIGHT (car print-proc) kern))
   (if (null? (cdr print-proc))
     stencil
     (stack-simple-barlines grob stencil (cdr print-proc) kern ls)))
   
#(define-public (make-round-filled-box x1 x2 y1 y2 blot-diameter)
   (let* ((width (- x2 x1))
          (height (- y2 y1))
          (blot-diameter (cond ((< width blot-diameter) width)
                              ((< height blot-diameter) height)
                              (else blot-diameter))))
     (ly:make-stencil (list 'round-filled-box (- x1) x2 (- y1) y2 blot-diameter)
                      (cons x1 x2)
                      (cons y1 y2))))      
         
#(define-public (bar-line::calc-anchor grob)
   (let* ((staff-line-thickness (ly:staff-symbol-line-thickness grob))
          (glyph (ly:grob-property grob 'glyph-name))
          (type-ls (string-split glyph #\_))
          (type (car type-ls))
          (reverse-type (string-reverse type))
          (nmbr (count-equal-signs-left type ":"))
          (reverse-nmbr (count-equal-signs-left reverse-type ":"))
          (strg-lngth (string-length type))
          (first-sub-strg (if (and (not (null? type-ls)) (> strg-lngth 1))
                  (substring type 0 1)
                  ""))
          (last-sub-strg (if (and (not (null? type-ls)) (> strg-lngth 1))
                           (substring reverse-type 0 1)
                           ""))
          (kern (* (ly:grob-property grob 'kern 1) staff-line-thickness))
          (x-extent (ly:stencil-extent (bar-line::custom-print grob) X))
          ;;(segno-width (+ (interval-length
          ;;               (ly:stencil-extent
          ;;                (ly:font-get-glyph
          ;;                 (ly:grob-default-font grob)
          ;;                  "scripts.varsegno")
          ;;                X))
          ;;              kern))
          ;;(tick-width (+ staff-line-thickness kern))
          (dot-width (+ (interval-length
                         (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 ((and (string=? last-sub-strg ":") (string=? first-sub-strg ":"))
                      (set! anchor (+ anchor 
                      	      (/ (* nmbr dot-width) 2.0)
                      	      (/ (* reverse-nmbr dot-width) -2.0))))
                     ((string=? first-sub-strg ":")
                      (set! anchor (+ anchor (/ (* nmbr dot-width) 2.0))))
                     ((string=? last-sub-strg ":")
                      (set! anchor (+ anchor (/ (* reverse-nmbr dot-width) -2.0))))
               ;      ((string=? first-sub-strg "S")
               ;       (set! anchor (+ anchor (/ segno-width 2.0))))
               ;      ((string=? first-sub-strg "'")
               ;       (set! anchor (+ anchor (/ tick-width 2.0))))
               )
                      ))
         anchor))
                      
#(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))

% Simple BarLine-print-definitions
                     
#(define-public (make-simple-bar-line grob width extent rounded)
   (let* ((height (interval-length extent))
          (blot-diameter (if rounded
                             (ly:output-def-lookup (ly:grob-layout grob) 'blot-diameter)
                             0)))
   (ly:round-filled-box (cons 0 width)
                           extent
                           blot-diameter)))
     
#(define-public (make-thick-bar-line grob width extent rounded)
   (let* ((staff-line-thickness (ly:staff-symbol-line-thickness grob))
          (fatline (* (ly:grob-property grob 'thick-thickness 1) staff-line-thickness)))
   (make-simple-bar-line grob fatline extent rounded)))

#(define-public (make-tick-bar-line grob width extent rounded)
   (let ((half-staff (* 1/2 (ly:staff-symbol-staff-space grob)))
         (stafflinethick (ly:staff-symbol-line-thickness grob))
         (height (interval-length extent))
         (blot (if rounded
                 (ly:output-def-lookup (ly:grob-layout grob) 'blot-diameter)
                 0)))
   (ly:stencil-translate-axis
     (make-round-filled-box 0 stafflinethick (- height half-staff) (+ height half-staff) blot)
   (interval-start extent) Y)))

#(define-public (make-dotted-bar-line grob extent)
   (let* ((position (round (* (interval-end extent) 2)))
          (correction (if (even? position) 0.5 0.0))
          (stencil empty-stencil))
     (let ((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 
                                (ly:font-get-glyph (ly:grob-default-font grob) "dots.dot")
                                (+ i correction)
                                Y)))))
     stencil))
     
#(define-public (make-dashed-bar-line grob extent thickness)
   (let* ((staff-symbol (ly:grob-object grob 'staff-symbol))
          (staff-extent (ly:grob-extent staff-symbol staff-symbol Y))
          (blot (ly:output-def-lookup (ly:grob-layout grob) 'blot-diameter))
          (line-thickness (ly:staff-symbol-line-thickness grob))
          (staff-space (ly:staff-symbol-staff-space grob))
          (height (- (interval-length extent) 0 ))
          (staff-height (interval-length staff-extent))
          (dash-size (- 1.0 (ly:grob-property grob 'gap 0.3)))
          (num (ceiling (/ (* 1.5 height) (+ dash-size staff-space))))
          (factors-lst
            (map
              (lambda (x) (+ (/ num 100) (* 0.983 (/ height (1- (* 2 num))) x)))
              (iota (* 2 num))))
          (factors (reverse (cdr (reverse (cdr factors-lst)))))
          (stencil empty-stencil)              
          (stencil-2 (ly:stencil-add
                               (ly:stencil-translate-axis 
                                (make-round-filled-box 0 thickness (/ dash-size -2) 0 blot)
                                (+ (interval-end extent)(* 0.5 line-thickness))
                                Y)
                               (ly:stencil-translate-axis 
                                (make-round-filled-box 0 thickness 0 (/ dash-size 2) blot)
                                (- (interval-start extent) (* 0.5 line-thickness))
                                Y)))
          (line-count (ly:grob-property staff-symbol 'line-count 0))
          (diff (- height staff-height)))

        (define (helper args)
             (set! stencil-2
                (ly:stencil-add stencil-2
                     (ly:stencil-translate-axis 
                      (make-round-filled-box 0 (/ thickness 1) 
                                             (car args) (cadr args) blot)
                      (interval-start extent)
                      Y)))
             (if (null? (cddr args))
               stencil-2
               (helper (cddr args))))

   (if (<= diff 0)
            (let ((blot (ly:output-def-lookup (ly:grob-layout grob) 'blot-diameter))
                  (half-space (/ staff-space 2.0))
                  (bar 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) (/ line-thickness 2.0))))
                        (bot-y (max (* (- i dash-size) half-space)
                                    (- 0 (* (1- line-count) half-space) (/ line-thickness 2.0)))))
                    (set! bar (ly:stencil-add bar
                                              (make-round-filled-box 0 thickness bot-y top-y blot)))))
              bar)
              
  (if (zero? num)
            empty-stencil
            (helper factors)))))                           
                        
#(define-public (make-colon-bar-line grob)
   (let* ((dot (ly:font-get-glyph (ly:grob-default-font grob) "dots.dot"))
          (staff-symbol (ly:grob-object grob 'staff-symbol))
          (line-count (ly:grob-property staff-symbol 'line-count 0))
          (staff-space (ly:staff-symbol-staff-space grob))
          (dist (cond ((odd? line-count) 1)
                      ((= line-count 0) 1)
                      ((< staff-space 2) (* 2 staff-space))
                      (else (* 0.5 staff-space))))
          (colon empty-stencil))
     (set! colon (ly:stencil-add colon dot))
     (set! colon (ly:stencil-translate-axis colon dist Y))
     (set! colon (ly:stencil-add colon dot))
     (set! colon (ly:stencil-translate-axis colon (/ dist -2) Y))
     colon))

#(define-public (make-segno-bar-line grob width rounded)
   (let* ((staff-line-thickness (ly:staff-symbol-line-thickness grob))
          (glyph (ly:grob-property grob 'glyph))
          (kern (* (ly:grob-property grob 'kern 1) staff-line-thickness))
          (thinkern (* (ly:grob-property grob 'thin-kern 1) staff-line-thickness))
          (thin-stil (make-simple-bar-line grob width extent rounded))
          (double-line-stencil (ly:stencil-combine-at-edge 
                            thin-stil X LEFT thin-stil thinkern))
          (double-line-stencil-x-length (interval-length (ly:stencil-extent double-line-stencil X)))
          (segno-stil (ly:stencil-add
                        (ly:font-get-glyph (ly:grob-default-font grob) "scripts.varsegno")
                          (ly:stencil-translate-axis
                            double-line-stencil
                            (* 0.5 thinkern) 
                            X))))
   segno-stil)) 

#(define-public (make-segno-span-bar-line grob width rounded)
   (let* ((staff-line-thickness (ly:staff-symbol-line-thickness grob))
          (glyph (ly:grob-property grob 'glyph))
          (kern (* (ly:grob-property grob 'kern 1) staff-line-thickness))
          (thinkern (* (ly:grob-property grob 'thin-kern 1) staff-line-thickness))
          (thin-stil (make-simple-bar-line grob width extent rounded))
          (double-line-stencil (ly:stencil-combine-at-edge 
                            thin-stil X LEFT thin-stil thinkern))
          (segno-stil (ly:font-get-glyph (ly:grob-default-font grob) "scripts.varsegno"))
          (segno-stil-x-extent (ly:stencil-extent segno-stil X))
          (dummy-stil (ly:make-stencil "" segno-stil-x-extent (cons 0 0)))
          (double-line-stencil-x-length (interval-length (ly:stencil-extent double-line-stencil X)))
          (segno-span-stil (ly:stencil-add
                             dummy-stil
                             (ly:stencil-translate-axis
                               double-line-stencil
                               (* 0.5 thinkern) 
                               X))))
        segno-span-stil))
      
#(define-public (make-kievan-bar-line grob)
   (let* ((font (ly:grob-default-font grob))
          (stencil (ly:font-get-glyph font "scripts.barline.kievan")))
         stencil))

#(define-public (make-space-bar-line extent grob)
   (let ((space-bar-stencil (ly:make-stencil "" extent (cons 0 0))))
   space-bar-stencil))
   
#(define-public (make-bracket-right-bar-line grob width extent rounded)
   (let* ((staff-line-thickness (ly:staff-symbol-line-thickness grob))
          (fatline (* (ly:grob-property grob 'thick-thickness 1) staff-line-thickness))
          (bracket-tip-up (ly:font-get-glyph (ly:grob-default-font grob) "brackettips.up"))
          (bracket-tip-up-y-length (interval-length (ly:stencil-extent bracket-tip-up Y)))
          (tip-up (grob-interpret-markup grob
                    (markup #:with-dimensions '(0 . 0) `(0 . ,bracket-tip-up-y-length)
                            #:stencil (ly:font-get-glyph (ly:grob-default-font grob) "brackettips.up"))))
          (tip-down (grob-interpret-markup grob
                      (markup #:with-dimensions '(0 . 0) `(0 . ,bracket-tip-up-y-length)
                              #:stencil (ly:font-get-glyph (ly:grob-default-font grob) "brackettips.down"))))
          (thick-bar (make-thick-bar-line grob width extent rounded))
          (thin-bar (make-simple-bar-line grob width extent rounded))
          (staff-line (ly:output-def-lookup (ly:grob-layout grob) 'line-thickness))
          (kern (* (ly:grob-property grob 'kern) staff-line))
          (stencil (ly:stencil-add
                       thick-bar
                       (ly:stencil-translate-axis
                          tip-up
                          (interval-end extent) Y)
                       (ly:stencil-translate-axis
                          tip-down
                          (interval-start extent) Y))))
   stencil))
   
#(define-public (make-bracket-left-bar-line grob width extent rounded)
   (ly:stencil-scale (make-bracket-right-bar-line grob width extent rounded) -1 1))
       
% End of simple BarLine-print-definitions         
         
#(define basic-glyph-list '("|"  ":"  "*" "!" "" ";" "'" "S" "k" "-" "x" "[" "]"))
     
#(define (bar-glyph-print-procedures grob thickness extent rounded)
   `(("|" . ,(make-simple-bar-line grob thickness extent rounded))
     ("*" . ,(make-dotted-bar-line grob extent))
     (":" . ,(make-colon-bar-line grob))
     ("!" . ,(make-thick-bar-line grob thickness extent rounded))
     ("'" . ,(make-tick-bar-line grob thickness extent rounded))
     (";" . ,(make-dashed-bar-line grob extent thickness))
     ("S" . ,(make-segno-bar-line grob thickness rounded))
     ("k" . ,(make-kievan-bar-line grob))
     ("" . ,empty-stencil)
     ("-" . ,(make-segno-span-bar-line grob thickness rounded))
     ("x" . ,(make-space-bar-line extent grob))
     ("[" . ,(make-bracket-right-bar-line grob thickness extent rounded))
     ("]" . ,(make-bracket-left-bar-line grob thickness extent rounded))
     ))
     
#(define extent '(0 . 0))

#(define-public (bar-line::print-simple-barlines bar-line)
   (let* ((glyph-name (ly:grob-property bar-line 'glyph-name))
          (strg-ls (string->string-list glyph-name))
          (staff-line (ly:output-def-lookup (ly:grob-layout bar-line) 'line-thickness))
          (kern (* (ly:grob-property bar-line 'kern) staff-line))
          (thickness (* 1.0 (ly:grob-property bar-line 'hair-thickness) staff-line))
          (print-proc (map 
                        (lambda (x) (assoc-get x 
                        		(if (member x basic-glyph-list)
                        		   (bar-glyph-print-procedures bar-line thickness extent #t)
                        		   (user-bar-glyph-print-procedures extent bar-line))
                        		  )) 
                       strg-ls))
          (stencil empty-stencil))

   (let ((compound-stencil (cond ((equal? ":|!" glyph-name)
                                  (ly:stencil-combine-at-edge
                                    (ly:stencil-combine-at-edge
                                      (make-thick-bar-line bar-line thickness extent #t) 
                                      X LEFT 
                                      (make-simple-bar-line bar-line thickness extent #t) 
                                      kern)
                                   X LEFT (make-colon-bar-line bar-line) kern)
                                    )
                                 ((and (= 1 (length strg-ls)) (equal? "" (car strg-ls)))
                                  empty-stencil)
                	 ((and (= 1 (length strg-ls)) (member (car strg-ls) bar-glyph-signs-list))
                	    (car print-proc))
                                 ((> (length strg-ls) 1)
                                  (set! stencil (stack-simple-barlines bar-line stencil print-proc kern strg-ls))
                                  stencil)
                                  )))
   compound-stencil)))
   
#(define bar-glyph-signs-list 
  '("|"  ":"  "*" "!" ";" "'" "S" "k" "" "||" "-"
  "|:" "!|:" ":|" ":|!" ":|:" ":!!:" "x" "[" "]"))
  
#(define bar-glyph-alist '(
  ("|" . ("|" . ()))
  (";" . (";" . ()))
  (":" . (":" . ()))
  ("*" . ("*" . ()))
  ("!" . ("!" . ()))
  ("'" . ("'" . ()))
  ("S" . ("||" . "S"))
  ("k" . ("k" . ()))
  ("" . ("" . ""))
  ("[" . ("|" . "["))
  ("]" . ("]" . ()))
  ("||" . ("||" . ()))
  ("|:" . ("|" . "|:"))
  ("!|:" . ("|" . "!|:"))
  (":|" . (":|" . ()))
  (":|!" . (":|!" . ()))
  (":|:" . (":|" . "|:"))
  (":!!:" . (":|!" . "!|:"))
    ))

#(define bar-glyph-print-functions `())
  
#(set! bar-glyph-print-functions
     (set-new-alist! bar-glyph-print-functions bar-glyph-signs-list 
		bar-line::print-simple-barlines))

#(define-public (bar-line::custom-print grob)
   (let* ((glyph-name (ly:grob-property grob 'glyph-name))
          (print-proc (assoc-get glyph-name bar-glyph-print-functions))
          (bar-extent (ly:grob-property grob 'bar-extent '(0 . 0))))
     (set! extent bar-extent)
     (if (procedure? print-proc)
         (print-proc grob)
         (print-proc grob)
         ;(ly:bar-line::print grob)
         )))
      
#(define (set-bar-glyph-alist! custom-type)
  (let* ((type-ls (string-split custom-type #\_))
         (type-ls-lngth (length type-ls))
         (type (car type-ls))
         (strg-lngth (string-length type))
         (strg-ls (string->string-list type))
         (custom-type-left (if (> type-ls-lngth 2)
                              (cadr type-ls)
                              (car type-ls)))
         (custom-type-right (if (> type-ls-lngth 2)
                               (caddr type-ls)
                               '()))
         (type-left (if (and (> strg-lngth 1) (equal? (car (reverse strg-ls)) ":"))
  	           (string-take type (- strg-lngth 1))
  	           type))
         (type-right-default "!|:")
         (segno-type-left (if (and (> strg-lngth 1) (member "S" strg-ls))
         	             (let* ((ls-lngth (string-length (string-list->string (cdr (member "S" strg-ls))))))
         	                (string-take type (- strg-lngth ls-lngth)))
         	             type))
         (segno-type-right (if (and (> strg-lngth 1) (member "S" strg-ls))
         	              (string-list->string (cdr (member "S" strg-ls)))
         	              type)))
         	              
(if (assoc-get type bar-glyph-alist)
  #f
  (if (= type-ls-lngth 1)
    (cond ((= strg-lngth 1)
                (if (equal? type "S")
                  (set! bar-glyph-alist (acons type `("||" . "S") bar-glyph-alist))
                  (set! bar-glyph-alist (acons type `(,type . ()) bar-glyph-alist))
                  ))
          ((and (> strg-lngth 1) (equal? (car (reverse strg-ls)) ":"))
                (if (member "S" strg-ls)
                  (set! bar-glyph-alist (acons type `(,segno-type-left . ,segno-type-right) bar-glyph-alist))
                  (set! bar-glyph-alist (acons type `(,type-left . ,type-right-default) bar-glyph-alist))))
          (else
                (set! bar-glyph-alist (acons type `(,type . ()) bar-glyph-alist))))
    (set! bar-glyph-alist (acons type `(,custom-type-left . ,custom-type-right) bar-glyph-alist))
      )
  )))
  
#(define (set-bar-glyph-print-functions! custom-type)
  (let* ((type-ls (string-split custom-type #\_))
         (type-ls-lngth (length type-ls))
         (type (car type-ls))
         (strg-lngth (string-length type))
         (strg-ls (string->string-list type))
         (custom-type-left (if (> type-ls-lngth 2)
                              (cadr type-ls)
                              (car type-ls)))
         (custom-type-right (if (> type-ls-lngth 2)
                               (caddr type-ls)
                               '()))
         (type-left (if (and (> strg-lngth 1) (equal? (car (reverse strg-ls)) ":"))
  	           (string-take type (- strg-lngth 1))
  	           type))
         (type-right-default "!|:")
         (segno-type-left (if (and (> strg-lngth 1) (member "S" strg-ls))
         	             (let* ((ls-lngth (string-length (string-list->string (cdr (member "S" strg-ls))))))
         	             (string-take type (- strg-lngth ls-lngth)))
         	             type))
         (segno-type-right (if (and (> strg-lngth 1) (member "S" strg-ls))
         	              (string-list->string (cdr (member "S" strg-ls)))
         	              type)))

(if (assoc-get type bar-glyph-print-functions)
  #f
(begin
 (set! bar-glyph-print-functions (acons type bar-line::print-simple-barlines bar-glyph-print-functions))
  (if (= type-ls-lngth 1)
   (begin
     (set! bar-glyph-print-functions (acons type-left bar-line::print-simple-barlines bar-glyph-print-functions))
     (set! bar-glyph-print-functions (acons type-right-default bar-line::print-simple-barlines bar-glyph-print-functions))
     (set! bar-glyph-print-functions (acons segno-type-left bar-line::print-simple-barlines bar-glyph-print-functions))
     (set! bar-glyph-print-functions (acons segno-type-right bar-line::print-simple-barlines bar-glyph-print-functions)))
   (begin
      (set! bar-glyph-print-functions (acons custom-type-left bar-line::print-simple-barlines bar-glyph-print-functions))
      (set! bar-glyph-print-functions (acons custom-type-right bar-line::print-simple-barlines bar-glyph-print-functions)))))
  )
  ))

% new \bar-function

bar =
#(define-music-function (parser location custom-type) (string?)
   (_i "Insert a bar line of type @var{type}")
 (let* ((type-ls (string-split custom-type #\_))
        (type (car type-ls)))

  (set-bar-glyph-alist! custom-type)
  (set-bar-glyph-print-functions! custom-type)
  (set-span-bar-glyphs-alist! custom-type)

  (context-spec-music
   (make-property-set 'whichBar type)
   'Timing)))
 
% Line-break

#(define (index-cell cell dir)
  (if (equal? dir 1)
      (cdr cell)
      (car cell)))
           
#(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 bar-glyph-alist))
         (glyph-name (if (= dir CENTER)
         	        glyph
         	        (if (and result 
         	                 (string? (index-cell result dir)))
         	            (index-cell result dir)
         	            #f))))
    glyph-name))

#(define-public (bar-line::custom-calc-break-visibility grob)
   (let* ((glyph (ly:grob-property grob 'glyph))
          (result (assoc-get glyph bar-glyph-alist)))
     (if result
        (vector (string? (car result)) #t (string? (cdr result)))
        all-invisible)))
   
%  Span-bar  
  
#(define-public (bar-line::print-simple-custom-span-bars bar-line)
   (let* ((glyph-name (ly:grob-property bar-line 'glyph-name))
          (alist-glyph (car (assoc glyph-name span-bar-glyphs-alist)))
          ;(alist-glyph (assoc glyph-name span-bar-glyphs-alist))
          ;(alist-glyph (pair? alist-glyph))
          (new-glyph-name (if (equal? glyph-name alist-glyph)
                            (cdr (assoc glyph-name span-bar-glyphs-alist))
                            glyph-name))
          (orig-strg-ls (string->string-list glyph-name))
          (strg-ls (string->string-list new-glyph-name))
          (staff-line (ly:output-def-lookup (ly:grob-layout bar-line) 'line-thickness))
          (kern (* (ly:grob-property bar-line 'kern) staff-line))
          (thickness (* 1.0 (ly:grob-property bar-line 'hair-thickness) staff-line))
          
          (positions-of-x-in-orig-strg-ls (positions-in-list "x" strg-ls))
          (to-be-replaced (map 
                 (lambda (y) (list-ref orig-strg-ls y))
                   positions-of-x-in-orig-strg-ls))
          (to-be-replaced-stencils (map 
                        (lambda (x) (assoc-get x 
                        		(if (member x basic-glyph-list)
                        		   (bar-glyph-print-procedures bar-line thickness extent #t)
                        		   (user-bar-glyph-print-procedures extent bar-line))
                        		  ))
                       to-be-replaced))
          (stil-ext-ls (map (lambda (c) (ly:stencil-extent c X)) to-be-replaced-stencils))
          (dummy-stils-ls (map (lambda (d) (make-space-bar-line d bar-line)) stil-ext-ls))
          (print-proc (map 
                        (lambda (x) (assoc-get x 
                        		(if (member x basic-glyph-list)
                        		   (bar-glyph-print-procedures bar-line thickness extent #t)
                        		   (user-bar-glyph-print-procedures extent bar-line))
                        		  )) 
                       strg-ls))        
          (new-print-proc (if (null? dummy-stils-ls)
                            print-proc
                            (replace-list-elts dummy-stils-ls positions-of-x-in-orig-strg-ls print-proc)))
          (stencil empty-stencil))
          
   (let ((compound-stencil (cond ((equal? ":|!" glyph-name)
                                  (ly:stencil-combine-at-edge
                                    (ly:stencil-combine-at-edge
                                      (make-thick-bar-line bar-line thickness extent #t) 
                                      X LEFT 
                                      (make-simple-bar-line bar-line thickness extent #t) 
                                      kern)
                                   X LEFT (make-space-bar-line extent bar-line) kern)
                                    )
                                 ((and (= 1 (length strg-ls)) (equal? "" (car strg-ls)))
                                  empty-stencil)
                	 ((and (= 1 (length strg-ls)) (member (car strg-ls) bar-glyph-signs-list))
                	    (car print-proc))
                                 ((> (length strg-ls) 1)
                                  (set! stencil (stack-simple-barlines bar-line stencil new-print-proc kern strg-ls))
                                  stencil))))
   compound-stencil)))

#(define span-bar-glyph-print-functions '())

#(define span-bar-glyph-signs-list 
  '("|"  ":"  "*" "!" ";" "'" "S" "k" "" "||" "-"
  "|:" "!|:" ":|" ":|!" ":|:" ":!!:" "x" "[" "]"))

#(set! span-bar-glyph-print-functions
     (set-new-alist! span-bar-glyph-print-functions span-bar-glyph-signs-list 
		bar-line::print-simple-custom-span-bars))

#(define replace-alist '((":" . "x")
                         ("S" . "x")
                         ("'" . "x")
                         ("u" . "x")
                         ("m" . "x")
                         ("s" . "x")
                         ("k" . "x")
                         ("[" . "x")
                         ("]" . "x")
                         ))
     
#(define (set-span-bar-glyphs-alist! custom-type)
  (let* ((ls (string-split custom-type #\_))
         (type-ls (convert-strings-of-list ls))
         (type-ls-lngth (length type-ls))
         (type (if (>= type-ls-lngth 4)
                 (cadddr ls)
                 (car ls)))
         (strg-lngth (string-length type))
         (strg-ls (string->string-list type))
         (new-type (car type-ls))  
         (segno-type-span (car (convert-strings-of-list (list type))))
         (segno-type-left-bar (if (and (> strg-lngth 1) (member "S" strg-ls))
         	                 (let* ((ls-lngth (string-length (string-list->string (cdr (member "S" strg-ls))))))
         	                    (string-take type (- strg-lngth ls-lngth)))
         	                 type))
         (segno-type-left-span (car (convert-strings-of-list (list segno-type-left-bar))))
         (segno-type-right-bar (if (and (> strg-lngth 1) (member "S" strg-ls))
         	                  (string-list->string (cdr (member "S" strg-ls)))
         	                  type))
         (segno-type-right-span (car (convert-strings-of-list (list segno-type-right-bar))))
         (type-left-bar (if (and (> strg-lngth 1) (equal? (car (reverse strg-ls)) ":"))
  	           (string-take type (- strg-lngth 1))
  	           type))
         (type-left-span (car (convert-strings-of-list (list type-left-bar ))))
         (type-right-bar (if (and (> strg-lngth 1) (equal? (car (reverse strg-ls)) ":"))
  	           (string-drop type 1)
  	           type))
         (type-right-span-default "")
         (xy-1 (if (or (string-contains (car ls) ":")
                       (string-contains (car ls) "k")
                       (string-contains (car ls) "'"))
                 (car type-ls)
                 (car ls)))
         (xy-2 (cond ((and (> type-ls-lngth 1) (> (length ls) 1))
          	        (if (or (string-contains (car ls) ":")
                                (string-contains (car ls) "k")
                                (string-contains (car ls) "'"))
                          (cadr type-ls)
                          (cadr type-ls)))))
         (xy-3 (cond ((and (> type-ls-lngth 1) (> (length ls) 1))
          	        (if (or (string-contains (car ls) ":")
                                (string-contains (car ls) "k")
                                (string-contains (car ls) "'"))
                          (caddr type-ls)
                          (caddr type-ls)))))
         )

  (cond ((= type-ls-lngth 1)
         (cond ((member "S" strg-ls)
                (begin 
                  (if (member type span-bar-glyph-signs-list)
                    #f
                    (set! span-bar-glyphs-alist (acons type segno-type-span span-bar-glyphs-alist)))
                  (if (member segno-type-left-span span-bar-glyph-signs-list)
                    #f
                    (set! span-bar-glyphs-alist (acons segno-type-left-bar segno-type-left-span span-bar-glyphs-alist)))
                  (if (member segno-type-right-span span-bar-glyph-signs-list)
                    #f
                    (set! span-bar-glyphs-alist (acons segno-type-right-bar segno-type-right-span span-bar-glyphs-alist)))
                           ))
               ((> strg-lngth 1)
                (set! span-bar-glyphs-alist (acons type-right-bar type-right-span-default span-bar-glyphs-alist))
                (set! span-bar-glyphs-alist (acons (car ls) xy-1 span-bar-glyphs-alist))
                (set! span-bar-glyphs-alist (acons type-left-bar type-left-span span-bar-glyphs-alist))
                )))
                
        ((and (= type-ls-lngth 3)(= (length ls) 3))
         (set! span-bar-glyphs-alist (acons (car ls) xy-1 span-bar-glyphs-alist))
         (set! span-bar-glyphs-alist (acons (cadr ls) xy-2 span-bar-glyphs-alist))
         (set! span-bar-glyphs-alist (acons (caddr ls) xy-3 span-bar-glyphs-alist)))
         
        ((and (= type-ls-lngth 6) 
              (= (length ls) 6))
                 (begin
                   (set! span-bar-glyphs-alist (acons (cadr ls) (cadr (reverse type-ls)) span-bar-glyphs-alist))
                   (set! span-bar-glyphs-alist (acons (caddr ls) (car (reverse type-ls)) span-bar-glyphs-alist))
                   (set! span-bar-glyphs-alist (acons (car ls) (cadddr type-ls) span-bar-glyphs-alist))
                     ))
        )
  ))
  
%% span-bar-defaults:

#(define-public span-bar-glyphs-alist `())

#(let ((l1 '("'" ":" "k" "" "[" "]"))
       (l2 '("|" "||" ";" "*" "!"))
       (l3 '("S"))
       (l4 '("!|:" ":|!" ":!!:" "|:"))
       (l5 '("!|x" "x|!" "x!!x" "|x"))
       )
    (append-to-alist! span-bar-glyphs-alist l1 "x")
    (append-to-alist! span-bar-glyphs-alist l2 l2)
    (append-to-alist! span-bar-glyphs-alist l3 "-")
    (append-to-alist! span-bar-glyphs-alist l4 l5))

% 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)))
                                  (set! extent l)
                                  (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::print-simple-custom-span-bars model-bar)
                                          )))))))
                   (set! span-bar (ly:stencil-translate-axis
                                    span-bar 
                                    (- (ly:grob-relative-coordinate grob refp Y))
                                    Y))))
         span-bar))

myLayout =
\layout {
  \context {
    \Staff
%    \override BarLine #'layer = #10
    \override BarLine #'break-align-anchor = #bar-line::calc-anchor
    \override BarLine #'glyph-name = #bar-line::custom-calc-glyph-name
    \override BarLine #'break-visibility = #bar-line::custom-calc-break-visibility
    \override BarLine #'stencil = #bar-line::custom-print
  }
  \context {
    \Score
    \override SpanBar #'stencil = #span-bar::print
    %\override BarNumber #'self-alignment-X = #CENTER
    \override BarNumber #'break-visibility = #'#(#f #t #t)
    startRepeatType = "!|:"
    endRepeatType = ":|!"
    doubleRepeatType = ":!!:"
  }
}

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%------- test
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

\layout { 
        \myLayout 
        ragged-right = ##t
}

% If you want to create a bar-line with the predefined print-procedures,
% you can write:
% 
% (1)
% \bar ":'''|!!|''':" 
% That will use the predefined defaults at line-break and for SpanBars.
% 
% (2)
% \bar ":'''|!!|''':1_:'''|!_!|''':"
% That will use custom-defined behaviour at line-break and predefined defaults for SpanBars.
% 
% (3)
% ":'''|!!|''':2_:'''|!2_!|''':2_xxxx;xx;xxxx_xxxx|x_**xxxx"
% That will use custom-defined behaviour at line-break and custom-defined behaviour for SpanBars.
% "x" is a placeholder with no visible output. 
% The extent of "x" is the same as the corresponding substring from the BarLine-glyph.
%
% Note that the numbers don't cause any printed output, they are identifiers. 
% Otherwise one setting would override an other, different setting of the same glyph.
%
% (4)
% Of course you can put it in avariable:
myBarI = { \bar ":'''|!!|''':2_:'''|!2_!|''':2_xxxx;xx;xxxx_xxxx|x_**xxxx" }

myBreak = \break

\markup \fill-line { \bold "Testing predefined print-procedures" }

%%{
mus¹ = \relative c' {
        d1 \bar ":'''|!!|''':"   
        d  \bar ":'''|!!|''':"   
        \override Score.RehearsalMark #'break-visibility = #'#(#t #f #f)
        \mark\markup \fontsize #-5 \center-column { \vspace #2  "default-line-break" "is bad," "specify it!" "See below." }
        \myBreak
        
        e \bar ":'''|!!|''':1_:'''|!1_!|''':1"  
        e \bar ":'''|!!|''':1_:'''|!1_!|''':1"  \myBreak
        
        f \bar ":'''|!!|''':2_:'''|!2_!''':2_xxxx;xx;xxxx_xxxx|x_**xxxx"  
        f \bar ":'''|!!|''':2_:'''|!2_!''':2_xxxx;xx;xxxx_xxxx|x_**xxxx"  \myBreak
                                      
        g \myBarI  
        g \myBarI  \myBreak
        
        a \bar "[|:_|_[|:_xx_|_xx" 
        a \bar "[|:_|_[|:_xx_|_xx" \myBreak
        
        b \bar ":|]_:|]_x_xxx_xxx_x"
        b \bar ":|]_:|]_x_xxx_xxx_x" \myBreak
        
        c \bar ":|][|:_:|]_[|:_xxxxxx_xxx_xxx"
        c \bar ":|][|:_:|]_[|:_xxxxxx_xxx_xxx" \myBreak
        
        cis \bar ":|]S[|:_:|]_S[|:_xxxxxxx_xxx_xxxx"
        cis \bar ":|]S[|:_:|]_S[|:_xxxxxxx_xxx_xxxx" \myBreak
        
        d
}

\score {
        \new StaffGroup <<
        \new Staff \mus¹
        \new Staff \mus¹
        \new Staff \transpose c c'' \mus¹
        >>
}
%%{
\markup \fill-line { \bold "Testing custom-defined print-procedures" } \noPageBreak

% If you want to create a bar-line with a custom-defined print-procedure:
% (1) define the print-procedure. e.g.:

      % Custom-stencil-1
      #(define-public (make-my-bar-line grob)
         (let* ((font (ly:grob-default-font grob))
                (stencil (ly:font-get-glyph font "scripts.segno")))
               stencil))
               
      % Custom-stencil-2 (from the user-list, slightly modified) 
      #(define (my-print-proc grob)
       (let* ((staff-line (ly:output-def-lookup (ly:grob-layout grob) 'line-thickness))
              (kern (* (ly:grob-property grob 'kern) staff-line)))
       (ly:make-stencil
         `(path 0.5
               `(rmoveto 0 -2
                 rlineto 0 4
                 rlineto 1 2
                 rmoveto -1 -6
                 rlineto 1 -2
                 ))
          (cons 0 kern)
          (cons -4 4))))
%}          
% (2) assign a glyph and the print-procedure
   #(define (user-bar-glyph-print-procedures extent grob)
   `(("u" . ,(my-print-proc grob))
     ("m" . ,(make-my-bar-line grob))
     ))
%%{     
% (3) append the custom-glyphs to bar-glyph-signs-list and span-bar-glyphs-alist.
   #(set! bar-glyph-signs-list (cons "u" bar-glyph-signs-list))
   #(set! bar-glyph-signs-list (cons "m" bar-glyph-signs-list))
   
   #(set! span-bar-glyphs-alist (acons "u" "x" span-bar-glyphs-alist))
   #(set! span-bar-glyphs-alist (acons "m" "x" span-bar-glyphs-alist))
   % Because there should be no Spanbar at "u" and "m", they are paired with "x".
  
mus² = \relative c' {
        d1 \bar "u_|_u"   
        d  \bar "u_|_u"   \myBreak
        
        e \bar "m_|_m_x_;_x"  
        e \bar "m_|_m_x_;_x"  \myBreak
        
        f \bar "u|:_|_u|:_xxx_|_xxx"  
        f \bar "u|:_|_u|:_xxx_|_xxx"  \myBreak
        
        g \bar ":|!mu_:|!_mu"  
        g \bar ":|!mu_:|!_mu"  \myBreak
        
        a
}

\score {
        \new StaffGroup <<
        \new Staff \mus²
        \new Staff \mus²
        \new Staff \transpose c c''' \mus²
        >>
}  
%}
%%{
\markup \fill-line { \bold "Testing alternative syntax" } \noPageBreak

% Alternatively you can use the following:

#(define (new-bar ls) 
(string-list->string (insert-strg ls "_")))

#(define myCuriousBarI (new-bar '(":|!S!|:*:|!S!|:" ":|!S!|:*" "*:|!S!|:")))
#(define myCuriousBarII (new-bar 
	'(":|!S!|:*:|!S!|:1" 
	  ":|!S!|:*1" 
	  "*:|!S!|:1"
	  "x;xxx;x*x;xxx;x"
	  "x;xxx;*x"
	  "x*;xxx;x")))

mus³ = \relative c' {
        d1 \bar \myCuriousBarI   
        d  \bar \myCuriousBarI   \myBreak
        
        e \bar \myCuriousBarII  
        e \bar \myCuriousBarII  \myBreak
        a \bar ":|||!*!*!*!*!"
}

\score {
        \new StaffGroup <<
        \new Staff \mus³
        \new Staff \transpose c c'' \mus³
        \new Staff \transpose c c''' \mus³
        >>
} 
%}