X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fdefine-markup-commands.scm;h=4844dcd75e321d60b5adec7849900bbfdf1be344;hb=47db9a3883d726ca53e2133a3b2298f78dd6a32e;hp=6ac78bac77a4df046666d7028f0d8cd9e28d8fa6;hpb=47657f55288626b9b18d14c31961c0a68502bc1c;p=lilypond.git diff --git a/scm/define-markup-commands.scm b/scm/define-markup-commands.scm index 6ac78bac77..4844dcd75e 100644 --- a/scm/define-markup-commands.scm +++ b/scm/define-markup-commands.scm @@ -1,6 +1,6 @@ ;;;; This file is part of LilyPond, the GNU music typesetter. ;;;; -;;;; Copyright (C) 2000--2011 Han-Wen Nienhuys +;;;; Copyright (C) 2000--2015 Han-Wen Nienhuys ;;;; Jan Nieuwenhuizen ;;;; ;;;; LilyPond is free software: you can redistribute it and/or modify @@ -111,9 +111,35 @@ ;; utility functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define-public empty-stencil (ly:make-stencil '() '(1 . -1) '(1 . -1))) +(define-public empty-stencil (ly:make-stencil '() + empty-interval empty-interval)) (define-public point-stencil (ly:make-stencil "" '(0 . 0) '(0 . 0))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; line has to come early since it is often used implicitly from the +;; markup macro since \markup { a b c } -> \markup \line { a b c } +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-markup-command (line layout props args) + (markup-list?) + #:category align + #:properties ((word-space) + (text-direction RIGHT)) + "Put @var{args} in a horizontal line. The property @code{word-space} +determines the space between markups in @var{args}. + +@lilypond[verbatim,quote] +\\markup { + \\line { + one two three + } +} +@end lilypond" + (let ((stencils (interpret-markup-list layout props args))) + (if (= text-direction LEFT) + (set! stencils (reverse stencils))) + (stack-stencil-line word-space stencils))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; geometric shapes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -139,6 +165,147 @@ A simple line. (y (cdr dest))) (make-line-stencil th 0 0 x y))) +(define-markup-command (draw-dashed-line layout props dest) + (number-pair?) + #:category graphic + #:properties ((thickness 1) + (on 1) + (off 1) + (phase 0) + (full-length #t)) + " +@cindex drawing dashed lines within text + +A dashed line. + +If @code{full-length} is set to #t (default) the dashed-line extends to the +whole length given by @var{dest}, without white space at beginning or end. +@code{off} will then be altered to fit. +To insist on the given (or default) values of @code{on}, @code{off} use +@code{\\override #'(full-length . #f)} +Manual settings for @code{on},@code{off} and @code{phase} are possible. +@lilypond[verbatim,quote] +\\markup { + \\draw-dashed-line #'(5.1 . 2.3) + \\override #'(on . 0.3) + \\override #'(off . 0.5) + \\draw-dashed-line #'(5.1 . 2.3) +} +@end lilypond" + (let* ((line-thickness (ly:output-def-lookup layout 'line-thickness)) + ;; Calculate the thickness to be used. + (th (* line-thickness thickness)) + (half-thick (/ th 2)) + ;; Get the extensions in x- and y-direction. + (x (car dest)) + (y (cdr dest)) + ;; Calculate the length of the dashed line. + (line-length (sqrt (+ (expt x 2) (expt y 2))))) + + (if (and full-length (not (= (+ on off) 0))) + (begin + ;; Add double-thickness to avoid overlapping. + (set! off (+ (* 2 th) off)) + (let* (;; Make a guess how often the off/on-pair should be printed + ;; after the initial `on´. + ;; Assume a minimum of 1 to avoid division by zero. + (guess (max 1 (round (/ (- line-length on) (+ off on))))) + ;; Not sure about the value or why corr is necessary at all, + ;; but it seems to be necessary. + (corr (if (= on 0) + (/ line-thickness 10) + 0)) + ;; Calculate a new value for off to fit the + ;; line-length. + (new-off (/ (- line-length corr (* (1+ guess) on)) guess)) + ) + (cond + + ;; Settings for (= on 0). Resulting in a dotted line. + + ;; If line-length isn't shorter than `th´, change the given + ;; value for `off´ to fit the line-length. + ((and (= on 0) (< th line-length)) + (set! off new-off)) + + ;; If the line-length is shorter than `th´, it makes no + ;; sense to adjust `off´. The rounded edges of the lines + ;; would prevent any nice output. + ;; Do nothing. + ;; This will result in a single dot for very short lines. + ((and (= on 0) (>= th line-length)) + #f) + + ;; Settings for (not (= on 0)). Resulting in a dashed line. + + ;; If line-length isn't shorter than one go of on-off-on, + ;; change the given value for `off´ to fit the line-length. + ((< (+ (* 2 on) off) line-length) + (set! off new-off)) + ;; If the line-length is too short, but greater than + ;; (* 4 th) set on/off to (/ line-length 3) + ((< (* 4 th) line-length) + (set! on (/ line-length 3)) + (set! off (/ line-length 3))) + ;; If the line-length is shorter than (* 4 th), it makes + ;; no sense trying to adjust on/off. The rounded edges of + ;; the lines would prevent any nice output. + ;; Simply set `on´ to line-length. + (else + (set! on line-length)))))) + + ;; If `on´ or `off´ is negative, or the sum of `on' and `off' equals zero a + ;; ghostscript-error occurs while calling + ;; (ly:make-stencil (list 'dashed-line th on off x y phase) x-ext y-ext) + ;; Better be paranoid. + (if (or (= (+ on off) 0) + (negative? on) + (negative? off)) + (begin + (ly:warning "Can't print a line - setting on/off to default") + (set! on 1) + (set! off 1))) + + ;; To give the lines produced by \draw-line and \draw-dashed-line the same + ;; length, half-thick has to be added to the stencil-extensions. + (ly:make-stencil + (list 'dashed-line th on off x y phase) + (interval-widen (ordered-cons 0 x) half-thick) + (interval-widen (ordered-cons 0 y) half-thick)))) + +(define-markup-command (draw-dotted-line layout props dest) + (number-pair?) + #:category graphic + #:properties ((thickness 1) + (off 1) + (phase 0)) + " +@cindex drawing dotted lines within text + +A dotted line. + +The dotted-line always extends to the whole length given by @var{dest}, without +white space at beginning or end. +Manual settings for @code{off} are possible to get larger or smaller space +between the dots. +The given (or default) value of @code{off} will be altered to fit the +line-length. +@lilypond[verbatim,quote] +\\markup { + \\draw-dotted-line #'(5.1 . 2.3) + \\override #'(thickness . 2) + \\override #'(off . 0.2) + \\draw-dotted-line #'(5.1 . 2.3) +} +@end lilypond" + + (let ((new-props (prepend-alist-chain 'on 0 + (prepend-alist-chain 'full-length #t props)))) + + (interpret-markup layout + new-props + (markup #:draw-dashed-line dest)))) + (define-markup-command (draw-hline layout props) () #:category graphic @@ -162,8 +329,8 @@ controls what fraction of the page is taken up. (interpret-markup layout props (markup #:draw-line (cons (* line-width - span-factor) - 0)))) + span-factor) + 0)))) (define-markup-command (draw-circle layout props radius thickness filled) (number? number? boolean?) @@ -187,8 +354,8 @@ optionally filled. (boolean?) #:category graphic #:properties ((thickness 0.1) - (font-size 0) - (baseline-skip 2)) + (font-size 0) + (baseline-skip 2)) " @cindex drawing triangles within text @@ -207,8 +374,8 @@ A triangle, either filled or empty. ,ex 0.0 ,(* 0.5 ex) ,(* 0.86 ex)) - ,thickness - ,filled) + ,thickness + ,filled) (cons 0 ex) (cons 0 (* .86 ex))))) @@ -216,8 +383,8 @@ A triangle, either filled or empty. (markup?) #:category graphic #:properties ((thickness 1) - (font-size 0) - (circle-padding 0.2)) + (font-size 0) + (circle-padding 0.2)) " @cindex circling text @@ -234,10 +401,66 @@ thickness and padding around the markup. @end lilypond" (let ((th (* (ly:output-def-lookup layout 'line-thickness) thickness)) - (pad (* (magstep font-size) circle-padding)) - (m (interpret-markup layout props arg))) + (pad (* (magstep font-size) circle-padding)) + (m (interpret-markup layout props arg))) (circle-stencil m th pad))) +(define-markup-command (ellipse layout props arg) + (markup?) + #:category graphic + #:properties ((thickness 1) + (font-size 0) + (x-padding 0.2) + (y-padding 0.2)) + " +@cindex drawing ellipse around text + +Draw an ellipse around @var{arg}. Use @code{thickness}, +@code{x-padding}, @code{y-padding} and @code{font-size} properties to determine +line thickness and padding around the markup. + +@lilypond[verbatim,quote] +\\markup { + \\ellipse { + Hi + } +} +@end lilypond" + (let ((th (* (ly:output-def-lookup layout 'line-thickness) + thickness)) + (pad-x (* (magstep font-size) x-padding)) + (pad-y (* (magstep font-size) y-padding)) + (m (interpret-markup layout props arg))) + (ellipse-stencil m th pad-x pad-y))) + +(define-markup-command (oval layout props arg) + (markup?) + #:category graphic + #:properties ((thickness 1) + (font-size 0) + (x-padding 0.75) + (y-padding 0.75)) + " +@cindex drawing oval around text + +Draw an oval around @var{arg}. Use @code{thickness}, +@code{x-padding}, @code{x-padding} and @code{font-size} properties to determine +line thickness and padding around the markup. + +@lilypond[verbatim,quote] +\\markup { + \\oval { + Hi + } +} +@end lilypond" + (let ((th (* (ly:output-def-lookup layout 'line-thickness) + thickness)) + (pad-x (* (magstep font-size) x-padding)) + (pad-y (* (magstep font-size) y-padding)) + (m (interpret-markup layout props arg))) + (oval-stencil m th pad-x pad-y))) + (define-markup-command (with-url layout props url arg) (string? markup?) #:category graphic @@ -249,7 +472,7 @@ the PDF backend. @lilypond[verbatim,quote] \\markup { - \\with-url #\"http://lilypond.org/web/\" { + \\with-url #\"http://lilypond.org/\" { LilyPond ... \\italic { music notation for everyone } @@ -257,10 +480,10 @@ the PDF backend. } @end lilypond" (let* ((stil (interpret-markup layout props arg)) - (xextent (ly:stencil-extent stil X)) - (yextent (ly:stencil-extent stil Y)) - (old-expr (ly:stencil-expr stil)) - (url-expr (list 'url-link url `(quote ,xextent) `(quote ,yextent)))) + (xextent (ly:stencil-extent stil X)) + (yextent (ly:stencil-extent stil Y)) + (old-expr (ly:stencil-expr stil)) + (url-expr (list 'url-link url `(quote ,xextent) `(quote ,yextent)))) (ly:stencil-add (ly:make-stencil url-expr xextent yextent) stil))) @@ -279,10 +502,10 @@ in the PDF backend. } @end lilypond" (let* ((stil (interpret-markup layout props arg)) - (xextent (ly:stencil-extent stil X)) - (yextent (ly:stencil-extent stil Y)) - (old-expr (ly:stencil-expr stil)) - (link-expr (list 'page-link page-number `(quote ,xextent) `(quote ,yextent)))) + (xextent (ly:stencil-extent stil X)) + (yextent (ly:stencil-extent stil Y)) + (old-expr (ly:stencil-expr stil)) + (link-expr (list 'page-link page-number `(quote ,xextent) `(quote ,yextent)))) (ly:stencil-add (ly:make-stencil link-expr xextent yextent) stil))) @@ -305,19 +528,18 @@ only works in the PDF backend. (let* ((arg-stencil (interpret-markup layout props arg)) (x-ext (ly:stencil-extent arg-stencil X)) (y-ext (ly:stencil-extent arg-stencil Y))) - (ly:make-stencil - `(delay-stencil-evaluation - ,(delay (ly:stencil-expr - (let* ((table (ly:output-def-lookup layout 'label-page-table)) + (ly:stencil-add + (ly:make-stencil + `(delay-stencil-evaluation + ,(delay (let* ((table (ly:output-def-lookup layout 'label-page-table)) (page-number (if (list? table) (assoc-get label table) - #f)) - (link-expr (list 'page-link page-number - `(quote ,x-ext) `(quote ,y-ext)))) - (ly:stencil-add (ly:make-stencil link-expr x-ext y-ext) -arg-stencil))))) - x-ext - y-ext))) + #f))) + (list 'page-link page-number + `(quote ,x-ext) `(quote ,y-ext))))) + x-ext + y-ext) + arg-stencil))) (define-markup-command (beam layout props width slope thickness) @@ -333,20 +555,20 @@ Create a beam with the specified parameters. } @end lilypond" (let* ((y (* slope width)) - (yext (cons (min 0 y) (max 0 y))) - (half (/ thickness 2))) + (yext (cons (min 0 y) (max 0 y))) + (half (/ thickness 2))) (ly:make-stencil `(polygon ',(list - 0 (/ thickness -2) - width (+ (* width slope) (/ thickness -2)) - width (+ (* width slope) (/ thickness 2)) - 0 (/ thickness 2)) - ,(ly:output-def-lookup layout 'blot-diameter) - #t) + 0 (/ thickness -2) + width (+ (* width slope) (/ thickness -2)) + width (+ (* width slope) (/ thickness 2)) + 0 (/ thickness 2)) + ,(ly:output-def-lookup layout 'blot-diameter) + #t) (cons 0 width) (cons (+ (- half) (car yext)) - (+ half (cdr yext)))))) + (+ half (cdr yext)))))) (define-markup-command (underline layout props arg) (markup?) @@ -371,19 +593,19 @@ thickness, and @code{offset} to determine line y-offset. @end lilypond" (let* ((thick (ly:output-def-lookup layout 'line-thickness)) (underline-thick (* thickness thick)) - (markup (interpret-markup layout props arg)) - (x1 (car (ly:stencil-extent markup X))) - (x2 (cdr (ly:stencil-extent markup X))) + (m (interpret-markup layout props arg)) + (x1 (car (ly:stencil-extent m X))) + (x2 (cdr (ly:stencil-extent m X))) (y (* thick (- offset))) (line (make-line-stencil underline-thick x1 y x2 y))) - (ly:stencil-add markup line))) + (ly:stencil-add m line))) (define-markup-command (box layout props arg) (markup?) #:category font #:properties ((thickness 1) - (font-size 0) - (box-padding 0.2)) + (font-size 0) + (box-padding 0.2)) " @cindex enclosing text within a box @@ -436,9 +658,9 @@ circle of diameter@tie{}0 (i.e., sharp corners). (markup?) #:category graphic #:properties ((thickness 1) - (corner-radius 1) - (font-size 0) - (box-padding 0.5)) + (corner-radius 1) + (font-size 0) + (box-padding 0.5)) "@cindex enclosing text in a box with rounded corners @cindex drawing boxes with rounded corners around text Draw a box with rounded corners around @var{arg}. Looks at @code{thickness}, @@ -507,6 +729,7 @@ Provide a white background for @var{arg}. @cindex putting space around text Add space around a markup object. +Identical to @code{pad-around}. @lilypond[verbatim,quote] \\markup { @@ -521,15 +744,11 @@ Add space around a markup object. } } @end lilypond" - (let* - ((stil (interpret-markup layout props arg)) - (xext (ly:stencil-extent stil X)) - (yext (ly:stencil-extent stil Y))) - - (ly:make-stencil - (ly:stencil-expr stil) - (interval-widen xext amount) - (interval-widen yext amount)))) + (let* ((m (interpret-markup layout props arg)) + (x (interval-widen (ly:stencil-extent m X) amount)) + (y (interval-widen (ly:stencil-extent m Y) amount))) + (ly:stencil-add (make-transparent-box-stencil x y) + m))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; space @@ -544,15 +763,13 @@ Add space around a markup object. Create a box of the same height as the space in the current font." (let ((m (ly:text-interface::interpret-markup layout props " "))) (ly:make-stencil (ly:stencil-expr m) - '(0 . 0) - (ly:stencil-extent m X) - ))) + '(0 . 0) + (ly:stencil-extent m X) + ))) -;; todo: fix negative space (define-markup-command (hspace layout props amount) (number?) #:category align - #:properties ((word-space)) " @cindex creating horizontal spaces in text @@ -567,16 +784,12 @@ Create an invisible object taking up horizontal space @var{amount}. three } @end lilypond" - (let ((corrected-space (- amount word-space))) - (if (> corrected-space 0) - (ly:make-stencil "" (cons 0 corrected-space) '(0 . 0)) - (ly:make-stencil "" (cons corrected-space corrected-space) '(0 . 0))))) + (ly:make-stencil "" (cons 0 amount) empty-interval)) -;; todo: fix negative space (define-markup-command (vspace layout props amount) - (number?) - #:category align - " + (number?) + #:category align + " @cindex creating vertical spaces in text Create an invisible object taking up vertical space @@ -594,9 +807,7 @@ of @var{amount} multiplied by 3. } @end lilypond" (let ((amount (* amount 3.0))) - (if (> amount 0) - (ly:make-stencil "" (cons 0 0) (cons 0 amount)) - (ly:make-stencil "" (cons 0 0) (cons amount amount))))) + (ly:make-stencil "" empty-interval (cons 0 amount)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -627,11 +838,11 @@ Use a stencil as markup. ((match (regexp-exec bbox-regexp string))) (if match - (map (lambda (x) - (string->number (match:substring match x))) - (cdr (iota 5))) + (map (lambda (x) + (string->number (match:substring match x))) + (cdr (iota 5))) - #f))) + #f))) (define-markup-command (epsfile layout props axis size file-name) (number? number? string?) @@ -686,38 +897,28 @@ rings = \\markup { ;; FIXME (ly:make-stencil (list 'embedded-ps - (format #f " + (format #f " gsave currentpoint translate 0.1 setlinewidth ~a grestore " - str)) + str)) '(0 . 0) '(0 . 0))) (define-markup-command (path layout props thickness commands) (number? list?) #:category graphic #:properties ((line-cap-style 'round) - (line-join-style 'round) - (filled #f)) + (line-join-style 'round) + (filled #f)) " @cindex paths, drawing @cindex drawing paths -Draws a path with line thickness @var{thickness} according to the +Draws a path with line @var{thickness} according to the directions given in @var{commands}. @var{commands} is a list of lists where the @code{car} of each sublist is a drawing command and the @code{cdr} comprises the associated arguments for each command. -Line-cap styles and line-join styles may be customized by -overriding the @code{line-cap-style} and @code{line-join-style} -properties, respectively. Available line-cap styles are -@code{'butt}, @code{'round}, and @code{'square}. Available -line-join styles are @code{'miter}, @code{'round}, and -@code{'bevel}. - -The property @code{filled} specifies whether or not the path is -filled with color. - There are seven commands available to use in the list @code{commands}: @code{moveto}, @code{rmoveto}, @code{lineto}, @code{rlineto}, @code{curveto}, @code{rcurveto}, and @@ -740,6 +941,16 @@ current subpath in the active path. Note that a sequence of commands @emph{must} begin with a @code{moveto} or @code{rmoveto} to work with the SVG output. +Line-cap styles and line-join styles may be customized by +overriding the @code{line-cap-style} and @code{line-join-style} +properties, respectively. Available line-cap styles are +@code{'butt}, @code{'round}, and @code{'square}. Available +line-join styles are @code{'miter}, @code{'round}, and +@code{'bevel}. + +The property @code{filled} specifies whether or not the path is +filled with color. + @lilypond[verbatim,quote] samplePath = #'((moveto 0 0) @@ -751,80 +962,105 @@ samplePath = \\markup { \\path #0.25 #samplePath + + \\override #'(line-join-style . miter) \\path #0.25 #samplePath + + \\override #'(filled . #t) \\path #0.25 #samplePath } @end lilypond" (let* ((half-thickness (/ thickness 2)) - (current-point '(0 . 0)) - (set-point (lambda (lst) (set! current-point lst))) - (relative? (lambda (x) - (string-prefix? "r" (symbol->string (car x))))) - ;; For calculating extents, we want to modify the command - ;; list so that all coordinates are absolute. - (new-commands (map (lambda (x) - (cond - ;; for rmoveto, rlineto - ((and (relative? x) (eq? 3 (length x))) - (let ((cp (cons - (+ (car current-point) - (second x)) - (+ (cdr current-point) - (third x))))) - (set-point cp) - (list (car cp) - (cdr cp)))) - ;; for rcurveto - ((and (relative? x) (eq? 7 (length x))) - (let* ((old-cp current-point) - (cp (cons - (+ (car old-cp) - (sixth x)) - (+ (cdr old-cp) - (seventh x))))) - (set-point cp) - (list (+ (car old-cp) (second x)) - (+ (cdr old-cp) (third x)) - (+ (car old-cp) (fourth x)) - (+ (cdr old-cp) (fifth x)) - (car cp) - (cdr cp)))) - ;; for moveto, lineto - ((eq? 3 (length x)) - (set-point (cons (second x) - (third x))) - (drop x 1)) - ;; for curveto - ((eq? 7 (length x)) - (set-point (cons (sixth x) - (seventh x))) - (drop x 1)) - ;; keep closepath for filtering; - ;; see `without-closepath'. - (else x))) - commands)) - ;; path-min-max does not accept 0-arg lists, - ;; and since closepath does not affect extents, filter - ;; out those commands here. - (without-closepath (filter (lambda (x) - (not (equal? 'closepath (car x)))) - new-commands)) - (extents (path-min-max - ;; set the origin to the first moveto - (list (list-ref (car without-closepath) 0) - (list-ref (car without-closepath) 1)) - without-closepath)) - (X-extent (cons (list-ref extents 0) (list-ref extents 1))) - (Y-extent (cons (list-ref extents 2) (list-ref extents 3))) - (command-list (fold-right append '() commands))) + (current-point '(0 . 0)) + (set-point (lambda (lst) (set! current-point lst))) + (relative? (lambda (x) + (string-prefix? "r" (symbol->string (car x))))) + ;; For calculating extents, we want to modify the command + ;; list so that all coordinates are absolute. + (new-commands (map (lambda (x) + (cond + ;; for rmoveto, rlineto + ((and (relative? x) (= 3 (length x))) + (let ((cp (cons + (+ (car current-point) + (second x)) + (+ (cdr current-point) + (third x))))) + (set-point cp) + (list (car cp) + (cdr cp)))) + ;; for rcurveto + ((and (relative? x) (= 7 (length x))) + (let* ((old-cp current-point) + (cp (cons + (+ (car old-cp) + (sixth x)) + (+ (cdr old-cp) + (seventh x))))) + (set-point cp) + (list (+ (car old-cp) (second x)) + (+ (cdr old-cp) (third x)) + (+ (car old-cp) (fourth x)) + (+ (cdr old-cp) (fifth x)) + (car cp) + (cdr cp)))) + ;; for moveto, lineto + ((= 3 (length x)) + (set-point (cons (second x) + (third x))) + (drop x 1)) + ;; for curveto + ((= 7 (length x)) + (set-point (cons (sixth x) + (seventh x))) + (drop x 1)) + ;; keep closepath for filtering; + ;; see `without-closepath'. + (else x))) + commands)) + ;; path-min-max does not accept 0-arg lists, + ;; and since closepath does not affect extents, filter + ;; out those commands here. + (without-closepath (filter (lambda (x) + (not (equal? 'closepath (car x)))) + new-commands)) + (extents (path-min-max + ;; set the origin to the first moveto + (list (list-ref (car without-closepath) 0) + (list-ref (car without-closepath) 1)) + without-closepath)) + (X-extent (cons (list-ref extents 0) (list-ref extents 1))) + (Y-extent (cons (list-ref extents 2) (list-ref extents 3))) + (command-list (fold-right append '() commands))) ;; account for line thickness (set! X-extent (interval-widen X-extent half-thickness)) (set! Y-extent (interval-widen Y-extent half-thickness)) (ly:make-stencil - `(path ,thickness `(,@',command-list) - ',line-cap-style ',line-join-style ,filled) - X-extent - Y-extent))) + `(path ,thickness `(,@',command-list) + ',line-cap-style ',line-join-style ,filled) + X-extent + Y-extent))) + +(define-markup-list-command (score-lines layout props score) + (ly:score?) + "This is the same as the @code{\\score} markup but delivers its +systems as a list of lines. Its @var{score} argument is entered in +braces like it would be for @code{\\score}." + (let ((output (ly:score-embedded-format score layout))) + + (if (ly:music-output? output) + (map + (lambda (paper-system) + ;; shift such that the refpoint of the bottom staff of + ;; the first system is the baseline of the score + (ly:stencil-translate-axis + (paper-system-stencil paper-system) + (- (car (paper-system-staff-extents paper-system))) + Y)) + (vector->list (ly:paper-score-paper-systems output))) + (begin + (ly:warning (_"no systems found in \\score markup, does it have a \\layout block?")) + '())))) (define-markup-command (score layout props score) (ly:score?) @@ -833,7 +1069,9 @@ samplePath = " @cindex inserting music into text -Inline an image of music. +Inline an image of music. The reference point (usually the middle +staff line) of the lowest staff in the top system is placed on the +baseline. @lilypond[verbatim,quote] \\markup { @@ -876,16 +1114,8 @@ Inline an image of music. } } @end lilypond" - (let ((output (ly:score-embedded-format score layout))) - - (if (ly:music-output? output) - (stack-stencils Y DOWN baseline-skip - (map paper-system-stencil - (vector->list - (ly:paper-score-paper-systems output)))) - (begin - (ly:warning (_"no systems found in \\score markup, does it have a \\layout block?")) - empty-stencil)))) + (stack-stencils Y DOWN baseline-skip + (score-lines-markup-list layout props score))) (define-markup-command (null layout props) () @@ -927,92 +1157,148 @@ the use of @code{\\simple} is unnecessary. @end lilypond" (interpret-markup layout props str)) -(define-markup-command (tied-lyric layout props str) - (string?) - #:category music - #:properties ((word-space)) - " -@cindex simple text strings with tie characters - -Like simple-markup, but use tie characters for @q{~} tilde symbols. +(define-markup-command (first-visible layout props args) + (markup-list?) + #:category other + "Use the first markup in @var{args} that yields a non-empty stencil +and ignore the rest. @lilypond[verbatim,quote] -\\markup \\column { - \\tied-lyric #\"Siam navi~all'onde~algenti Lasciate~in abbandono\" - \\tied-lyric #\"Impetuosi venti I nostri~affetti sono\" - \\tied-lyric #\"Ogni diletto~e scoglio Tutta la vita~e~un mar.\" +\\markup { + \\first-visible { + \\fromproperty #'header:composer + \\italic Unknown + } } @end lilypond" - (define (replace-ties tie str) - (if (string-contains str "~") - (let* - ((half-space (/ word-space 2)) - (parts (string-split str #\~)) - (tie-str (markup #:hspace half-space - #:musicglyph tie - #:hspace half-space)) - (joined (list-join parts tie-str))) - (make-concat-markup joined)) - str)) - - (define short-tie-regexp (make-regexp "~[^.]~")) - (define (match-short str) (regexp-exec short-tie-regexp str)) - - (define (replace-short str mkp) - (let ((match (match-short str))) - (if (not match) - (make-concat-markup (list - mkp - (replace-ties "ties.lyric.default" str))) - (let ((new-str (match:suffix match)) - (new-mkp (make-concat-markup (list - mkp - (replace-ties "ties.lyric.default" - (match:prefix match)) - (replace-ties "ties.lyric.short" - (match:substring match)))))) - (replace-short new-str new-mkp))))) - - (interpret-markup layout - props - (replace-short str (markup)))) + (define (false-if-empty stencil) + (if (ly:stencil-empty? stencil) #f stencil)) + (or + (any + (lambda (m) + (if (markup? m) + (false-if-empty (interpret-markup layout props m)) + (any false-if-empty (interpret-markup-list layout props (list m))))) + args) + empty-stencil)) (define-public empty-markup (make-simple-markup "")) ;; helper for justifying lines. -(define (get-fill-space word-count line-width word-space text-widths) - "Calculate the necessary paddings between each two adjacent texts. - The lengths of all texts are stored in @var{text-widths}. - The normal formula for the padding between texts a and b is: - padding = line-width/(word-count - 1) - (length(a) + length(b))/2 - The first and last padding have to be calculated specially using the - whole length of the first or last text. - All paddings are checked to be at least word-space, to ensure that - no texts collide. - Return a list of paddings." +(define (get-fill-space + word-count line-width word-space text-widths constant-space?) + "Calculate the necessary paddings between adjacent texts in a +single justified line. The lengths of all texts are stored in +@var{text-widths}. +When @var{constant-space?} is @code{#t}, the formula for the padding +between texts is: +padding = (line-width - total-text-width)/(word-count - 1) +When @var{constant-space?} is @code{#f}, the formula for the +padding between interior texts a and b is: +padding = line-width/(word-count - 1) - (length(a) + length(b))/2 +In this case, the first and last padding have to be calculated +specially using the whole length of the first or last text. +All paddings are checked to be at least word-space, to ensure that +no texts collide. +Return a list of paddings." (cond - ((null? text-widths) '()) - - ;; special case first padding - ((= (length text-widths) word-count) - (cons - (- (- (/ line-width (1- word-count)) (car text-widths)) - (/ (car (cdr text-widths)) 2)) - (get-fill-space word-count line-width word-space (cdr text-widths)))) - ;; special case last padding - ((= (length text-widths) 2) - (list (- (/ line-width (1- word-count)) - (+ (/ (car text-widths) 2) (car (cdr text-widths)))) 0)) - (else - (let ((default-padding - (- (/ line-width (1- word-count)) - (/ (+ (car text-widths) (car (cdr text-widths))) 2)))) - (cons - (if (> word-space default-padding) - word-space - default-padding) - (get-fill-space word-count line-width word-space (cdr text-widths))))))) + ((null? text-widths) '()) + (constant-space? + (make-list + (1- word-count) + ;; Ensure that space between words cannot be + ;; less than word-space. + (max + word-space + (/ (- line-width (apply + text-widths)) + (1- word-count))))) + + ;; special case first padding + ((= (length text-widths) word-count) + (cons + (- (- (/ line-width (1- word-count)) (car text-widths)) + (/ (cadr text-widths) 2)) + (get-fill-space + word-count line-width word-space (cdr text-widths) + constant-space?))) + ;; special case last padding + ((= (length text-widths) 2) + (list (- (/ line-width (1- word-count)) + (+ (/ (car text-widths) 2) (cadr text-widths))) + 0)) + (else + (let ((default-padding + (- (/ line-width (1- word-count)) + (/ (+ (car text-widths) (cadr text-widths)) 2)))) + (cons + (if (> word-space default-padding) + word-space + default-padding) + (get-fill-space + word-count line-width word-space (cdr text-widths) + constant-space?)))))) + +(define (justify-line-helper + layout props args text-direction word-space line-width constant-space?) + "Return a stencil which spreads @var{args} along a line of width +@var{line-width}. If @var{constant-space?} is set to @code{#t}, the +space between words is constant. If @code{#f}, the distance between +words varies according to their relative lengths." + (let* ((orig-stencils (interpret-markup-list layout props args)) + (stencils + (map (lambda (stc) + (if (ly:stencil-empty? stc X) + (ly:make-stencil (ly:stencil-expr stc) + '(0 . 0) (ly:stencil-extent stc Y)) + stc)) + orig-stencils)) + (text-widths + (map (lambda (stc) + (interval-length (ly:stencil-extent stc X))) + stencils)) + (text-width (apply + text-widths)) + (word-count (length stencils)) + (line-width (or line-width (ly:output-def-lookup layout 'line-width))) + (fill-space + (cond + ((= word-count 1) + (list + (/ (- line-width text-width) 2) + (/ (- line-width text-width) 2))) + ((= word-count 2) + (list + (- line-width text-width))) + (else + (get-fill-space + word-count line-width word-space text-widths + constant-space?)))) + (line-contents (if (= word-count 1) + (list + point-stencil + (car stencils) + point-stencil) + stencils))) + + (if (null? (remove ly:stencil-empty? orig-stencils)) + empty-stencil + (begin + (if (= text-direction LEFT) + (set! line-contents (reverse line-contents))) + (set! line-contents + (stack-stencils-padding-list + X RIGHT fill-space line-contents)) + (if (> word-count 1) + ;; shift s.t. stencils align on the left edge, even if + ;; first stencil had negative X-extent (e.g. center-column) + ;; (if word-count = 1, X-extents are already normalized in + ;; the definition of line-contents) + (set! line-contents + (ly:stencil-translate-axis + line-contents + (- (car (ly:stencil-extent (car stencils) X))) + X))) + line-contents)))) (define-markup-command (fill-line layout props args) (markup-list?) @@ -1041,81 +1327,28 @@ If there are no arguments, return an empty stencil. } } @end lilypond" - (let* ((orig-stencils (interpret-markup-list layout props args)) - (stencils - (map (lambda (stc) - (if (ly:stencil-empty? stc) - point-stencil - stc)) orig-stencils)) - (text-widths - (map (lambda (stc) - (if (ly:stencil-empty? stc) - 0.0 - (interval-length (ly:stencil-extent stc X)))) - stencils)) - (text-width (apply + text-widths)) - (word-count (length stencils)) - (line-width (or line-width (ly:output-def-lookup layout 'line-width))) - (fill-space - (cond - ((= word-count 1) - (list - (/ (- line-width text-width) 2) - (/ (- line-width text-width) 2))) - ((= word-count 2) - (list - (- line-width text-width))) - (else - (get-fill-space word-count line-width word-space text-widths)))) - - (line-contents (if (= word-count 1) - (list - point-stencil - (car stencils) - point-stencil) - stencils))) - - (if (null? (remove ly:stencil-empty? orig-stencils)) - empty-stencil - (begin - (if (= text-direction LEFT) - (set! line-contents (reverse line-contents))) - (set! line-contents - (stack-stencils-padding-list - X RIGHT fill-space line-contents)) - (if (> word-count 1) - ;; shift s.t. stencils align on the left edge, even if - ;; first stencil had negative X-extent (e.g. center-column) - ;; (if word-count = 1, X-extents are already normalized in - ;; the definition of line-contents) - (set! line-contents - (ly:stencil-translate-axis - line-contents - (- (car (ly:stencil-extent (car stencils) X))) - X))) - line-contents)))) + (justify-line-helper + layout props args text-direction word-space line-width #f)) -(define-markup-command (line layout props args) +(define-markup-command (justify-line layout props args) (markup-list?) #:category align - #:properties ((word-space) - (text-direction RIGHT)) - "Put @var{args} in a horizontal line. The property @code{word-space} -determines the space between markups in @var{args}. + #:properties ((text-direction RIGHT) + (word-space 0.6) + (line-width #f)) + "Put @var{markups} in a horizontal line of width @var{line-width}. +The markups are spread to fill the entire line and separated by equal +space. If there are no arguments, return an empty stencil. @lilypond[verbatim,quote] \\markup { - \\line { - one two three + \\justify-line { + Space between neighboring words is constant } } @end lilypond" - (let ((stencils (interpret-markup-list layout props args))) - (if (= text-direction LEFT) - (set! stencils (reverse stencils))) - (stack-stencil-line - word-space - (remove ly:stencil-empty? stencils)))) + (justify-line-helper + layout props args text-direction word-space line-width #t)) (define-markup-command (concat layout props args) (markup-list?) @@ -1142,83 +1375,125 @@ equivalent to @code{\"fi\"}. (fold-right (lambda (arg result-list) (let ((result (if (pair? result-list) (car result-list) - '()))) + '()))) (if (and (pair? arg) (eqv? (car arg) simple-markup)) - (set! arg (cadr arg))) + (set! arg (cadr arg))) (if (and (string? result) (string? arg)) (cons (string-append arg result) (cdr result-list)) - (cons arg result-list)))) + (cons arg result-list)))) '() arg-list)) (interpret-markup layout (prepend-alist-chain 'word-space 0 props) - (make-line-markup (if (markup-command-list? args) - args - (concat-string-args args))))) + (make-line-markup + (make-override-lines-markup-list + (cons 'word-space + (chain-assoc-get 'word-space props)) + (if (markup-command-list? args) + args + (concat-string-args args)))))) (define (wordwrap-stencils stencils - justify base-space line-width text-dir) + justify base-space line-width text-dir) "Perform simple wordwrap, return stencil of each line." (define space (if justify ;; justify only stretches lines. - (* 0.7 base-space) - base-space)) - (define (take-list width space stencils - accumulator accumulated-width) - "Return (head-list . tail) pair, with head-list fitting into width" - (if (null? stencils) - (cons accumulator stencils) - (let* ((first (car stencils)) - (first-wid (cdr (ly:stencil-extent (car stencils) X))) - (newwid (+ space first-wid accumulated-width))) - (if (or (null? accumulator) - (< newwid width)) - (take-list width space - (cdr stencils) - (cons first accumulator) - newwid) - (cons accumulator stencils))))) - (let loop ((lines '()) - (todo stencils)) - (let* ((line-break (take-list line-width space todo - '() 0.0)) - (line-stencils (car line-break)) - (space-left (- line-width - (apply + (map (lambda (x) (cdr (ly:stencil-extent x X))) - line-stencils)))) - (line-word-space (cond ((not justify) space) - ;; don't stretch last line of paragraph. - ;; hmmm . bug - will overstretch the last line in some case. - ((null? (cdr line-break)) - base-space) - ((null? line-stencils) 0.0) - ((null? (cdr line-stencils)) 0.0) - (else (/ space-left (1- (length line-stencils)))))) - (line (stack-stencil-line line-word-space - (if (= text-dir RIGHT) - (reverse line-stencils) - line-stencils)))) - (if (pair? (cdr line-break)) - (loop (cons line lines) - (cdr line-break)) - (begin - (if (= text-dir LEFT) - (set! line - (ly:stencil-translate-axis - line - (- line-width (interval-end (ly:stencil-extent line X))) - X))) - (reverse (cons line lines))))))) + (* 0.7 base-space) + base-space)) + (define (stencil-len s) + (interval-end (ly:stencil-extent s X))) + (define (maybe-shift line) + (if (= text-dir LEFT) + (ly:stencil-translate-axis + line + (- line-width (stencil-len line)) + X) + line)) + (if (null? stencils) + '() + (let loop ((lines '()) + (todo stencils)) + (let word-loop + ((line (first todo)) + (todo (cdr todo)) + (word-list (list (first todo)))) + (cond + ((pair? todo) + (let ((new (if (= text-dir LEFT) + (ly:stencil-stack (car todo) X RIGHT line space) + (ly:stencil-stack line X RIGHT (car todo) space)))) + (cond + ((<= (stencil-len new) line-width) + (word-loop new (cdr todo) + (cons (car todo) word-list))) + (justify + (let* ((word-list + ;; This depends on stencil stacking being + ;; associative so that stacking + ;; left-to-right and right-to-left leads to + ;; the same result + (if (= text-dir LEFT) + word-list + (reverse! word-list))) + (len (stencil-len line)) + (stretch (- line-width len)) + (spaces + (- (stencil-len + (stack-stencils X RIGHT (1+ space) word-list)) + len))) + (if (zero? spaces) + ;; Uh oh, nothing to fill. + (loop (cons (maybe-shift line) lines) todo) + (loop (cons + (stack-stencils X RIGHT + (+ space (/ stretch spaces)) + word-list) + lines) + todo)))) + (else ;; not justify + (loop (cons (maybe-shift line) lines) todo))))) + ;; todo is null + (justify + ;; Now we have the last line assembled with space + ;; which is compressed. We want to use the + ;; uncompressed version instead if it fits, and the + ;; justified version if it doesn't. + (let* ((word-list + ;; This depends on stencil stacking being + ;; associative so that stacking + ;; left-to-right and right-to-left leads to + ;; the same result + (if (= text-dir LEFT) + word-list + (reverse! word-list))) + (big-line (stack-stencils X RIGHT base-space word-list)) + (big-len (stencil-len big-line)) + (len (stencil-len line))) + (reverse! lines + (list + (if (> big-len line-width) + (stack-stencils X RIGHT + (/ + (+ + (* (- big-len line-width) + space) + (* (- line-width len) + base-space)) + (- big-len len)) + word-list) + (maybe-shift big-line)))))) + (else ;; not justify + (reverse! lines (list (maybe-shift line))))))))) + (define-markup-list-command (wordwrap-internal layout props justify args) (boolean? markup-list?) #:properties ((line-width #f) - (word-space) - (text-direction RIGHT)) + (word-space) + (text-direction RIGHT)) "Internal markup list command used to define @code{\\justify} and @code{\\wordwrap}." - (wordwrap-stencils (remove ly:stencil-empty? - (interpret-markup-list layout props args)) + (wordwrap-stencils (interpret-markup-list layout props args) justify word-space (or line-width @@ -1229,7 +1504,7 @@ equivalent to @code{\"fi\"}. (markup-list?) #:category align #:properties ((baseline-skip) - wordwrap-internal-markup-list) + wordwrap-internal-markup-list) " @cindex justifying text @@ -1254,7 +1529,7 @@ Use @code{\\override #'(line-width . @var{X})} to set the line width; (markup-list?) #:category align #:properties ((baseline-skip) - wordwrap-internal-markup-list) + wordwrap-internal-markup-list) "Simple wordwrap. Use @code{\\override #'(line-width . @var{X})} to set the line width, where @var{X} is the number of staff spaces. @@ -1269,13 +1544,13 @@ the line width, where @var{X} is the number of staff spaces. } @end lilypond" (stack-lines DOWN 0.0 baseline-skip - (wordwrap-internal-markup-list layout props #f args))) + (wordwrap-internal-markup-list layout props #f args))) (define-markup-list-command (wordwrap-string-internal layout props justify arg) (boolean? string?) #:properties ((line-width) - (word-space) - (text-direction RIGHT)) + (word-space) + (text-direction RIGHT)) "Internal markup list command used to define @code{\\justify-string} and @code{\\wordwrap-string}." (let* ((para-strings (regexp-split @@ -1288,21 +1563,20 @@ the line width, where @var{X} is the number of staff spaces. para-strings)) (para-lines (map (lambda (words) (let* ((stencils - (remove ly:stencil-empty? - (map (lambda (x) - (interpret-markup layout props x)) - words)))) + (map (lambda (x) + (interpret-markup layout props x)) + words))) (wordwrap-stencils stencils justify word-space line-width text-direction))) list-para-words))) - (apply append para-lines))) + (concatenate para-lines))) (define-markup-command (wordwrap-string layout props arg) (string?) #:category align #:properties ((baseline-skip) - wordwrap-string-internal-markup-list) + wordwrap-string-internal-markup-list) "Wordwrap a string. Paragraphs may be separated with double newlines. @lilypond[verbatim,quote] @@ -1328,7 +1602,7 @@ the line width, where @var{X} is the number of staff spaces. (string?) #:category align #:properties ((baseline-skip) - wordwrap-string-internal-markup-list) + wordwrap-string-internal-markup-list) "Justify a string. Paragraphs may be separated with double newlines @lilypond[verbatim,quote] @@ -1442,7 +1716,7 @@ curly braces as an argument; the follow example will not compile: } @end lilypond" (let* ((s1 (interpret-markup layout props arg1)) - (s2 (interpret-markup layout props arg2))) + (s2 (interpret-markup layout props arg2))) (ly:stencil-add s1 s2))) ;; @@ -1469,14 +1743,13 @@ in @var{args}. } @end lilypond" (let ((arg-stencils (interpret-markup-list layout props args))) - (stack-lines -1 0.0 baseline-skip - (remove ly:stencil-empty? arg-stencils)))) + (stack-lines -1 0.0 baseline-skip arg-stencils))) (define-markup-command (dir-column layout props args) (markup-list?) #:category align #:properties ((direction) - (baseline-skip)) + (baseline-skip)) " @cindex changing direction of text columns @@ -1539,7 +1812,7 @@ Put @code{args} in a centered column. (markup-list?) #:category align #:properties ((baseline-skip)) - " + " @cindex text columns, left-aligned Put @code{args} in a left-aligned column. @@ -1559,7 +1832,7 @@ Put @code{args} in a left-aligned column. (markup-list?) #:category align #:properties ((baseline-skip)) - " + " @cindex text columns, right-aligned Put @code{args} in a right-aligned column. @@ -1742,8 +2015,12 @@ alignment accordingly. @cindex setting extent of text objects Set the dimensions of @var{arg} to @var{x} and@tie{}@var{y}." - (let* ((m (interpret-markup layout props arg))) - (ly:make-stencil (ly:stencil-expr m) x y))) + (let* ((expr (ly:stencil-expr (interpret-markup layout props arg)))) + (ly:stencil-add + (make-transparent-box-stencil x y) + (ly:make-stencil + `(delay-stencil-evaluation ,(delay expr)) + x y)))) (define-markup-command (pad-around layout props amount arg) (number? markup?) @@ -1764,11 +2041,10 @@ Set the dimensions of @var{arg} to @var{x} and@tie{}@var{y}." } @end lilypond" (let* ((m (interpret-markup layout props arg)) - (x (ly:stencil-extent m X)) - (y (ly:stencil-extent m Y))) - (ly:make-stencil (ly:stencil-expr m) - (interval-widen x amount) - (interval-widen y amount)))) + (x (interval-widen (ly:stencil-extent m X) amount)) + (y (interval-widen (ly:stencil-extent m Y) amount))) + (ly:stencil-add (make-transparent-box-stencil x y) + m))) (define-markup-command (pad-x layout props amount arg) (number? markup?) @@ -1821,7 +2097,7 @@ Add padding @var{amount} around @var{arg} in the X@tie{}direction. (let* ((m (interpret-markup layout props arg)) (x (ly:stencil-extent m X)) (y (ly:stencil-extent m Y))) - (ly:make-stencil "" x y))) + (ly:make-stencil (list 'transparent-stencil (ly:stencil-expr m)) x y))) (define-markup-command (pad-to-box layout props x-ext y-ext arg) (number-pair? number-pair? markup?) @@ -1841,12 +2117,8 @@ Add padding @var{amount} around @var{arg} in the X@tie{}direction. } } @end lilypond" - (let* ((m (interpret-markup layout props arg)) - (x (ly:stencil-extent m X)) - (y (ly:stencil-extent m Y))) - (ly:make-stencil (ly:stencil-expr m) - (interval-union x-ext x) - (interval-union y-ext y)))) + (ly:stencil-add (make-transparent-box-stencil x-ext y-ext) + (interpret-markup layout props arg))) (define-markup-command (hcenter-in layout props length arg) (number? markup?) @@ -1924,8 +2196,8 @@ returns an empty markup. @var{procedure} should take a single argument." (let ((anonymous-with-signature (lambda (layout props arg) (procedure layout props arg)))) (set-object-property! anonymous-with-signature - 'markup-signature - (list markup?)) + 'markup-signature + (list markup?)) (interpret-markup layout props (list anonymous-with-signature arg)))) (define-markup-command (footnote layout props mkup note) @@ -1942,14 +2214,14 @@ returns an empty markup. @end lilypond The footnote will not be annotated automatically." (ly:stencil-combine-at-edge - (interpret-markup layout props mkup) - X - RIGHT - (ly:make-stencil - `(footnote (gensym "footnote") #f ,(interpret-markup layout props note)) - '(0 . 0) - '(0 . 0)) - 0.0)) + (interpret-markup layout props mkup) + X + RIGHT + (ly:make-stencil + `(footnote (gensym "footnote") #f ,(interpret-markup layout props note)) + '(0 . 0) + '(0 . 0)) + 0.0)) (define-markup-command (auto-footnote layout props mkup note) (markup? markup?) @@ -1967,62 +2239,52 @@ The footnote will not be annotated automatically." @end lilypond The footnote will be annotated automatically." (let* ((markup-stencil (interpret-markup layout props mkup)) - (auto-numbering (ly:output-def-lookup layout - 'footnote-auto-numbering)) (footnote-hash (gensym "footnote")) (stencil-seed 0) - (gauge-stencil (if auto-numbering - (interpret-markup - layout - props - ((ly:output-def-lookup - layout - 'footnote-numbering-function) - stencil-seed)) - empty-stencil)) - (x-ext (if auto-numbering - (ly:stencil-extent gauge-stencil X) - '(0 . 0))) - (y-ext (if auto-numbering - (ly:stencil-extent gauge-stencil Y) - '(0 . 0))) + (gauge-stencil (interpret-markup + layout + props + ((ly:output-def-lookup + layout + 'footnote-numbering-function) + stencil-seed))) + (x-ext (ly:stencil-extent gauge-stencil X)) + (y-ext (ly:stencil-extent gauge-stencil Y)) (footnote-number - (if auto-numbering - `(delay-stencil-evaluation - ,(delay - (ly:stencil-expr - (let* ((table - (ly:output-def-lookup layout - 'number-footnote-table)) - (footnote-stencil (if (list? table) - (assoc-get footnote-hash - table) - empty-stencil)) - (footnote-stencil (if (ly:stencil? footnote-stencil) - footnote-stencil - (begin - (ly:programming-error -"Cannot find correct footnote for a markup object.") - empty-stencil))) - (gap (- (interval-length x-ext) - (interval-length - (ly:stencil-extent footnote-stencil X)))) - (y-trans (- (+ (cdr y-ext) - raise) - (cdr (ly:stencil-extent footnote-stencil - Y))))) - (ly:stencil-translate footnote-stencil - (cons gap y-trans)))))) - '())) + `(delay-stencil-evaluation + ,(delay + (ly:stencil-expr + (let* ((table + (ly:output-def-lookup layout + 'number-footnote-table)) + (footnote-stencil (if (list? table) + (assoc-get footnote-hash + table) + empty-stencil)) + (footnote-stencil (if (ly:stencil? footnote-stencil) + footnote-stencil + (begin + (ly:programming-error + "Cannot find correct footnote for a markup object.") + empty-stencil))) + (gap (- (interval-length x-ext) + (interval-length + (ly:stencil-extent footnote-stencil X)))) + (y-trans (- (+ (cdr y-ext) + raise) + (cdr (ly:stencil-extent footnote-stencil + Y))))) + (ly:stencil-translate footnote-stencil + (cons gap y-trans))))))) (main-stencil (ly:stencil-combine-at-edge - markup-stencil - X - RIGHT - (ly:make-stencil footnote-number x-ext y-ext) - padding))) - (ly:stencil-add - main-stencil - (ly:make-stencil + markup-stencil + X + RIGHT + (ly:make-stencil footnote-number x-ext y-ext) + padding))) + (ly:stencil-add + main-stencil + (ly:make-stencil `(footnote ,footnote-hash #t ,(interpret-markup layout props note)) '(0 . 0) '(0 . 0))))) @@ -2103,7 +2365,7 @@ may be any property supported by @rinternals{font-interface}, } @end lilypond" (interpret-markup layout props - `(,fontsize-markup -1 ,arg))) + `(,fontsize-markup -1 ,arg))) (define-markup-command (larger layout props arg) (markup?) @@ -2119,7 +2381,7 @@ may be any property supported by @rinternals{font-interface}, } @end lilypond" (interpret-markup layout props - `(,fontsize-markup 1 ,arg))) + `(,fontsize-markup 1 ,arg))) (define-markup-command (finger layout props arg) (markup?) @@ -2140,7 +2402,7 @@ may be any property supported by @rinternals{font-interface}, (define-markup-command (abs-fontsize layout props size arg) (number? markup?) #:category font - "Use @var{size} as the absolute font size to display @var{arg}. + "Use @var{size} as the absolute font size (in points) to display @var{arg}. Adjusts @code{baseline-skip} and @code{word-space} accordingly. @lilypond[verbatim,quote] @@ -2153,23 +2415,25 @@ Adjusts @code{baseline-skip} and @code{word-space} accordingly. } @end lilypond" (let* ((ref-size (ly:output-def-lookup layout 'text-font-size 12)) - (text-props (list (ly:output-def-lookup layout 'text-font-defaults))) - (ref-word-space (chain-assoc-get 'word-space text-props 0.6)) - (ref-baseline (chain-assoc-get 'baseline-skip text-props 3)) - (magnification (/ size ref-size))) - (interpret-markup layout - (cons `((baseline-skip . ,(* magnification ref-baseline)) - (word-space . ,(* magnification ref-word-space)) - (font-size . ,(magnification->font-size magnification))) - props) - arg))) + (text-props (list (ly:output-def-lookup layout 'text-font-defaults))) + (ref-word-space (chain-assoc-get 'word-space text-props 0.6)) + (ref-baseline (chain-assoc-get 'baseline-skip text-props 3)) + (magnification (/ size ref-size))) + (interpret-markup + layout + (cons + `((baseline-skip . ,(* magnification ref-baseline)) + (word-space . ,(* magnification ref-word-space)) + (font-size . ,(magnification->font-size magnification))) + props) + arg))) (define-markup-command (fontsize layout props increment arg) (number? markup?) #:category font #:properties ((font-size 0) - (word-space 1) - (baseline-skip 2)) + (word-space 1) + (baseline-skip 2)) "Add @var{increment} to the font-size. Adjusts @code{baseline-skip} accordingly. @@ -2181,11 +2445,14 @@ accordingly. smaller } @end lilypond" - (let ((entries (list - (cons 'baseline-skip (* baseline-skip (magstep increment))) - (cons 'word-space (* word-space (magstep increment))) - (cons 'font-size (+ font-size increment))))) - (interpret-markup layout (cons entries props) arg))) + (interpret-markup + layout + (cons + `((baseline-skip . ,(* baseline-skip (magstep increment))) + (word-space . ,(* word-space (magstep increment))) + (font-size . ,(+ font-size increment))) + props) + arg)) (define-markup-command (magnify layout props sz arg) (number? markup?) @@ -2408,33 +2675,33 @@ Note: @code{\\smallCaps} does not support accented characters. (define (char-list->markup chars lower) (let ((final-string (string-upcase (reverse-list->string chars)))) (if lower - (markup #:fontsize -2 final-string) - final-string))) + (markup #:fontsize -2 final-string) + final-string))) (define (make-small-caps rest-chars currents current-is-lower prev-result) (if (null? rest-chars) - (make-concat-markup - (reverse! (cons (char-list->markup currents current-is-lower) - prev-result))) - (let* ((ch (car rest-chars)) - (is-lower (char-lower-case? ch))) - (if (or (and current-is-lower is-lower) - (and (not current-is-lower) (not is-lower))) - (make-small-caps (cdr rest-chars) - (cons ch currents) - is-lower - prev-result) - (make-small-caps (cdr rest-chars) - (list ch) - is-lower - (if (null? currents) - prev-result - (cons (char-list->markup - currents current-is-lower) - prev-result))))))) + (make-concat-markup + (reverse! (cons (char-list->markup currents current-is-lower) + prev-result))) + (let* ((ch (car rest-chars)) + (is-lower (char-lower-case? ch))) + (if (or (and current-is-lower is-lower) + (and (not current-is-lower) (not is-lower))) + (make-small-caps (cdr rest-chars) + (cons ch currents) + is-lower + prev-result) + (make-small-caps (cdr rest-chars) + (list ch) + is-lower + (if (null? currents) + prev-result + (cons (char-list->markup + currents current-is-lower) + prev-result))))))) (interpret-markup layout props - (if (string? arg) - (make-small-caps (string->list arg) (list) #f (list)) - arg))) + (if (string? arg) + (make-small-caps (string->list arg) (list) #f (list)) + arg))) (define-markup-command (caps layout props arg) (markup?) @@ -2488,7 +2755,7 @@ done in a different font. The recommended font for this is bold and italic. ;; ugh - latin1 (interpret-markup layout (prepend-alist-chain 'font-encoding 'latin1 props) - arg)) + arg)) (define-markup-command (italic layout props arg) (markup?) @@ -2562,7 +2829,7 @@ of @code{italic}. } @end lilypond" (interpret-markup layout (prepend-alist-chain 'font-series 'medium props) - arg)) + arg)) (define-markup-command (normal-text layout props arg) (markup?) @@ -2586,8 +2853,8 @@ normal text font, no matter what font was used earlier. ;; ugh - latin1 (interpret-markup layout (cons '((font-family . roman) (font-shape . upright) - (font-series . medium) (font-encoding . latin1)) - props) + (font-series . medium) (font-encoding . latin1)) + props) arg)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -2610,13 +2877,13 @@ the possible glyphs. } @end lilypond" (let* ((font (ly:paper-get-font layout - (cons '((font-encoding . fetaMusic) - (font-name . #f)) + (cons '((font-encoding . fetaMusic) + (font-name . #f)) - props))) - (glyph (ly:font-get-glyph font glyph-name))) + props))) + (glyph (ly:font-get-glyph font glyph-name))) (if (null? (ly:stencil-expr glyph)) - (ly:warning (_ "Cannot find glyph ~a") glyph-name)) + (ly:warning (_ "Cannot find glyph ~a") glyph-name)) glyph)) @@ -2750,8 +3017,58 @@ Draw @var{arg} in color specified by @var{color}. @end lilypond" (let ((stil (interpret-markup layout props arg))) (ly:make-stencil (list 'color color (ly:stencil-expr stil)) - (ly:stencil-extent stil X) - (ly:stencil-extent stil Y)))) + (ly:stencil-extent stil X) + (ly:stencil-extent stil Y)))) + +(define-markup-command (tied-lyric layout props str) + (string?) + #:category music + #:properties ((word-space)) + " +@cindex simple text strings with tie characters + +Like simple-markup, but use tie characters for @q{~} tilde symbols. + +@lilypond[verbatim,quote] +\\markup \\column { + \\tied-lyric #\"Siam navi~all'onde~algenti Lasciate~in abbandono\" + \\tied-lyric #\"Impetuosi venti I nostri~affetti sono\" + \\tied-lyric #\"Ogni diletto~e scoglio Tutta la vita~e~un mar.\" +} +@end lilypond" + (define (replace-ties tie str) + (if (string-contains str "~") + (let* + ((half-space (/ word-space 2)) + (parts (string-split str #\~)) + (tie-str (markup #:hspace half-space + #:musicglyph tie + #:hspace half-space)) + (joined (list-join parts tie-str))) + (make-concat-markup joined)) + str)) + + (define short-tie-regexp (make-regexp "~[^.]~")) + (define (match-short str) (regexp-exec short-tie-regexp str)) + + (define (replace-short str mkp) + (let ((match (match-short str))) + (if (not match) + (make-concat-markup (list + mkp + (replace-ties "ties.lyric.default" str))) + (let ((new-str (match:suffix match)) + (new-mkp (make-concat-markup (list + mkp + (replace-ties "ties.lyric.default" + (match:prefix match)) + (replace-ties "ties.lyric.short" + (match:substring match)))))) + (replace-short new-str new-mkp))))) + + (interpret-markup layout + props + (replace-short str (markup)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; glyphs @@ -2777,14 +3094,14 @@ Use the filled head if @var{filled} is specified. @end lilypond" (let* ((name (format #f "arrowheads.~a.~a~a" - (if filled - "close" - "open") - axis - dir))) + (if filled + "close" + "open") + axis + dir))) (ly:font-get-glyph (ly:paper-get-font layout (cons '((font-encoding . fetaMusic)) - props)) + props)) name))) (define-markup-command (lookup layout props glyph-name) @@ -2803,7 +3120,7 @@ Use the filled head if @var{filled} is specified. } @end lilypond" (ly:font-get-glyph (ly:paper-get-font layout props) - glyph-name)) + glyph-name)) (define-markup-command (char layout props num) (integer?) @@ -2829,22 +3146,22 @@ format require the prefix @code{#x}. (integer->char (+ i (char->integer #\A))))) (define number->mark-alphabet-vector (list->vector - (map (lambda (i) (integer->char (+ i (char->integer #\A)))) (iota 26)))) + (map (lambda (i) (integer->char (+ i (char->integer #\A)))) (iota 26)))) (define (number->markletter-string vec n) "Double letters for big marks." (let* ((lst (vector-length vec))) (if (>= n lst) - (string-append (number->markletter-string vec (1- (quotient n lst))) - (number->markletter-string vec (remainder n lst))) - (make-string 1 (vector-ref vec n))))) + (string-append (number->markletter-string vec (1- (quotient n lst))) + (number->markletter-string vec (remainder n lst))) + (make-string 1 (vector-ref vec n))))) (define-markup-command (markletter layout props num) (integer?) #:category other - "Make a markup letter for @var{num}. The letters start with A to@tie{}Z -(skipping letter@tie{}I), and continue with double letters. + "Make a markup letter for @var{num}. The letters start with A +to@tie{}Z (skipping letter@tie{}I), and continue with double letters. @lilypond[verbatim,quote] \\markup { @@ -2854,12 +3171,12 @@ format require the prefix @code{#x}. } @end lilypond" (ly:text-interface::interpret-markup layout props - (number->markletter-string number->mark-letter-vector num))) + (number->markletter-string number->mark-letter-vector num))) (define-markup-command (markalphabet layout props num) (integer?) #:category other - "Make a markup letter for @var{num}. The letters start with A to@tie{}Z + "Make a markup letter for @var{num}. The letters start with A to@tie{}Z and continue with double letters. @lilypond[verbatim,quote] @@ -2869,67 +3186,67 @@ and continue with double letters. \\markalphabet #26 } @end lilypond" - (ly:text-interface::interpret-markup layout props - (number->markletter-string number->mark-alphabet-vector num))) + (ly:text-interface::interpret-markup layout props + (number->markletter-string number->mark-alphabet-vector num))) (define-public (horizontal-slash-interval num forward number-interval mag) (if forward - (cond ;((= num 6) (interval-widen number-interval (* mag 0.5))) - ;((= num 5) (interval-widen number-interval (* mag 0.5))) - (else (interval-widen number-interval (* mag 0.25)))) - (cond ((= num 6) (interval-widen number-interval (* mag 0.5))) - ;((= num 5) (interval-widen number-interval (* mag 0.5))) - (else (interval-widen number-interval (* mag 0.25)))) - )) + (cond ;; ((= num 6) (interval-widen number-interval (* mag 0.5))) + ;; ((= num 5) (interval-widen number-interval (* mag 0.5))) + (else (interval-widen number-interval (* mag 0.25)))) + (cond ((= num 6) (interval-widen number-interval (* mag 0.5))) + ;; ((= num 5) (interval-widen number-interval (* mag 0.5))) + (else (interval-widen number-interval (* mag 0.25)))) + )) (define-public (adjust-slash-stencil num forward stencil mag) (if forward - (cond ((= num 2) - (ly:stencil-translate stencil (cons (* mag -0.00) (* mag 0.2)))) - ((= num 3) - (ly:stencil-translate stencil (cons (* mag -0.00) (* mag 0.2)))) - ;((= num 5) - ;(ly:stencil-translate stencil (cons (* mag -0.00) (* mag -0.07)))) - ;((= num 7) - ; (ly:stencil-translate stencil (cons (* mag -0.00) (* mag -0.15)))) - (else stencil)) - (cond ((= num 6) - (ly:stencil-translate stencil (cons (* mag -0.00) (* mag 0.15)))) - ;((= num 8) - ; (ly:stencil-translate stencil (cons (* mag -0.00) (* mag -0.15)))) - (else stencil)) + (cond ((= num 2) + (ly:stencil-translate stencil (cons (* mag -0.00) (* mag 0.2)))) + ((= num 3) + (ly:stencil-translate stencil (cons (* mag -0.00) (* mag 0.2)))) + ;; ((= num 5) + ;; (ly:stencil-translate stencil (cons (* mag -0.00) (* mag -0.07)))) + ;; ((= num 7) + ;; (ly:stencil-translate stencil (cons (* mag -0.00) (* mag -0.15)))) + (else stencil)) + (cond ((= num 6) + (ly:stencil-translate stencil (cons (* mag -0.00) (* mag 0.15)))) + ;; ((= num 8) + ;; (ly:stencil-translate stencil (cons (* mag -0.00) (* mag -0.15)))) + (else stencil)) + ) ) -) (define (slashed-digit-internal layout props num forward font-size thickness) (let* ((mag (magstep font-size)) (thickness (* mag (ly:output-def-lookup layout 'line-thickness) thickness)) - ; backward slashes might use slope and point in the other direction! + ;; backward slashes might use slope and point in the other direction! (dy (* mag (if forward 0.4 -0.4))) (number-stencil (interpret-markup layout (prepend-alist-chain 'font-encoding 'fetaText props) (number->string num))) (num-x (horizontal-slash-interval num forward (ly:stencil-extent number-stencil X) mag)) (center (interval-center (ly:stencil-extent number-stencil Y))) - ; Use the real extents of the slash, not the whole number, because we - ; might translate the slash later on! + ;; Use the real extents of the slash, not the whole number, + ;; because we might translate the slash later on! (num-y (interval-widen (cons center center) (abs dy))) (is-sane (and (interval-sane? num-x) (interval-sane? num-y))) (slash-stencil (if is-sane (make-line-stencil thickness - (car num-x) (- (interval-center num-y) dy) - (cdr num-x) (+ (interval-center num-y) dy)) + (car num-x) (- (interval-center num-y) dy) + (cdr num-x) (+ (interval-center num-y) dy)) #f))) (if (ly:stencil? slash-stencil) - (begin - ; for some numbers we need to shift the slash/backslash up or down to make - ; the slashed digit look better - (set! slash-stencil (adjust-slash-stencil num forward slash-stencil mag)) - (set! number-stencil - (ly:stencil-add number-stencil slash-stencil))) - (ly:warning "Unable to create slashed digit ~a" num)) + (begin + ;; for some numbers we need to shift the slash/backslash up or + ;; down to make the slashed digit look better + (set! slash-stencil (adjust-slash-stencil num forward slash-stencil mag)) + (set! number-stencil + (ly:stencil-add number-stencil slash-stencil))) + (ly:warning "Unable to create slashed digit ~a" num)) number-stencil)) @@ -2937,7 +3254,7 @@ and continue with double letters. (integer?) #:category other #:properties ((font-size 0) - (thickness 1.6)) + (thickness 1.6)) " @cindex slashed digits @@ -2957,7 +3274,7 @@ figured bass notation. (integer?) #:category other #:properties ((font-size 0) - (thickness 1.6)) + (thickness 1.6)) " @cindex backslashed digits @@ -3005,8 +3322,8 @@ figured bass notation. \\markup { \\eyeglasses } @end lilypond" (interpret-markup layout props - (make-override-markup '(line-cap-style . butt) - (make-path-markup 0.15 eyeglassespath)))) + (make-override-markup '(line-cap-style . butt) + (make-path-markup 0.15 eyeglassespath)))) (define-markup-command (left-brace layout props size) (number?) @@ -3025,28 +3342,28 @@ A feta brace in point size @var{size}. (cons '((font-encoding . fetaBraces) (font-name . #f)) props))) - (glyph-count (1- (ly:otf-glyph-count font))) + (glyph-count (1- (ly:otf-glyph-count font))) (scale (ly:output-def-lookup layout 'output-scale)) (scaled-size (/ (ly:pt size) scale)) (glyph (lambda (n) (ly:font-get-glyph font (string-append "brace" - (number->string n))))) - (get-y-from-brace (lambda (brace) - (interval-length - (ly:stencil-extent (glyph brace) Y)))) + (number->string n))))) + (get-y-from-brace (lambda (brace) + (interval-length + (ly:stencil-extent (glyph brace) Y)))) (find-brace (binary-search 0 glyph-count get-y-from-brace scaled-size)) (glyph-found (glyph find-brace))) (if (or (null? (ly:stencil-expr glyph-found)) - (< scaled-size (interval-length (ly:stencil-extent (glyph 0) Y))) - (> scaled-size (interval-length - (ly:stencil-extent (glyph glyph-count) Y)))) + (< scaled-size (interval-length (ly:stencil-extent (glyph 0) Y))) + (> scaled-size (interval-length + (ly:stencil-extent (glyph glyph-count) Y)))) (begin (ly:warning (_ "no brace found for point size ~S ") size) (ly:warning (_ "defaulting to ~S pt") - (/ (* scale (interval-length - (ly:stencil-extent glyph-found Y))) - (ly:pt 1))))) + (/ (* scale (interval-length + (ly:stencil-extent glyph-found Y))) + (ly:pt 1))))) glyph-found)) (define-markup-command (right-brace layout props size) @@ -3074,12 +3391,16 @@ A feta brace in point size @var{size}, rotated 180 degrees. (number? number? number?) #:category music #:properties ((font-size 0) - (style '())) + (flag-style '()) + (style '())) " @cindex notes within text by log and dot-count -Construct a note symbol, with stem. By using fractional values for +Construct a note symbol, with stem and flag. By using fractional values for @var{dir}, longer or shorter stems can be obtained. +Supports all note-head-styles. +Supported flag-styles are @code{default}, @code{old-straight-flag}, +@code{modern-straight-flag} and @code{flat-flag}. @lilypond[verbatim,quote] \\markup { @@ -3090,56 +3411,124 @@ Construct a note symbol, with stem. By using fractional values for @end lilypond" (define (get-glyph-name-candidates dir log style) (map (lambda (dir-name) - (format #f "noteheads.~a~a" dir-name - (if (and (symbol? style) - (not (equal? 'default style))) - (select-head-glyph style (min log 2)) - (min log 2)))) - (list (if (= dir UP) "u" "d") - "s"))) + (format #f "noteheads.~a~a" dir-name + (if (and (symbol? style) + (not (equal? 'default style))) + (select-head-glyph style (min log 2)) + (min log 2)))) + (list (if (= dir UP) "u" "d") + "s"))) (define (get-glyph-name font cands) (if (null? cands) - "" - (if (ly:stencil-empty? (ly:font-get-glyph font (car cands))) - (get-glyph-name font (cdr cands)) - (car cands)))) + "" + (if (ly:stencil-empty? (ly:font-get-glyph font (car cands))) + (get-glyph-name font (cdr cands)) + (car cands)))) + + (define (buildflags flag-stencil remain curr-stencil spacing) + ;; Function to recursively create a stencil with @code{remain} flags + ;; from the single-flag stencil @code{curr-stencil}, which is already + ;; translated to the position of the previous flag position. + ;; + ;; Copy and paste from /scm/flag-styles.scm + (if (> remain 0) + (let* ((translated-stencil + (ly:stencil-translate-axis curr-stencil spacing Y)) + (new-stencil (ly:stencil-add flag-stencil translated-stencil))) + (buildflags new-stencil (- remain 1) translated-stencil spacing)) + flag-stencil)) + + (define (straight-flag-mrkp flag-thickness flag-spacing + upflag-angle upflag-length + downflag-angle downflag-length + dir) + ;; Create a stencil for a straight flag. @var{flag-thickness} and + ;; @var{flag-spacing} are given in staff spaces, @var{upflag-angle} and + ;; @var{downflag-angle} are given in degrees, and @var{upflag-length} and + ;; @var{downflag-length} are given in staff spaces. + ;; + ;; All lengths are scaled according to the font size of the note. + ;; + ;; From /scm/flag-styles.scm, modified to fit here. + + (let* ((stem-up (> dir 0)) + ;; scale with the note size + (factor (magstep font-size)) + (stem-thickness (* factor 0.1)) + (line-thickness (ly:output-def-lookup layout 'line-thickness)) + (half-stem-thickness (/ (* stem-thickness line-thickness) 2)) + (raw-length (if stem-up upflag-length downflag-length)) + (angle (if stem-up upflag-angle downflag-angle)) + (flag-length (+ (* raw-length factor) half-stem-thickness)) + (flag-end (if (= angle 0) + (cons flag-length (* half-stem-thickness dir)) + (polar->rectangular flag-length angle))) + (thickness (* flag-thickness factor)) + (thickness-offset (cons 0 (* -1 thickness dir))) + (spacing (* -1 flag-spacing factor dir)) + (start (cons (- half-stem-thickness) (* half-stem-thickness dir))) + ;; The points of a round-filled-polygon need to be given in + ;; clockwise order, otherwise the polygon will be enlarged by + ;; blot-size*2! + (points (if stem-up + (list start + flag-end + (offset-add flag-end thickness-offset) + (offset-add start thickness-offset)) + (list start + (offset-add start thickness-offset) + (offset-add flag-end thickness-offset) + flag-end))) + (stencil (ly:round-filled-polygon points half-stem-thickness)) + ;; Log for 1/8 is 3, so we need to subtract 3 + (flag-stencil (buildflags stencil (- log 3) stencil spacing))) + flag-stencil)) (let* ((font (ly:paper-get-font layout (cons '((font-encoding . fetaMusic)) - props))) - (size-factor (magstep font-size)) - (stem-length (* size-factor (max 3 (- log 1)))) + props))) + (size-factor (magstep font-size)) + (blot (ly:output-def-lookup layout 'blot-diameter)) (head-glyph-name - (let ((result (get-glyph-name font (get-glyph-name-candidates - (sign dir) log style)))) - (if (string-null? result) - ;; If no glyph name can be found, select default heads. Though - ;; this usually means an unsupported style has been chosen, it - ;; also prevents unrelated 'style settings from other grobs - ;; (e.g., TextSpanner and TimeSignature) leaking into markup. - (get-glyph-name font (get-glyph-name-candidates - (sign dir) log 'default)) - result))) + (let ((result (get-glyph-name font + (get-glyph-name-candidates + (sign dir) log style)))) + (if (string-null? result) + ;; If no glyph name can be found, select default heads. + ;; Though this usually means an unsupported style has been + ;; chosen, it also prevents unrelated 'style settings from + ;; other grobs (e.g., TextSpanner and TimeSignature) leaking + ;; into markup. + (get-glyph-name font + (get-glyph-name-candidates + (sign dir) log 'default)) + result))) (head-glyph (ly:font-get-glyph font head-glyph-name)) - (attach-indices (ly:note-head::stem-attachment font head-glyph-name)) - (stem-thickness (* size-factor 0.13)) + (ancient-flags? (or (eq? style 'mensural) (eq? style 'neomensural))) + (attach-indices (ly:note-head::stem-attachment font head-glyph-name)) + (stem-length (* size-factor (max 3 (- log 1)))) + ;; With ancient-flags we want a tighter stem + (stem-thickness (* size-factor (if ancient-flags? 0.1 0.13))) (stemy (* dir stem-length)) (attach-off (cons (interval-index - (ly:stencil-extent head-glyph X) - (* (sign dir) (car attach-indices))) - (* (sign dir) ; fixme, this is inconsistent between X & Y. - (interval-index - (ly:stencil-extent head-glyph Y) - (cdr attach-indices))))) + (ly:stencil-extent head-glyph X) + (* (sign dir) (car attach-indices))) + ;; fixme, this is inconsistent between X & Y. + (* (sign dir) + (interval-index + (ly:stencil-extent head-glyph Y) + (cdr attach-indices))))) + ;; For a tighter stem (with ancient-flags) the stem-width has to be + ;; adjusted. + (stem-X-corr (if ancient-flags? (* 0.5 dir stem-thickness) 0)) (stem-glyph (and (> log 0) - (ly:round-filled-box - (ordered-cons (car attach-off) - (+ (car attach-off) - (* (- (sign dir)) stem-thickness))) - (cons (min stemy (cdr attach-off)) - (max stemy (cdr attach-off))) - (/ stem-thickness 3)))) - + (ly:round-filled-box + (ordered-cons (+ stem-X-corr (car attach-off)) + (+ stem-X-corr (car attach-off) + (* (- (sign dir)) stem-thickness))) + (cons (min stemy (cdr attach-off)) + (max stemy (cdr attach-off))) + (/ stem-thickness 3)))) (dot (ly:font-get-glyph font "dots.dot")) (dotwid (interval-length (ly:stencil-extent dot X))) (dots (and (> dot-count 0) @@ -3148,22 +3537,49 @@ Construct a note symbol, with stem. By using fractional values for (ly:stencil-translate-axis dot (* 2 x dotwid) X)) (iota dot-count))))) + ;; Straight-flags. Values taken from /scm/flag-style.scm + (modern-straight-flag (straight-flag-mrkp 0.55 1 -18 1.1 22 1.2 dir)) + (old-straight-flag (straight-flag-mrkp 0.55 1 -45 1.2 45 1.4 dir)) + (flat-flag (straight-flag-mrkp 0.55 1.0 0 1.0 0 1.0 dir)) + ;; Calculate a corrective to avoid a gap between + ;; straight-flags and the stem. + (flag-style-Y-corr (if (or (eq? flag-style 'modern-straight-flag) + (eq? flag-style 'old-straight-flag) + (eq? flag-style 'flat-flag)) + (/ blot 10 (* -1 dir)) + 0)) (flaggl (and (> log 2) (ly:stencil-translate - (ly:font-get-glyph font - (string-append "flags." - (if (> dir 0) "u" "d") - (number->string log))) - (cons (+ (car attach-off) (if (< dir 0) - stem-thickness 0)) - stemy))))) + (cond ((eq? flag-style 'modern-straight-flag) + modern-straight-flag) + ((eq? flag-style 'old-straight-flag) + old-straight-flag) + ((eq? flag-style 'flat-flag) + flat-flag) + (else + (ly:font-get-glyph font + (format #f (if ancient-flags? + "flags.mensural~a2~a" + "flags.~a~a") + (if (> dir 0) "u" "d") + log)))) + (cons (+ (car attach-off) + ;; For tighter stems (with ancient-flags) the + ;; flag has to be adjusted different. + (if (and (not ancient-flags?) (< dir 0)) + stem-thickness + 0)) + (+ stemy flag-style-Y-corr)))))) ;; If there is a flag on an upstem and the stem is short, move the dots ;; to avoid the flag. 16th notes get a special case because their flags ;; hang lower than any other flags. + ;; Not with ancient flags or straight-flags. (if (and dots (> dir 0) (> log 2) - (or (< dir 1.15) (and (= log 4) (< dir 1.3)))) - (set! dots (ly:stencil-translate-axis dots 0.5 X))) + (or (eq? flag-style 'default) (null? flag-style)) + (not ancient-flags?) + (or (< dir 1.15) (and (= log 4) (< dir 1.3)))) + (set! dots (ly:stencil-translate-axis dots 0.5 X))) (if flaggl (set! stem-glyph (ly:stencil-add flaggl stem-glyph))) (if (ly:stencil? stem-glyph) @@ -3173,9 +3589,9 @@ Construct a note symbol, with stem. By using fractional values for (set! stem-glyph (ly:stencil-add (ly:stencil-translate-axis - dots - (+ (cdr (ly:stencil-extent head-glyph X)) dotwid) - X) + dots + (+ (cdr (ly:stencil-extent head-glyph X)) dotwid) + X) stem-glyph))) stem-glyph)) @@ -3187,7 +3603,7 @@ Construct a note symbol, with stem. By using fractional values for "Parse the `duration-string', e.g. ''4..'' or ''breve.'', and return a (log dots) list." (let ((match (regexp-exec (make-regexp "(breve|longa|maxima|[0-9]+)(\\.*)") - duration-string))) + duration-string))) (if (and match (string=? duration-string (match:substring match 0))) (let ((len (match:substring match 1)) (dots (match:substring match 2))) @@ -3222,6 +3638,287 @@ a shortened down stem. (let ((parsed (parse-simple-duration duration))) (note-by-number-markup layout props (car parsed) (cadr parsed) dir))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; the rest command. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-markup-command (rest-by-number layout props log dot-count) + (number? number?) + #:category music + #:properties ((font-size 0) + (style '()) + (multi-measure-rest #f)) + " +@cindex rests or multi-measure-rests within text by log and dot-count + +A rest or multi-measure-rest symbol. + +@lilypond[verbatim,quote] +\\markup { + \\rest-by-number #3 #2 + \\hspace #2 + \\rest-by-number #0 #1 + \\hspace #2 + \\override #'(multi-measure-rest . #t) + \\rest-by-number #0 #0 +} +@end lilypond" + + (define (get-glyph-name-candidates log style) + (let* (;; Choose the style-string to be added. + ;; If no glyph exists, select others for the specified styles + ;; otherwise defaulting. + (style-strg + (cond ( + ;; 'baroque needs to be special-cased, otherwise + ;; `select-head-glyph´ would catch neomensural-glyphs for + ;; this style, if (< log 0). + (eq? style 'baroque) + (string-append (number->string log) "")) + ((eq? style 'petrucci) + (string-append (number->string log) "mensural")) + ;; In other cases `select-head-glyph´ from output-lib.scm + ;; works for rest-glyphs, too. + ((and (symbol? style) (not (eq? style 'default))) + (select-head-glyph style log)) + (else log))) + ;; Choose ledgered glyphs for whole and half rest. + ;; Except for the specified styles, logs and MultiMeasureRests. + (ledger-style-rests + (if (and (or (list? style) + (not (member style + '(neomensural mensural petrucci)))) + (not multi-measure-rest) + (or (= log 0) (= log 1))) + "o" + ""))) + (format #f "rests.~a~a" style-strg ledger-style-rests))) + + (define (get-glyph-name font cands) + (if (ly:stencil-empty? (ly:font-get-glyph font cands)) + "" + cands)) + + (let* ((font + (ly:paper-get-font layout + (cons '((font-encoding . fetaMusic)) props))) + (rest-glyph-name + (let ((result + (get-glyph-name font + (get-glyph-name-candidates log style)))) + (if (string-null? result) + ;; If no glyph name can be found, select default rests. Though + ;; this usually means an unsupported style has been chosen, it + ;; also prevents unrelated 'style settings from other grobs + ;; (e.g., TextSpanner and TimeSignature) leaking into markup. + (get-glyph-name font (get-glyph-name-candidates log 'default)) + result))) + (rest-glyph (ly:font-get-glyph font rest-glyph-name)) + (dot (ly:font-get-glyph font "dots.dot")) + (dot-width (interval-length (ly:stencil-extent dot X))) + (dots (and (> dot-count 0) + (apply ly:stencil-add + (map (lambda (x) + (ly:stencil-translate-axis + dot (* 2 x dot-width) X)) + (iota dot-count)))))) + + ;; Apart from mensural-, neomensural- and petrucci-style ledgered + ;; glyphs are taken for whole and half rests. + ;; If they are dotted, move the dots in X-direction to avoid collision. + (if (and dots + (< log 2) + (>= log 0) + (not (member style '(neomensural mensural petrucci)))) + (set! dots (ly:stencil-translate-axis dots dot-width X))) + + ;; Add dots to the rest-glyph. + ;; + ;; Not sure how to vertical align dots. + ;; For now the dots are centered for half, whole or longer rests. + ;; Otherwise placed near the top of the rest. + ;; + ;; Dots for rests with (< log 0) dots are allowed, but not + ;; if multi-measure-rest is set #t. + (if (and (not multi-measure-rest) dots) + (set! rest-glyph + (ly:stencil-add + (ly:stencil-translate + dots + (cons + (+ (cdr (ly:stencil-extent rest-glyph X)) dot-width) + (if (< log 2) + (interval-center (ly:stencil-extent rest-glyph Y)) + (- (interval-end (ly:stencil-extent rest-glyph Y)) + (/ (* 2 dot-width) 3))))) + rest-glyph))) + rest-glyph)) + +(define-markup-command (rest layout props duration) + (string?) + #:category music + #:properties ((style '()) + (multi-measure-rest #f) + (multi-measure-rest-number #t) + (word-space 0.6)) + " +@cindex rests or multi-measure-rests within text by string + +This produces a rest, with the @var{duration} for the rest type and +augmentation dots. +@code{\"breve\"}, @code{\"longa\"} and @code{\"maxima\"} are valid +input-strings. + +Printing MultiMeasureRests could be enabled with +@code{\\override #'(multi-measure-rest . #t)} +If MultiMeasureRests are taken, the MultiMeasureRestNumber is printed above. +This is enabled for all styles using default-glyphs. +Could be disabled with @code{\\override #'(multi-measure-rest-number . #f)} + +@lilypond[verbatim,quote] +\\markup { + \\rest #\"4..\" + \\hspace #2 + \\rest #\"breve\" + \\hspace #2 + \\override #'(multi-measure-rest . #t) + { + \\rest #\"7\" + \\hspace #2 + \\override #'(multi-measure-rest-number . #f) + \\rest #\"7\" + } +} +@end lilypond" + ;; Get the number of mmr-glyphs. + ;; Store them in a list. + ;; example: (mmr-numbers 25) -> '(3 0 0 1) + (define (mmr-numbers nmbr) + (let* ((8-bar-glyph (floor (/ nmbr 8))) + (8-remainder (remainder nmbr 8)) + (4-bar-glyph (floor (/ 8-remainder 4))) + (4-remainder (remainder nmbr 4)) + (2-bar-glyph (floor (/ 4-remainder 2))) + (2-remainder (remainder 4-remainder 2)) + (1-bar-glyph (floor (/ 2-remainder 1)))) + (list 8-bar-glyph 4-bar-glyph 2-bar-glyph 1-bar-glyph))) + + ;; Get the correct mmr-glyphs. + ;; Store them in a list. + ;; example: + ;; (get-mmr-glyphs '(1 0 1 0) '("rests.M3" "rests.M2" "rests.M1" "rests.0")) + ;; -> ("rests.M3" "rests.M1") + (define (get-mmr-glyphs lst1 lst2) + (define (helper l1 l2 l3) + (if (null? l1) + (reverse l3) + (helper (cdr l1) + (cdr l2) + (append (make-list (car l1) (car l2)) l3)))) + (helper lst1 lst2 '())) + + ;; If duration is not valid, print a warning and return empty-stencil + (if (or (and (not (integer? (car (parse-simple-duration duration)))) + (not multi-measure-rest)) + (and (= (string-length (car (string-split duration #\. ))) 1) + (= (string->number (car (string-split duration #\. ))) 0))) + (begin + (ly:warning (_ "not a valid duration string: ~a - ignoring") duration) + empty-stencil) + (let* ( + ;; For simple rests: + ;; Get a (log dots) list. + (parsed (parse-simple-duration duration)) + ;; Create the rest-stencil + (stil + (rest-by-number-markup layout props (car parsed) (cadr parsed))) + ;; For MultiMeasureRests: + ;; Get the duration-part of duration + (dur-part-string (car (string-split duration #\. ))) + ;; Get the duration of MMR: + ;; If not a number (eg. "maxima") calculate it. + (mmr-duration + (or (string->number dur-part-string) (expt 2 (abs (car parsed))))) + ;; Get a list of the correct number of each mmr-glyph. + (count-mmr-glyphs-list (mmr-numbers mmr-duration)) + ;; Create a list of mmr-stencils, + ;; translating the glyph for a whole rest. + (mmr-stils-list + (map + (lambda (x) + (let ((single-mmr-stil + (rest-by-number-markup layout props (* -1 x) 0))) + (if (= x 0) + (ly:stencil-translate-axis + single-mmr-stil + ;; Ugh, hard-coded, why 1? + 1 + Y) + single-mmr-stil))) + (get-mmr-glyphs count-mmr-glyphs-list (reverse (iota 4))))) + ;; Adjust the space between the mmr-glyphs, + ;; if not default-glyphs are used. + (word-space (if (member style + '(neomensural mensural petrucci)) + (/ (* word-space 2) 3) + word-space)) + ;; Create the final mmr-stencil + ;; via `stack-stencil-line´ from /scm/markup.scm + (mmr-stil (stack-stencil-line word-space mmr-stils-list))) + + ;; Print the number above a multi-measure-rest + ;; Depends on duration, style and multi-measure-rest-number set #t + (if (and multi-measure-rest + multi-measure-rest-number + (> mmr-duration 1) + (not (member style '(neomensural mensural petrucci)))) + (let* ((mmr-stil-x-center + (interval-center (ly:stencil-extent mmr-stil X))) + (duration-markup + (markup + #:fontsize -2 + #:override '(font-encoding . fetaText) + (number->string mmr-duration))) + (mmr-number-stil + (interpret-markup layout props duration-markup)) + (mmr-number-stil-x-center + (interval-center (ly:stencil-extent mmr-number-stil X)))) + + (set! mmr-stil (ly:stencil-combine-at-edge + mmr-stil + Y UP + (ly:stencil-translate-axis + mmr-number-stil + (- mmr-stil-x-center mmr-number-stil-x-center) + X) + ;; Ugh, hardcoded + 0.8)))) + (if multi-measure-rest + mmr-stil + stil)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; fermata markup +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-markup-command (fermata layout props) () + #:category music + #:properties ((direction UP)) + "Create a fermata glyph. When @var{direction} is @code{DOWN}, use +an inverted glyph. Note that within music, one would usually use the +@code{\\fermata} articulation instead of a markup. + +@lilypond[verbatim,quote] + { c''1^\\markup \\fermata d''1_\\markup \\fermata } + +\\markup { \\fermata \\override #`(direction . ,DOWN) \\fermata } +@end lilypond +" + (interpret-markup layout props + (if (eqv? direction DOWN) + (markup #:musicglyph "scripts.dfermata") + (markup #:musicglyph "scripts.ufermata")))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; translating. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -3244,7 +3941,7 @@ A negative @var{amount} indicates raising; see also @code{\\raise}. } @end lilypond" (ly:stencil-translate-axis (interpret-markup layout props arg) - (- amount) Y)) + (- amount) Y)) (define-markup-command (translate-scaled layout props offset arg) (number-pair? markup?) @@ -3331,9 +4028,9 @@ Make a fraction of two markups. ;; should stack mols separately, to maintain LINE on baseline (stack (stack-lines DOWN padding baseline (list m1 line m2)))) (set! stack - (ly:stencil-aligned-to stack Y CENTER)) + (ly:stencil-aligned-to stack Y CENTER)) (set! stack - (ly:stencil-aligned-to stack X LEFT)) + (ly:stencil-aligned-to stack X LEFT)) ;; should have EX dimension ;; empirical anyway (ly:stencil-translate-axis stack offset Y)))) @@ -3341,7 +4038,7 @@ Make a fraction of two markups. (define-markup-command (normal-size-super layout props arg) (markup?) #:category font - #:properties ((baseline-skip)) + #:properties ((font-size 0)) " @cindex setting superscript in standard font size @@ -3357,13 +4054,12 @@ Set @var{arg} in superscript with a normal font size. @end lilypond" (ly:stencil-translate-axis (interpret-markup layout props arg) - (* 0.5 baseline-skip) Y)) + (* 1.0 (magstep font-size)) Y)) (define-markup-command (super layout props arg) (markup?) #:category font - #:properties ((font-size 0) - (baseline-skip)) + #:properties ((font-size 0)) " @cindex superscript text @@ -3384,7 +4080,7 @@ Set @var{arg} in superscript. layout (cons `((font-size . ,(- font-size 3))) props) arg) - (* 0.5 baseline-skip) + (* 1.0 (magstep font-size)) ; original font-size Y)) (define-markup-command (translate layout props offset arg) @@ -3404,13 +4100,12 @@ is a pair of numbers representing the displacement in the X and Y axis. } @end lilypond" (ly:stencil-translate (interpret-markup layout props arg) - offset)) + offset)) (define-markup-command (sub layout props arg) (markup?) #:category font - #:properties ((font-size 0) - (baseline-skip)) + #:properties ((font-size 0)) " @cindex subscript text @@ -3432,13 +4127,13 @@ Set @var{arg} in subscript. layout (cons `((font-size . ,(- font-size 3))) props) arg) - (* -0.5 baseline-skip) + (* -0.75 (magstep font-size)) ; original font-size Y)) (define-markup-command (normal-size-sub layout props arg) (markup?) #:category font - #:properties ((baseline-skip)) + #:properties ((font-size 0)) " @cindex setting subscript in standard font size @@ -3454,7 +4149,7 @@ Set @var{arg} in subscript with a normal font size. @end lilypond" (ly:stencil-translate-axis (interpret-markup layout props arg) - (* -0.5 baseline-skip) + (* -0.75 (magstep font-size)) Y)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -3505,10 +4200,10 @@ Draw vertical brackets around @var{arg}. (markup?) #:category graphic #:properties ((angularity 0) - (padding) - (size 1) - (thickness 1) - (width 0.25)) + (padding) + (size 1) + (thickness 1) + (width 0.25)) " @cindex placing parentheses around text @@ -3535,17 +4230,17 @@ a column containing several lines of text. } } @end lilypond" - (let* ((markup (interpret-markup layout props arg)) - (scaled-width (* size width)) - (scaled-thickness - (* (chain-assoc-get 'line-thickness props 0.1) - thickness)) - (half-thickness - (min (* size 0.5 scaled-thickness) - (* (/ 4 3.0) scaled-width))) - (padding (chain-assoc-get 'padding props half-thickness))) + (let* ((m (interpret-markup layout props arg)) + (scaled-width (* size width)) + (scaled-thickness + (* (chain-assoc-get 'line-thickness props 0.1) + thickness)) + (half-thickness + (min (* size 0.5 scaled-thickness) + (* (/ 4 3.0) scaled-width))) + (padding (chain-assoc-get 'padding props half-thickness))) (parenthesize-stencil - markup half-thickness scaled-width angularity padding))) + m half-thickness scaled-width angularity padding))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -3561,23 +4256,32 @@ a column containing several lines of text. Reference to a page number. @var{label} is the label set on the referenced page (using the @code{\\label} command), @var{gauge} a markup used to estimate the maximum width of the page number, and @var{default} the value to display -when @var{label} is not found." +when @var{label} is not found. + +(If the current book or bookpart is set to use roman numerals for page numbers, +the reference will be formatted accordingly -- in which case the @var{gauge}'s +width may require additional tweaking.)" (let* ((gauge-stencil (interpret-markup layout props gauge)) - (x-ext (ly:stencil-extent gauge-stencil X)) - (y-ext (ly:stencil-extent gauge-stencil Y))) + (x-ext (ly:stencil-extent gauge-stencil X)) + (y-ext (ly:stencil-extent gauge-stencil Y))) + (ly:stencil-add + (make-transparent-box-stencil x-ext y-ext)) (ly:make-stencil `(delay-stencil-evaluation ,(delay (ly:stencil-expr - (let* ((table (ly:output-def-lookup layout 'label-page-table)) - (page-number (if (list? table) - (assoc-get label table) - #f)) - (page-markup (if page-number (format #f "~a" page-number) default)) - (page-stencil (interpret-markup layout props page-markup)) - (gap (- (interval-length x-ext) - (interval-length (ly:stencil-extent page-stencil X))))) - (interpret-markup layout props - (markup #:concat (#:hspace gap page-markup))))))) + (let* ((table (ly:output-def-lookup layout 'label-page-table)) + (page-number (if (list? table) + (assoc-get label table) + #f)) + (number-type (ly:output-def-lookup layout 'page-number-type)) + (page-markup (if page-number + (number-format number-type page-number) + default)) + (page-stencil (interpret-markup layout props page-markup)) + (gap (- (interval-length x-ext) + (interval-length (ly:stencil-extent page-stencil X))))) + (interpret-markup layout props + (markup #:hspace gap page-markup)))))) x-ext y-ext))) @@ -3607,8 +4311,8 @@ Negative values may be used to produce mirror images. } @end lilypond" (let ((stil (interpret-markup layout props arg)) - (sx (car factor-pair)) - (sy (cdr factor-pair))) + (sx (car factor-pair)) + (sy (cdr factor-pair))) (ly:stencil-scale stil sx sy))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -3633,20 +4337,20 @@ Patterns are distributed on @var{axis}. } @end lilypond" (let ((pattern-width (interval-length - (ly:stencil-extent (interpret-markup layout props pattern) X))) + (ly:stencil-extent (interpret-markup layout props pattern) X))) (new-props (prepend-alist-chain 'word-space 0 (prepend-alist-chain 'baseline-skip 0 props)))) (let loop ((i (1- count)) (patterns (markup))) (if (zero? i) (interpret-markup - layout - new-props - (if (= axis X) - (markup patterns pattern) - (markup #:column (patterns pattern)))) + layout + new-props + (if (= axis X) + (markup patterns pattern) + (markup #:column (patterns pattern)))) (loop (1- i) - (if (= axis X) - (markup patterns pattern #:hspace space) - (markup #:column (patterns pattern #:vspace space)))))))) + (if (= axis X) + (markup patterns pattern #:hspace space) + (markup #:column (patterns pattern #:vspace space)))))))) (define-markup-command (fill-with-pattern layout props space dir pattern left right) (number? ly:dir? markup? markup? markup?) @@ -3690,35 +4394,57 @@ Patterns are aligned to the @var{dir} markup. #:pattern (1+ count) X space pattern right)))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Replacements +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-markup-command (replace layout props replacements arg) + (list? markup?) + #:category font + " +Used to automatically replace a string by another in the markup @var{arg}. +Each pair of the alist @var{replacements} specifies what should be replaced. +The @code{key} is the string to be replaced by the @code{value} string. + +@lilypond[verbatim, quote] +\\markup \\replace #'((\"thx\" . \"Thanks!\")) thx +@end lilypond" + (interpret-markup + layout + (internal-add-text-replacements + props + replacements) + (markup arg))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Markup list commands ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-public (space-lines baseline stils) (let space-stil ((stils stils) - (result (list))) + (result (list))) (if (null? stils) - (reverse! result) - (let* ((stil (car stils)) - (dy-top (max (- (/ baseline 1.5) - (interval-bound (ly:stencil-extent stil Y) UP)) - 0.0)) - (dy-bottom (max (+ (/ baseline 3.0) - (interval-bound (ly:stencil-extent stil Y) DOWN)) - 0.0)) - (new-stil (ly:make-stencil - (ly:stencil-expr stil) - (ly:stencil-extent stil X) - (cons (- (interval-bound (ly:stencil-extent stil Y) DOWN) - dy-bottom) - (+ (interval-bound (ly:stencil-extent stil Y) UP) - dy-top))))) - (space-stil (cdr stils) (cons new-stil result)))))) + (reverse! result) + (let* ((stil (car stils)) + (dy-top (max (- (/ baseline 1.5) + (interval-bound (ly:stencil-extent stil Y) UP)) + 0.0)) + (dy-bottom (max (+ (/ baseline 3.0) + (interval-bound (ly:stencil-extent stil Y) DOWN)) + 0.0)) + (new-stil (ly:make-stencil + (ly:stencil-expr stil) + (ly:stencil-extent stil X) + (cons (- (interval-bound (ly:stencil-extent stil Y) DOWN) + dy-bottom) + (+ (interval-bound (ly:stencil-extent stil Y) UP) + dy-top))))) + (space-stil (cdr stils) (cons new-stil result)))))) (define-markup-list-command (justified-lines layout props args) (markup-list?) #:properties ((baseline-skip) - wordwrap-internal-markup-list) + wordwrap-internal-markup-list) " @cindex justifying lines of text @@ -3732,7 +4458,7 @@ Use @code{\\override-lines #'(line-width . @var{X})} to set the line width; (define-markup-list-command (wordwrap-lines layout props args) (markup-list?) #:properties ((baseline-skip) - wordwrap-internal-markup-list) + wordwrap-internal-markup-list) "Like @code{\\wordwrap}, but return a list of lines instead of a single markup. Use @code{\\override-lines #'(line-width . @var{X})} to set the line width, where @var{X} is the number of staff spaces." @@ -3746,9 +4472,46 @@ where @var{X} is the number of staff spaces." "Like @code{\\column}, but return a list of lines instead of a single markup. @code{baseline-skip} determines the space between each markup in @var{args}." (space-lines baseline-skip - (interpret-markup-list layout props args))) + (interpret-markup-list layout props args))) (define-markup-list-command (override-lines layout props new-prop args) (pair? markup-list?) "Like @code{\\override}, for markup lists." (interpret-markup-list layout (cons (list new-prop) props) args)) + +(define-markup-list-command (map-markup-commands layout props compose args) + (procedure? markup-list?) + "This applies the function @var{compose} to every markup in +@var{args} (including elements of markup list command calls) in order +to produce a new markup list. Since the return value from a markup +list command call is not a markup list but rather a list of stencils, +this requires passing those stencils off as the results of individual +markup calls. That way, the results should work out as long as no +markups rely on side effects." + (let ((key (make-symbol "key"))) + (catch + key + (lambda () + ;; if `compose' does not actually interpret its markup + ;; argument, we still need to return a list of stencils, + ;; created from the single returned stencil + (list + (interpret-markup layout props + (compose + (make-on-the-fly-markup + (lambda (layout props m) + ;; here all effects of `compose' on the + ;; properties should be visible, so we + ;; call interpret-markup-list at this + ;; point of time and harvest its + ;; stencils + (throw key + (interpret-markup-list + layout props args))) + (make-null-markup)))))) + (lambda (key stencils) + (map + (lambda (sten) + (interpret-markup layout props + (compose (make-stencil-markup sten)))) + stencils)))))