X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fbar-line.scm;h=3fad8f8912949bf96a9944b6a1019432be850cb3;hb=HEAD;hp=370f0d476c3dfffb4c4f50ff6db05864773265ef;hpb=00e988e3411483174d55606b5ac61f3feee504fd;p=lilypond.git diff --git a/scm/bar-line.scm b/scm/bar-line.scm index 370f0d476c..3fad8f8912 100644 --- a/scm/bar-line.scm +++ b/scm/bar-line.scm @@ -1,6 +1,6 @@ ;;;; This file is part of LilyPond, the GNU music typesetter. ;;;; -;;;; Copyright (C) 2009--2012 Marc Hohl +;;;; Copyright (C) 2009--2015 Marc Hohl ;;;; ;;;; LilyPond is free software: you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by @@ -27,7 +27,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; helper functions for staff and layout properties -(define (calc-blot thickness extent grob) +(define (bar-line::calc-blot thickness extent grob) "Calculate the blot diameter by taking @code{'rounded} and the dimensions of the extent into account." (let* ((rounded (ly:grob-property grob 'rounded #f)) @@ -35,12 +35,21 @@ and the dimensions of the extent into account." (let ((blot-diameter (layout-blot-diameter grob)) (height (interval-length extent))) - (cond ((< thickness blot-diameter) thickness) - ((< height blot-diameter) height) - (else blot-diameter))) + (cond ((< thickness blot-diameter) thickness) + ((< height blot-diameter) height) + (else blot-diameter))) 0))) - - blot)) + blot)) + +(define-public (bar-line::draw-filled-box x-ext y-ext thickness extent grob) + "Return a straight bar-line created by @code{ly:round-filled-box} looking at +@var{x-ext}, @var{y-ext}, @var{thickness}. The blot is calculated by +@code{bar-line::calc-blot}, which needs @var{extent} and @var{grob}. +@var{y-ext} is not necessarily of same value as @var{extent}." + (ly:round-filled-box + x-ext + y-ext + (bar-line::calc-blot thickness extent grob))) (define (get-span-glyph bar-glyph) "Get the corresponding span glyph from the @code{span-glyph-bar-alist}. @@ -48,12 +57,12 @@ Pad the string with @code{annotation-char}s to the length of the @var{bar-glyph} string." (let ((span-glyph (assoc-get bar-glyph span-bar-glyph-alist bar-glyph))) - (if (string? span-glyph) - (set! span-glyph (string-pad-right + (if (string? span-glyph) + (set! span-glyph (string-pad-right span-glyph (string-length bar-glyph) replacement-char))) - span-glyph)) + span-glyph)) (define (get-staff-symbol grob) "Return the staff symbol corresponding to Grob @var{grob}." @@ -66,51 +75,51 @@ Pad the string with @code{annotation-char}s to the length of the (let* ((layout (ly:grob-layout grob)) (blot-diameter (ly:output-def-lookup layout 'blot-diameter))) - blot-diameter)) + blot-diameter)) (define (staff-symbol-line-count staff) "Get or compute the number of lines of staff @var{staff}." (let ((line-count 0)) - (if (ly:grob? staff) - (let ((line-pos (ly:grob-property staff 'line-positions '()))) + (if (ly:grob? staff) + (let ((line-pos (ly:grob-property staff 'line-positions '()))) - (set! line-count (if (pair? line-pos) - (length line-pos) - (ly:grob-property staff 'line-count 0))))) + (set! line-count (if (pair? line-pos) + (length line-pos) + (ly:grob-property staff 'line-count 0))))) - line-count)) + line-count)) (define (staff-symbol-line-span grob) (let ((line-pos (ly:grob-property grob 'line-positions '())) (iv (cons 0.0 0.0))) - (if (pair? line-pos) - (begin - (set! iv (cons (car line-pos) (car line-pos))) - (map (lambda (x) - (set! iv (cons (min (car iv) x) - (max (cdr iv) x)))) - (cdr line-pos))) + (if (pair? line-pos) + (begin + (set! iv (cons (car line-pos) (car line-pos))) + (for-each (lambda (x) + (set! iv (cons (min (car iv) x) + (max (cdr iv) x)))) + (cdr line-pos))) - (let ((line-count (ly:grob-property grob 'line-count 0))) + (let ((line-count (ly:grob-property grob 'line-count 0))) - (set! iv (cons (- 1 line-count) - (- line-count 1))))) - iv)) + (set! iv (cons (- 1 line-count) + (- line-count 1))))) + iv)) (define (staff-symbol-line-positions grob) "Get or compute the @code{'line-positions} list from @var{grob}." (let ((line-pos (ly:grob-property grob 'line-positions '()))) - (if (not (pair? line-pos)) - (let* ((line-count (ly:grob-property grob 'line-count 0)) - (height (- line-count 1.0))) + (if (not (pair? line-pos)) + (let* ((line-count (ly:grob-property grob 'line-count 0)) + (height (- line-count 1.0))) - (set! line-pos (map (lambda (x) - (- height (* x 2))) - (iota line-count))))) - line-pos)) + (set! line-pos (map (lambda (x) + (- height (* x 2))) + (iota line-count))))) + line-pos)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; internal helper functions @@ -128,19 +137,19 @@ mandatory to the procedures stored in @code{bar-glyph-print-procedures}." (let ((proc (assoc-get glyph bar-glyph-print-procedures)) (stencil empty-stencil)) - (if (procedure? proc) - (set! stencil (proc grob extent)) - (ly:warning (_ "Bar glyph ~a not known. Ignoring.") glyph)) - stencil)) + (if (procedure? proc) + (set! stencil (proc grob extent)) + (ly:warning (_ "Bar glyph ~a not known. Ignoring.") glyph)) + stencil)) (define (string->string-list str) "Convert a string into a list of strings with length 1. -@code{"aBc"} will be converted to @code{("a" "B" "c")}. -An empty string will be converted to a list containing @code{""}." +@code{\"aBc\"} will be converted to @code{(\"a\" \"B\" \"c\")}. +An empty string will be converted to a list containing @code{\"\"}." (if (and (string? str) (not (zero? (string-length str)))) (map (lambda (s) - (string s)) + (string s)) (string->list str)) (list ""))) @@ -149,25 +158,25 @@ An empty string will be converted to a list containing @code{""}." annotation char from string @var{str}." (let ((pos (string-index str annotation-char))) - (if pos - (substring str 0 pos) - str))) + (if pos + (substring str 0 pos) + str))) (define (check-for-annotation str) "Check whether the annotation char is present in string @var{str}." (if (string? str) (if (string-index str annotation-char) (ly:warning - (_ "Annotation '~a' is allowed in the first argument of a bar line definition only.") - str)))) + (_ "Annotation '~a' is allowed in the first argument of a bar line definition only.") + str)))) (define (check-for-replacement str) "Check whether the replacement char is present in string @var{str}." (if (string? str) (if (string-index str replacement-char) (ly:warning - (_ "Replacement '~a' is allowed in the last argument of a bar line definition only.") - str)))) + (_ "Replacement '~a' is allowed in the last argument of a bar line definition only.") + str)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; functions used by external routines @@ -179,18 +188,18 @@ annotation char from string @var{str}." (last-pos (1- (length sorted-elts))) (idx 0)) - (map (lambda (g) - (ly:grob-set-property! - g - 'has-span-bar - (cons (if (eq? idx last-pos) - #f - grob) - (if (zero? idx) - #f - grob))) - (set! idx (1+ idx))) - sorted-elts))) + (for-each (lambda (g) + (ly:grob-set-property! + g + 'has-span-bar + (cons (if (eq? idx last-pos) + #f + grob) + (if (zero? idx) + #f + grob))) + (set! idx (1+ idx))) + sorted-elts))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Line break decisions. @@ -203,17 +212,17 @@ and as a span bar (@var{span-glyph}) respectively." (check-for-annotation span-glyph) ;; only the last argument may call for replacements (for-each (lambda (s) - (check-for-replacement s)) + (check-for-replacement s)) (list bar-glyph eol-glyph bol-glyph)) ;; the bar-glyph-alist has entries like ;; (bar-glyph . ( eol-glyph . bol-glyph)) (set! bar-glyph-alist - (acons bar-glyph (cons eol-glyph bol-glyph) bar-glyph-alist)) + (acons bar-glyph (cons eol-glyph bol-glyph) bar-glyph-alist)) ;; the span-bar-glyph-alist has entries like ;; (bar-glyph . span-glyph) (set! span-bar-glyph-alist - (acons bar-glyph span-glyph span-bar-glyph-alist))) + (acons bar-glyph span-glyph span-bar-glyph-alist))) (define-session bar-glyph-alist '()) @@ -227,10 +236,10 @@ is not used within the routine." (if (or (not (string? glyph)) (> (string-length glyph) 1)) (ly:warning - (_ "add-bar-glyph-print-procedure: glyph '~a' has to be a single ASCII character.") - glyph) + (_ "add-bar-glyph-print-procedure: glyph '~a' has to be a single ASCII character.") + glyph) (set! bar-glyph-print-procedures - (acons glyph proc bar-glyph-print-procedures)))) + (acons glyph proc bar-glyph-print-procedures)))) (define-session bar-glyph-print-procedures `()) @@ -250,35 +259,38 @@ is not used within the routine." (let* ((line-thickness (layout-line-thickness grob)) (thickness (* (ly:grob-property grob 'hair-thickness 1) line-thickness)) - (blot (calc-blot thickness extent grob)) (extent (bar-line::widen-bar-extent-on-span grob extent))) - - (ly:round-filled-box (cons 0 thickness) - extent - blot))) + (bar-line::draw-filled-box + (cons 0 thickness) + extent + thickness + extent + grob))) (define (make-thick-bar-line grob extent) "Draw a thick bar line." (let* ((line-thickness (layout-line-thickness grob)) (thickness (* (ly:grob-property grob 'thick-thickness 1) line-thickness)) - (blot (calc-blot thickness extent grob)) (extent (bar-line::widen-bar-extent-on-span grob extent))) - - (ly:round-filled-box (cons 0 thickness) - extent - blot))) + (bar-line::draw-filled-box + (cons 0 thickness) + extent + thickness + extent + grob))) (define (make-tick-bar-line grob extent) "Draw a tick bar line." (let* ((half-staff (* 1/2 (ly:staff-symbol-staff-space grob))) (staff-line-thickness (ly:staff-symbol-line-thickness grob)) - (height (interval-end extent)) - (blot (calc-blot staff-line-thickness extent grob))) - - (ly:round-filled-box (cons 0 staff-line-thickness) - (cons (- height half-staff) (+ height half-staff)) - blot))) + (height (interval-end extent))) + (bar-line::draw-filled-box + (cons 0 staff-line-thickness) + (cons (- height half-staff) (+ height half-staff)) + staff-line-thickness + extent + grob))) (define (make-colon-bar-line grob extent) "Draw repeat dots." @@ -366,19 +378,19 @@ is not used within the routine." (- 0.5 correction)))) (counting (interval-length (cons i e))) (stil-list (map - (lambda (x) - (ly:stencil-translate-axis - dot (+ x correction) Y)) - (iota counting i 1)))) + (lambda (x) + (ly:stencil-translate-axis + dot (+ x correction) Y)) + (iota counting i 1)))) - (define (add-stencils! stil l) - (if (null? l) - stil - (if (null? (cdr l)) - (ly:stencil-add stil (car l)) - (add-stencils! (ly:stencil-add stil (car l)) (cdr l))))) + (define (add-stencils! stil l) + (if (null? l) + stil + (if (null? (cdr l)) + (ly:stencil-add stil (car l)) + (add-stencils! (ly:stencil-add stil (car l)) (cdr l))))) - (add-stencils! empty-stencil stil-list))) + (add-stencils! empty-stencil stil-list))) (define (make-dashed-bar-line grob extent) "Draw a dashed bar line." @@ -391,16 +403,16 @@ is not used within the routine." (dash-size (- 1.0 (ly:grob-property grob 'gap 0.3))) (line-count (staff-symbol-line-count staff-symbol))) - (if (< (abs (+ line-thickness - (* (1- line-count) staff-space) - (- height))) - 0.1) - (let ((blot (layout-blot-diameter grob)) - (half-space (/ staff-space 2.0)) - (half-thick (/ line-thickness 2.0)) - (stencil empty-stencil)) + (if (< (abs (+ line-thickness + (* (1- line-count) staff-space) + (- height))) + 0.1) + (let ((blot (layout-blot-diameter grob)) + (half-space (/ staff-space 2.0)) + (half-thick (/ line-thickness 2.0)) + (stencil empty-stencil)) - (map (lambda (i) + (for-each (lambda (i) (let ((top-y (min (* (+ i dash-size) half-space) (+ (* (1- line-count) half-space) half-thick))) @@ -408,31 +420,31 @@ is not used within the routine." (- 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))))) - (iota line-count (1- line-count) (- 2))) - stencil) - (let* ((dashes (/ height staff-space)) - (total-dash-size (/ height dashes)) - (factor (/ (- dash-size thickness) staff-space)) - (stencil (ly:stencil-translate-axis - (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 (/ thickness -2) (/ thickness 2)) - (cons 0 height)) - (interval-start extent) - Y))) - - (ly:stencil-translate-axis stencil (/ thickness 2) X))))) + (set! stencil + (ly:stencil-add + stencil + (ly:round-filled-box (cons 0 thickness) + (cons bot-y top-y) + blot))))) + (iota line-count (1- line-count) (- 2))) + stencil) + (let* ((dashes (/ height staff-space)) + (total-dash-size (/ height dashes)) + (factor (/ (- dash-size thickness) staff-space)) + (stencil (ly:stencil-translate-axis + (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 (/ thickness -2) (/ thickness 2)) + (cons 0 height)) + (interval-start extent) + Y))) + + (ly:stencil-translate-axis stencil (/ thickness 2) X))))) (define ((make-segno-bar-line show-segno) grob extent) @@ -440,40 +452,40 @@ is not used within the routine." the segno sign is drawn over the double bar line; otherwise, it draws the span bar variant, i.e. without the segno sign." (let* ((line-thickness (layout-line-thickness grob)) - (thinkern (* (ly:grob-property grob 'thin-kern 1) line-thickness)) + (segno-kern (* (ly:grob-property grob 'segno-kern 1) line-thickness)) (thin-stil (make-simple-bar-line grob extent)) (double-line-stil (ly:stencil-combine-at-edge - thin-stil - X - LEFT - thin-stil - thinkern)) + thin-stil + X + LEFT + thin-stil + segno-kern)) (segno (ly:font-get-glyph (ly:grob-default-font grob) "scripts.varsegno")) (stencil (ly:stencil-add - (if show-segno - segno - (ly:make-stencil - "" - (ly:stencil-extent segno X) - (cons 0 0))) - (ly:stencil-translate-axis - double-line-stil - (* 1/2 thinkern) - X)))) - - stencil)) + (if show-segno + segno + (ly:make-stencil + "" + (ly:stencil-extent segno X) + (cons 0 0))) + (ly:stencil-translate-axis + double-line-stil + (* 1/2 segno-kern) + X)))) + + stencil)) (define (make-kievan-bar-line grob extent) "Draw a kievan bar line." (let* ((font (ly:grob-default-font grob)) - (stencil (stencil-whiteout - (ly:font-get-glyph font "scripts.barline.kievan")))) + (stencil (stencil-whiteout-box + (ly:font-get-glyph font "scripts.barline.kievan")))) - ;; the kievan bar line has no staff lines underneath, - ;; so we whiteout them and move the grob to a higher layer - (ly:grob-set-property! grob 'layer 1) - stencil)) + ;; the kievan bar line has no staff lines underneath, + ;; so we whiteout-box them and move the grob to a higher layer + (ly:grob-set-property! grob 'layer 1) + stencil)) (define ((make-bracket-bar-line dir) grob extent) "Draw a bracket-style bar line. If @var{dir} is set to @code{LEFT}, the @@ -489,20 +501,20 @@ opening bracket will be drawn, for @code{RIGHT} we get the closing bracket." (cons 0 0) (ly:stencil-extent brackettips-up Y))) (tip-down-stil (ly:make-stencil (ly:stencil-expr brackettips-down) - (cons 0 0) - (ly:stencil-extent brackettips-down Y))) + (cons 0 0) + (ly:stencil-extent brackettips-down Y))) (stencil (ly:stencil-add - thick-stil - (ly:stencil-translate-axis tip-up-stil - (interval-end extent) - Y) - (ly:stencil-translate-axis tip-down-stil - (interval-start extent) - Y)))) - - (if (eq? dir LEFT) - stencil - (ly:stencil-scale stencil -1 1)))) + thick-stil + (ly:stencil-translate-axis tip-up-stil + (interval-end extent) + Y) + (ly:stencil-translate-axis tip-down-stil + (interval-start extent) + Y)))) + + (if (eqv? dir LEFT) + stencil + (ly:stencil-scale stencil -1 1)))) (define ((make-spacer-bar-line glyph) grob extent) "Draw an invisible bar line which has the same dimensions as the one @@ -510,7 +522,7 @@ drawn by the procedure associated with glyph @var{glyph}." (let* ((stil (glyph->stencil glyph grob extent)) (stil-x-extent (ly:stencil-extent stil X))) - (ly:make-stencil "" stil-x-extent extent))) + (ly:make-stencil "" stil-x-extent extent))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; bar line callbacks @@ -519,36 +531,36 @@ drawn by the procedure associated with glyph @var{glyph}." (let ((staff-symbol (get-staff-symbol grob)) (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)) - (half-staff-line-thickness (/ (ly:staff-symbol-line-thickness grob) 2)) - (staff-space (ly:staff-symbol-staff-space grob))) - - (set! staff-extent (ly:staff-symbol::height staff-symbol)) - - (if (zero? staff-space) - (set! staff-space 1.0)) - - (if (< (interval-length staff-extent) staff-space) - ;; staff is too small (perhaps consists of a single line); - ;; extend the bar line to make it visible - (set! staff-extent - (interval-widen staff-extent staff-space)) - ;; Due to rounding problems, bar lines extending to the outermost edges - ;; of the staff lines appear wrongly in on-screen display - ;; (and, to a lesser extent, in print) - they stick out a pixel. - ;; The solution is to extend bar lines only to the middle - ;; of the staff line - unless they have different colors, - ;; when it would be undesirable. - ;; - ;; This reduction should not influence whether the bar is to be - ;; expanded later, so length is not updated on purpose. - (if (eq? bar-line-color staff-color) - (set! staff-extent - (interval-widen staff-extent - (- half-staff-line-thickness))))))) - staff-extent)) + (if (ly:grob? staff-symbol) + (let ((bar-line-color (ly:grob-property grob 'color)) + (staff-color (ly:grob-property staff-symbol 'color)) + (half-staff-line-thickness (/ (ly:staff-symbol-line-thickness grob) 2)) + (staff-space (ly:staff-symbol-staff-space grob))) + + (set! staff-extent (ly:staff-symbol::height staff-symbol)) + + (if (zero? staff-space) + (set! staff-space 1.0)) + + (if (< (interval-length staff-extent) staff-space) + ;; staff is too small (perhaps consists of a single line); + ;; extend the bar line to make it visible + (set! staff-extent + (interval-widen staff-extent staff-space)) + ;; Due to rounding problems, bar lines extending to the outermost edges + ;; of the staff lines appear wrongly in on-screen display + ;; (and, to a lesser extent, in print) - they stick out a pixel. + ;; The solution is to extend bar lines only to the middle + ;; of the staff line - unless they have different colors, + ;; when it would be undesirable. + ;; + ;; This reduction should not influence whether the bar is to be + ;; expanded later, so length is not updated on purpose. + (if (eq? bar-line-color staff-color) + (set! staff-extent + (interval-widen staff-extent + (- half-staff-line-thickness))))))) + staff-extent)) ;; this function may come in handy when defining new bar line glyphs, so ;; we make it public. @@ -559,23 +571,23 @@ drawn by the procedure associated with glyph @var{glyph}." (let ((staff-symbol (get-staff-symbol grob)) (has-span-bar (ly:grob-property grob 'has-span-bar #f))) - (if (and (ly:grob? staff-symbol) - (pair? has-span-bar)) - (let ((bar-line-color (ly:grob-property grob 'color)) - (staff-color (ly:grob-property staff-symbol 'color)) - (half-staff-line-thickness (/ (ly:staff-symbol-line-thickness grob) 2))) - (if (eq? bar-line-color staff-color) - ;; if the colors are equal, ly:bar-line::calc-bar-extent has - ;; shortened the bar line extent by a half-staff-line-thickness - ;; this is reverted on the interval bounds where span bars appear: - (begin - (and (ly:grob? (car has-span-bar)) - (set! extent (cons (- (car extent) half-staff-line-thickness) - (cdr extent)))) - (and (ly:grob? (cdr has-span-bar)) - (set! extent (cons (car extent) - (+ (cdr extent) half-staff-line-thickness)))))))) - extent)) + (if (and (ly:grob? staff-symbol) + (pair? has-span-bar)) + (let ((bar-line-color (ly:grob-property grob 'color)) + (staff-color (ly:grob-property staff-symbol 'color)) + (half-staff-line-thickness (/ (ly:staff-symbol-line-thickness grob) 2))) + (if (eq? bar-line-color staff-color) + ;; if the colors are equal, ly:bar-line::calc-bar-extent has + ;; shortened the bar line extent by a half-staff-line-thickness + ;; this is reverted on the interval bounds where span bars appear: + (begin + (and (ly:grob? (car has-span-bar)) + (set! extent (cons (- (car extent) half-staff-line-thickness) + (cdr extent)))) + (and (ly:grob? (cdr has-span-bar)) + (set! extent (cons (car extent) + (+ (cdr extent) half-staff-line-thickness)))))))) + extent)) (define (bar-line::bar-y-extent grob refpoint) "Compute the y-extent of the bar line relative to @var{refpoint}." @@ -583,24 +595,24 @@ drawn by the procedure associated with glyph @var{glyph}." (rel-y (ly:grob-relative-coordinate grob refpoint Y)) (y-extent (coord-translate extent rel-y))) - y-extent)) + y-extent)) (define-public (ly:bar-line::print grob) "The print routine for bar lines." (let ((glyph-name (ly:grob-property grob 'glyph-name)) (extent (ly:grob-property grob 'bar-extent '(0 . 0)))) - (if (and glyph-name - (> (interval-length extent) 0)) - (bar-line::compound-bar-line grob glyph-name extent) - #f))) + (if (and glyph-name + (> (interval-length extent) 0)) + (bar-line::compound-bar-line grob glyph-name extent) + #f))) (define-public (bar-line::compound-bar-line grob bar-glyph extent) "Build the bar line stencil." (let* ((line-thickness (layout-line-thickness grob)) (kern (* (ly:grob-property grob 'kern 1) line-thickness)) (bar-glyph-list (string->string-list - (strip-string-annotation bar-glyph))) + (strip-string-annotation bar-glyph))) (span-glyph (get-span-glyph bar-glyph)) (span-glyph-list (string->string-list span-glyph)) (neg-stencil empty-stencil) @@ -608,53 +620,53 @@ drawn by the procedure associated with glyph @var{glyph}." (is-first-neg-stencil #t) (is-first-stencil #t)) - ;; We build up two separate stencils first: - ;; (1) the neg-stencil is built from all glyphs that have - ;; a replacement-char in the span bar - ;; (2) the main stencil is built from all remaining glyphs - ;; - ;; Afterwards the neg-stencil is attached left to the - ;; stencil; this ensures that the main stencil starts - ;; at x = 0. - ;; - ;; For both routines holds: - ;; we stack the stencils obtained by the corresponding - ;; single glyphs with spacing 'kern' except for the - ;; first stencil - ;; (Thanks to Harm who came up with this idea!) - (for-each (lambda (bar span) - (if (and (string=? span (string replacement-char)) - is-first-stencil) - (begin - (set! neg-stencil - (ly:stencil-combine-at-edge - neg-stencil - X - RIGHT - (glyph->stencil bar grob extent) - (if is-first-neg-stencil 0 kern))) - (set! is-first-neg-stencil #f)) - (begin - (set! stencil - (ly:stencil-combine-at-edge - stencil - X - RIGHT - (glyph->stencil bar grob extent) - (if is-first-stencil 0 kern))) - (set! is-first-stencil #f)))) - bar-glyph-list span-glyph-list) - ;; if we have a non-empty neg-stencil, - ;; we attach it to the left side of the stencil - (and (not is-first-neg-stencil) - (set! stencil - (ly:stencil-combine-at-edge - stencil - X - LEFT - neg-stencil - kern))) - stencil)) + ;; We build up two separate stencils first: + ;; (1) the neg-stencil is built from all glyphs that have + ;; a replacement-char in the span bar + ;; (2) the main stencil is built from all remaining glyphs + ;; + ;; Afterwards the neg-stencil is attached left to the + ;; stencil; this ensures that the main stencil starts + ;; at x = 0. + ;; + ;; For both routines holds: + ;; we stack the stencils obtained by the corresponding + ;; single glyphs with spacing 'kern' except for the + ;; first stencil + ;; (Thanks to Harm who came up with this idea!) + (for-each (lambda (bar span) + (if (and (string=? span (string replacement-char)) + is-first-stencil) + (begin + (set! neg-stencil + (ly:stencil-combine-at-edge + neg-stencil + X + RIGHT + (glyph->stencil bar grob extent) + (if is-first-neg-stencil 0 kern))) + (set! is-first-neg-stencil #f)) + (begin + (set! stencil + (ly:stencil-combine-at-edge + stencil + X + RIGHT + (glyph->stencil bar grob extent) + (if is-first-stencil 0 kern))) + (set! is-first-stencil #f)))) + bar-glyph-list span-glyph-list) + ;; if we have a non-empty neg-stencil, + ;; we attach it to the left side of the stencil + (and (not is-first-neg-stencil) + (set! stencil + (ly:stencil-combine-at-edge + stencil + X + LEFT + neg-stencil + kern))) + stencil)) (define-public (ly:bar-line::calc-anchor grob) "Calculate the anchor position of a bar line. The anchor is used for @@ -665,22 +677,22 @@ the correct placement of bar numbers etc." (x-extent (ly:grob-extent grob grob X)) (anchor 0.0)) - (and (> (interval-length x-extent) 0) - (if (or (= (length bar-glyph-list) 1) - (string=? bar-glyph span-glyph) - (string=? span-glyph "")) - ;; We use the x-extent of the stencil if either - ;; - we have a single bar-glyph - ;; - bar-glyph and span-glyph are identical - ;; - we have no span-glyph - (set! anchor (interval-center x-extent)) - ;; If the conditions above do not hold,the anchor is the - ;; center of the corresponding span bar stencil extent - (set! anchor (interval-center - (ly:stencil-extent - (span-bar::compound-bar-line grob bar-glyph dummy-extent) - X))))) - anchor)) + (and (> (interval-length x-extent) 0) + (if (or (= (length bar-glyph-list) 1) + (string=? bar-glyph span-glyph) + (string=? span-glyph "")) + ;; We use the x-extent of the stencil if either + ;; - we have a single bar-glyph + ;; - bar-glyph and span-glyph are identical + ;; - we have no span-glyph + (set! anchor (interval-center x-extent)) + ;; If the conditions above do not hold,the anchor is the + ;; center of the corresponding span bar stencil extent + (set! anchor (interval-center + (ly:stencil-extent + (span-bar::compound-bar-line grob bar-glyph dummy-extent) + X))))) + anchor)) (define-public (bar-line::calc-glyph-name grob) "Determine the @code{glyph-name} of the bar line depending on the @@ -692,9 +704,9 @@ line break status." glyph (if (and result (string? (index-cell result dir))) - (index-cell result dir) - #f)))) - glyph-name)) + (index-cell result dir) + #f)))) + glyph-name)) (define-public (bar-line::calc-break-visibility grob) "Calculate the visibility of a bar line at line breaks." @@ -716,92 +728,92 @@ The corresponding SpanBar glyph is computed within (pos (1- (ly:grob-array-length elts))) (glyph-name '())) - (while (and (eq? glyph-name '()) - (> pos -1)) - (begin (set! glyph-name - (ly:grob-property (ly:grob-array-ref elts pos) - 'glyph-name)) - (set! pos (1- pos)))) - (if (eq? glyph-name '()) - (begin (ly:grob-suicide! grob) - (set! glyph-name ""))) - glyph-name)) + (while (and (eq? glyph-name '()) + (> pos -1)) + (begin (set! glyph-name + (ly:grob-property (ly:grob-array-ref elts pos) + 'glyph-name)) + (set! pos (1- pos)))) + (if (eq? glyph-name '()) + (begin (ly:grob-suicide! grob) + (set! glyph-name ""))) + glyph-name)) (define-public (ly:span-bar::width grob) "Compute the width of the SpanBar stencil." (let ((width (cons 0 0))) - (if (grob::is-live? grob) - (let* ((glyph-name (ly:grob-property grob 'glyph-name)) - (stencil (span-bar::compound-bar-line grob - glyph-name - dummy-extent))) + (if (grob::is-live? grob) + (let* ((glyph-name (ly:grob-property grob 'glyph-name)) + (stencil (span-bar::compound-bar-line grob + glyph-name + dummy-extent))) - (set! width (ly:stencil-extent stencil X)))) - width)) + (set! width (ly:stencil-extent stencil X)))) + width)) (define-public (ly:span-bar::before-line-breaking grob) "A dummy callback that kills the Grob @var{grob} if it contains no elements." (let ((elts (ly:grob-object grob 'elements))) - (if (zero? (ly:grob-array-length elts)) - (ly:grob-suicide! grob)))) + (if (zero? (ly:grob-array-length elts)) + (ly:grob-suicide! grob)))) (define-public (span-bar::compound-bar-line grob bar-glyph extent) "Build the stencil of the span bar." (let* ((line-thickness (layout-line-thickness grob)) (kern (* (ly:grob-property grob 'kern 1) line-thickness)) (bar-glyph-list (string->string-list - (strip-string-annotation bar-glyph))) + (strip-string-annotation bar-glyph))) (span-glyph (assoc-get bar-glyph span-bar-glyph-alist 'undefined)) (stencil empty-stencil)) - (if (string? span-glyph) - (let ((span-glyph-list (string->string-list span-glyph)) - (is-first-stencil #t)) - - (for-each (lambda (bar span) - ;; the stencil stack routine is similar to the one - ;; used in bar-line::compound-bar-line, but here, - ;; leading replacement-chars are discarded. - (if (not (and (string=? span (string replacement-char)) - is-first-stencil)) - (begin - (set! stencil - (ly:stencil-combine-at-edge - stencil - X - RIGHT - ;; if the current glyph is the replacement-char, - ;; we take the corresponding glyph from the - ;; bar-glyph-list and insert an empty stencil - ;; with the appropriate width. - ;; (this method would fail if the bar-glyph-list - ;; were shorter than the span-glyph-list, - ;; but this makes hardly any sense from a - ;; typographical point of view - (if (string=? span (string replacement-char)) - ((make-spacer-bar-line bar) grob extent) - (glyph->stencil span grob extent)) - (if is-first-stencil 0 kern))) - (set! is-first-stencil #f)))) - bar-glyph-list span-glyph-list)) - ;; if span-glyph is not a string, it may be #f or 'undefined; - ;; the latter signals that the span bar for the current bar-glyph - ;; is undefined, so we raise a warning. - (if (eq? span-glyph 'undefined) - (ly:warning - (_ "No span bar glyph defined for bar glyph '~a'; ignoring.") - bar-glyph))) - stencil)) + (if (string? span-glyph) + (let ((span-glyph-list (string->string-list span-glyph)) + (is-first-stencil #t)) + + (for-each (lambda (bar span) + ;; the stencil stack routine is similar to the one + ;; used in bar-line::compound-bar-line, but here, + ;; leading replacement-chars are discarded. + (if (not (and (string=? span (string replacement-char)) + is-first-stencil)) + (begin + (set! stencil + (ly:stencil-combine-at-edge + stencil + X + RIGHT + ;; if the current glyph is the replacement-char, + ;; we take the corresponding glyph from the + ;; bar-glyph-list and insert an empty stencil + ;; with the appropriate width. + ;; (this method would fail if the bar-glyph-list + ;; were shorter than the span-glyph-list, + ;; but this makes hardly any sense from a + ;; typographical point of view + (if (string=? span (string replacement-char)) + ((make-spacer-bar-line bar) grob extent) + (glyph->stencil span grob extent)) + (if is-first-stencil 0 kern))) + (set! is-first-stencil #f)))) + bar-glyph-list span-glyph-list)) + ;; if span-glyph is not a string, it may be #f or 'undefined; + ;; the latter signals that the span bar for the current bar-glyph + ;; is undefined, so we raise a warning. + (if (eq? span-glyph 'undefined) + (ly:warning + (_ "No span bar glyph defined for bar glyph '~a'; ignoring.") + bar-glyph))) + stencil)) ;; The method used in the following routine depends on bar_engraver ;; not being removed from staff context. If bar_engraver is removed, ;; the size of the staff lines is evaluated as 0, which results in a ;; solid span bar line with faulty y coordinate. ;; -;; This routine was originally by Juergen Reuter, but it was a on the +;; This routine was originally by Juergen Reuter, but it was on the ;; bulky side. Rewritten by Han-Wen. Ported from c++ to Scheme by Marc Hohl. (define-public (ly:span-bar::print grob) "The print routine for span bars." @@ -815,72 +827,72 @@ no elements." (bar-glyph (ly:grob-property grob 'glyph-name)) (span-bar empty-stencil)) - (if (string? bar-glyph) - (let ((extents '()) - (make-span-bars '()) - (model-bar #f)) + (if (string? bar-glyph) + (let ((extents '()) + (make-span-bars '()) + (model-bar #f)) - ;; we compute the extents of each system and store them - ;; in a list; dito for the 'allow-span-bar property. - ;; model-bar takes the bar grob, if given. - (map (lambda (bar) + ;; we compute the extents of each system and store them + ;; in a list; dito for the 'allow-span-bar property. + ;; model-bar takes the bar grob, if given. + (for-each (lambda (bar) (let ((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 (interval-union ext refp-extent)) - - (if (> (interval-length ext) 0) - (begin - (set! extents (append extents (list ext))) - (set! model-bar bar) - (set! make-span-bars - (append make-span-bars - (list (ly:grob-property - bar - 'allow-span-bar - #t)))))))))) - elts) - ;; if there is no bar grob, we use the callback argument - (if (not model-bar) - (set! model-bar grob)) - ;; we discard the first entry in make-span-bars, - ;; because its corresponding bar line is the - ;; uppermost and therefore not connected to - ;; another bar line - (if (pair? make-span-bars) - (set! make-span-bars (cdr make-span-bars))) - ;; the span bar reaches from the lower end of the upper staff - ;; to the upper end of the lower staff - when allow-span-bar is #t - (reduce (lambda (curr prev) - (let ((span-extent (cons 0 0)) - (allow-span-bar (car make-span-bars))) - - (set! make-span-bars (cdr make-span-bars)) - (if (> (interval-length prev) 0) - (begin - (set! span-extent (cons (cdr prev) - (car curr))) - ;; draw the span bar only when the staff lines - ;; don't overlap and allow-span-bar is #t: - (and (> (interval-length span-extent) 0) - allow-span-bar - (set! span-bar - (ly:stencil-add - span-bar - (span-bar::compound-bar-line - model-bar - bar-glyph - span-extent)))))) - curr)) - "" extents) - (set! span-bar (ly:stencil-translate-axis - span-bar - (- (ly:grob-relative-coordinate grob refp Y)) - Y)))) - span-bar)) + (if (ly:grob? staff-symbol) + (let ((refp-extent (ly:grob-extent staff-symbol refp Y))) + + (set! ext (interval-union ext refp-extent)) + + (if (> (interval-length ext) 0) + (begin + (set! extents (append extents (list ext))) + (set! model-bar bar) + (set! make-span-bars + (append make-span-bars + (list (ly:grob-property + bar + 'allow-span-bar + #t)))))))))) + elts) + ;; if there is no bar grob, we use the callback argument + (if (not model-bar) + (set! model-bar grob)) + ;; we discard the first entry in make-span-bars, + ;; because its corresponding bar line is the + ;; uppermost and therefore not connected to + ;; another bar line + (if (pair? make-span-bars) + (set! make-span-bars (cdr make-span-bars))) + ;; the span bar reaches from the lower end of the upper staff + ;; to the upper end of the lower staff - when allow-span-bar is #t + (reduce (lambda (curr prev) + (let ((span-extent (cons 0 0)) + (allow-span-bar (car make-span-bars))) + + (set! make-span-bars (cdr make-span-bars)) + (if (> (interval-length prev) 0) + (begin + (set! span-extent (cons (cdr prev) + (car curr))) + ;; draw the span bar only when the staff lines + ;; don't overlap and allow-span-bar is #t: + (and (> (interval-length span-extent) 0) + allow-span-bar + (set! span-bar + (ly:stencil-add + span-bar + (span-bar::compound-bar-line + model-bar + bar-glyph + span-extent)))))) + curr)) + "" extents) + (set! span-bar (ly:stencil-translate-axis + span-bar + (- (ly:grob-relative-coordinate grob refp Y)) + Y)))) + span-bar)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; volta bracket functions @@ -892,7 +904,7 @@ no elements." (append volta-bracket-allow-volta-hook-list (list bar-glyph))) (ly:warning (_ ("Volta hook bar line must be a string; ignoring '~a'.") - bar-glyph)))) + bar-glyph)))) (define-session volta-bracket-allow-volta-hook-list '()) @@ -910,80 +922,81 @@ of the volta brackets relative to the bar lines." line-thickness 1/2)) (bar-array (ly:grob-object grob 'bars)) - (bar-array-length (ly:grob-array-length bar-array)) ;; the bar-array starts with the uppermost bar line grob that is ;; covered by the left edge of the volta bracket; more (span) ;; bar line grobs from other staves may follow - (left-bar-line (if (> bar-array-length 0) - (ly:grob-array-ref bar-array 0) - '())) + (left-bar-line (and (ly:grob-array? bar-array) + (positive? (ly:grob-array-length bar-array)) + (ly:grob-array-ref bar-array 0))) ;; we need the vertical-axis-group-index of the left-bar-line ;; to find the corresponding right-bar-line - (vag-index (if (null? left-bar-line) - -1 - (ly:grob-get-vertical-axis-group-index left-bar-line))) + (vag-index (and left-bar-line + (ly:grob-get-vertical-axis-group-index left-bar-line))) ;; the bar line corresponding to the right edge of the volta bracket ;; is the last entry with the same vag-index, so we transform the array to a list, - ;; reverse it and search for suitable entries: - (filtered-grobs (filter (lambda (e) - (eq? (ly:grob-get-vertical-axis-group-index e) - vag-index)) - (reverse (ly:grob-array->list bar-array)))) - ;; we need the first one (if any) - (right-bar-line (if (pair? filtered-grobs) - (car filtered-grobs) - '())) + ;; reverse it and search for the first suitable entry from + ;; the back + (right-bar-line (and left-bar-line + (find (lambda (e) + (eqv? (ly:grob-get-vertical-axis-group-index e) + vag-index)) + (reverse (ly:grob-array->list bar-array))))) ;; the left-bar-line may be a #', ;; so we add "" as a fallback return value - (left-bar-glyph-name (if (null? left-bar-line) - (string annotation-char) - (ly:grob-property left-bar-line 'glyph-name ""))) - (right-bar-glyph-name (if (null? right-bar-line) - (string annotation-char) - (ly:grob-property right-bar-line 'glyph-name ""))) - (left-bar-broken (or (null? left-bar-line) - (not (zero? (ly:item-break-dir left-bar-line))))) - (right-bar-broken (or (null? right-bar-line) - (not (zero? (ly:item-break-dir right-bar-line))))) + (left-bar-glyph-name (if left-bar-line + (ly:grob-property left-bar-line 'glyph-name "") + (string annotation-char))) + (right-bar-glyph-name (if right-bar-line + (ly:grob-property right-bar-line 'glyph-name "") + (string annotation-char))) + ;; This is the original logic. It flags left-bar-broken if + ;; there is no left-bar-line. That seems strange. + (left-bar-broken (not (and left-bar-line + (zero? (ly:item-break-dir left-bar-line))))) + (right-bar-broken (not (and right-bar-line + (zero? (ly:item-break-dir + right-bar-line))))) + ;; Revert to current grob for getting layout info if no + ;; left-bar-line available (left-span-stencil-extent (ly:stencil-extent + (span-bar::compound-bar-line + (or left-bar-line grob) + left-bar-glyph-name + dummy-extent) + X)) + (right-span-stencil-extent (ly:stencil-extent (span-bar::compound-bar-line - left-bar-line - left-bar-glyph-name - dummy-extent) + (or right-bar-line grob) + right-bar-glyph-name + dummy-extent) X)) - (right-span-stencil-extent (ly:stencil-extent - (span-bar::compound-bar-line - right-bar-line - right-bar-glyph-name - dummy-extent) - X)) (left-shorten 0.0) (right-shorten 0.0)) - ;; since "empty" intervals may look like (1.0 . -1.0), we use the - ;; min/max functions to make sure that the placement is not corrupted - ;; in case of empty bar lines - (set! left-shorten - (if left-bar-broken - (- (max 0 (interval-end left-span-stencil-extent)) - (max 0 (interval-end (ly:stencil-extent - (bar-line::compound-bar-line - left-bar-line - left-bar-glyph-name - dummy-extent) - X))) - volta-half-line-thickness) - (- (max 0 (interval-end left-span-stencil-extent)) - volta-half-line-thickness))) - - (set! right-shorten - (if right-bar-broken - (+ (- (max 0 (interval-end right-span-stencil-extent))) - volta-half-line-thickness) - (- (min 0 (interval-start right-span-stencil-extent)) - volta-half-line-thickness))) - - (cons left-shorten right-shorten))) + ;; since "empty" intervals may look like (1.0 . -1.0), we use the + ;; min/max functions to make sure that the placement is not corrupted + ;; in case of empty bar lines + (set! left-shorten + (if left-bar-broken + (- (max 0 (interval-end left-span-stencil-extent)) + (max 0 (interval-end (ly:stencil-extent + (bar-line::compound-bar-line + (or left-bar-line grob) + left-bar-glyph-name + dummy-extent) + X))) + volta-half-line-thickness) + (- (max 0 (interval-end left-span-stencil-extent)) + volta-half-line-thickness))) + + (set! right-shorten + (if right-bar-broken + (+ (- (max 0 (interval-end right-span-stencil-extent))) + volta-half-line-thickness) + (- (min 0 (interval-start right-span-stencil-extent)) + volta-half-line-thickness))) + + (cons left-shorten right-shorten))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; predefined bar glyph print procedures @@ -1048,7 +1061,7 @@ of the volta brackets relative to the bar lines." (define-bar-line ":|." ":|." #f " |.") (define-bar-line ".|:" "|" ".|:" ".|") (define-bar-line "[|:" "|" "[|:" " |") -(define-bar-line ":|]" ":|]" #f " |") +(define-bar-line ":|]" ":|]" #f " | ") (define-bar-line ":|][|:" ":|]" "[|:" " | |") (define-bar-line ".|:-||" "||" ".|:" ".|")