X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fdefine-markup-commands.scm;h=3e7b2f2308f2e61d35282743328ded3e69d90a81;hb=2c894ac3f60274f9fdd0bf2593cfb856c5c7b13f;hp=ecbe876ffa6e1a88b8f91d53b391cb5141340c7b;hpb=4b1f3e392230dfd31312e192afb02deaf0ad77d0;p=lilypond.git diff --git a/scm/define-markup-commands.scm b/scm/define-markup-commands.scm old mode 100755 new mode 100644 index ecbe876ffa..3e7b2f2308 --- 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--2012 Han-Wen Nienhuys +;;;; Copyright (C) 2000--2015 Han-Wen Nienhuys ;;;; Jan Nieuwenhuizen ;;;; ;;;; LilyPond is free software: you can redistribute it and/or modify @@ -115,6 +115,31 @@ 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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -194,40 +219,40 @@ Manual settings for @code{on},@code{off} and @code{phase} are possible. ;; 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)))))) + (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 @@ -244,9 +269,9 @@ Manual settings for @code{on},@code{off} and @code{phase} are possible. ;; 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)))) + (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?) @@ -275,11 +300,92 @@ line-length. @end lilypond" (let ((new-props (prepend-alist-chain 'on 0 - (prepend-alist-chain 'full-length #t props)))) + (prepend-alist-chain 'full-length #t props)))) - (interpret-markup layout - new-props - (markup #:draw-dashed-line dest)))) + (interpret-markup layout + new-props + (markup #:draw-dashed-line dest)))) + +(define-markup-command (draw-squiggle-line layout props sq-length dest eq-end?) + (number? number-pair? boolean?) + #:category graphic + #:properties ((thickness 0.5) + (angularity 0) + (height 0.5) + (orientation 1)) + " +@cindex drawing squiggled lines within text + +A squiggled line. + +If @code{eq-end?} is set to @code{#t}, it is ensured the squiggled line ends +with a bow in same direction as the starting one. @code{sq-length} is the +length of the first bow. @code{dest} is the end point of the squiggled line. +To match @code{dest} the squiggled line is scaled accordingly. +Its appearance may be customized by overrides for @code{thickness}, +@code{angularity}, @code{height} and @code{orientation}. +@lilypond[verbatim,quote] +\\markup + \\column { + \\draw-squiggle-line #0.5 #'(6 . 0) ##t + \\override #'(orientation . -1) + \\draw-squiggle-line #0.5 #'(6 . 0) ##t + \\draw-squiggle-line #0.5 #'(6 . 0) ##f + \\override #'(height . 1) + \\draw-squiggle-line #0.5 #'(6 . 0) ##t + \\override #'(thickness . 5) + \\draw-squiggle-line #0.5 #'(6 . 0) ##t + \\override #'(angularity . 2) + \\draw-squiggle-line #0.5 #'(6 . 0) ##t + } +@end lilypond" + (let* ((line-thickness (ly:output-def-lookup layout 'line-thickness)) + (thick (* thickness line-thickness)) + (x (car dest)) + (y (cdr dest)) + (length-to-print (magnitude (make-rectangular x y))) + ;; Make a guess how many bows may be needed + (guess (max 1 (truncate (/ length-to-print sq-length)))) + ;; If `eq-end?' is set #t, make sure squiggle-line starts and ends + ;; with a bow in same direction + (amount (if (and (even? guess) eq-end?) (1+ guess) guess)) + ;; The lined-up bows needs to fit `length-to-print' + ;; Thus scale the length of first bow accordingly + ;; Other bows are copies + (guessed-squiggle-line-length (* amount sq-length)) + (line-length-diff (- length-to-print guessed-squiggle-line-length)) + (line-length-diff-for-each-squiggle + (/ line-length-diff amount)) + (first-bow-length (+ sq-length line-length-diff-for-each-squiggle)) + ;; Get first bows + ;; TODO two bows are created via `make-bow-stencil' + ;; cheaper to use `ly:stencil-scale'? + (first-bow-end-coord + (cons + (/ (* first-bow-length x) length-to-print) + (/ (* first-bow-length y) length-to-print))) + (init-bow + (lambda (o) + (make-bow-stencil + '(0 . 0) + first-bow-end-coord + thick angularity height o))) + (init-bow-up (init-bow orientation)) + (init-bow-down (init-bow (- orientation))) + ;; Get a list of starting-points for the bows + (list-of-starts + (map + (lambda (n) + (cons + (* n (car first-bow-end-coord)) + (* n (cdr first-bow-end-coord)))) + (iota amount)))) + ;; The final stencil: lined-up bows + (apply ly:stencil-add + (map + ly:stencil-translate + (circular-list init-bow-up init-bow-down) + list-of-starts)))) (define-markup-command (draw-hline layout props) () @@ -304,8 +410,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?) @@ -329,8 +435,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 @@ -349,8 +455,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))))) @@ -358,8 +464,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 @@ -376,10 +482,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 @@ -399,10 +561,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))) @@ -421,13 +583,23 @@ 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))) +(define-public (book-first-page layout props) + "Return the @code{'first-page-number} of the entire book" + (define (ancestor layout) + "Return the topmost layout ancestor" + (let ((parent (ly:output-def-parent layout))) + (if (not (ly:output-def? parent)) + layout + (ancestor parent)))) + (ly:output-def-lookup (ancestor layout) 'first-page-number)) + (define-markup-command (with-link layout props label arg) (symbol? markup?) #:category other @@ -447,20 +619,24 @@ 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)) - (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))) - + (ly:stencil-add + (ly:make-stencil + `(delay-stencil-evaluation + ,(delay (let* ((table (ly:output-def-lookup layout 'label-page-table)) + (table-page-number + (if (list? table) + (assoc-get label table) + #f)) + (first-page-number (book-first-page layout props)) + (current-page-number + (if table-page-number + (1+ (- table-page-number first-page-number)) + #f))) + (list 'page-link current-page-number + `(quote ,x-ext) `(quote ,y-ext))))) + x-ext + y-ext) + arg-stencil))) (define-markup-command (beam layout props width slope thickness) (number? number? number?) @@ -475,20 +651,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?) @@ -513,19 +689,108 @@ 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 (tie layout props arg) + (markup?) + #:category font + #:properties ((thickness 1) + (offset 2) + (direction UP) + (shorten-pair '(0 . 0))) + " +@cindex tie-ing text + +Adds a horizontal bow created with @code{make-tie-stencil} at bottom or top +of @var{arg}. Looks at @code{thickness} to determine line thickness, and +@code{offset} to determine y-offset. The added bow fits the extent of +@var{arg}, @code{shorten-pair} may be used to modify this. +@var{direction} may be set using an @code{override} or direction-modifiers or +@code{voiceOne}, etc. + +@lilypond[verbatim,quote] +\\markup { + \\override #'(direction . 1) + \\tie \"above\" + \\override #'(direction . -1) + \\tie \"below\" +} +@end lilypond" + (let* ((line-thickness (ly:output-def-lookup layout 'line-thickness)) + (thick (* thickness line-thickness)) + (stil (interpret-markup layout props arg)) + (x1 (car (ly:stencil-extent stil X))) + (x2 (cdr (ly:stencil-extent stil X))) + (y-ext (ly:stencil-extent stil Y)) + (y (+ (* line-thickness offset direction) + ;; we put out zero for positive text-direction, to make it + ;; consistent with `underline-markup' + ;; TODO: this will be problematic for args like "Eng" + ;; fix it here _and_ in `underline-markup' + (if (negative? direction) 0 (cdr y-ext)))) + (tie + (make-tie-stencil + (cons (+ x1 (car shorten-pair) line-thickness) y) + (cons (- x2 (cdr shorten-pair) line-thickness) y) + thick + direction))) + (ly:stencil-add stil tie))) + +(define-markup-command (undertie layout props arg) + (markup?) + #:category font + #:properties (tie-markup) + " +@cindex undertie-ing text + +@lilypond[verbatim,quote] +\\markup \\line { + \\undertie \"undertied\" + \\override #'(offset . 5) + \\override #'(thickness . 1) + \\undertie \"undertied\" + \\override #'(offset . 1) + \\override #'(thickness . 5) + \\undertie \"undertied\" +} +@end lilypond" + (interpret-markup layout (prepend-alist-chain 'direction DOWN props) + (make-tie-markup arg))) + +(define-markup-command (overtie layout props arg) + (markup?) + #:category font + #:properties (tie-markup) + " +@cindex overtie-ing text + +Overtie @var{arg}. + +@lilypond[verbatim,quote] +\\markup \\line { + \\overtie \"overtied\" + \\override #'(offset . 5) + \\override #'(thickness . 1) + \\overtie \"overtied\" + \\override #'(offset . 1) + \\override #'(thickness . 5) + \\overtie \"overtied\" +} +@end lilypond" + (interpret-markup layout (prepend-alist-chain 'direction UP props) + (make-tie-markup arg))) (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 @@ -578,9 +843,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}, @@ -627,19 +892,44 @@ Rotate object with @var{ang} degrees around its center. (define-markup-command (whiteout layout props arg) (markup?) #:category other + #:properties ((style 'box) + (thickness '())) " @cindex adding a white background to text -Provide a white background for @var{arg}. +Provide a white background for @var{arg}. The shape of the white +background is determined by @code{style}. The default +is @code{box} which produces a rectangle. @code{rounded-box} +produces a rounded rectangle. @code{outline} approximates the +outline of the markup. @lilypond[verbatim,quote] \\markup { \\combine - \\filled-box #'(-1 . 10) #'(-3 . 4) #1 - \\whiteout whiteout + \\filled-box #'(-1 . 15) #'(-3 . 4) #1 + \\override #'(thickness . 1.5) + \\whiteout whiteout-box +} +\\markup { + \\combine + \\filled-box #'(-1 . 24) #'(-3 . 4) #1 + \\override #'(style . rounded-box) + \\override #'(thickness . 3) + \\whiteout whiteout-rounded-box +} +\\markup { + \\combine + \\filled-box #'(-1 . 18) #'(-3 . 4) #1 + \\override #'(style . outline) + \\override #'(thickness . 3) + \\whiteout whiteout-outline } @end lilypond" - (stencil-whiteout (interpret-markup layout props arg))) + (stencil-whiteout + (interpret-markup layout props arg) + style + thickness + (ly:output-def-lookup layout 'line-thickness))) (define-markup-command (pad-markup layout props amount arg) (number? markup?) @@ -649,6 +939,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 { @@ -663,15 +954,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 @@ -686,9 +973,9 @@ 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) + ))) (define-markup-command (hspace layout props amount) (number?) @@ -710,9 +997,9 @@ Create an invisible object taking up horizontal space @var{amount}. (ly:make-stencil "" (cons 0 amount) empty-interval)) (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 @@ -761,11 +1048,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?) @@ -820,38 +1107,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 @@ -874,6 +1151,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) @@ -885,90 +1172,90 @@ 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) (= 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))) + (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. This is not usually called directly by -the user. Instead, it is called when the parser encounters -@code{\\score} in a context where only markup lists are allowed. When -used as the argument of a toplevel @code{\\markuplist}, the result can -be split across pages." + "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) @@ -981,8 +1268,8 @@ be split across pages." (- (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?")) + (begin + (ly:warning (_"no systems found in \\score markup, does it have a \\layout block?")) '())))) (define-markup-command (score layout props score) @@ -1080,92 +1367,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?) @@ -1194,79 +1537,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)))) + (justify-line-helper + layout props args text-direction word-space line-width #f)) - (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 (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 stencils))) + (justify-line-helper + layout props args text-direction word-space line-width #t)) (define-markup-command (concat layout props args) (markup-list?) @@ -1291,101 +1583,122 @@ equivalent to @code{\"fi\"}. @end lilypond" (define (concat-string-args arg-list) (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))) + (let ((result (and (pair? result-list) + (car result-list)))) + (cond ((not (pair? arg))) + ((eq? (car arg) simple-markup) + (set! arg (cadr arg))) + ((eq? (car arg) char-markup) + (set! arg (ly:wide-char->utf-8 (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 - (make-override-lines-markup-list - (cons 'word-space - (chain-assoc-get 'word-space props)) - (if (markup-command-list? args) - args - (concat-string-args args)))))) + (stack-stencil-line 0 + (interpret-markup-list layout 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 (stencil-space stencil line-start) - (if (ly:stencil-empty? stencil X) - 0 - (cdr (ly:stencil-extent - (ly:stencil-stack (if line-start - empty-stencil - point-stencil) - X RIGHT stencil) - X)))) - (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 (stencil-space first (null? accumulator))) - (newwid (+ (if (or (ly:stencil-empty? first Y) - (ly:stencil-empty? first X)) - 0 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 - (stencil-space - (stack-stencil-line 0 line-stencils) - #t))) - (line-words (count (lambda (s) (not (or (ly:stencil-empty? s Y) - (ly:stencil-empty? s 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) - ((< line-words 2) space) - (else (/ space-left (1- line-words))))) - (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 (interpret-markup-list layout props args) justify @@ -1398,7 +1711,7 @@ equivalent to @code{\"fi\"}. (markup-list?) #:category align #:properties ((baseline-skip) - wordwrap-internal-markup-list) + wordwrap-internal-markup-list) " @cindex justifying text @@ -1423,7 +1736,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. @@ -1438,13 +1751,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 @@ -1464,13 +1777,13 @@ the line width, where @var{X} is the number of staff spaces. 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] @@ -1496,7 +1809,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] @@ -1594,11 +1907,7 @@ the line width, where @var{X} is the number of staff spaces. Print two markups on top of each other. Note: @code{\\combine} cannot take a list of markups enclosed in -curly braces as an argument; the follow example will not compile: - -@example -\\combine @{ a list @} -@end example +curly braces as an argument; for this purpose use @code{\\overlay} instead. @lilypond[verbatim,quote] \\markup { @@ -1610,9 +1919,30 @@ 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))) +(define-markup-command (overlay layout props args) + (markup-list?) + #:category align + " +@cindex merging text + +Takes a list of markups combining them. + +@lilypond[verbatim,quote] +\\markup { + \\fontsize #5 + \\override #'(thickness . 2) + \\overlay { + \\draw-line #'(0 . 4) + \\arrow-head #Y #DOWN ##f + \\translate #'(0 . 4)\\arrow-head #Y #UP ##f + } +} +@end lilypond" + (apply ly:stencil-add (interpret-markup-list layout props args))) + ;; ;; TODO: should extract baseline-skip from each argument somehow.. ;; @@ -1643,7 +1973,7 @@ in @var{args}. (markup-list?) #:category align #:properties ((direction) - (baseline-skip)) + (baseline-skip)) " @cindex changing direction of text columns @@ -1706,7 +2036,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. @@ -1726,7 +2056,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. @@ -1909,8 +2239,30 @@ 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 (with-outline layout props outline arg) + (markup? markup?) + #:category other + " +Print @var{arg} with the outline and dimensions of @var{outline}." + (ly:stencil-outline (interpret-markup layout props arg) + (interpret-markup layout props outline))) + +(define-markup-command (with-dimensions-from layout props arg1 arg2) + (markup? markup?) + #:category other + " +Print @var{arg2} with the dimensions of @var{arg1}." + (let* ((stil1 (interpret-markup layout props arg1)) + (x (ly:stencil-extent stil1 0)) + (y (ly:stencil-extent stil1 1))) + (interpret-markup layout props (markup #:with-dimensions x y arg2)))) (define-markup-command (pad-around layout props amount arg) (number? markup?) @@ -1931,11 +2283,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?) @@ -1985,10 +2336,7 @@ 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 "" x y))) + (ly:stencil-outline empty-stencil (interpret-markup layout props arg))) (define-markup-command (pad-to-box layout props x-ext y-ext arg) (number-pair? number-pair? markup?) @@ -2008,12 +2356,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?) @@ -2088,12 +2432,9 @@ returns an empty markup. (procedure? markup?) #:category other "Apply the @var{procedure} markup command to @var{arg}. -@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?)) - (interpret-markup layout props (list anonymous-with-signature arg)))) +@var{procedure} takes the same arguments as @code{interpret-markup} +and returns a stencil." + (procedure layout props arg)) (define-markup-command (footnote layout props mkup note) (markup? markup?) @@ -2109,14 +2450,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?) @@ -2137,49 +2478,49 @@ The footnote will be annotated automatically." (footnote-hash (gensym "footnote")) (stencil-seed 0) (gauge-stencil (interpret-markup + layout + props + ((ly:output-def-lookup layout - props - ((ly:output-def-lookup - layout - 'footnote-numbering-function) - stencil-seed))) + 'footnote-numbering-function) + stencil-seed))) (x-ext (ly:stencil-extent gauge-stencil X)) - (y-ext (ly:stencil-extent gauge-stencil Y)) + (y-ext (ly:stencil-extent gauge-stencil Y)) (footnote-number - `(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))))) @@ -2260,7 +2601,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?) @@ -2276,7 +2617,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?) @@ -2296,8 +2637,9 @@ may be any property supported by @rinternals{font-interface}, (define-markup-command (abs-fontsize layout props size arg) (number? markup?) + #:properties ((word-space 0.6) (baseline-skip 3)) #: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] @@ -2311,24 +2653,22 @@ 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))) + (interpret-markup + layout + (cons + `((baseline-skip . ,(* magnification baseline-skip)) + (word-space . ,(* magnification 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. @@ -2570,33 +2910,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?) @@ -2650,7 +2990,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?) @@ -2724,7 +3064,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?) @@ -2748,8 +3088,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)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -2761,7 +3101,7 @@ normal text font, no matter what font was used earlier. #:category music "@var{glyph-name} is converted to a musical symbol; for example, @code{\\musicglyph #\"accidentals.natural\"} selects the natural sign from -the music font. See @ruser{The Feta font} for a complete listing of +the music font. See @ruser{The Emmentaler font} for a complete listing of the possible glyphs. @lilypond[verbatim,quote] @@ -2772,13 +3112,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)) @@ -2912,8 +3252,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 @@ -2939,14 +3329,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) @@ -2965,7 +3355,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?) @@ -2991,22 +3381,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 { @@ -3016,12 +3406,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] @@ -3031,67 +3421,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)) @@ -3099,7 +3489,7 @@ and continue with double letters. (integer?) #:category other #:properties ((font-size 0) - (thickness 1.6)) + (thickness 1.6)) " @cindex slashed digits @@ -3119,7 +3509,7 @@ figured bass notation. (integer?) #:category other #:properties ((font-size 0) - (thickness 1.6)) + (thickness 1.6)) " @cindex backslashed digits @@ -3167,8 +3557,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?) @@ -3187,28 +3577,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) @@ -3243,9 +3633,12 @@ A feta brace in point size @var{size}, rotated 180 degrees. 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} and -@code{modern-straight-flag}. +Supports all note-head-styles. Ancient note-head-styles will get +mensural-style-flags. @code{flag-style} may be overridden independently. +Supported flag-styles are @code{default}, @code{old-straight-flag}, +@code{modern-straight-flag}, @code{flat-flag}, @code{mensural} and +@code{neomensural}. The latter two flag-styles will both result in +mensural-flags. Both are supplied for convenience. @lilypond[verbatim,quote] \\markup { @@ -3256,120 +3649,129 @@ Supported flag-styles are @code{default}, @code{old-straight-flag} and @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 + ;; 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)) + (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 (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))) + 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 (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))) + (raw-points + (list + '(0 . 0) + flag-end + (offset-add flag-end thickness-offset) + thickness-offset)) + (points (map (lambda (coord) (offset-add coord start)) raw-points)) + (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) + (font-name . #f)) + props))) + ;; default for text-font-size is 11 + ;; hence we use (/ text-font-size 11) later, to ensure proper scaling + ;; of stem-length and thickness + (text-font-size (ly:output-def-lookup layout 'text-font-size 11)) (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)) - (ancient-flags? (or (eq? style 'mensural) (eq? style 'neomensural))) + (ancient-flags? + (member style + '(mensural neomensural petrucci semipetrucci blackpetrucci))) (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)) + (stem-thickness + (* size-factor (/ text-font-size 11) (if ancient-flags? 0.1 0.13))) + (stemy (* dir (/ text-font-size 11) stem-length)) (attach-off (cons (interval-index - (ly:stencil-extent head-glyph X) - (* (sign dir) (car attach-indices))) - ; fixme, this is inconsistent between X & Y. + (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-X-corr + (if (or ancient-flags? + (member flag-style '(mensural neomensural))) + (* 0.5 dir stem-thickness) 0)) (stem-glyph (and (> log 0) (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)))) + (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) @@ -3381,42 +3783,49 @@ Supported flag-styles are @code{default}, @code{old-straight-flag} and ;; 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 'old-straight-flag) + (eq? flag-style 'flat-flag)) (/ blot 10 (* -1 dir)) 0)) (flaggl (and (> log 2) (ly:stencil-translate - (cond ((eq? flag-style 'modern-straight-flag) - modern-straight-flag) - ((eq? flag-style 'old-straight-flag) - old-straight-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)))))) - + (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 (or (member flag-style + '(mensural neomensural)) + (and ancient-flags? + (null? flag-style))) + "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 (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))) + (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) @@ -3425,11 +3834,11 @@ Supported flag-styles are @code{default}, @code{old-straight-flag} and (if (ly:stencil? dots) (set! stem-glyph (ly:stencil-add - (ly:stencil-translate-axis - dots - (+ (cdr (ly:stencil-extent head-glyph X)) dotwid) - X) - stem-glyph))) + (ly:stencil-translate-axis + dots + (+ (cdr (ly:stencil-extent head-glyph X)) dotwid) + X) + stem-glyph))) stem-glyph)) (define-public log2 @@ -3506,44 +3915,46 @@ A rest or multi-measure-rest symbol. ;; If no glyph exists, select others for the specified styles ;; otherwise defaulting. (style-strg - (cond ( + (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))) + (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))) + (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)) + (if (ly:stencil-empty? (ly:font-get-glyph font cands)) "" cands)) (let* ((font - (ly:paper-get-font layout - (cons '((font-encoding . fetaMusic)) props))) + (ly:paper-get-font layout + (cons '((font-encoding . fetaMusic) + (font-name . #f)) + props))) (rest-glyph-name - (let ((result - (get-glyph-name font - (get-glyph-name-candidates log style)))) - (if (string-null? result) + (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 @@ -3567,7 +3978,7 @@ A rest or multi-measure-rest symbol. (< log 2) (>= log 0) (not (member style '(neomensural mensural petrucci)))) - (set! dots (ly:stencil-translate-axis dots dot-width X))) + (set! dots (ly:stencil-translate-axis dots dot-width X))) ;; Add dots to the rest-glyph. ;; @@ -3581,13 +3992,13 @@ A rest or multi-measure-rest symbol. (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))))) + 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)) @@ -3631,14 +4042,14 @@ Could be disabled with @code{\\override #'(multi-measure-rest-number . #f)} ;; 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))) + (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. @@ -3646,93 +4057,115 @@ Could be disabled with @code{\\override #'(multi-measure-rest-number . #f)} ;; (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 '())) + (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 + (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 + ;; 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)))) + (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. @@ -3756,7 +4189,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?) @@ -3843,9 +4276,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)))) @@ -3853,7 +4286,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 @@ -3869,13 +4302,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 @@ -3896,7 +4328,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) @@ -3916,13 +4348,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 @@ -3944,13 +4375,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 @@ -3966,7 +4397,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)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -4017,10 +4448,11 @@ 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) + (line-thickness 0.1) + (width 0.25)) " @cindex placing parentheses around text @@ -4047,17 +4479,16 @@ 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 + (* line-thickness thickness)) + (half-thickness + (min (* size 0.5 scaled-thickness) + (* (/ 4 3.0) scaled-width))) + (padding (or padding half-thickness))) (parenthesize-stencil - markup half-thickness scaled-width angularity padding))) + m half-thickness scaled-width angularity padding))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -4073,23 +4504,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 #: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))) @@ -4119,8 +4559,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))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -4145,20 +4585,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?) @@ -4230,29 +4670,29 @@ The @code{key} is the string to be replaced by the @code{value} string. (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 @@ -4266,7 +4706,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." @@ -4280,13 +4720,159 @@ 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 (table layout props column-align lst) + (number-list? markup-list?) + #:properties ((padding 0) + (baseline-skip)) + "@cindex creating a table. + +Returns a table. + +@var{column-align} specifies how each column is aligned, possible values are +-1, 0, 1. The number of elements in @var{column-align} determines how many +columns will be printed. +The entries to print are given by @var{lst}, a markup-list. If needed, the last +row is filled up with @code{point-stencil}s. +Overriding @code{padding} may be used to increase columns horizontal distance. +Overriding @code{baseline-skip} to increase rows vertical distance. +@lilypond[verbatim,quote] +\\markuplist { + \\override #'(padding . 2) + \\table + #'(0 1 0 -1) + { + \\underline { center-aligned right-aligned center-aligned left-aligned } + one \\number 1 thousandth \\number 0.001 + eleven \\number 11 hundredth \\number 0.01 + twenty \\number 20 tenth \\number 0.1 + thousand \\number 1000 one \\number 1.0 + } +} +@end lilypond +" + + (define (split-lst initial-lst lngth result-lst) + ;; split a list into a list of sublists of length lngth + ;; eg. (split-lst '(1 2 3 4 5 6) 2 '()) + ;; -> ((1 2) (3 4) (5 6)) + (cond ((not (integer? (/ (length initial-lst) lngth))) + (ly:warning + "Can't split list of length ~a into ~a parts, returning empty list" + (length initial-lst) lngth) + '()) + ((null? initial-lst) + (reverse result-lst)) + (else + (split-lst + (drop initial-lst lngth) + lngth + (cons (take initial-lst lngth) result-lst))))) + + (define (dists-list init padding lst) + ;; Returns a list, where each element of `lst' is + ;; added to the sum of the previous elements of `lst' plus padding. + ;; `init' will be the first element of the resulting list. The addition + ;; starts with the values of `init', `padding' and `(car lst)'. + ;; eg. (dists-list 0.01 0.1 '(1 2 3 4))) + ;; -> (0.01 1.11 3.21 6.31 10.41) + (if (or (not (number? init)) + (not (number? padding)) + (not (number-list? lst))) + (begin + (ly:warning + "not fitting argument for `dists-list', return empty lst ") + '()) + (reverse + (fold (lambda (elem rl) (cons (+ elem padding (car rl)) rl)) + (list init) + lst)))) + + (let* (;; get the number of columns + (columns (length column-align)) + (init-stils (interpret-markup-list layout props lst)) + ;; If the given markup-list is the result of a markup-list call, their + ;; length may not be easily predictable, thus we add point-stencils + ;; to fill last row of the table. + (rem (remainder (length init-stils) columns)) + (filled-stils + (if (zero? rem) + init-stils + (append init-stils (make-list (- columns rem) point-stencil)))) + ;; get the stencils in sublists of length `columns' + (stils + (split-lst filled-stils columns '())) + ;; procedure to return stencil-length + ;; If it is nan, return 0 + (lengths-proc + (lambda (m) + (let ((lngth (interval-length (ly:stencil-extent m X)))) + (if (nan? lngth) 0 lngth)))) + ;; get the max width of each column in a list + (columns-max-x-lengths + (map + (lambda (x) + (apply max 0 + (map + lengths-proc + (map (lambda (l) (list-ref l x)) stils)))) + (iota columns))) + ;; create a list of (basic) distances, which each column should + ;; moved, using `dists-list'. Some padding may be added. + (dist-sequence + (dists-list 0 padding columns-max-x-lengths)) + ;; Get all stencils of a row, moved accurately to build columns. + ;; If the items of a column are aligned other than left, we need to + ;; move them to avoid collisions: + ;; center aligned: move all items half the width of the widest item + ;; right aligned: move all items the full width of the widest item. + ;; Added to the default-offset calculated in `dist-sequence'. + ;; `stencils-for-row-proc' needs four arguments: + ;; stil - a stencil + ;; dist - a numerical value as basic offset in X direction + ;; column - a numerical value for the column we're in + ;; x-align - a numerical value how current column should be + ;; aligned, where (-1, 0, 1) means (LEFT, CENTER, RIGHT) + (stencils-for-row-proc + (lambda (stil dist column x-align) + (ly:stencil-translate-axis + (ly:stencil-aligned-to stil X x-align) + (cond ((member x-align '(0 1)) + (let* (;; get the stuff for relevant column + (stuff-for-column + (map + (lambda (s) (list-ref s column)) + stils)) + ;; get length of every column-item + (lengths-for-column + (map lengths-proc stuff-for-column)) + (widest + (apply max 0 lengths-for-column))) + (+ dist (/ widest (if (= x-align 0) 2 1))))) + (else dist)) + X))) + ;; get a list of rows using `ly:stencil-add' on a list of stencils + (rows + (map + (lambda (stil-list) + (apply ly:stencil-add + (map + ;; the procedure creating the stencils: + stencils-for-row-proc + ;; the procedure's args: + stil-list + dist-sequence + (iota columns) + column-align))) + stils))) + (space-lines baseline-skip rows))) + (define-markup-list-command (map-markup-commands layout props compose args) (procedure? markup-list?) "This applies the function @var{compose} to every markup in