;;;; This file is part of LilyPond, the GNU music typesetter.
;;;;
-;;;; Copyright (C) 2009--2012 Marc Hohl <marc@hohlart.de>
+;;;; Copyright (C) 2009--2015 Marc Hohl <marc@hohlart.de>
;;;;
;;;; LilyPond is free software: you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; You should have received a copy of the GNU General Public License
;;;; along with LilyPond. If not, see <http://www.gnu.org/licenses/>.
-;; helper functions
+
+
+;; TODO:
+;; (1) Dashed bar lines may stick out above and below the staff lines
+;;
+;; (2) Dashed and dotted lines look ugly in combination with span bars
+;;
+;; (This was the case in the c++-version of (span) bar stuff)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; helper functions for staff and layout properties
+
+(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))
+ (blot (if rounded
+ (let ((blot-diameter (layout-blot-diameter grob))
+ (height (interval-length extent)))
+
+ (cond ((< thickness blot-diameter) thickness)
+ ((< height blot-diameter) height)
+ (else blot-diameter)))
+ 0)))
+ 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}.
+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
+ span-glyph
+ (string-length bar-glyph)
+ replacement-char)))
+ span-glyph))
(define (get-staff-symbol grob)
+ "Return the staff symbol corresponding to Grob @var{grob}."
(if (grob::has-interface grob 'staff-symbol-interface)
grob
(ly:grob-object grob 'staff-symbol)))
(define (layout-blot-diameter grob)
+ "Get the blot diameter of the @var{grob}'s corresponding layout."
(let* ((layout (ly:grob-layout grob))
- (blot (ly:output-def-lookup layout 'blot-diameter)))
-
- blot))
+ (blot-diameter (ly:output-def-lookup layout 'blot-diameter)))
-(define (layout-line-thickness grob)
- (let* ((layout (ly:grob-layout grob))
- (line-thickness (ly:output-def-lookup layout 'line-thickness)))
+ blot-diameter))
- line-thickness))
-
-(define (staff-symbol-line-count grob)
+(define (staff-symbol-line-count staff)
+ "Get or compute the number of lines of staff @var{staff}."
(let ((line-count 0))
- (if (ly:grob? grob)
- (let ((line-pos (ly:grob-property grob '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 grob '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)))
-
- (set! line-pos (map (lambda (x)
- (- height (* x 2)))
- (iota line-count)))))
- line-pos))
-
+ (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))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; internal helper functions
+
+(define annotation-char #\-)
+(define replacement-char #\ )
+
+(define dummy-extent (cons -1 1))
+
+
+(define (glyph->stencil glyph grob extent)
+ "Return a stencil computed by the procedure associated with
+glyph @var{glyph}. The arguments @var{grob} and @var{extent} are
+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))
+
+(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{\"\"}."
+ (if (and (string? str)
+ (not (zero? (string-length str))))
+ (map (lambda (s)
+ (string s))
+ (string->list str))
+ (list "")))
+
+(define (strip-string-annotation str)
+ "Strip annotations starting with and including the
+annotation char from string @var{str}."
+ (let ((pos (string-index str annotation-char)))
+
+ (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))))
+
+(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))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; functions used by external routines
(define-public (span-bar::notify-grobs-of-my-existence grob)
+ "Set the @code{'has-span-bar} property for all elements of Grob @var{grob}."
(let* ((elts (ly:grob-array->list (ly:grob-object grob 'elements)))
(sorted-elts (sort elts ly:grob-vertical<?))
(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)))
-
-;; How should a bar line behave at a break?
-;; the following alist has the form
-;; ( unbroken-bar-glyph . ( bar-glyph-at-end-of-line . bar-glyph-at-begin-of-line ))
-
-(define bar-glyph-alist
- '((":|:" . (":|" . "|:"))
- (":|.|:" . (":|" . "|:"))
- (":|.:" . (":|" . "|:"))
- ("||:" . ("||" . "|:"))
- ("dashed" . ("dashed" . '()))
- ("|" . ("|" . ()))
- ("|s" . (() . "|"))
- ("|:" . ("|" . "|:"))
- ("|." . ("|." . ()))
-
- ;; hmm... should we end with a bar line here?
- (".|" . ("|" . ".|"))
- (":|" . (":|" . ()))
- ("||" . ("||" . ()))
- (".|." . (".|." . ()))
- ("|.|" . ("|.|" . ()))
- ("" . ("" . ""))
- (":" . (":" . ""))
- ("." . ("." . ()))
- ("'" . ("'" . ()))
- ("empty" . (() . ()))
- ("brace" . (() . "brace"))
- ("bracket" . (() . "bracket"))
-
- ;; segno bar lines
- ("S" . ("||" . "S"))
- ("|S" . ("|" . "S"))
- ("S|" . ("S" . ()))
- (":|S" . (":|" . "S"))
- (":|S." . (":|S" . ()))
- ("S|:" . ("S" . "|:"))
- (".S|:" . ("|" . "S|:"))
- (":|S|:" . (":|" . "S|:"))
- (":|S.|:" . (":|S" . "|:"))
-
- ;; ancient bar lines
- ("kievan" . ("kievan" . ""))))
-
+ (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.
+
+(define-public (define-bar-line bar-glyph eol-glyph bol-glyph span-glyph)
+ "Define a bar glyph @var{bar-glyph} and its substitute at the end of
+a line (@var{eol-glyph}), at the beginning of a new line (@var{bol-glyph})
+and as a span bar (@var{span-glyph}) respectively."
+ ;; the last argument may not include annotations
+ (check-for-annotation span-glyph)
+ ;; only the last argument may call for replacements
+ (for-each (lambda (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))
+
+ ;; 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)))
+
+(define-session bar-glyph-alist '())
+
+(define-session span-bar-glyph-alist '())
+
+(define-public (add-bar-glyph-print-procedure glyph proc)
+ "Specify the single glyph @var{glyph} that calls print procedure @var{proc}.
+The procedure @var{proc} has to be defined in the form
+@code{(make-...-bar-line grob extent)} even if the @var{extent}
+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)
+ (set! bar-glyph-print-procedures
+ (acons glyph proc bar-glyph-print-procedures))))
+
+(define-session bar-glyph-print-procedures `())
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; drawing functions for various bar line types
+;; to include them and other user-defined functions,
+;; all of them have the form
+;; (make-...-bar-line grob extent)
+;; even if the extent is not used.
(define (make-empty-bar-line grob extent)
+ "Draw an empty bar line."
(ly:make-stencil "" (cons 0 0) extent))
-(define (make-simple-bar-line grob width extent rounded)
- (let ((blot (if rounded
- (layout-blot-diameter grob)
- 0)))
-
- (ly:round-filled-box (cons 0 width)
- extent
- blot)))
-
-(define (make-tick-bar-line grob height rounded)
- (let ((half-staff (* 1/2 (ly:staff-symbol-staff-space grob)))
- (staff-line-thickness (ly:staff-symbol-line-thickness grob))
- (blot (if rounded
- (layout-blot-diameter grob)
- 0)))
-
- (ly:round-filled-box (cons 0 staff-line-thickness)
- (cons (- height half-staff) (+ height half-staff))
- blot)))
-
-(define (make-colon-bar-line grob)
+(define (make-simple-bar-line grob extent)
+ "Draw a simple bar line."
+ (let* ((line-thickness (layout-line-thickness grob))
+ (thickness (* (ly:grob-property grob 'hair-thickness 1)
+ line-thickness))
+ (extent (bar-line::widen-bar-extent-on-span grob extent)))
+ (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))
+ (extent (bar-line::widen-bar-extent-on-span grob extent)))
+ (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)))
+ (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."
(let* ((staff-space (ly:staff-symbol-staff-space grob))
(line-thickness (ly:staff-symbol-line-thickness grob))
(dot (ly:font-get-glyph (ly:grob-default-font grob) "dots.dot"))
(dot-y-length (interval-length (ly:stencil-extent dot Y)))
(stencil empty-stencil)
- ;; the two dots of the repeat sign should be centred at the middle of
- ;; the staff and neither should collide with staff lines
- ;;
- ;; the default distance between centre of dots is composed of
- ;; - a staffline (with width line-thickness)
- ;; - some space below and above dot
- ;; - two half-dots
- ;; and we need to measure it as line positions,
+ ;; the two dots of the repeat sign should be centred at the
+ ;; middle of the staff and neither should collide with staff
+ ;; lines.
+ ;; the required space is measured in line positions,
;; i.e. in half staff spaces.
- ;;
- ;; space between dot and staffline should be comparable to staffline
- ;; width so that a relatively common idiom
- ;; (0.5 staff-size combined with set-layout-staff-size 10) works ok -
- ;; that makes the choice of 1 staffline too big.
- ;; 0.1 will be used if to be positioned between staff lines,
- ;; dot diameter if outside staff.
+
+ ;; dots are to fall into distict spaces, except when there's
+ ;; only one space (and it's big enough to hold two dots and
+ ;; some space between them)
+
+ ;; choose defaults working without any staff
(center 0.0)
(dist (* 4 dot-y-length)))
(set! center
(interval-center (staff-symbol-line-span
staff-symbol)))
- ;; fold the staff into two at center and find the
- ;; first gap big enough to hold a dot and some space
- ;; below and above
- (let* ((half-staff
- (sort (append (map (lambda (lp)
- (abs (- lp center)))
- line-pos)
- '(0.0)) <))
- (gap-to-find (/ (+ dot-y-length
- (* 1.2 line-thickness))
+ ;; fold the staff into two at center
+ (let* ((folded-staff
+ (sort (map (lambda (lp) (abs (- lp center)))
+ line-pos) <))
+ (gap-to-find (/ (+ dot-y-length line-thickness)
(/ staff-space 2)))
- (found #f))
-
- ;; initialize dist for the case when both dots should
- ;; be outside the staff
- (set! dist (+ (* 2 (car (reverse half-staff)))
- (/ (* 4 dot-y-length) staff-space)))
-
- (reduce (lambda (x y) (if (and (> (- x y) gap-to-find)
- (not found))
- (begin
- (set! found #t)
- (set! dist (+ x y))))
- x)
- ""
- half-staff))))))))
+ (first (car folded-staff)))
+
+ ;; find the first space big enough
+ ;; to hold a dot and a staff line
+ ;; (a space in the folded staff may be
+ ;; narrower but can't be wider than the
+ ;; corresponding original spaces)
+ (set! dist
+ (or
+ (any (lambda (x y)
+ (and (> (- y x) gap-to-find)
+ (+ x y)))
+ folded-staff (cdr folded-staff))
+ (if (< gap-to-find first)
+ ;; there's a central space big
+ ;; enough to hold both dots
+ first
+
+ ;; dots should go outside
+ (+ (* 2 (last folded-staff))
+ (/ (* 4 dot-y-length)
+ staff-space))))))))))))
(set! staff-space 1.0))
(let* ((stencil empty-stencil)
(/ staff-space 2)) Y)))
stencil)))
+
(define (make-dotted-bar-line grob extent)
+ "Draw a dotted bar line."
(let* ((position (round (* (interval-end extent) 2)))
(correction (if (even? position) 0.5 0.0))
(dot (ly:font-get-glyph (ly:grob-default-font grob) "dots.dot"))
(- 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))))
-
- (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)))
-
-(define (make-dashed-bar-line grob extent thickness)
+ (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)))))
+
+ (add-stencils! empty-stencil stil-list)))
+
+(define (make-dashed-bar-line grob extent)
+ "Draw a dashed bar line."
(let* ((height (interval-length extent))
(staff-symbol (get-staff-symbol grob))
(staff-space (ly:staff-symbol-staff-space grob))
(line-thickness (layout-line-thickness grob))
+ (thickness (* (ly:grob-property grob 'hair-thickness 1)
+ line-thickness))
(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)))
(- 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)))
-
- (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 0 thickness)
- (cons 0 height))
- (interval-start extent)
- Y)))))
-
-(define (make-segno-bar-line grob glyph extent rounded)
+ (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)
+ "Draw a segno bar line. If @var{show-segno} is set to @code{#t},
+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))
- (kern (* (ly:grob-property grob 'kern 1) line-thickness))
- (thinkern (* (ly:grob-property grob 'thin-kern 1) line-thickness))
- (hair (* (ly:grob-property grob 'hair-thickness 1) line-thickness))
- (fatline (* (ly:grob-property grob 'thick-thickness 1) line-thickness))
- (thin-stil (make-simple-bar-line grob hair extent rounded))
- (thick-stil (make-simple-bar-line grob fatline extent rounded))
- (colon-stil (make-colon-bar-line grob))
- (segno-stil (ly:stencil-add
- (ly:stencil-combine-at-edge
- (ly:stencil-combine-at-edge
- '() X LEFT thin-stil thinkern)
- X RIGHT thin-stil thinkern)
- (ly:font-get-glyph (ly:grob-default-font grob) "scripts.varsegno")))
- (glyph (cond
- ((string=? glyph "|S") "S")
- ((string=? glyph "S|") "S")
- (else glyph)))
- (stencil (cond
- ((or (string=? glyph "S|:")
- (string=? glyph ".S|:"))
- (ly:stencil-combine-at-edge
- (ly:stencil-combine-at-edge
- (ly:stencil-combine-at-edge
- thick-stil X RIGHT thin-stil kern)
- X RIGHT colon-stil kern)
- X LEFT segno-stil thinkern))
- ((or (string=? glyph ":|S")
- (string=? glyph ":|S."))
- (ly:stencil-combine-at-edge
- (ly:stencil-combine-at-edge
- (ly:stencil-combine-at-edge
- thick-stil X LEFT thin-stil kern)
- X LEFT colon-stil kern)
- X RIGHT segno-stil thinkern))
- ((or (string=? glyph ":|S|:")
- (string=? glyph ":|S.|:"))
- (ly:stencil-combine-at-edge
- (ly:stencil-combine-at-edge
- (ly:stencil-combine-at-edge
- (ly:stencil-combine-at-edge
- (ly:stencil-combine-at-edge
- (ly:stencil-combine-at-edge
- thick-stil X LEFT thin-stil kern)
- X LEFT colon-stil kern)
- X RIGHT segno-stil thinkern)
- X RIGHT thick-stil thinkern)
- X RIGHT thin-stil kern)
- X RIGHT colon-stil kern))
- ((string=? glyph "|._.|")
- (ly:stencil-combine-at-edge
- (ly:stencil-combine-at-edge
- (ly:stencil-combine-at-edge
- thick-stil X LEFT thin-stil kern)
- X RIGHT thick-stil (+ (interval-length
- (ly:stencil-extent segno-stil X))
- (* 2 thinkern)))
- X RIGHT thin-stil kern))
- (else segno-stil))))
-
- stencil))
-
-(define (make-kievan-bar-line grob)
+ (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
+ 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 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"))))
-
- ;; the kievan bar line has mo staff lines underneath,
- ;; so we whiteout them and move ithe grob to a higher layer
- (ly:grob-set-property! grob 'layer 1)
- stencil))
-
+ (stencil (stencil-whiteout-box
+ (ly:font-get-glyph font "scripts.barline.kievan"))))
+
+ ;; 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
+opening bracket will be drawn, for @code{RIGHT} we get the closing bracket."
+ (let* ((thick-stil (make-thick-bar-line grob extent))
+ (brackettips-up (ly:font-get-glyph (ly:grob-default-font grob)
+ "brackettips.up"))
+ (brackettips-down (ly:font-get-glyph (ly:grob-default-font grob)
+ "brackettips.down"))
+ ;; the x-extent of the brackettips must not be taken into account
+ ;; for bar line constructs like "[|:", so we set new bounds:
+ (tip-up-stil (ly:make-stencil (ly:stencil-expr brackettips-up)
+ (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)))
+ (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 (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
+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)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; bar line callbacks
(define-public (ly:bar-line::calc-bar-extent grob)
(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))
- (radius (ly:staff-symbol-staff-radius grob))
- (staff-line-thickness (ly:staff-symbol-line-thickness grob)))
-
- ;; 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.
- (set! staff-extent (ly:staff-symbol::height staff-symbol))
- (if (and (eq? bar-line-color staff-color)
- radius)
- (set! staff-extent
- (interval-scale staff-extent
- (- 1 (* 1/2 (/ staff-line-thickness radius))))))))
- 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.
+;; This code should not be included in ly:bar-line::calc-bar-extent, because
+;; this may confuse the drawing functions for dashed and dotted bar lines.
+(define-public (bar-line::widen-bar-extent-on-span grob extent)
+ "Widens the bar line @var{extent} towards span bars adjacent to grob @var{grob}."
+ (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))
(define (bar-line::bar-y-extent grob refpoint)
+ "Compute the y-extent of the bar line relative to @var{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))
+ y-extent))
(define-public (ly:bar-line::print grob)
- (let ((glyph (ly:grob-property grob 'glyph-name))
+ "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 (not (eq? glyph '()))
- (> (interval-length extent) 0))
- (bar-line::compound-bar-line grob glyph extent #f)
- #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 glyph extent rounded)
+(define-public (bar-line::compound-bar-line grob bar-glyph extent)
+ "Build the bar line stencil."
(let* ((line-thickness (layout-line-thickness grob))
- (height (interval-length extent))
(kern (* (ly:grob-property grob 'kern 1) line-thickness))
- (thinkern (* (ly:grob-property grob 'thin-kern 1) line-thickness))
- (hair (* (ly:grob-property grob 'hair-thickness 1) line-thickness))
- (fatline (* (ly:grob-property grob 'thick-thickness 1) line-thickness))
- (thin-stil (make-simple-bar-line grob hair extent rounded))
- (thick-stil (make-simple-bar-line grob fatline extent rounded))
- (colon-stil (make-colon-bar-line grob))
- (glyph (cond
- ((not glyph) "")
- ((string=? glyph "||:") "|:")
- ;; bar-line::compound-bar-line is called only if
- ;; height > 0, but just in case ...
- ((and (string=? glyph ":|")
- (zero? height)) "|.")
- ((and (string=? glyph "|:")
- (zero? height)) ".|")
- (else glyph)))
- (stencil (cond
- ((string=? glyph "|") thin-stil)
- ((string=? glyph ".") thick-stil)
- ((string=? glyph "||")
- (ly:stencil-combine-at-edge
- (ly:stencil-combine-at-edge
- '() X LEFT thin-stil thinkern)
- X RIGHT thin-stil thinkern))
- ((string=? glyph "|.")
- (ly:stencil-combine-at-edge
- thick-stil X LEFT thin-stil kern))
- ((string=? glyph ".|")
- (ly:stencil-combine-at-edge
- thick-stil X RIGHT thin-stil kern))
- ((string=? glyph "|:")
- (ly:stencil-combine-at-edge
- (ly:stencil-combine-at-edge
- thick-stil X RIGHT thin-stil kern)
- X RIGHT colon-stil kern))
- ((string=? glyph ":|")
- (ly:stencil-combine-at-edge
- (ly:stencil-combine-at-edge
- thick-stil X LEFT thin-stil kern)
- X LEFT colon-stil kern))
- ((string=? glyph ":|:")
- (ly:stencil-combine-at-edge
- (ly:stencil-combine-at-edge
- (ly:stencil-combine-at-edge
- (ly:stencil-combine-at-edge
- '() X LEFT thick-stil thinkern)
- X LEFT colon-stil kern)
- X RIGHT thick-stil kern)
- X RIGHT colon-stil kern))
- ((string=? glyph ":|.|:")
- (ly:stencil-combine-at-edge
- (ly:stencil-combine-at-edge
- (ly:stencil-combine-at-edge
- (ly:stencil-combine-at-edge
- thick-stil X LEFT thin-stil kern)
- X LEFT colon-stil kern)
- X RIGHT thin-stil kern)
- X RIGHT colon-stil kern))
- ((string=? glyph ":|.:")
- (ly:stencil-combine-at-edge
- (ly:stencil-combine-at-edge
- (ly:stencil-combine-at-edge
- thick-stil X LEFT thin-stil kern)
- X LEFT colon-stil kern)
- X RIGHT colon-stil kern))
- ((string=? glyph ".|.")
- (ly:stencil-combine-at-edge
- (ly:stencil-combine-at-edge
- '() X LEFT thick-stil thinkern)
- X RIGHT thick-stil kern))
- ((string=? glyph "|.|")
- (ly:stencil-combine-at-edge
- (ly:stencil-combine-at-edge
- thick-stil X LEFT thin-stil kern)
- X RIGHT thin-stil kern))
- ((string=? glyph ":")
- (make-dotted-bar-line grob extent))
- ((or (string=? glyph "|._.|")
- (string-contains glyph "S"))
- (make-segno-bar-line grob glyph extent rounded))
- ((string=? glyph "'")
- (make-tick-bar-line grob (interval-end extent) rounded))
- ((string=? glyph "dashed")
- (make-dashed-bar-line grob extent hair))
- ((string=? glyph "kievan")
- (make-kievan-bar-line grob))
- (else (make-empty-bar-line grob extent)))))
- stencil))
+ (bar-glyph-list (string->string-list
+ (strip-string-annotation bar-glyph)))
+ (span-glyph (get-span-glyph bar-glyph))
+ (span-glyph-list (string->string-list span-glyph))
+ (neg-stencil empty-stencil)
+ (stencil empty-stencil)
+ (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))
(define-public (ly:bar-line::calc-anchor grob)
- (let* ((line-thickness (layout-line-thickness grob))
- (kern (* (ly:grob-property grob 'kern 1) line-thickness))
- (glyph (ly:grob-property grob 'glyph-name ""))
+ "Calculate the anchor position of a bar line. The anchor is used for
+the correct placement of bar numbers etc."
+ (let* ((bar-glyph (ly:grob-property grob 'glyph-name ""))
+ (bar-glyph-list (string->string-list (strip-string-annotation bar-glyph)))
+ (span-glyph (assoc-get bar-glyph span-bar-glyph-alist bar-glyph))
(x-extent (ly:grob-extent grob grob X))
- (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 ((string=? glyph "|:")
- (set! anchor (+ anchor (/ dot-width -2.0))))
- ((string=? glyph ":|")
- (set! anchor (+ anchor (/ dot-width 2.0)))))))
- 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
+line break status."
(let* ((glyph (ly:grob-property grob 'glyph))
(dir (ly:item-break-dir grob))
(result (assoc-get glyph bar-glyph-alist))
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."
(let* ((glyph (ly:grob-property grob 'glyph))
(result (assoc-get glyph bar-glyph-alist)))
(vector (string? (car result)) #t (string? (cdr result)))
all-invisible)))
-;; which span bar belongs to a bar line?
-
-(define-public span-bar-glyph-alist
- '(("|:" . ".|")
- ("||:" . ".|")
- (":|" . "|.")
- (":|.:" . "|.")
- (":|:" . ".|.")
- (":|.|:" . "|.|")
- (":|.|" . "|.")
- ("S" . "||" )
- ("S|" . "||")
- ("|S" . "||")
- ("S|:" . ".|")
- (".S|:" . ".|")
- (":|S" . "|.")
- (":|S." . "|.")
- (":|S|:" . "|._.|")
- (":|S.|:" . "|._.|")
- ("kievan" . "")
- ("'" . "")))
-
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; span bar callbacks
(define-public (ly:span-bar::calc-glyph-name grob)
+ "Return the @code{'glyph-name} of the corresponding BarLine grob.
+The corresponding SpanBar glyph is computed within
+@code{span-bar::compound-bar-line}."
(let* ((elts (ly:grob-object grob 'elements))
(pos (1- (ly:grob-array-length elts)))
- (glyph '()))
-
- (while (and (eq? glyph '())
- (> pos -1))
- (begin (set! glyph (ly:grob-property (ly:grob-array-ref elts pos)
- 'glyph-name))
- (set! pos (1- pos))))
- (if (eq? glyph '())
- (begin (ly:grob-suicide! grob)
- (set! glyph "")))
- (assoc-get glyph span-bar-glyph-alist glyph)))
+ (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 (ly:grob-property grob 'glyph-name))
- (stencil (bar-line::compound-bar-line grob glyph (cons -1 1) #f)))
+ (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)))
+ (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))
;; 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."
(let* ((elts-array (ly:grob-object grob 'elements))
(refp (ly:grob-common-refpoint-of-array grob elts-array Y))
(elts (reverse (sort (ly:grob-array->list elts-array)
;; Elements must be ordered according to their y coordinates
;; relative to their common axis group parent.
;; Otherwise, the computation goes mad.
- (glyph (ly:grob-property grob 'glyph-name))
+ (bar-glyph (ly:grob-property grob 'glyph-name))
(span-bar empty-stencil))
- (if (string? 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)
- (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 ((l (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! l (cons (cdr prev) (car curr)))
- (if (or (zero? (interval-length l))
- (not allow-span-bar))
- (begin
- ;; there is overlap between the bar lines
- ;; or 'allow-span-bar = #f.
- ;; Do nothing.
- )
- (set! span-bar
- (ly:stencil-add span-bar
- (bar-line::compound-bar-line
- model-bar
- glyph
- l
- #f))))))
- curr))
- "" extents)
- (set! span-bar (ly:stencil-translate-axis
- span-bar
- (- (ly:grob-relative-coordinate grob refp Y))
- Y))))
- span-bar))
+ (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.
+ (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))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; volta bracket functions
+
+(define-public (allow-volta-hook bar-glyph)
+ "Allow the volta bracket hook being drawn over bar line @var{bar-glyph}."
+ (if (string? bar-glyph)
+ (set! volta-bracket-allow-volta-hook-list
+ (append volta-bracket-allow-volta-hook-list
+ (list bar-glyph)))
+ (ly:warning (_ ("Volta hook bar line must be a string; ignoring '~a'.")
+ bar-glyph))))
+
+(define-session volta-bracket-allow-volta-hook-list '())
+
+(define-public (volta-bracket::calc-hook-visibility bar-glyph)
+ "Determine the visibility of the volta bracket hook. It is called in
+@code{lily/volta-bracket.cc} and returns @code{#t} if @emph{no} hook
+should be drawn."
+ (not (member bar-glyph volta-bracket-allow-volta-hook-list)))
+
+(define-public (ly:volta-bracket::calc-shorten-pair grob)
+ "Calculate the @code{shorten-pair} values for an ideal placement
+of the volta brackets relative to the bar lines."
+ (let* ((line-thickness (layout-line-thickness grob))
+ (volta-half-line-thickness (* (ly:grob-property grob 'thickness 1.6)
+ line-thickness
+ 1/2))
+ (bar-array (ly:grob-object grob 'bars))
+ ;; 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 (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 (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 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 #'<Grob Item >,
+ ;; so we add "" as a fallback return value
+ (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
+ (or right-bar-line grob)
+ 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
+ (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
+
+(add-bar-glyph-print-procedure "" make-empty-bar-line)
+(add-bar-glyph-print-procedure "|" make-simple-bar-line)
+(add-bar-glyph-print-procedure "." make-thick-bar-line)
+(add-bar-glyph-print-procedure "!" make-dashed-bar-line)
+(add-bar-glyph-print-procedure "'" make-tick-bar-line)
+(add-bar-glyph-print-procedure ":" make-colon-bar-line)
+(add-bar-glyph-print-procedure ";" make-dotted-bar-line)
+(add-bar-glyph-print-procedure "k" make-kievan-bar-line)
+(add-bar-glyph-print-procedure "S" (make-segno-bar-line #t))
+(add-bar-glyph-print-procedure "=" (make-segno-bar-line #f))
+(add-bar-glyph-print-procedure "[" (make-bracket-bar-line LEFT))
+(add-bar-glyph-print-procedure "]" (make-bracket-bar-line RIGHT))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; predefined bar lines
+;;
+;; definition of bar lines goes as follows:
+;;
+;; (define-bar-line "normal bar[-annotation]" "end of line" "start of line" "span bar")
+;;
+;; each entry has to be a string or #f.
+;; The empty string "" is allowed and yields in an invisible bar line,
+;; whereas #f reads 'no stencil'.
+;;
+;; Convention: if two bar lines would be identical in their
+;; unbroken bar glyph, we use annotations to make them distinct;
+;; as a general rule of thumb the main difference in their
+;; behavior at the end of a line is used as annotation, cf.
+;;
+;; (define-bar-line ".|:" "|" ".|:" ".|")
+;; (define-bar-line ".|:-||" "||" ".|:" ".|")
+;;
+;; or
+;;
+;; (define-bar-line "S-|" "|" "S" "=")
+;; (define-bar-line "S-S" "S" "" "=")
+
+;; common bar lines
+(define-bar-line "" "" "" #f)
+(define-bar-line "-" #f #f #f)
+(define-bar-line "|" "|" #f "|")
+(define-bar-line "|-s" #f "|" "|")
+(define-bar-line "." "." #f ".")
+(define-bar-line ".|" "|" ".|" ".|")
+(define-bar-line "|." "|." #f "|.")
+(define-bar-line "||" "||" #f "||")
+(define-bar-line ".." ".." #f "..")
+(define-bar-line "|.|" "|.|" #f "|.|")
+(define-bar-line "!" "!" #f "!")
+(define-bar-line ";" ";" #f ";")
+(define-bar-line "'" "'" #f #f)
+
+;; repeats
+(define-bar-line ":|.:" ":|." ".|:" " |.")
+(define-bar-line ":..:" ":|." ".|:" " ..")
+(define-bar-line ":|.|:" ":|." ".|:" " |.|")
+(define-bar-line ":.|.:" ":|." ".|:" " .|.")
+(define-bar-line ":|." ":|." #f " |.")
+(define-bar-line ".|:" "|" ".|:" ".|")
+(define-bar-line "[|:" "|" "[|:" " |")
+(define-bar-line ":|]" ":|]" #f " | ")
+(define-bar-line ":|][|:" ":|]" "[|:" " | |")
+(define-bar-line ".|:-||" "||" ".|:" ".|")
+
+;; segno bar lines
+(define-bar-line "S" "||" "S" "=")
+(define-bar-line "S-|" "|" "S" "=")
+(define-bar-line "S-S" "S" #f "=")
+(define-bar-line ":|.S" ":|." "S" " |.")
+(define-bar-line ":|.S-S" ":|.S" "" " |.")
+(define-bar-line "S.|:" "|" "S.|:" " .|")
+(define-bar-line "S.|:-S" "S" ".|:" " .|")
+(define-bar-line ":|.S.|:" ":|." "S.|:" " |. .|")
+(define-bar-line ":|.S.|:-S" ":|.S" ".|:" " |. .|")
+
+;; ancient bar lines
+(define-bar-line "k" "k" #f #f) ;; kievan style
+
+;; volta hook settings
+(allow-volta-hook ":|.")
+(allow-volta-hook ".|:")
+(allow-volta-hook "|.")
+(allow-volta-hook ":..:")
+(allow-volta-hook ":|.|:")
+(allow-volta-hook ":|.:")
+(allow-volta-hook ".|")
+(allow-volta-hook ":|.S")
+(allow-volta-hook ":|.S-S")
+(allow-volta-hook ":|.S.|:")
+(allow-volta-hook ":|.S.|:-S")
+(allow-volta-hook ":|]")
+(allow-volta-hook ":|][|:")
projects / lilypond.git / blobdiff