Am 05.06.2012 08:29, schrieb Marc Hohl:
Hi all,
Am 03.06.2012 22:58, schrieb Thomas Morley:
Hi,
together with Marc Hohl I was working on Issue 1320 for a couple of
weeks.
Now we have a first working version using a new approach to design
BarLines:
Only simple BarLines are predefined e.g "|" "." ":" etc (plus some
exceptions).
Some defaults for the line-break and the SpanBars are predefined, too.
All is stacked together on-the-fly.
Harm has sent me the latest version of the file with some minor
improvements:
Ok, and here is the file ;-)
Regards,
Marc
\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³
>>
}
%}
_______________________________________________
lilypond-devel mailing list
[email protected]
https://lists.gnu.org/mailman/listinfo/lilypond-devel
