X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fdefine-markup-commands.scm;h=a6c84b8f6ee3b96c0c1398781ff0e5ecd2aedb5f;hb=3af0951f9a11677240efa6228683dd4fcea13eaf;hp=c04f8ee58b1677daec4eb90621ddff22e32b2d77;hpb=1e55f09955cfbff635df165952697d1d75d57bba;p=lilypond.git diff --git a/scm/define-markup-commands.scm b/scm/define-markup-commands.scm index c04f8ee58b..a6c84b8f6e 100644 --- a/scm/define-markup-commands.scm +++ b/scm/define-markup-commands.scm @@ -1,14 +1,109 @@ -;;;; define-markup-commands.scm -- markup commands +;;;; This file is part of LilyPond, the GNU music typesetter. ;;;; -;;;; source file of the GNU LilyPond music typesetter -;;;; -;;;; (c) 2000--2007 Han-Wen Nienhuys +;;;; Copyright (C) 2000--2015 Han-Wen Nienhuys ;;;; Jan Nieuwenhuizen - - -;;; markup commands -;;; * each markup function should have a doc string with -;; syntax, description and example. +;;;; +;;;; LilyPond is free software: you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation, either version 3 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; LilyPond is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with LilyPond. If not, see . + +;;; +;;; Markup commands and markup-list commands definitions. +;;; +;;; Markup commands which are part of LilyPond, are defined +;;; in the (lily) module, which is the current module in this file, +;;; using the `define-markup-command' macro. +;;; +;;; Usage: +;;; +;;; (define-markup-command (command-name layout props args...) +;;; args-signature +;;; [ #:category category ] +;;; [ #:properties property-bindings ] +;;; documentation-string +;;; ..body..) +;;; +;;; with: +;;; command-name +;;; the name of the markup command +;;; +;;; layout and props +;;; arguments that are automatically passed to the command when it +;;; is interpreted. +;;; `layout' is an output def, which properties can be accessed +;;; using `ly:output-def-lookup'. +;;; `props' is a list of property settings which can be accessed +;;; using `chain-assoc-get' (more on that below) +;;; +;;; args... +;;; the command arguments. +;;; There is no limitation on the order of command arguments. +;;; However, markup functions taking a markup as their last +;;; argument are somewhat special as you can apply them to a +;;; markup list, and the result is a markup list where the +;;; markup function (with the specified leading arguments) has +;;; been applied to every element of the original markup list. +;;; +;;; Since replicating the leading arguments for applying a +;;; markup function to a markup list is cheap mostly for +;;; Scheme arguments, you avoid performance pitfalls by just +;;; using Scheme arguments for the leading arguments of markup +;;; functions that take a markup as their last argument. +;;; +;;; args-signature +;;; the arguments signature, i.e., a list of type predicates which +;;; are used to type check the arguments, and also to define the general +;;; argument types (markup, markup-list, scheme) that the command is +;;; expecting. +;;; For instance, if a command expects a number, then a markup, the +;;; signature would be: (number? markup?) +;;; +;;; category +;;; for documentation purpose, builtin markup commands are grouped by +;;; category. This can be any symbol. When documentation is generated, +;;; the symbol is converted to a capitalized string, where hyphens are +;;; replaced by spaces. +;;; +;;; property-bindings +;;; this is used both for documentation generation, and to ease +;;; programming the command itself. It is list of +;;; (property-name default-value) +;;; or (property-name) +;;; elements. Each property is looked-up in the `props' argument, and +;;; the symbol naming the property is bound to its value. +;;; When the property is not found in `props', then the symbol is bound +;;; to the given default value. When no default value is given, #f is +;;; used instead. +;;; Thus, using the following property bindings: +;;; ((thickness 0.1) +;;; (font-size 0)) +;;; is equivalent to writing: +;;; (let ((thickness (chain-assoc-get 'thickness props 0.1)) +;;; (font-size (chain-assoc-get 'font-size props 0))) +;;; ..body..) +;;; When a command `B' internally calls an other command `A', it may +;;; desirable to see in `B' documentation all the properties and +;;; default values used by `A'. In that case, add `A-markup' to the +;;; property-bindings of B. (This is used when generating +;;; documentation, but won't create bindings.) +;;; +;;; documentation-string +;;; the command documentation string (used to generate manuals) +;;; +;;; body +;;; the command body. The function is supposed to return a stencil. +;;; +;;; Each markup command definition shall have a documentation string +;;; with description, syntax and example. (use-modules (ice-9 regex)) @@ -16,17 +111,43 @@ ;; utility functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define-public empty-stencil (ly:make-stencil '() '(1 . -1) '(1 . -1))) +(define-public empty-stencil (ly:make-stencil '() + empty-interval empty-interval)) (define-public point-stencil (ly:make-stencil "" '(0 . 0) '(0 . 0))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; line has to come early since it is often used implicitly from the +;; markup macro since \markup { a b c } -> \markup \line { a b c } +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-markup-command (line layout props args) + (markup-list?) + #:category align + #:properties ((word-space) + (text-direction RIGHT)) + "Put @var{args} in a horizontal line. The property @code{word-space} +determines the space between markups in @var{args}. + +@lilypond[verbatim,quote] +\\markup { + \\line { + one two three + } +} +@end lilypond" + (let ((stencils (interpret-markup-list layout props args))) + (if (= text-direction LEFT) + (set! stencils (reverse stencils))) + (stack-stencil-line word-space stencils))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; geometric shapes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define-builtin-markup-command (draw-line layout props dest) +(define-markup-command (draw-line layout props dest) (number-pair?) - graphic - ((thickness 1)) + #:category graphic + #:properties ((thickness 1)) " @cindex drawing lines within text @@ -42,22 +163,263 @@ A simple line. thickness)) (x (car dest)) (y (cdr dest))) + (make-line-stencil th 0 0 x y))) + +(define-markup-command (draw-dashed-line layout props dest) + (number-pair?) + #:category graphic + #:properties ((thickness 1) + (on 1) + (off 1) + (phase 0) + (full-length #t)) + " +@cindex drawing dashed lines within text + +A dashed line. + +If @code{full-length} is set to #t (default) the dashed-line extends to the +whole length given by @var{dest}, without white space at beginning or end. +@code{off} will then be altered to fit. +To insist on the given (or default) values of @code{on}, @code{off} use +@code{\\override #'(full-length . #f)} +Manual settings for @code{on},@code{off} and @code{phase} are possible. +@lilypond[verbatim,quote] +\\markup { + \\draw-dashed-line #'(5.1 . 2.3) + \\override #'(on . 0.3) + \\override #'(off . 0.5) + \\draw-dashed-line #'(5.1 . 2.3) +} +@end lilypond" + (let* ((line-thickness (ly:output-def-lookup layout 'line-thickness)) + ;; Calculate the thickness to be used. + (th (* line-thickness thickness)) + (half-thick (/ th 2)) + ;; Get the extensions in x- and y-direction. + (x (car dest)) + (y (cdr dest)) + ;; Calculate the length of the dashed line. + (line-length (sqrt (+ (expt x 2) (expt y 2))))) + + (if (and full-length (not (= (+ on off) 0))) + (begin + ;; Add double-thickness to avoid overlapping. + (set! off (+ (* 2 th) off)) + (let* (;; Make a guess how often the off/on-pair should be printed + ;; after the initial `on´. + ;; Assume a minimum of 1 to avoid division by zero. + (guess (max 1 (round (/ (- line-length on) (+ off on))))) + ;; Not sure about the value or why corr is necessary at all, + ;; but it seems to be necessary. + (corr (if (= on 0) + (/ line-thickness 10) + 0)) + ;; Calculate a new value for off to fit the + ;; line-length. + (new-off (/ (- line-length corr (* (1+ guess) on)) guess)) + ) + (cond + + ;; Settings for (= on 0). Resulting in a dotted line. + + ;; If line-length isn't shorter than `th´, change the given + ;; value for `off´ to fit the line-length. + ((and (= on 0) (< th line-length)) + (set! off new-off)) + + ;; If the line-length is shorter than `th´, it makes no + ;; sense to adjust `off´. The rounded edges of the lines + ;; would prevent any nice output. + ;; Do nothing. + ;; This will result in a single dot for very short lines. + ((and (= on 0) (>= th line-length)) + #f) + + ;; Settings for (not (= on 0)). Resulting in a dashed line. + + ;; If line-length isn't shorter than one go of on-off-on, + ;; change the given value for `off´ to fit the line-length. + ((< (+ (* 2 on) off) line-length) + (set! off new-off)) + ;; If the line-length is too short, but greater than + ;; (* 4 th) set on/off to (/ line-length 3) + ((< (* 4 th) line-length) + (set! on (/ line-length 3)) + (set! off (/ line-length 3))) + ;; If the line-length is shorter than (* 4 th), it makes + ;; no sense trying to adjust on/off. The rounded edges of + ;; the lines would prevent any nice output. + ;; Simply set `on´ to line-length. + (else + (set! on line-length)))))) + + ;; If `on´ or `off´ is negative, or the sum of `on' and `off' equals zero a + ;; ghostscript-error occurs while calling + ;; (ly:make-stencil (list 'dashed-line th on off x y phase) x-ext y-ext) + ;; Better be paranoid. + (if (or (= (+ on off) 0) + (negative? on) + (negative? off)) + (begin + (ly:warning "Can't print a line - setting on/off to default") + (set! on 1) + (set! off 1))) + + ;; To give the lines produced by \draw-line and \draw-dashed-line the same + ;; length, half-thick has to be added to the stencil-extensions. (ly:make-stencil - `(draw-line - ,th - 0 0 - ,x ,y) - (cons (min x 0) (max x 0)) - (cons (min y 0) (max y 0))))) - -(define-builtin-markup-command (draw-circle layout props radius thickness fill) - (number? number? boolean?) - graphic + (list 'dashed-line th on off x y phase) + (interval-widen (ordered-cons 0 x) half-thick) + (interval-widen (ordered-cons 0 y) half-thick)))) + +(define-markup-command (draw-dotted-line layout props dest) + (number-pair?) + #:category graphic + #:properties ((thickness 1) + (off 1) + (phase 0)) + " +@cindex drawing dotted lines within text + +A dotted line. + +The dotted-line always extends to the whole length given by @var{dest}, without +white space at beginning or end. +Manual settings for @code{off} are possible to get larger or smaller space +between the dots. +The given (or default) value of @code{off} will be altered to fit the +line-length. +@lilypond[verbatim,quote] +\\markup { + \\draw-dotted-line #'(5.1 . 2.3) + \\override #'(thickness . 2) + \\override #'(off . 0.2) + \\draw-dotted-line #'(5.1 . 2.3) +} +@end lilypond" + + (let ((new-props (prepend-alist-chain 'on 0 + (prepend-alist-chain 'full-length #t props)))) + + (interpret-markup layout + new-props + (markup #:draw-dashed-line dest)))) + +(define-markup-command (draw-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 + (lambda (stil pt) (ly:stencil-translate stil pt)) + (circular-list init-bow-up init-bow-down) + list-of-starts)))) + +(define-markup-command (draw-hline layout props) () + #:category graphic + #:properties ((draw-line-markup) + (line-width) + (span-factor 1)) + " +@cindex drawing a line across a page + +Draws a line across a page, where the property @code{span-factor} +controls what fraction of the page is taken up. +@lilypond[verbatim,quote] +\\markup { + \\column { + \\draw-hline + \\override #'(span-factor . 1/3) + \\draw-hline + } +} +@end lilypond" + (interpret-markup layout + props + (markup #:draw-line (cons (* line-width + span-factor) + 0)))) + +(define-markup-command (draw-circle layout props radius thickness filled) + (number? number? boolean?) + #:category graphic " @cindex drawing circles within text -A circle of radius @var{radius}, thickness @var{thickness} and +A circle of radius @var{radius} and thickness @var{thickness}, optionally filled. @lilypond[verbatim,quote] @@ -67,14 +429,14 @@ optionally filled. \\draw-circle #2 #0 ##t } @end lilypond" - (make-circle-stencil radius thickness fill)) + (make-circle-stencil radius thickness filled)) -(define-builtin-markup-command (triangle layout props filled) +(define-markup-command (triangle layout props filled) (boolean?) - graphic - ((thickness 0.1) - (font-size 0) - (baseline-skip 2)) + #:category graphic + #:properties ((thickness 0.1) + (font-size 0) + (baseline-skip 2)) " @cindex drawing triangles within text @@ -93,17 +455,17 @@ 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))))) -(define-builtin-markup-command (circle layout props arg) +(define-markup-command (circle layout props arg) (markup?) - graphic - ((thickness 1) - (font-size 0) - (circle-padding 0.2)) + #:category graphic + #:properties ((thickness 1) + (font-size 0) + (circle-padding 0.2)) " @cindex circling text @@ -120,14 +482,69 @@ 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-builtin-markup-command (with-url layout props url arg) +(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?) - graphic - () + #:category graphic " @cindex inserting URL links into text @@ -136,7 +553,7 @@ the PDF backend. @lilypond[verbatim,quote] \\markup { - \\with-url #\"http://lilypond.org/web/\" { + \\with-url #\"http://lilypond.org/\" { LilyPond ... \\italic { music notation for everyone } @@ -144,17 +561,86 @@ 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))) -(define-builtin-markup-command (beam layout props width slope thickness) +(define-markup-command (page-link layout props page-number arg) + (number? markup?) + #:category other + " +@cindex referencing page numbers in text + +Add a link to the page @var{page-number} around @var{arg}. This only works +in the PDF backend. + +@lilypond[verbatim,quote] +\\markup { + \\page-link #2 { \\italic { This links to page 2... } } +} +@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)))) + + (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 + " +@cindex referencing page labels in text + +Add a link to the page holding label @var{label} around @var{arg}. This +only works in the PDF backend. + +@lilypond[verbatim,quote] +\\markup { + \\with-link #'label { + \\italic { This links to the page containing the label... } + } +} +@end lilypond" + (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: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?) - graphic - () + #:category graphic " @cindex drawing beams within text @@ -165,59 +651,146 @@ 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) + `(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) (cons 0 width) (cons (+ (- half) (car yext)) - (+ half (cdr yext)))))) + (+ half (cdr yext)))))) -(define-builtin-markup-command (underline layout props arg) +(define-markup-command (underline layout props arg) (markup?) - font - ((thickness 1)) + #:category font + #:properties ((thickness 1) (offset 2)) " @cindex underlining text Underline @var{arg}. Looks at @code{thickness} to determine line -thickness and y offset. +thickness, and @code{offset} to determine line y-offset. + +@lilypond[verbatim,quote] +\\markup \\fill-line { + \\underline \"underlined\" + \\override #'(offset . 5) + \\override #'(thickness . 1) + \\underline \"underlined\" + \\override #'(offset . 1) + \\override #'(thickness . 5) + \\underline \"underlined\" +} +@end lilypond" + (let* ((thick (ly:output-def-lookup layout 'line-thickness)) + (underline-thick (* thickness thick)) + (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 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 { - default - \\hspace #2 - \\override #'(thickness . 2) - \\underline { - underline - } + \\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" - (let* ((thick (* (ly:output-def-lookup layout 'line-thickness) - thickness)) - (markup (interpret-markup layout props arg)) - (x1 (car (ly:stencil-extent markup X))) - (x2 (cdr (ly:stencil-extent markup X))) - (y (* thick -2)) - (line (ly:make-stencil - `(draw-line ,thick ,x1 ,y ,x2 ,y) - (cons (min x1 0) (max x2 0)) - (cons thick thick)))) - (ly:stencil-add markup line))) + (interpret-markup layout (prepend-alist-chain 'direction UP props) + (make-tie-markup arg))) -(define-builtin-markup-command (box layout props arg) +(define-markup-command (box layout props arg) (markup?) - font - ((thickness 1) - (font-size 0) - (box-padding 0.2)) + #:category font + #:properties ((thickness 1) + (font-size 0) + (box-padding 0.2)) " @cindex enclosing text within a box @@ -238,10 +811,9 @@ thickness and padding around the markup. (m (interpret-markup layout props arg))) (box-stencil m th pad))) -(define-builtin-markup-command (filled-box layout props xext yext blot) +(define-markup-command (filled-box layout props xext yext blot) (number-pair? number-pair? number?) - graphic - () + #:category graphic " @cindex drawing solid boxes within text @cindex drawing boxes with rounded corners @@ -253,7 +825,7 @@ Draw a box with rounded corners of dimensions @var{xext} and @end verbatim creates a box extending horizontally from -0.3 to 1.8 and vertically from -0.3 up to 1.8, with corners formed from a -circle of diameter@tie{}0 (i.e. sharp corners). +circle of diameter@tie{}0 (i.e., sharp corners). @lilypond[verbatim,quote] \\markup { @@ -267,19 +839,19 @@ circle of diameter@tie{}0 (i.e. sharp corners). (ly:round-filled-box xext yext blot)) -(define-builtin-markup-command (rounded-box layout props arg) +(define-markup-command (rounded-box layout props arg) (markup?) - graphic - ((thickness 1) - (corner-radius 1) - (font-size 0) - (box-padding 0.5)) - "@cindex enclosing text in a bow with rounded corners + #:category graphic + #:properties ((thickness 1) + (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}, @code{box-padding} and @code{font-size} properties to determine line thickness and padding around the markup; the @code{corner-radius} property -makes possible to define another shape for the corners (default is 1). +makes it possible to define another shape for the corners (default is 1). @lilypond[quote,verbatim,relative=2] c4^\\markup { @@ -288,7 +860,7 @@ c4^\\markup { } } c,8. c16 c4 r -@end lilypond" +@end lilypond" (let ((th (* (ly:output-def-lookup layout 'line-thickness) thickness)) (pad (* (magstep font-size) box-padding)) @@ -296,10 +868,9 @@ c,8. c16 c4 r (ly:stencil-add (rounded-box-stencil m th pad corner-radius) m))) -(define-builtin-markup-command (rotate layout props ang arg) +(define-markup-command (rotate layout props ang arg) (number? markup?) - align - () + #:category align " @cindex rotating text @@ -318,33 +889,57 @@ Rotate object with @var{ang} degrees around its center. (let* ((stil (interpret-markup layout props arg))) (ly:stencil-rotate stil ang 0 0))) -(define-builtin-markup-command (whiteout layout props arg) +(define-markup-command (whiteout layout props arg) (markup?) - other - () + #: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-builtin-markup-command (pad-markup layout props padding arg) +(define-markup-command (pad-markup layout props amount arg) (number? markup?) - align - () + #:category align " @cindex padding text @cindex putting space around text Add space around a markup object. +Identical to @code{pad-around}. @lilypond[verbatim,quote] \\markup { @@ -353,57 +948,42 @@ Add space around a markup object. } \\hspace #2 \\box { - \\pad-around #1 { + \\pad-markup #1 { padded } } } @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 padding) - (interval-widen yext padding)))) + (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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define-builtin-markup-command (strut layout props) - () - other +(define-markup-command (strut layout props) () + #:category other " @cindex creating vertical spaces in text Create a box of the same height as the space in the current font." (let ((m (ly:text-interface::interpret-markup layout props " "))) (ly:make-stencil (ly:stencil-expr m) - '(0 . 0) - (ly:stencil-extent m X) - ))) + '(0 . 0) + (ly:stencil-extent m X) + ))) -;; todo: fix negative space -(define-builtin-markup-command (hspace layout props amount) +(define-markup-command (hspace layout props amount) (number?) - align - () + #:category align " @cindex creating horizontal spaces in text -This produces an invisible object taking horizontal space. For example, - -@example -\\markup @{ A \\hspace #2.0 B @} -@end example - -@noindent -puts extra space between A and@tie{}B, on top of the space that is -normally inserted before elements on a line. +Create an invisible object taking up horizontal space @var{amount}. @lilypond[verbatim,quote] \\markup { @@ -414,19 +994,39 @@ normally inserted before elements on a line. three } @end lilypond" - (if (> amount 0) - (ly:make-stencil "" (cons 0 amount) '(-1 . 1)) - (ly:make-stencil "" (cons amount amount) '(-1 . 1)))) + (ly:make-stencil "" (cons 0 amount) empty-interval)) + +(define-markup-command (vspace layout props amount) + (number?) + #:category align + " +@cindex creating vertical spaces in text + +Create an invisible object taking up vertical space +of @var{amount} multiplied by 3. + +@lilypond[verbatim,quote] +\\markup { + \\center-column { + one + \\vspace #2 + two + \\vspace #5 + three + } +} +@end lilypond" + (let ((amount (* amount 3.0))) + (ly:make-stencil "" empty-interval (cons 0 amount)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; importing graphics. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define-builtin-markup-command (stencil layout props stil) +(define-markup-command (stencil layout props stil) (ly:stencil?) - other - () + #:category other " @cindex importing stencils into text @@ -446,18 +1046,17 @@ Use a stencil as markup. "Extract the bbox from STRING, or return #f if not present." (let* ((match (regexp-exec bbox-regexp string))) - + (if match - (map (lambda (x) - (string->number (match:substring match x))) - (cdr (iota 5))) - - #f))) + (map (lambda (x) + (string->number (match:substring match x))) + (cdr (iota 5))) -(define-builtin-markup-command (epsfile layout props axis size file-name) + #f))) + +(define-markup-command (epsfile layout props axis size file-name) (number? number? string?) - graphic - () + #:category graphic " @cindex inlining an Encapsulated PostScript image @@ -477,88 +1076,212 @@ Inline an EPS image. The image is scaled along @var{axis} to (eps-file->stencil axis size file-name) )) -(define-builtin-markup-command (postscript layout props str) +(define-markup-command (postscript layout props str) (string?) - graphic - () + #:category graphic " @cindex inserting PostScript directly into text - This inserts @var{str} directly into the output as a PostScript -command string. Due to technicalities of the output backends, -different scales should be used for the @TeX{} and PostScript backend, -selected with @code{-f}. - -For the @TeX{} backend, the following string prints a rotated text - -@example -0 0 moveto /ecrm10 findfont -1.75 scalefont setfont 90 rotate (hello) show -@end example - -@noindent -The magical constant 1.75 scales from LilyPond units (staff spaces) to -@TeX{} dimensions. - -For the postscript backend, use the following - -@example -gsave /ecrm10 findfont - 10.0 output-scale div - scalefont setfont 90 rotate (hello) show grestore -@end example +command string. @lilypond[verbatim,quote] -eyeglassesps = #\" +ringsps = #\" 0.15 setlinewidth - -0.9 0 translate - 1.1 1.1 scale - 1.2 0.7 moveto - 0.7 0.7 0.5 0 361 arc - stroke - 2.20 0.70 0.50 0 361 arc - stroke - 1.45 0.85 0.30 0 180 arc + 0.9 0.6 moveto + 0.4 0.6 0.5 0 361 arc stroke - 0.20 0.70 moveto - 0.80 2.00 lineto - 0.92 2.26 1.30 2.40 1.15 1.70 curveto + 1.0 0.6 0.5 0 361 arc stroke - 2.70 0.70 moveto - 3.30 2.00 lineto - 3.42 2.26 3.80 2.40 3.65 1.70 curveto - stroke\" + \" -eyeglasses = \\markup { - \\with-dimensions #'(0 . 4.4) #'(0 . 2.5) - \\postscript #eyeglassesps +rings = \\markup { + \\with-dimensions #'(-0.2 . 1.6) #'(0 . 1.2) + \\postscript #ringsps } \\relative c'' { - c2^\\eyeglasses - a2_\\eyeglasses + c2^\\rings + a2_\\rings } @end lilypond" ;; FIXME (ly:make-stencil (list 'embedded-ps - (format " + (format #f " gsave currentpoint translate 0.1 setlinewidth ~a grestore " - str)) + str)) '(0 . 0) '(0 . 0))) -(define-builtin-markup-command (score layout props score) +(define-markup-command (path layout props thickness commands) (number? list?) + #:category graphic + #:properties ((line-cap-style 'round) + (line-join-style 'round) + (filled #f)) + " +@cindex paths, drawing +@cindex drawing paths +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. + +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 +@code{closepath}. Note that the commands that begin with @emph{r} +are the relative variants of the other three commands. + +The commands @code{moveto}, @code{rmoveto}, @code{lineto}, and +@code{rlineto} take 2 arguments; they are the X and Y coordinates +for the destination point. + +The commands @code{curveto} and @code{rcurveto} create cubic +Bézier curves, and take 6 arguments; the first two are the X and Y +coordinates for the first control point, the second two are the X +and Y coordinates for the second control point, and the last two +are the X and Y coordinates for the destination point. + +The @code{closepath} command takes zero arguments and closes the +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) + (lineto -1 1) + (lineto 1 1) + (lineto 1 -1) + (curveto -5 -5 -5 5 -1 0) + (closepath)) + +\\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))) + + ;; 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))) + +(define-markup-list-command (score-lines layout props score) (ly:score?) - music - () + "This is the same as the @code{\\score} markup but delivers its +systems as a list of lines. Its @var{score} argument is entered in +braces like it would be for @code{\\score}." + (let ((output (ly:score-embedded-format score layout))) + + (if (ly:music-output? output) + (map + (lambda (paper-system) + ;; shift such that the refpoint of the bottom staff of + ;; the first system is the baseline of the score + (ly:stencil-translate-axis + (paper-system-stencil paper-system) + (- (car (paper-system-staff-extents paper-system))) + Y)) + (vector->list (ly:paper-score-paper-systems output))) + (begin + (ly:warning (_"no systems found in \\score markup, does it have a \\layout block?")) + '())))) + +(define-markup-command (score layout props score) + (ly:score?) + #:category music + #:properties ((baseline-skip)) " @cindex inserting music into text -Inline an image of music. +Inline an image of music. The reference point (usually the middle +staff line) of the lowest staff in the top system is placed on the +baseline. @lilypond[verbatim,quote] \\markup { @@ -587,31 +1310,26 @@ Inline an image of music. indent = 0.0\\cm \\context { \\Score - \\override RehearsalMark #'break-align-symbols = - #'(time-signature key-signature) - \\override RehearsalMark #'self-alignment-X = #LEFT + \\override RehearsalMark + #'break-align-symbols = #'(time-signature key-signature) + \\override RehearsalMark + #'self-alignment-X = #LEFT } \\context { \\Staff - \\override TimeSignature #'break-align-anchor-alignment = #LEFT + \\override TimeSignature + #'break-align-anchor-alignment = #LEFT } } } } @end lilypond" - (let* ((output (ly:score-embedded-format score layout))) + (stack-stencils Y DOWN baseline-skip + (score-lines-markup-list layout props score))) - (if (ly:music-output? output) - (paper-system-stencil - (vector-ref (ly:paper-score-paper-systems output) 0)) - (begin - (ly:warning (_"no systems found in \\score markup, does it have a \\layout block?")) - empty-stencil)))) - -(define-builtin-markup-command (null layout props) - () - other +(define-markup-command (null layout props) () + #:category other " @cindex creating empty text objects @@ -628,10 +1346,9 @@ An empty markup with extents of a single point. ;; basic formatting. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define-builtin-markup-command (simple layout props str) +(define-markup-command (simple layout props str) (string?) - font - () + #:category font " @cindex simple text strings @@ -650,74 +1367,155 @@ the use of @code{\\simple} is unnecessary. @end lilypond" (interpret-markup layout props str)) -(define-builtin-markup-command (tied-lyric layout props str) - (string?) - music - () - " -@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 { - \\tied-lyric #\"Lasciate~i monti\" + \\first-visible { + \\fromproperty #'header:composer + \\italic Unknown + } } @end lilypond" - (if (string-contains str "~") - (let* - ((parts (string-split str #\~)) - (tie-str (ly:wide-char->utf-8 #x203f)) - (joined (list-join parts tie-str)) - (join-stencil (interpret-markup layout props tie-str)) - ) - - (interpret-markup layout - (prepend-alist-chain - 'word-space - (/ (interval-length (ly:stencil-extent join-stencil X)) -3.5) - props) - (make-line-markup joined))) - ;(map (lambda (s) (interpret-markup layout props s)) parts)) - (interpret-markup layout props str))) + (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 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. - 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 (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 - (cons - (- (/ line-width (1- word-count)) - (/ (+ (car text-widths) (car (cdr text-widths))) 2)) - (get-fill-space word-count line-width (cdr text-widths)))))) - -(define-builtin-markup-command (fill-line layout props markups) + ((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?) - align - ((text-direction RIGHT) - (word-space 1) - (line-width #f)) + #:category align + #: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 spaced or flushed to fill the entire line. If there are no arguments, return an empty stencil. @@ -739,198 +1537,190 @@ If there are no arguments, return an empty stencil. } } @end lilypond" - (let* ((orig-stencils (interpret-markup-list layout props markups)) - (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)) - (prop-line-width (chain-assoc-get 'line-width props #f)) - (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 text-widths)))) - (fill-space-normal - (map (lambda (x) - (if (< x word-space) - word-space - x)) - fill-space)) - - (line-stencils (if (= word-count 1) - (list - point-stencil - (car stencils) - point-stencil) - stencils))) - - (if (= text-direction LEFT) - (set! line-stencils (reverse line-stencils))) + (justify-line-helper + layout props args text-direction word-space line-width #f)) - (if (null? (remove ly:stencil-empty? orig-stencils)) - empty-stencil - (stack-stencils-padding-list X - RIGHT fill-space-normal line-stencils)))) - -(define-builtin-markup-command (line layout props args) +(define-markup-command (justify-line layout props args) (markup-list?) - align - ((word-space) - (text-direction RIGHT)) - "Put @var{args} in a horizontal line. The property @code{word-space} -determines the space between each markup in @var{args}. + #:category align + #: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 { - A simple line of text + \\justify-line { + Space between neighboring words is constant } } @end lilypond" - (let ((stencils (interpret-markup-list layout props args))) - (if (= text-direction LEFT) - (set! stencils (reverse stencils))) - (stack-stencil-line - word-space - (remove ly:stencil-empty? stencils)))) + (justify-line-helper + layout props args text-direction word-space line-width #t)) -(define-builtin-markup-command (concat layout props args) +(define-markup-command (concat layout props args) (markup-list?) - align - () + #:category align " @cindex concatenating text @cindex ligatures in text -Concatenate @var{args} in a horizontal line, without spaces inbetween. +Concatenate @var{args} in a horizontal line, without spaces in between. Strings and simple markups are concatenated on the input level, allowing ligatures. For example, @code{\\concat @{ \"f\" \\simple #\"i\" @}} is equivalent to @code{\"fi\"}. @lilypond[verbatim,quote] \\markup { - \\bold { - au - \\concat { - Mouv - \\super - t - } + \\concat { + one + two + three } } @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 (if (markup-command-list? args) - args - (concat-string-args args))))) + (make-line-markup + (make-override-lines-markup-list + (cons 'word-space + (chain-assoc-get 'word-space props)) + (if (markup-command-list? args) + args + (concat-string-args args)))))) (define (wordwrap-stencils stencils - justify base-space line-width text-dir) - "Perform simple wordwrap, return stencil of each line." + justify base-space line-width text-dir) + "Perform simple wordwrap, return stencil of each line." (define space (if justify ;; justify only stretches lines. - (* 0.7 base-space) - base-space)) - (define (take-list width space stencils - accumulator accumulated-width) - "Return (head-list . tail) pair, with head-list fitting into width" - (if (null? stencils) - (cons accumulator stencils) - (let* ((first (car stencils)) - (first-wid (cdr (ly:stencil-extent (car stencils) X))) - (newwid (+ space first-wid accumulated-width))) - (if (or (null? accumulator) - (< newwid width)) - (take-list width space - (cdr stencils) - (cons first accumulator) - newwid) - (cons accumulator stencils))))) - (let loop ((lines '()) - (todo stencils)) - (let* ((line-break (take-list line-width space todo - '() 0.0)) - (line-stencils (car line-break)) - (space-left (- line-width - (apply + (map (lambda (x) (cdr (ly:stencil-extent x X))) - line-stencils)))) - (line-word-space (cond ((not justify) space) - ;; don't stretch last line of paragraph. - ;; hmmm . bug - will overstretch the last line in some case. - ((null? (cdr line-break)) - base-space) - ((null? line-stencils) 0.0) - ((null? (cdr line-stencils)) 0.0) - (else (/ space-left (1- (length line-stencils)))))) - (line (stack-stencil-line line-word-space - (if (= text-dir RIGHT) - (reverse line-stencils) - line-stencils)))) - (if (pair? (cdr line-break)) - (loop (cons line lines) - (cdr line-break)) - (begin - (if (= text-dir LEFT) - (set! line - (ly:stencil-translate-axis - line - (- line-width (interval-end (ly:stencil-extent line X))) - X))) - (reverse (cons line lines))))))) - -(define-builtin-markup-list-command (wordwrap-internal layout props justify args) + (* 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?) - ((line-width #f) - (word-space) - (text-direction RIGHT)) + #:properties ((line-width #f) + (word-space) + (text-direction RIGHT)) "Internal markup list command used to define @code{\\justify} and @code{\\wordwrap}." - (wordwrap-stencils (remove ly:stencil-empty? - (interpret-markup-list layout props args)) + (wordwrap-stencils (interpret-markup-list layout props args) justify word-space (or line-width (ly:output-def-lookup layout 'line-width)) text-direction)) -(define-builtin-markup-command (justify layout props args) +(define-markup-command (justify layout props args) (markup-list?) - align - ((baseline-skip) - wordwrap-internal-markup-list) + #:category align + #:properties ((baseline-skip) + wordwrap-internal-markup-list) " @cindex justifying text -Like wordwrap, but with lines stretched to justify the margins. +Like @code{\\wordwrap}, but with lines stretched to justify the margins. Use @code{\\override #'(line-width . @var{X})} to set the line width; @var{X}@tie{}is the number of staff spaces. @@ -947,11 +1737,11 @@ Use @code{\\override #'(line-width . @var{X})} to set the line width; (stack-lines DOWN 0.0 baseline-skip (wordwrap-internal-markup-list layout props #t args))) -(define-builtin-markup-command (wordwrap layout props args) +(define-markup-command (wordwrap layout props args) (markup-list?) - align - ((baseline-skip) - wordwrap-internal-markup-list) + #:category align + #:properties ((baseline-skip) + 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. @@ -966,13 +1756,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-builtin-markup-list-command (wordwrap-string-internal layout props justify arg) +(define-markup-list-command (wordwrap-string-internal layout props justify arg) (boolean? string?) - ((line-width) - (word-space) - (text-direction RIGHT)) + #:properties ((line-width) + (word-space) + (text-direction RIGHT)) "Internal markup list command used to define @code{\\justify-string} and @code{\\wordwrap-string}." (let* ((para-strings (regexp-split @@ -985,81 +1775,80 @@ the line width, where @var{X} is the number of staff spaces. para-strings)) (para-lines (map (lambda (words) (let* ((stencils - (remove ly:stencil-empty? - (map (lambda (x) - (interpret-markup layout props x)) - words)))) + (map (lambda (x) + (interpret-markup layout props x)) + words))) (wordwrap-stencils stencils justify word-space line-width text-direction))) list-para-words))) - (apply append para-lines))) + (concatenate para-lines))) -(define-builtin-markup-command (wordwrap-string layout props arg) +(define-markup-command (wordwrap-string layout props arg) (string?) - align - ((baseline-skip) - wordwrap-string-internal-markup-list) + #:category align + #:properties ((baseline-skip) + wordwrap-string-internal-markup-list) "Wordwrap a string. Paragraphs may be separated with double newlines. - + @lilypond[verbatim,quote] \\markup { \\override #'(line-width . 40) \\wordwrap-string #\"Lorem ipsum dolor sit amet, consectetur - adipisicing elit, sed do eiusmod tempor incididunt ut labore - et dolore magna aliqua. - - - Ut enim ad minim veniam, quis nostrud exercitation ullamco - laboris nisi ut aliquip ex ea commodo consequat. - - - Excepteur sint occaecat cupidatat non proident, sunt in culpa - qui officia deserunt mollit anim id est laborum\" + adipisicing elit, sed do eiusmod tempor incididunt ut labore + et dolore magna aliqua. + + + Ut enim ad minim veniam, quis nostrud exercitation ullamco + laboris nisi ut aliquip ex ea commodo consequat. + + + Excepteur sint occaecat cupidatat non proident, sunt in culpa + qui officia deserunt mollit anim id est laborum\" } @end lilypond" (stack-lines DOWN 0.0 baseline-skip (wordwrap-string-internal-markup-list layout props #f arg))) -(define-builtin-markup-command (justify-string layout props arg) +(define-markup-command (justify-string layout props arg) (string?) - align - ((baseline-skip) - wordwrap-string-internal-markup-list) + #:category align + #:properties ((baseline-skip) + wordwrap-string-internal-markup-list) "Justify a string. Paragraphs may be separated with double newlines - + @lilypond[verbatim,quote] \\markup { \\override #'(line-width . 40) \\justify-string #\"Lorem ipsum dolor sit amet, consectetur - adipisicing elit, sed do eiusmod tempor incididunt ut labore - et dolore magna aliqua. - - - Ut enim ad minim veniam, quis nostrud exercitation ullamco - laboris nisi ut aliquip ex ea commodo consequat. - - - Excepteur sint occaecat cupidatat non proident, sunt in culpa - qui officia deserunt mollit anim id est laborum\" + adipisicing elit, sed do eiusmod tempor incididunt ut labore + et dolore magna aliqua. + + + Ut enim ad minim veniam, quis nostrud exercitation ullamco + laboris nisi ut aliquip ex ea commodo consequat. + + + Excepteur sint occaecat cupidatat non proident, sunt in culpa + qui officia deserunt mollit anim id est laborum\" } @end lilypond" (stack-lines DOWN 0.0 baseline-skip (wordwrap-string-internal-markup-list layout props #t arg))) -(define-builtin-markup-command (wordwrap-field layout props symbol) +(define-markup-command (wordwrap-field layout props symbol) (symbol?) - align - () + #:category align "Wordwrap the data which has been assigned to @var{symbol}. - + @lilypond[verbatim,quote] \\header { title = \"My title\" - descr = \"Lorem ipsum dolor sit amet, consectetur adipisicing elit, - sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. - Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris - nisi ut aliquip ex ea commodo consequat.\" + myText = \"Lorem ipsum dolor sit amet, consectetur adipisicing + elit, sed do eiusmod tempor incididunt ut labore et dolore + magna aliqua. Ut enim ad minim veniam, quis nostrud + exercitation ullamco laboris nisi ut aliquip ex ea commodo + consequat.\" } \\paper { @@ -1067,7 +1856,7 @@ the line width, where @var{X} is the number of staff spaces. \\column { \\fill-line { \\fromproperty #'header:title } \\null - \\wordwrap-field #'header:descr + \\wordwrap-field #'header:myText } } } @@ -1081,19 +1870,18 @@ the line width, where @var{X} is the number of staff spaces. (wordwrap-string-markup layout props m) empty-stencil))) -(define-builtin-markup-command (justify-field layout props symbol) +(define-markup-command (justify-field layout props symbol) (symbol?) - align - () + #:category align "Justify the data which has been assigned to @var{symbol}. - + @lilypond[verbatim,quote] \\header { title = \"My title\" - descr = \"Lorem ipsum dolor sit amet, consectetur adipisicing elit, - sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. - Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris - nisi ut aliquip ex ea commodo consequat.\" + myText = \"Lorem ipsum dolor sit amet, consectetur adipisicing + elit, sed do eiusmod tempor incididunt ut labore et dolore magna + aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco + laboris nisi ut aliquip ex ea commodo consequat.\" } \\paper { @@ -1101,7 +1889,7 @@ the line width, where @var{X} is the number of staff spaces. \\column { \\fill-line { \\fromproperty #'header:title } \\null - \\justify-field #'header:descr + \\justify-field #'header:myText } } } @@ -1115,21 +1903,16 @@ the line width, where @var{X} is the number of staff spaces. (justify-string-markup layout props m) empty-stencil))) -(define-builtin-markup-command (combine layout props m1 m2) +(define-markup-command (combine layout props arg1 arg2) (markup? markup?) - align - () + #:category align " @cindex merging text 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 { @@ -1140,23 +1923,44 @@ curly braces as an argument; the follow example will not compile: \\arrow-head #Y #DOWN ##f } @end lilypond" - (let* ((s1 (interpret-markup layout props m1)) - (s2 (interpret-markup layout props m2))) + (let* ((s1 (interpret-markup layout props arg1)) + (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.. -;; -(define-builtin-markup-command (column layout props args) +;; +(define-markup-command (column layout props args) (markup-list?) - align - ((baseline-skip)) + #:category align + #:properties ((baseline-skip)) " @cindex stacking text in a column Stack the markups in @var{args} vertically. The property -@code{baseline-skip} determines the space between each -markup in @var{args}. +@code{baseline-skip} determines the space between markups +in @var{args}. @lilypond[verbatim,quote] \\markup { @@ -1168,30 +1972,36 @@ markup in @var{args}. } @end lilypond" (let ((arg-stencils (interpret-markup-list layout props args))) - (stack-lines -1 0.0 baseline-skip - (remove ly:stencil-empty? arg-stencils)))) + (stack-lines -1 0.0 baseline-skip arg-stencils))) -(define-builtin-markup-command (dir-column layout props args) +(define-markup-command (dir-column layout props args) (markup-list?) - align - ((direction) - (baseline-skip)) + #:category align + #:properties ((direction) + (baseline-skip)) " @cindex changing direction of text columns -Make a column of args, going up or down, depending on the setting -of the @code{#'direction} layout property. +Make a column of @var{args}, going up or down, depending on the +setting of the @code{direction} layout property. @lilypond[verbatim,quote] \\markup { - \\override #'(direction . 1) { + \\override #`(direction . ,UP) { \\dir-column { going up } } + \\hspace #1 \\dir-column { going down } + \\hspace #1 + \\override #'(direction . 1) { + \\dir-column { + going up + } + } } @end lilypond" (stack-lines (if (number? direction) direction -1) @@ -1199,10 +2009,18 @@ of the @code{#'direction} layout property. baseline-skip (interpret-markup-list layout props args))) -(define-builtin-markup-command (center-align layout props args) +(define (general-column align-dir baseline mols) + "Stack @var{mols} vertically, aligned to @var{align-dir} horizontally." + + (let* ((aligned-mols (map (lambda (x) (ly:stencil-aligned-to x X align-dir)) mols)) + (stacked-stencil (stack-lines -1 0.0 baseline aligned-mols)) + (stacked-extent (ly:stencil-extent stacked-stencil X))) + (ly:stencil-translate-axis stacked-stencil (- (car stacked-extent)) X ))) + +(define-markup-command (center-column layout props args) (markup-list?) - align - ((baseline-skip)) + #:category align + #:properties ((baseline-skip)) " @cindex centering a column of text @@ -1210,21 +2028,58 @@ Put @code{args} in a centered column. @lilypond[verbatim,quote] \\markup { - \\center-align { + \\center-column { + one + two + three + } +} +@end lilypond" + (general-column CENTER baseline-skip (interpret-markup-list layout props args))) + +(define-markup-command (left-column layout props args) + (markup-list?) + #:category align + #:properties ((baseline-skip)) + " +@cindex text columns, left-aligned + +Put @code{args} in a left-aligned column. + +@lilypond[verbatim,quote] +\\markup { + \\left-column { + one + two + three + } +} +@end lilypond" + (general-column LEFT baseline-skip (interpret-markup-list layout props args))) + +(define-markup-command (right-column layout props args) + (markup-list?) + #:category align + #:properties ((baseline-skip)) + " +@cindex text columns, right-aligned + +Put @code{args} in a right-aligned column. + +@lilypond[verbatim,quote] +\\markup { + \\right-column { one two three } } @end lilypond" - (let* ((mols (interpret-markup-list layout props args)) - (cmols (map (lambda (x) (ly:stencil-aligned-to x X CENTER)) mols))) - (stack-lines -1 0.0 baseline-skip cmols))) + (general-column RIGHT baseline-skip (interpret-markup-list layout props args))) -(define-builtin-markup-command (vcenter layout props arg) +(define-markup-command (vcenter layout props arg) (markup?) - align - () + #:category align " @cindex vertically centering text @@ -1232,19 +2087,18 @@ Align @code{arg} to its Y@tie{}center. @lilypond[verbatim,quote] \\markup { - \\arrow-head #X #RIGHT ##f + one \\vcenter - Centered - \\arrow-head #X #LEFT ##f + two + three } @end lilypond" (let* ((mol (interpret-markup layout props arg))) (ly:stencil-aligned-to mol Y CENTER))) -(define-builtin-markup-command (hcenter layout props arg) +(define-markup-command (center-align layout props arg) (markup?) - align - () + #:category align " @cindex horizontally centering text @@ -1253,19 +2107,19 @@ Align @code{arg} to its X@tie{}center. @lilypond[verbatim,quote] \\markup { \\column { - ↓ - \\hcenter - centered + one + \\center-align + two + three } } @end lilypond" (let* ((mol (interpret-markup layout props arg))) (ly:stencil-aligned-to mol X CENTER))) -(define-builtin-markup-command (right-align layout props arg) +(define-markup-command (right-align layout props arg) (markup?) - align - () + #:category align " @cindex right aligning text @@ -1274,19 +2128,19 @@ Align @var{arg} on its right edge. @lilypond[verbatim,quote] \\markup { \\column { - ↓ + one \\right-align - right-aligned + two + three } } @end lilypond" (let* ((m (interpret-markup layout props arg))) (ly:stencil-aligned-to m X RIGHT))) -(define-builtin-markup-command (left-align layout props arg) +(define-markup-command (left-align layout props arg) (markup?) - align - () + #:category align " @cindex left aligning text @@ -1295,19 +2149,19 @@ Align @var{arg} on its left edge. @lilypond[verbatim,quote] \\markup { \\column { - ↓ + one \\left-align - left-aligned + two + three } } @end lilypond" (let* ((m (interpret-markup layout props arg))) (ly:stencil-aligned-to m X LEFT))) -(define-builtin-markup-command (general-align layout props axis dir arg) +(define-markup-command (general-align layout props axis dir arg) (integer? number? markup?) - align - () + #:category align " @cindex controlling general text alignment @@ -1316,26 +2170,28 @@ Align @var{arg} in @var{axis} direction to the @var{dir} side. @lilypond[verbatim,quote] \\markup { \\column { - ↓ + one \\general-align #X #LEFT - \\line { X, Left } - ↓ + two + three + \\null + one \\general-align #X #CENTER - \\line { X, Center } + two + three \\null \\line { - \\arrow-head #X #RIGHT ##f - \\general-align #Y #DOWN - \\line { Y, Down } - \\arrow-head #X #LEFT ##f + one + \\general-align #Y #UP + two + three } + \\null \\line { - \\arrow-head #X #RIGHT ##f + one \\general-align #Y #3.2 - \\line { - \\line { Y, Arbitrary alignment } - } - \\arrow-head #X #LEFT ##f + two + three } } } @@ -1343,57 +2199,73 @@ Align @var{arg} in @var{axis} direction to the @var{dir} side. (let* ((m (interpret-markup layout props arg))) (ly:stencil-aligned-to m axis dir))) -(define-builtin-markup-command (halign layout props dir arg) +(define-markup-command (halign layout props dir arg) (number? markup?) - align - () + #:category align " @cindex setting horizontal text alignment -Set horizontal alignment. If @var{dir} is @code{-1}, then it is +Set horizontal alignment. If @var{dir} is @w{@code{-1}}, then it is left-aligned, while @code{+1} is right. Values in between interpolate alignment accordingly. @lilypond[verbatim,quote] \\markup { \\column { - ↓ + one \\halign #LEFT - Left - ↓ + two + three + \\null + one \\halign #CENTER - Center - ↓ + two + three + \\null + one \\halign #RIGHT - Right - ↓ - \\halign #1.2 - \\line { - Arbitrary alignment - } + two + three + \\null + one + \\halign #-5 + two + three } } @end lilypond" (let* ((m (interpret-markup layout props arg))) (ly:stencil-aligned-to m X dir))) -(define-builtin-markup-command (with-dimensions layout props x y arg) +(define-markup-command (with-dimensions layout props x y arg) (number-pair? number-pair? markup?) - other - () + #:category other " @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))) +Set the dimensions of @var{arg} to @var{x} and@tie{}@var{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-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-builtin-markup-command (pad-around layout props amount arg) +(define-markup-command (pad-around layout props amount arg) (number? markup?) - align - () + #:category align "Add padding @var{amount} all around @var{arg}. - + @lilypond[verbatim,quote] \\markup { \\box { @@ -1408,16 +2280,14 @@ 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-builtin-markup-command (pad-x layout props amount arg) +(define-markup-command (pad-x layout props amount arg) (number? markup?) - align - () + #:category align " @cindex padding text horizontally @@ -1443,21 +2313,19 @@ Add padding @var{amount} around @var{arg} in the X@tie{}direction. (interval-widen x amount) y))) -(define-builtin-markup-command (put-adjacent layout props axis dir arg1 arg2) +(define-markup-command (put-adjacent layout props axis dir arg1 arg2) (integer? ly:dir? markup? markup?) - align - () + #:category align "Put @var{arg2} next to @var{arg1}, without moving @var{arg1}." (let ((m1 (interpret-markup layout props arg1)) (m2 (interpret-markup layout props arg2))) (ly:stencil-combine-at-edge m1 axis dir m2 0.0))) -(define-builtin-markup-command (transparent layout props arg) +(define-markup-command (transparent layout props arg) (markup?) - other - () - "Make the argument transparent. - + #:category other + "Make @var{arg} transparent. + @lilypond[verbatim,quote] \\markup { \\transparent { @@ -1468,12 +2336,11 @@ Add padding @var{amount} around @var{arg} in the X@tie{}direction. (let* ((m (interpret-markup layout props arg)) (x (ly:stencil-extent m X)) (y (ly:stencil-extent m Y))) - (ly:make-stencil "" x y))) + (ly:make-stencil (list 'transparent-stencil (ly:stencil-expr m)) x y))) -(define-builtin-markup-command (pad-to-box layout props x-ext y-ext arg) +(define-markup-command (pad-to-box layout props x-ext y-ext arg) (number-pair? number-pair? markup?) - align - () + #:category align "Make @var{arg} take at least @var{x-ext}, @var{y-ext} space. @lilypond[verbatim,quote] @@ -1489,17 +2356,12 @@ 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-builtin-markup-command (hcenter-in layout props length arg) +(define-markup-command (hcenter-in layout props length arg) (number? markup?) - align - () + #:category align "Center @var{arg} horizontally within a box of extending @var{length}/2 to the left and right. @@ -1526,16 +2388,23 @@ Add padding @var{amount} around @var{arg} in the X@tie{}direction. (make-pad-to-box-markup (cons (/ length -2) (/ length 2)) '(0 . 0) - (make-hcenter-markup arg)))) + (make-center-align-markup arg)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; property ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define-builtin-markup-command (fromproperty layout props symbol) +(define-markup-command (property-recursive layout props symbol) (symbol?) - other - () + #:category other + "Print out a warning when a header field markup contains some recursive +markup definition." + (ly:warning "Recursive definition of property ~a detected!" symbol) + empty-stencil) + +(define-markup-command (fromproperty layout props symbol) + (symbol?) + #:category other "Read the @var{symbol} from property settings, and produce a stencil from the markup contained within. If @var{symbol} is not defined, it returns an empty markup. @@ -1555,35 +2424,117 @@ returns an empty markup. @end lilypond" (let ((m (chain-assoc-get symbol props))) (if (markup? m) - (interpret-markup layout props m) + ;; prevent infinite loops by clearing the interpreted property: + (interpret-markup layout (cons (list (cons symbol `(,property-recursive-markup ,symbol))) props) m) empty-stencil))) -(define-builtin-markup-command (on-the-fly layout props procedure arg) - (symbol? markup?) - other - () +(define-markup-command (on-the-fly layout props procedure arg) + (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)))) - -(define-builtin-markup-command (override layout props new-prop 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?) + #:category other + "Have footnote @var{note} act as an annotation to the markup @var{mkup}. + +@lilypond[verbatim,quote] +\\markup { + \\auto-footnote a b + \\override #'(padding . 0.2) + \\auto-footnote c d +} +@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)) + +(define-markup-command (auto-footnote layout props mkup note) + (markup? markup?) + #:category other + #:properties ((raise 0.5) + (padding 0.0)) + "Have footnote @var{note} act as an annotation to the markup @var{mkup}. + +@lilypond[verbatim,quote] +\\markup { + \\auto-footnote a b + \\override #'(padding . 0.2) + \\auto-footnote c d +} +@end lilypond +The footnote will be annotated automatically." + (let* ((markup-stencil (interpret-markup layout props mkup)) + (footnote-hash (gensym "footnote")) + (stencil-seed 0) + (gauge-stencil (interpret-markup + layout + props + ((ly:output-def-lookup + layout + 'footnote-numbering-function) + stencil-seed))) + (x-ext (ly:stencil-extent gauge-stencil X)) + (y-ext (ly:stencil-extent gauge-stencil Y)) + (footnote-number + `(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 + `(footnote ,footnote-hash #t ,(interpret-markup layout props note)) + '(0 . 0) + '(0 . 0))))) + +(define-markup-command (override layout props new-prop arg) (pair? markup?) - other - () + #:category other " @cindex overriding properties within text markup -Add the first argument in to the property list. Properties may be -any sort of property supported by @rinternals{font-interface} and -@rinternals{text-interface}, for example - -@example -\\override #'(font-family . married) \"bla\" -@end example +Add the argument @var{new-prop} to the property list. Properties +may be any property supported by @rinternals{font-interface}, +@rinternals{text-interface} and +@rinternals{instrument-specific-markup-interface}. @lilypond[verbatim,quote] \\markup { @@ -1608,11 +2559,10 @@ any sort of property supported by @rinternals{font-interface} and ;; files ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define-builtin-markup-command (verbatim-file layout props name) +(define-markup-command (verbatim-file layout props name) (string?) - other - () - "Read the contents of a file, and include it verbatim. + #:category other + "Read the contents of file @var{name}, and include it verbatim. @lilypond[verbatim,quote] \\markup { @@ -1631,34 +2581,12 @@ any sort of property supported by @rinternals{font-interface} and ;; fonts. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define-builtin-markup-command (bigger layout props arg) - (markup?) - font - () - "Increase the font size relative to current setting. - -@lilypond[verbatim,quote] -\\markup { - \\huge { - huge - \\hspace #2 - \\bigger { - bigger - } - \\hspace #2 - huge - } -} -@end lilypond" - (interpret-markup layout props - `(,fontsize-markup 1 ,arg))) -(define-builtin-markup-command (smaller layout props arg) +(define-markup-command (smaller layout props arg) (markup?) - font - () - "Decrease the font size relative to current setting. - + #:category font + "Decrease the font size relative to the current setting. + @lilypond[verbatim,quote] \\markup { \\fontsize #3.5 { @@ -1673,13 +2601,12 @@ any sort of property supported by @rinternals{font-interface} and } @end lilypond" (interpret-markup layout props - `(,fontsize-markup -1 ,arg))) + `(,fontsize-markup -1 ,arg))) -(define-builtin-markup-command (larger layout props arg) +(define-markup-command (larger layout props arg) (markup?) - font - () - "Copy of the @code{\\bigger} command. + #:category font + "Increase the font size relative to the current setting. @lilypond[verbatim,quote] \\markup { @@ -1689,13 +2616,14 @@ any sort of property supported by @rinternals{font-interface} and larger } @end lilypond" - (interpret-markup layout props (make-bigger-markup arg))) + (interpret-markup layout props + `(,fontsize-markup 1 ,arg))) -(define-builtin-markup-command (finger layout props arg) +(define-markup-command (finger layout props arg) (markup?) - font - () - "Set the argument as small numbers. + #:category font + "Set @var{arg} as small numbers. + @lilypond[verbatim,quote] \\markup { \\finger { @@ -1704,15 +2632,15 @@ any sort of property supported by @rinternals{font-interface} and } @end lilypond" (interpret-markup layout - (cons '((font-size . -5) (font-encoding . fetaNumber)) props) + (cons '((font-size . -5) (font-encoding . fetaText)) props) arg)) -(define-builtin-markup-command (abs-fontsize layout props size arg) +(define-markup-command (abs-fontsize layout props size arg) (number? markup?) - font - () - "Use @var{size} as the absolute font size to display @var{arg}. -Adjust baseline skip and word space accordingly. + #:category font + "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] \\markup { default text font size @@ -1723,24 +2651,28 @@ Adjust baseline skip and 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))) - -(define-builtin-markup-command (fontsize layout props increment arg) + (text-props (list (ly:output-def-lookup layout 'text-font-defaults))) + (ref-word-space (chain-assoc-get 'word-space text-props 0.6)) + (ref-baseline (chain-assoc-get 'baseline-skip text-props 3)) + (magnification (/ size ref-size))) + (interpret-markup + layout + (cons + `((baseline-skip . ,(* magnification ref-baseline)) + (word-space . ,(* magnification ref-word-space)) + (font-size . ,(magnification->font-size magnification))) + props) + arg))) + +(define-markup-command (fontsize layout props increment arg) (number? markup?) - font - ((font-size 0) - (word-space 1) - (baseline-skip 2)) - "Add @var{increment} to the font-size. Adjust baseline skip accordingly. + #:category font + #:properties ((font-size 0) + (word-space 1) + (baseline-skip 2)) + "Add @var{increment} to the font-size. Adjusts @code{baseline-skip} +accordingly. + @lilypond[verbatim,quote] \\markup { default @@ -1749,16 +2681,18 @@ Adjust baseline skip and word space accordingly. smaller } @end lilypond" - (let ((entries (list - (cons 'baseline-skip (* baseline-skip (magstep increment))) - (cons 'word-space (* word-space (magstep increment))) - (cons 'font-size (+ font-size increment))))) - (interpret-markup layout (cons entries props) arg))) + (interpret-markup + layout + (cons + `((baseline-skip . ,(* baseline-skip (magstep increment))) + (word-space . ,(* word-space (magstep increment))) + (font-size . ,(+ font-size increment))) + props) + arg)) -(define-builtin-markup-command (magnify layout props sz arg) +(define-markup-command (magnify layout props sz arg) (number? markup?) - font - () + #:category font " @cindex magnifying text @@ -1782,16 +2716,15 @@ Use @code{\\fontsize} otherwise. } @end lilypond" (interpret-markup - layout + layout (prepend-alist-chain 'font-size (magnification->font-size sz) props) arg)) -(define-builtin-markup-command (bold layout props arg) +(define-markup-command (bold layout props arg) (markup?) - font - () + #:category font "Switch to bold font-series. - + @lilypond[verbatim,quote] \\markup { default @@ -1802,12 +2735,11 @@ Use @code{\\fontsize} otherwise. @end lilypond" (interpret-markup layout (prepend-alist-chain 'font-series 'bold props) arg)) -(define-builtin-markup-command (sans layout props arg) +(define-markup-command (sans layout props arg) (markup?) - font - () - "Switch to the sans serif family. - + #:category font + "Switch to the sans serif font family. + @lilypond[verbatim,quote] \\markup { default @@ -1819,13 +2751,12 @@ Use @code{\\fontsize} otherwise. @end lilypond" (interpret-markup layout (prepend-alist-chain 'font-family 'sans props) arg)) -(define-builtin-markup-command (number layout props arg) +(define-markup-command (number layout props arg) (markup?) - font - () + #:category font "Set font family to @code{number}, which yields the font used for -time signatures and fingerings. This font only contains numbers and -some punctuation. It doesn't have any letters. +time signatures and fingerings. This font contains numbers and +some punctuation; it has no letters. @lilypond[verbatim,quote] \\markup { @@ -1834,14 +2765,13 @@ some punctuation. It doesn't have any letters. } } @end lilypond" - (interpret-markup layout (prepend-alist-chain 'font-encoding 'fetaNumber props) arg)) + (interpret-markup layout (prepend-alist-chain 'font-encoding 'fetaText props) arg)) -(define-builtin-markup-command (roman layout props arg) +(define-markup-command (roman layout props arg) (markup?) - font - () + #:category font "Set font family to @code{roman}. - + @lilypond[verbatim,quote] \\markup { \\sans \\bold { @@ -1857,10 +2787,9 @@ some punctuation. It doesn't have any letters. @end lilypond" (interpret-markup layout (prepend-alist-chain 'font-family 'roman props) arg)) -(define-builtin-markup-command (huge layout props arg) +(define-markup-command (huge layout props arg) (markup?) - font - () + #:category font "Set font size to +2. @lilypond[verbatim,quote] @@ -1873,10 +2802,9 @@ some punctuation. It doesn't have any letters. @end lilypond" (interpret-markup layout (prepend-alist-chain 'font-size 2 props) arg)) -(define-builtin-markup-command (large layout props arg) +(define-markup-command (large layout props arg) (markup?) - font - () + #:category font "Set font size to +1. @lilypond[verbatim,quote] @@ -1889,12 +2817,11 @@ some punctuation. It doesn't have any letters. @end lilypond" (interpret-markup layout (prepend-alist-chain 'font-size 1 props) arg)) -(define-builtin-markup-command (normalsize layout props arg) +(define-markup-command (normalsize layout props arg) (markup?) - font - () + #:category font "Set font size to default. - + @lilypond[verbatim,quote] \\markup { \\teeny { @@ -1910,12 +2837,11 @@ some punctuation. It doesn't have any letters. @end lilypond" (interpret-markup layout (prepend-alist-chain 'font-size 0 props) arg)) -(define-builtin-markup-command (small layout props arg) +(define-markup-command (small layout props arg) (markup?) - font - () + #:category font "Set font size to -1. - + @lilypond[verbatim,quote] \\markup { default @@ -1926,12 +2852,11 @@ some punctuation. It doesn't have any letters. @end lilypond" (interpret-markup layout (prepend-alist-chain 'font-size -1 props) arg)) -(define-builtin-markup-command (tiny layout props arg) +(define-markup-command (tiny layout props arg) (markup?) - font - () + #:category font "Set font size to -2. - + @lilypond[verbatim,quote] \\markup { default @@ -1942,12 +2867,11 @@ some punctuation. It doesn't have any letters. @end lilypond" (interpret-markup layout (prepend-alist-chain 'font-size -2 props) arg)) -(define-builtin-markup-command (teeny layout props arg) +(define-markup-command (teeny layout props arg) (markup?) - font - () + #:category font "Set font size to -3. - + @lilypond[verbatim,quote] \\markup { default @@ -1958,21 +2882,19 @@ some punctuation. It doesn't have any letters. @end lilypond" (interpret-markup layout (prepend-alist-chain 'font-size -3 props) arg)) -(define-builtin-markup-command (fontCaps layout props arg) +(define-markup-command (fontCaps layout props arg) (markup?) - font - () + #:category font "Set @code{font-shape} to @code{caps} - + Note: @code{\\fontCaps} requires the installation and selection of fonts which support the @code{caps} font shape." (interpret-markup layout (prepend-alist-chain 'font-shape 'caps props) arg)) ;; Poor man's caps -(define-builtin-markup-command (smallCaps layout props text) +(define-markup-command (smallCaps layout props arg) (markup?) - font - () + #:category font "Emit @var{arg} as small caps. Note: @code{\\smallCaps} does not support accented characters. @@ -1989,38 +2911,37 @@ 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? text) - (make-small-caps (string->list text) (list) #f (list)) - text))) + (if (string? arg) + (make-small-caps (string->list arg) (list) #f (list)) + arg))) -(define-builtin-markup-command (caps layout props arg) +(define-markup-command (caps layout props arg) (markup?) - font - () + #:category font "Copy of the @code{\\smallCaps} command. @lilypond[verbatim,quote] @@ -2034,10 +2955,9 @@ Note: @code{\\smallCaps} does not support accented characters. @end lilypond" (interpret-markup layout props (make-smallCaps-markup arg))) -(define-builtin-markup-command (dynamic layout props arg) +(define-markup-command (dynamic layout props arg) (markup?) - font - () + #:category font "Use the dynamic font. This font only contains @b{s}, @b{f}, @b{m}, @b{z}, @b{p}, and @b{r}. When producing phrases, like @q{pi@`{u}@tie{}@b{f}}, the normal words (like @q{pi@`{u}}) should be @@ -2050,14 +2970,13 @@ done in a different font. The recommended font for this is bold and italic. } @end lilypond" (interpret-markup - layout (prepend-alist-chain 'font-encoding 'fetaDynamic props) arg)) + layout (prepend-alist-chain 'font-encoding 'fetaText props) arg)) -(define-builtin-markup-command (text layout props arg) +(define-markup-command (text layout props arg) (markup?) - font - () + #:category font "Use a text font instead of music symbol or music alphabet font. - + @lilypond[verbatim,quote] \\markup { \\number { @@ -2072,12 +2991,11 @@ 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-builtin-markup-command (italic layout props arg) +(define-markup-command (italic layout props arg) (markup?) - font - () + #:category font "Use italic @code{font-shape} for @var{arg}. @lilypond[verbatim,quote] @@ -2090,12 +3008,11 @@ done in a different font. The recommended font for this is bold and italic. @end lilypond" (interpret-markup layout (prepend-alist-chain 'font-shape 'italic props) arg)) -(define-builtin-markup-command (typewriter layout props arg) +(define-markup-command (typewriter layout props arg) (markup?) - font - () + #:category font "Use @code{font-family} typewriter for @var{arg}. - + @lilypond[verbatim,quote] \\markup { default @@ -2107,11 +3024,11 @@ done in a different font. The recommended font for this is bold and italic. (interpret-markup layout (prepend-alist-chain 'font-family 'typewriter props) arg)) -(define-builtin-markup-command (upright layout props arg) +(define-markup-command (upright layout props arg) (markup?) - font - () - "Set font shape to @code{upright}. This is the opposite of @code{italic}. + #:category font + "Set @code{font-shape} to @code{upright}. This is the opposite +of @code{italic}. @lilypond[verbatim,quote] \\markup { @@ -2129,11 +3046,10 @@ done in a different font. The recommended font for this is bold and italic. (interpret-markup layout (prepend-alist-chain 'font-shape 'upright props) arg)) -(define-builtin-markup-command (medium layout props arg) +(define-markup-command (medium layout props arg) (markup?) - font - () - "Switch to medium font series (in contrast to bold). + #:category font + "Switch to medium font-series (in contrast to bold). @lilypond[verbatim,quote] \\markup { @@ -2149,43 +3065,67 @@ done in a different font. The recommended font for this is bold and italic. } @end lilypond" (interpret-markup layout (prepend-alist-chain 'font-series 'medium props) - arg)) + arg)) -(define-builtin-markup-command (normal-text layout props arg) +(define-markup-command (normal-text layout props arg) (markup?) - font - () + #:category font "Set all font related properties (except the size) to get the default normal text font, no matter what font was used earlier. @lilypond[verbatim,quote] \\markup { \\huge \\bold \\sans \\caps { - Some text with font overrides + huge bold sans caps \\hspace #2 \\normal-text { - Default text, same font-size + huge normal } \\hspace #2 - More text as before + as before } } @end lilypond" ;; 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)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; symbols. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define-builtin-markup-command (doublesharp layout props) - () - music +(define-markup-command (musicglyph layout props glyph-name) + (string?) + #: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 possible glyphs. + +@lilypond[verbatim,quote] +\\markup { + \\musicglyph #\"f\" + \\musicglyph #\"rests.2\" + \\musicglyph #\"clefs.G_change\" +} +@end lilypond" + (let* ((font (ly:paper-get-font layout + (cons '((font-encoding . fetaMusic) + (font-name . #f)) + + props))) + (glyph (ly:font-get-glyph font glyph-name))) + (if (null? (ly:stencil-expr glyph)) + (ly:warning (_ "Cannot find glyph ~a") glyph-name)) + + glyph)) + +(define-markup-command (doublesharp layout props) () + #:category music "Draw a double sharp symbol. @lilypond[verbatim,quote] @@ -2195,10 +3135,9 @@ normal text font, no matter what font was used earlier. @end lilypond" (interpret-markup layout props (markup #:musicglyph (assoc-get 1 standard-alteration-glyph-name-alist "")))) -(define-builtin-markup-command (sesquisharp layout props) - () - music +(define-markup-command (sesquisharp layout props) () + #:category music "Draw a 3/2 sharp symbol. @lilypond[verbatim,quote] @@ -2206,12 +3145,11 @@ normal text font, no matter what font was used earlier. \\sesquisharp } @end lilypond" - (interpret-markup layout props (markup #:musicglyph (assoc-get 3/4 standard-alteration-glyph-name-alist "")))) + (interpret-markup layout props (markup #:musicglyph (assoc-get 3/4 standard-alteration-glyph-name-alist "")))) -(define-builtin-markup-command (sharp layout props) - () - music +(define-markup-command (sharp layout props) () + #:category music "Draw a sharp symbol. @lilypond[verbatim,quote] @@ -2221,11 +3159,10 @@ normal text font, no matter what font was used earlier. @end lilypond" (interpret-markup layout props (markup #:musicglyph (assoc-get 1/2 standard-alteration-glyph-name-alist "")))) -(define-builtin-markup-command (semisharp layout props) - () - music +(define-markup-command (semisharp layout props) () - "Draw a semi sharp symbol. + #:category music + "Draw a semisharp symbol. @lilypond[verbatim,quote] \\markup { @@ -2234,10 +3171,9 @@ normal text font, no matter what font was used earlier. @end lilypond" (interpret-markup layout props (markup #:musicglyph (assoc-get 1/4 standard-alteration-glyph-name-alist "")))) -(define-builtin-markup-command (natural layout props) - () - music +(define-markup-command (natural layout props) () + #:category music "Draw a natural symbol. @lilypond[verbatim,quote] @@ -2247,10 +3183,9 @@ normal text font, no matter what font was used earlier. @end lilypond" (interpret-markup layout props (markup #:musicglyph (assoc-get 0 standard-alteration-glyph-name-alist "")))) -(define-builtin-markup-command (semiflat layout props) - () - music +(define-markup-command (semiflat layout props) () + #:category music "Draw a semiflat symbol. @lilypond[verbatim,quote] @@ -2260,10 +3195,9 @@ normal text font, no matter what font was used earlier. @end lilypond" (interpret-markup layout props (markup #:musicglyph (assoc-get -1/4 standard-alteration-glyph-name-alist "")))) -(define-builtin-markup-command (flat layout props) - () - music +(define-markup-command (flat layout props) () + #:category music "Draw a flat symbol. @lilypond[verbatim,quote] @@ -2273,10 +3207,9 @@ normal text font, no matter what font was used earlier. @end lilypond" (interpret-markup layout props (markup #:musicglyph (assoc-get -1/2 standard-alteration-glyph-name-alist "")))) -(define-builtin-markup-command (sesquiflat layout props) - () - music +(define-markup-command (sesquiflat layout props) () + #:category music "Draw a 3/2 flat symbol. @lilypond[verbatim,quote] @@ -2286,10 +3219,9 @@ normal text font, no matter what font was used earlier. @end lilypond" (interpret-markup layout props (markup #:musicglyph (assoc-get -3/4 standard-alteration-glyph-name-alist "")))) -(define-builtin-markup-command (doubleflat layout props) - () - music +(define-markup-command (doubleflat layout props) () + #:category music "Draw a double flat symbol. @lilypond[verbatim,quote] @@ -2299,10 +3231,9 @@ normal text font, no matter what font was used earlier. @end lilypond" (interpret-markup layout props (markup #:musicglyph (assoc-get -1 standard-alteration-glyph-name-alist "")))) -(define-builtin-markup-command (with-color layout props color arg) +(define-markup-command (with-color layout props color arg) (color? markup?) - other - () + #:category other " @cindex coloring text @@ -2322,17 +3253,66 @@ 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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define-builtin-markup-command (arrow-head layout props axis direction filled) +(define-markup-command (arrow-head layout props axis dir filled) (integer? ly:dir? boolean?) - graphic - () + #:category graphic "Produce an arrow head in specified direction and axis. Use the filled head if @var{filled} is specified. @lilypond[verbatim,quote] @@ -2349,51 +3329,22 @@ Use the filled head if @var{filled} is specified. } @end lilypond" (let* - ((name (format "arrowheads.~a.~a~a" - (if filled - "close" - "open") - axis - direction))) + ((name (format #f "arrowheads.~a.~a~a" + (if filled + "close" + "open") + axis + dir))) (ly:font-get-glyph (ly:paper-get-font layout (cons '((font-encoding . fetaMusic)) - props)) + props)) name))) -(define-builtin-markup-command (musicglyph layout props glyph-name) - (string?) - 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 possible glyphs. - -@lilypond[verbatim,quote] -\\markup { - \\musicglyph #\"f\" - \\musicglyph #\"rests.2\" - \\musicglyph #\"clefs.G_change\" -} -@end lilypond" - (let* ((font (ly:paper-get-font layout - (cons '((font-encoding . fetaMusic) - (font-name . #f)) - - props))) - (glyph (ly:font-get-glyph font glyph-name))) - (if (null? (ly:stencil-expr glyph)) - (ly:warning (_ "Cannot find glyph ~a") glyph-name)) - - glyph)) - - -(define-builtin-markup-command (lookup layout props glyph-name) +(define-markup-command (lookup layout props glyph-name) (string?) - other - () + #:category other "Lookup a glyph by name. - + @lilypond[verbatim,quote] \\markup { \\override #'(font-encoding . fetaBraces) { @@ -2405,18 +3356,17 @@ the possible glyphs. } @end lilypond" (ly:font-get-glyph (ly:paper-get-font layout props) - glyph-name)) + glyph-name)) -(define-builtin-markup-command (char layout props num) +(define-markup-command (char layout props num) (integer?) - other - () - "Produce a single character. For example, @code{\\char #65} produces the -letter @q{A}. + #:category other + "Produce a single character. Characters encoded in hexadecimal +format require the prefix @code{#x}. @lilypond[verbatim,quote] \\markup { - \\char #65 + \\char #65 \\char ##x00a9 } @end lilypond" (ly:text-interface::interpret-markup layout props (ly:wide-char->utf-8 num))) @@ -2432,23 +3382,22 @@ letter @q{A}. (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-builtin-markup-command (markletter layout props num) +(define-markup-command (markletter layout props num) (integer?) - 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. + #: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. @lilypond[verbatim,quote] \\markup { @@ -2458,13 +3407,12 @@ letter @q{A}. } @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-builtin-markup-command (markalphabet layout props num) +(define-markup-command (markalphabet layout props num) (integer?) - other - () - "Make a markup letter for @var{num}. The letters start with A to@tie{}Z + #:category other + "Make a markup letter for @var{num}. The letters start with A to@tie{}Z and continue with double letters. @lilypond[verbatim,quote] @@ -2474,77 +3422,75 @@ 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 'fetaNumber props) + (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 - (ly:make-stencil - `(draw-line ,thickness - ,(car num-x) ,(- (interval-center num-y) dy) - ,(cdr num-x) ,(+ (interval-center num-y) dy)) - num-x num-y) + (make-line-stencil thickness + (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)) -(define-builtin-markup-command (slashed-digit layout props num) +(define-markup-command (slashed-digit layout props num) (integer?) - other - ((font-size 0) - (thickness 1.6)) + #:category other + #:properties ((font-size 0) + (thickness 1.6)) " @cindex slashed digits @@ -2560,11 +3506,11 @@ figured bass notation. @end lilypond" (slashed-digit-internal layout props num #t font-size thickness)) -(define-builtin-markup-command (backslashed-digit layout props num) +(define-markup-command (backslashed-digit layout props num) (integer?) - other - ((font-size 0) - (thickness 1.6)) + #:category other + #:properties ((font-size 0) + (thickness 1.6)) " @cindex backslashed digits @@ -2580,22 +3526,120 @@ figured bass notation. @end lilypond" (slashed-digit-internal layout props num #f font-size thickness)) +;; eyeglasses +(define eyeglassespath + '((moveto 0.42 0.77) + (rcurveto 0 0.304 -0.246 0.55 -0.55 0.55) + (rcurveto -0.304 0 -0.55 -0.246 -0.55 -0.55) + (rcurveto 0 -0.304 0.246 -0.55 0.55 -0.55) + (rcurveto 0.304 0 0.55 0.246 0.55 0.55) + (closepath) + (moveto 2.07 0.77) + (rcurveto 0 0.304 -0.246 0.55 -0.55 0.55) + (rcurveto -0.304 0 -0.55 -0.246 -0.55 -0.55) + (rcurveto 0 -0.304 0.246 -0.55 0.55 -0.55) + (rcurveto 0.304 0 0.55 0.246 0.55 0.55) + (closepath) + (moveto 1.025 0.935) + (rcurveto 0 0.182 -0.148 0.33 -0.33 0.33) + (rcurveto -0.182 0 -0.33 -0.148 -0.33 -0.33) + (moveto -0.68 0.77) + (rlineto 0.66 1.43) + (rcurveto 0.132 0.286 0.55 0.44 0.385 -0.33) + (moveto 2.07 0.77) + (rlineto 0.66 1.43) + (rcurveto 0.132 0.286 0.55 0.44 0.385 -0.33))) + +(define-markup-command (eyeglasses layout props) + () + #:category other + "Prints out eyeglasses, indicating strongly to look at the conductor. +@lilypond[verbatim,quote] +\\markup { \\eyeglasses } +@end lilypond" + (interpret-markup layout props + (make-override-markup '(line-cap-style . butt) + (make-path-markup 0.15 eyeglassespath)))) + +(define-markup-command (left-brace layout props size) + (number?) + #:category other + " +A feta brace in point size @var{size}. + +@lilypond[verbatim,quote] +\\markup { + \\left-brace #35 + \\hspace #2 + \\left-brace #45 +} +@end lilypond" + (let* ((font (ly:paper-get-font layout + (cons '((font-encoding . fetaBraces) + (font-name . #f)) + props))) + (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)))) + (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)))) + (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))))) + glyph-found)) + +(define-markup-command (right-brace layout props size) + (number?) + #:category other + " +A feta brace in point size @var{size}, rotated 180 degrees. + +@lilypond[verbatim,quote] +\\markup { + \\right-brace #45 + \\hspace #2 + \\right-brace #35 +} +@end lilypond" + (interpret-markup layout props (markup #:rotate 180 #:left-brace size))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; the note command. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; TODO: better syntax. -(define-builtin-markup-command (note-by-number layout props log dot-count dir) +(define-markup-command (note-by-number layout props log dot-count dir) (number? number? number?) - music - ((font-size 0) - (style '())) + #:category music + #:properties ((font-size 0) + (flag-style '()) + (style '())) " @cindex notes within text by log and dot-count -Construct a note symbol, with stem. By using fractional values for -@var{dir}, you can obtain longer or shorter stems. +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. 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 { @@ -2606,44 +3650,123 @@ Construct a note symbol, with stem. By using fractional values for @end lilypond" (define (get-glyph-name-candidates dir log style) (map (lambda (dir-name) - (format "noteheads.~a~a~a" dir-name (min log 2) - (if (and (symbol? style) - (not (equal? 'default style))) - (symbol->string style) - ""))) - (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)))) - - (let* ((font (ly:paper-get-font layout (cons '((font-encoding . fetaMusic)) props))) - (size-factor (magstep font-size)) - (stem-length (* size-factor (max 3 (- log 1)))) - (head-glyph-name (get-glyph-name font (get-glyph-name-candidates (sign dir) log style))) + "" + (if (ly:stencil-empty? (ly:font-get-glyph font (car cands))) + (get-glyph-name font (cdr cands)) + (car cands)))) + + (define (buildflags flag-stencil remain curr-stencil spacing) + ;; Function to recursively create a stencil with @code{remain} flags + ;; from the single-flag stencil @code{curr-stencil}, which is already + ;; translated to the position of the previous flag position. + ;; + ;; Copy and paste from /scm/flag-styles.scm + (if (> remain 0) + (let* ((translated-stencil + (ly:stencil-translate-axis curr-stencil spacing Y)) + (new-stencil (ly:stencil-add flag-stencil translated-stencil))) + (buildflags new-stencil (- remain 1) translated-stencil spacing)) + flag-stencil)) + + (define (straight-flag-mrkp flag-thickness flag-spacing + upflag-angle upflag-length + downflag-angle downflag-length + dir) + ;; Create a stencil for a straight flag. @var{flag-thickness} and + ;; @var{flag-spacing} are given in staff spaces, @var{upflag-angle} and + ;; @var{downflag-angle} are given in degrees, and @var{upflag-length} and + ;; @var{downflag-length} are given in staff spaces. + ;; + ;; All lengths are scaled according to the font size of the note. + ;; + ;; From /scm/flag-styles.scm, modified to fit here. + + (let* ((stem-up (> dir 0)) + ;; scale with the note size + (factor (magstep font-size)) + (stem-thickness (* factor 0.1)) + (line-thickness (ly:output-def-lookup layout 'line-thickness)) + (half-stem-thickness (/ (* stem-thickness line-thickness) 2)) + (raw-length (if stem-up upflag-length downflag-length)) + (angle (if stem-up upflag-angle downflag-angle)) + (flag-length (+ (* raw-length factor) half-stem-thickness)) + (flag-end (if (= angle 0) + (cons flag-length (* half-stem-thickness dir)) + (polar->rectangular flag-length angle))) + (thickness (* flag-thickness factor)) + (thickness-offset (cons 0 (* -1 thickness dir))) + (spacing (* -1 flag-spacing factor dir)) + (start (cons (- half-stem-thickness) (* half-stem-thickness dir))) + (points (list start + flag-end + (offset-add flag-end thickness-offset) + (offset-add start thickness-offset))) + (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))) + (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))) (head-glyph (ly:font-get-glyph font head-glyph-name)) - (attach-indices (ly:note-head::stem-attachment font head-glyph-name)) - (stem-thickness (* size-factor 0.13)) + (ancient-flags? + (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)) (attach-off (cons (interval-index - (ly:stencil-extent head-glyph X) - (* (sign dir) (car attach-indices))) - (* (sign dir) ; fixme, this is inconsistent between X & Y. - (interval-index - (ly:stencil-extent head-glyph Y) - (cdr attach-indices))))) + (ly:stencil-extent head-glyph X) + (* (sign dir) (car attach-indices))) + ;; fixme, this is inconsistent between X & Y. + (* (sign dir) + (interval-index + (ly:stencil-extent head-glyph Y) + (cdr attach-indices))))) + ;; For a tighter stem (with ancient-flags) the stem-width has to be + ;; adjusted. + (stem-X-corr + (if (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 (car attach-off) - (+ (car attach-off) (* (- (sign dir)) stem-thickness))) - (cons (min stemy (cdr attach-off)) - (max stemy (cdr attach-off))) - (/ stem-thickness 3)))) - + (ly:round-filled-box + (ordered-cons (+ stem-X-corr (car attach-off)) + (+ stem-X-corr (car attach-off) + (* (- (sign dir)) stem-thickness))) + (cons (min stemy (cdr attach-off)) + (max stemy (cdr attach-off))) + (/ stem-thickness 3)))) (dot (ly:font-get-glyph font "dots.dot")) (dotwid (interval-length (ly:stencil-extent dot X))) (dots (and (> dot-count 0) @@ -2652,18 +3775,53 @@ Construct a note symbol, with stem. By using fractional values for (ly:stencil-translate-axis dot (* 2 x dotwid) X)) (iota dot-count))))) + ;; Straight-flags. Values taken from /scm/flag-style.scm + (modern-straight-flag (straight-flag-mrkp 0.55 1 -18 1.1 22 1.2 dir)) + (old-straight-flag (straight-flag-mrkp 0.55 1 -45 1.2 45 1.4 dir)) + (flat-flag (straight-flag-mrkp 0.55 1.0 0 1.0 0 1.0 dir)) + ;; Calculate a corrective to avoid a gap between + ;; straight-flags and the stem. + (flag-style-Y-corr (if (or (eq? flag-style 'modern-straight-flag) + (eq? flag-style 'old-straight-flag) + (eq? flag-style 'flat-flag)) + (/ blot 10 (* -1 dir)) + 0)) (flaggl (and (> log 2) (ly:stencil-translate - (ly:font-get-glyph font - (string-append "flags." - (if (> dir 0) "u" "d") - (number->string log))) - (cons (+ (car attach-off) (if (< dir 0) stem-thickness 0)) stemy))))) - - ; 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. - (if (and dots (> dir 0) (> log 2) (or (< dir 1.15) (and (= log 4) (< dir 1.3)))) - (set! dots (ly:stencil-translate-axis dots 0.5 X))) + (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))) (if flaggl (set! stem-glyph (ly:stencil-add flaggl stem-glyph))) (if (ly:stencil? stem-glyph) @@ -2673,21 +3831,23 @@ Construct a note symbol, with stem. By using fractional values for (set! stem-glyph (ly:stencil-add (ly:stencil-translate-axis - dots - (+ (cdr (ly:stencil-extent head-glyph X)) dotwid) - X) + dots + (+ (cdr (ly:stencil-extent head-glyph X)) dotwid) + X) stem-glyph))) stem-glyph)) -(define-public log2 +(define-public log2 (let ((divisor (log 2))) (lambda (z) (inexact->exact (/ (log z) divisor))))) (define (parse-simple-duration duration-string) - "Parse the `duration-string', e.g. ''4..'' or ''breve.'', and return a (log dots) list." - (let ((match (regexp-exec (make-regexp "(breve|longa|maxima|[0-9]+)(\\.*)") duration-string))) + "Parse the `duration-string', e.g. ''4..'' or ''breve.'', +and return a (log dots) list." + (let ((match (regexp-exec (make-regexp "(breve|longa|maxima|[0-9]+)(\\.*)") + duration-string))) (if (and match (string=? duration-string (match:substring match 0))) - (let ((len (match:substring match 1)) + (let ((len (match:substring match 1)) (dots (match:substring match 2))) (list (cond ((string=? len "breve") -1) ((string=? len "longa") -2) @@ -2696,10 +3856,10 @@ Construct a note symbol, with stem. By using fractional values for (if dots (string-length dots) 0))) (ly:error (_ "not a valid duration string: ~a") duration-string)))) -(define-builtin-markup-command (note layout props duration dir) +(define-markup-command (note layout props duration dir) (string? number?) - music - (note-by-number-markup) + #:category music + #:properties (note-by-number-markup) " @cindex notes within text by string @@ -2720,14 +3880,296 @@ a shortened down stem. (let ((parsed (parse-simple-duration duration))) (note-by-number-markup layout props (car parsed) (cadr parsed) dir))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; the rest command. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-markup-command (rest-by-number layout props log dot-count) + (number? number?) + #:category music + #:properties ((font-size 0) + (style '()) + (multi-measure-rest #f)) + " +@cindex rests or multi-measure-rests within text by log and dot-count + +A rest or multi-measure-rest symbol. + +@lilypond[verbatim,quote] +\\markup { + \\rest-by-number #3 #2 + \\hspace #2 + \\rest-by-number #0 #1 + \\hspace #2 + \\override #'(multi-measure-rest . #t) + \\rest-by-number #0 #0 +} +@end lilypond" + + (define (get-glyph-name-candidates log style) + (let* (;; Choose the style-string to be added. + ;; If no glyph exists, select others for the specified styles + ;; otherwise defaulting. + (style-strg + (cond ( + ;; 'baroque needs to be special-cased, otherwise + ;; `select-head-glyph´ would catch neomensural-glyphs for + ;; this style, if (< log 0). + (eq? style 'baroque) + (string-append (number->string log) "")) + ((eq? style 'petrucci) + (string-append (number->string log) "mensural")) + ;; In other cases `select-head-glyph´ from output-lib.scm + ;; works for rest-glyphs, too. + ((and (symbol? style) (not (eq? style 'default))) + (select-head-glyph style log)) + (else log))) + ;; Choose ledgered glyphs for whole and half rest. + ;; Except for the specified styles, logs and MultiMeasureRests. + (ledger-style-rests + (if (and (or (list? style) + (not (member style + '(neomensural mensural petrucci)))) + (not multi-measure-rest) + (or (= log 0) (= log 1))) + "o" + ""))) + (format #f "rests.~a~a" style-strg ledger-style-rests))) + + (define (get-glyph-name font cands) + (if (ly:stencil-empty? (ly:font-get-glyph font cands)) + "" + cands)) + + (let* ((font + (ly:paper-get-font layout + (cons '((font-encoding . fetaMusic) + (font-name . #f)) + props))) + (rest-glyph-name + (let ((result + (get-glyph-name font + (get-glyph-name-candidates log style)))) + (if (string-null? result) + ;; If no glyph name can be found, select default rests. Though + ;; this usually means an unsupported style has been chosen, it + ;; also prevents unrelated 'style settings from other grobs + ;; (e.g., TextSpanner and TimeSignature) leaking into markup. + (get-glyph-name font (get-glyph-name-candidates log 'default)) + result))) + (rest-glyph (ly:font-get-glyph font rest-glyph-name)) + (dot (ly:font-get-glyph font "dots.dot")) + (dot-width (interval-length (ly:stencil-extent dot X))) + (dots (and (> dot-count 0) + (apply ly:stencil-add + (map (lambda (x) + (ly:stencil-translate-axis + dot (* 2 x dot-width) X)) + (iota dot-count)))))) + + ;; Apart from mensural-, neomensural- and petrucci-style ledgered + ;; glyphs are taken for whole and half rests. + ;; If they are dotted, move the dots in X-direction to avoid collision. + (if (and dots + (< log 2) + (>= log 0) + (not (member style '(neomensural mensural petrucci)))) + (set! dots (ly:stencil-translate-axis dots dot-width X))) + + ;; Add dots to the rest-glyph. + ;; + ;; Not sure how to vertical align dots. + ;; For now the dots are centered for half, whole or longer rests. + ;; Otherwise placed near the top of the rest. + ;; + ;; Dots for rests with (< log 0) dots are allowed, but not + ;; if multi-measure-rest is set #t. + (if (and (not multi-measure-rest) dots) + (set! rest-glyph + (ly:stencil-add + (ly:stencil-translate + dots + (cons + (+ (cdr (ly:stencil-extent rest-glyph X)) dot-width) + (if (< log 2) + (interval-center (ly:stencil-extent rest-glyph Y)) + (- (interval-end (ly:stencil-extent rest-glyph Y)) + (/ (* 2 dot-width) 3))))) + rest-glyph))) + rest-glyph)) + +(define-markup-command (rest layout props duration) + (string?) + #:category music + #:properties ((style '()) + (multi-measure-rest #f) + (multi-measure-rest-number #t) + (word-space 0.6)) + " +@cindex rests or multi-measure-rests within text by string + +This produces a rest, with the @var{duration} for the rest type and +augmentation dots. +@code{\"breve\"}, @code{\"longa\"} and @code{\"maxima\"} are valid +input-strings. + +Printing MultiMeasureRests could be enabled with +@code{\\override #'(multi-measure-rest . #t)} +If MultiMeasureRests are taken, the MultiMeasureRestNumber is printed above. +This is enabled for all styles using default-glyphs. +Could be disabled with @code{\\override #'(multi-measure-rest-number . #f)} + +@lilypond[verbatim,quote] +\\markup { + \\rest #\"4..\" + \\hspace #2 + \\rest #\"breve\" + \\hspace #2 + \\override #'(multi-measure-rest . #t) + { + \\rest #\"7\" + \\hspace #2 + \\override #'(multi-measure-rest-number . #f) + \\rest #\"7\" + } +} +@end lilypond" + ;; Get the number of mmr-glyphs. + ;; Store them in a list. + ;; example: (mmr-numbers 25) -> '(3 0 0 1) + (define (mmr-numbers nmbr) + (let* ((8-bar-glyph (floor (/ nmbr 8))) + (8-remainder (remainder nmbr 8)) + (4-bar-glyph (floor (/ 8-remainder 4))) + (4-remainder (remainder nmbr 4)) + (2-bar-glyph (floor (/ 4-remainder 2))) + (2-remainder (remainder 4-remainder 2)) + (1-bar-glyph (floor (/ 2-remainder 1)))) + (list 8-bar-glyph 4-bar-glyph 2-bar-glyph 1-bar-glyph))) + + ;; Get the correct mmr-glyphs. + ;; Store them in a list. + ;; example: + ;; (get-mmr-glyphs '(1 0 1 0) '("rests.M3" "rests.M2" "rests.M1" "rests.0")) + ;; -> ("rests.M3" "rests.M1") + (define (get-mmr-glyphs lst1 lst2) + (define (helper l1 l2 l3) + (if (null? l1) + (reverse l3) + (helper (cdr l1) + (cdr l2) + (append (make-list (car l1) (car l2)) l3)))) + (helper lst1 lst2 '())) + + ;; If duration is not valid, print a warning and return empty-stencil + (if (or (and (not (integer? (car (parse-simple-duration duration)))) + (not multi-measure-rest)) + (and (= (string-length (car (string-split duration #\. ))) 1) + (= (string->number (car (string-split duration #\. ))) 0))) + (begin + (ly:warning (_ "not a valid duration string: ~a - ignoring") duration) + empty-stencil) + (let* ( + ;; For simple rests: + ;; Get a (log dots) list. + (parsed (parse-simple-duration duration)) + ;; Create the rest-stencil + (stil + (rest-by-number-markup layout props (car parsed) (cadr parsed))) + ;; For MultiMeasureRests: + ;; Get the duration-part of duration + (dur-part-string (car (string-split duration #\. ))) + ;; Get the duration of MMR: + ;; If not a number (eg. "maxima") calculate it. + (mmr-duration + (or (string->number dur-part-string) (expt 2 (abs (car parsed))))) + ;; Get a list of the correct number of each mmr-glyph. + (count-mmr-glyphs-list (mmr-numbers mmr-duration)) + ;; Create a list of mmr-stencils, + ;; translating the glyph for a whole rest. + (mmr-stils-list + (map + (lambda (x) + (let ((single-mmr-stil + (rest-by-number-markup layout props (* -1 x) 0))) + (if (= x 0) + (ly:stencil-translate-axis + single-mmr-stil + ;; Ugh, hard-coded, why 1? + 1 + Y) + single-mmr-stil))) + (get-mmr-glyphs count-mmr-glyphs-list (reverse (iota 4))))) + ;; Adjust the space between the mmr-glyphs, + ;; if not default-glyphs are used. + (word-space (if (member style + '(neomensural mensural petrucci)) + (/ (* word-space 2) 3) + word-space)) + ;; Create the final mmr-stencil + ;; via `stack-stencil-line´ from /scm/markup.scm + (mmr-stil (stack-stencil-line word-space mmr-stils-list))) + + ;; Print the number above a multi-measure-rest + ;; Depends on duration, style and multi-measure-rest-number set #t + (if (and multi-measure-rest + multi-measure-rest-number + (> mmr-duration 1) + (not (member style '(neomensural mensural petrucci)))) + (let* ((mmr-stil-x-center + (interval-center (ly:stencil-extent mmr-stil X))) + (duration-markup + (markup + #:fontsize -2 + #:override '(font-encoding . fetaText) + (number->string mmr-duration))) + (mmr-number-stil + (interpret-markup layout props duration-markup)) + (mmr-number-stil-x-center + (interval-center (ly:stencil-extent mmr-number-stil X)))) + + (set! mmr-stil (ly:stencil-combine-at-edge + mmr-stil + Y UP + (ly:stencil-translate-axis + mmr-number-stil + (- mmr-stil-x-center mmr-number-stil-x-center) + X) + ;; Ugh, hardcoded + 0.8)))) + (if multi-measure-rest + mmr-stil + stil)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; fermata markup +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-markup-command (fermata layout props) () + #:category music + #:properties ((direction UP)) + "Create a fermata glyph. When @var{direction} is @code{DOWN}, use +an inverted glyph. Note that within music, one would usually use the +@code{\\fermata} articulation instead of a markup. + +@lilypond[verbatim,quote] + { c''1^\\markup \\fermata d''1_\\markup \\fermata } + +\\markup { \\fermata \\override #`(direction . ,DOWN) \\fermata } +@end lilypond +" + (interpret-markup layout props + (if (eqv? direction DOWN) + (markup #:musicglyph "scripts.dfermata") + (markup #:musicglyph "scripts.ufermata")))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; translating. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define-builtin-markup-command (lower layout props amount arg) +(define-markup-command (lower layout props amount arg) (number? markup?) - align - () + #:category align " @cindex lowering text @@ -2736,19 +4178,19 @@ A negative @var{amount} indicates raising; see also @code{\\raise}. @lilypond[verbatim,quote] \\markup { - default - \\lower #3 { - three spaces lower - } + one + \\lower #3 + two + three } @end lilypond" (ly:stencil-translate-axis (interpret-markup layout props arg) - (- amount) Y)) + (- amount) Y)) -(define-builtin-markup-command (translate-scaled layout props offset arg) +(define-markup-command (translate-scaled layout props offset arg) (number-pair? markup?) - align - ((font-size 0)) + #:category align + #:properties ((font-size 0)) " @cindex translating text @cindex scaling text @@ -2771,13 +4213,12 @@ Translate @var{arg} by @var{offset}, scaling the offset by the (ly:stencil-translate (interpret-markup layout props arg) scaled))) -(define-builtin-markup-command (raise layout props amount arg) +(define-markup-command (raise layout props amount arg) (number? markup?) - align - () + #:category align " @cindex raising text - + Raise @var{arg} by the distance @var{amount}. A negative @var{amount} indicates lowering, see also @code{\\lower}. @@ -2802,10 +4243,10 @@ and/or @code{extra-offset} properties. @end lilypond" (ly:stencil-translate-axis (interpret-markup layout props arg) amount Y)) -(define-builtin-markup-command (fraction layout props arg1 arg2) +(define-markup-command (fraction layout props arg1 arg2) (markup? markup?) - other - ((font-size 0)) + #:category other + #:properties ((font-size 0)) " @cindex creating text fractions @@ -2831,17 +4272,17 @@ 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)))) -(define-builtin-markup-command (normal-size-super layout props arg) +(define-markup-command (normal-size-super layout props arg) (markup?) - font - ((baseline-skip)) + #:category font + #:properties ((font-size 0)) " @cindex setting superscript in standard font size @@ -2857,18 +4298,16 @@ 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-builtin-markup-command (super layout props arg) +(define-markup-command (super layout props arg) (markup?) - font - ((font-size 0) - (baseline-skip)) - " + #:category font + #:properties ((font-size 0)) + " @cindex superscript text -Raising and lowering texts can be done with @code{\\super} and -@code{\\sub}: +Set @var{arg} in superscript. @lilypond[verbatim,quote] \\markup { @@ -2885,26 +4324,17 @@ Raising and lowering texts can be done with @code{\\super} and layout (cons `((font-size . ,(- font-size 3))) props) arg) - (* 0.5 baseline-skip) + (* 1.0 (magstep font-size)) ; original font-size Y)) -(define-builtin-markup-command (translate layout props offset arg) +(define-markup-command (translate layout props offset arg) (number-pair? markup?) - align - () + #:category align " @cindex translating text - -This translates an object. Its first argument is a cons of numbers. - -@example -A \\translate #(cons 2 -3) @{ B C @} D -@end example -This moves @q{B C} 2@tie{}spaces to the right, and 3 down, relative to its -surroundings. This command cannot be used to move isolated scripts -vertically, for the same reason that @code{\\raise} cannot be used for -that. +Translate @var{arg} relative to its surroundings. @var{offset} +is a pair of numbers representing the displacement in the X and Y axis. @lilypond[verbatim,quote] \\markup { @@ -2914,13 +4344,12 @@ that. } @end lilypond" (ly:stencil-translate (interpret-markup layout props arg) - offset)) + offset)) -(define-builtin-markup-command (sub layout props arg) +(define-markup-command (sub layout props arg) (markup?) - font - ((font-size 0) - (baseline-skip)) + #:category font + #:properties ((font-size 0)) " @cindex subscript text @@ -2942,17 +4371,17 @@ 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-builtin-markup-command (normal-size-sub layout props arg) +(define-markup-command (normal-size-sub layout props arg) (markup?) - font - ((baseline-skip)) + #:category font + #:properties ((font-size 0)) " @cindex setting subscript in standard font size -Set @var{arg} in subscript, in a normal font size. +Set @var{arg} in subscript with a normal font size. @lilypond[verbatim,quote] \\markup { @@ -2964,20 +4393,19 @@ Set @var{arg} in subscript, in 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)) - + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; brackets. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define-builtin-markup-command (hbracket layout props arg) +(define-markup-command (hbracket layout props arg) (markup?) - graphic - () + #:category graphic " @cindex placing horizontal brackets around text - + Draw horizontal brackets around @var{arg}. @lilypond[verbatim,quote] @@ -2993,13 +4421,12 @@ Draw horizontal brackets around @var{arg}. (m (interpret-markup layout props arg))) (bracketify-stencil m X th (* 2.5 th) th))) -(define-builtin-markup-command (bracket layout props arg) +(define-markup-command (bracket layout props arg) (markup?) - graphic - () + #:category graphic " @cindex placing vertical brackets around text - + Draw vertical brackets around @var{arg}. @lilypond[verbatim,quote] @@ -3012,69 +4439,256 @@ Draw vertical brackets around @var{arg}. (let ((th 0.1) ;; todo: take from GROB. (m (interpret-markup layout props arg))) (bracketify-stencil m Y th (* 2.5 th) th))) - + +(define-markup-command (parenthesize layout props arg) + (markup?) + #:category graphic + #:properties ((angularity 0) + (padding) + (size 1) + (thickness 1) + (width 0.25)) + " +@cindex placing parentheses around text + +Draw parentheses around @var{arg}. This is useful for parenthesizing +a column containing several lines of text. + +@lilypond[verbatim,quote] +\\markup { + \\line { + \\parenthesize { + \\column { + foo + bar + } + } + \\override #'(angularity . 2) { + \\parenthesize { + \\column { + bah + baz + } + } + } + } +} +@end lilypond" + (let* ((m (interpret-markup layout props arg)) + (scaled-width (* size width)) + (scaled-thickness + (* (chain-assoc-get 'line-thickness props 0.1) + thickness)) + (half-thickness + (min (* size 0.5 scaled-thickness) + (* (/ 4 3.0) scaled-width))) + (padding (chain-assoc-get 'padding props half-thickness))) + (parenthesize-stencil + m half-thickness scaled-width angularity padding))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Delayed markup evaluation ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define-builtin-markup-command (page-ref layout props label gauge default) +(define-markup-command (page-ref layout props label gauge default) (symbol? markup? markup?) - other - () + #:category other " @cindex referencing page numbers in text -Reference to a page number. @var{label} is the label set on the referenced +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)) - (label-page (and (list? table) (assoc label table))) - (page-number (and label-page (cdr label-page))) - (page-markup (if page-number (format "~a" page-number) default)) - (page-stencil (interpret-markup layout props page-markup)) - (gap (- (interval-length x-ext) - (interval-length (ly:stencil-extent page-stencil X))))) - (interpret-markup layout props - (markup #:concat (#:hspace gap page-markup))))))) + (let* ((table (ly:output-def-lookup layout 'label-page-table)) + (page-number (if (list? table) + (assoc-get label table) + #f)) + (number-type (ly:output-def-lookup layout 'page-number-type)) + (page-markup (if page-number + (number-format number-type page-number) + default)) + (page-stencil (interpret-markup layout props page-markup)) + (gap (- (interval-length x-ext) + (interval-length (ly:stencil-extent page-stencil X))))) + (interpret-markup layout props + (markup #:hspace gap page-markup)))))) x-ext y-ext))) - + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; scaling +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-markup-command (scale layout props factor-pair arg) + (number-pair? markup?) + #:category graphic + " +@cindex scaling markup +@cindex mirroring markup + +Scale @var{arg}. @var{factor-pair} is a pair of numbers +representing the scaling-factor in the X and Y axes. +Negative values may be used to produce mirror images. + +@lilypond[verbatim,quote] +\\markup { + \\line { + \\scale #'(2 . 1) + stretched + \\scale #'(1 . -1) + mirrored + } +} +@end lilypond" + (let ((stil (interpret-markup layout props arg)) + (sx (car factor-pair)) + (sy (cdr factor-pair))) + (ly:stencil-scale stil sx sy))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Repeating +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-markup-command (pattern layout props count axis space pattern) + (integer? integer? number? markup?) + #:category other + " +Prints @var{count} times a @var{pattern} markup. +Patterns are spaced apart by @var{space}. +Patterns are distributed on @var{axis}. + +@lilypond[verbatim, quote] +\\markup \\column { + \"Horizontally repeated :\" + \\pattern #7 #X #2 \\flat + \\null + \"Vertically repeated :\" + \\pattern #3 #Y #0.5 \\flat +} +@end lilypond" + (let ((pattern-width (interval-length + (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)))) + (loop (1- i) + (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?) + #:category align + #:properties ((word-space) + (line-width)) + " +Put @var{left} and @var{right} in a horizontal line of width @code{line-width} +with a line of markups @var{pattern} in between. +Patterns are spaced apart by @var{space}. +Patterns are aligned to the @var{dir} markup. + +@lilypond[verbatim, quote] +\\markup \\column { + \"right-aligned :\" + \\fill-with-pattern #1 #RIGHT . first right + \\fill-with-pattern #1 #RIGHT . second right + \\null + \"center-aligned :\" + \\fill-with-pattern #1.5 #CENTER - left right + \\null + \"left-aligned :\" + \\override #'(line-width . 50) + \\fill-with-pattern #2 #LEFT : left first + \\override #'(line-width . 50) + \\fill-with-pattern #2 #LEFT : left second +} +@end lilypond" + (let* ((pattern-x-extent (ly:stencil-extent (interpret-markup layout props pattern) X)) + (pattern-width (interval-length pattern-x-extent)) + (left-width (interval-length (ly:stencil-extent (interpret-markup layout props left) X))) + (right-width (interval-length (ly:stencil-extent (interpret-markup layout props right) X))) + (middle-width (max 0 (- line-width (+ (+ left-width right-width) (* word-space 2))))) + (period (+ space pattern-width)) + (count (truncate (/ (- middle-width pattern-width) period))) + (x-offset (+ (* (- (- middle-width (* count period)) pattern-width) (/ (1+ dir) 2)) (abs (car pattern-x-extent))))) + (interpret-markup layout props + (markup left + #:with-dimensions (cons 0 middle-width) '(0 . 0) + #:translate (cons x-offset 0) + #:pattern (1+ count) X space pattern + right)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Replacements +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-markup-command (replace layout props replacements arg) + (list? markup?) + #:category font + " +Used to automatically replace a string by another in the markup @var{arg}. +Each pair of the alist @var{replacements} specifies what should be replaced. +The @code{key} is the string to be replaced by the @code{value} string. + +@lilypond[verbatim, quote] +\\markup \\replace #'((\"thx\" . \"Thanks!\")) thx +@end lilypond" + (interpret-markup + layout + (internal-add-text-replacements + props + replacements) + (markup arg))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Markup list commands ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-public (space-lines baseline stils) (let space-stil ((stils stils) - (result (list))) + (result (list))) (if (null? stils) - (reverse! result) - (let* ((stil (car stils)) - (dy-top (max (- (/ baseline 1.5) - (interval-bound (ly:stencil-extent stil Y) UP)) - 0.0)) - (dy-bottom (max (+ (/ baseline 3.0) - (interval-bound (ly:stencil-extent stil Y) DOWN)) - 0.0)) - (new-stil (ly:make-stencil - (ly:stencil-expr stil) - (ly:stencil-extent stil X) - (cons (- (interval-bound (ly:stencil-extent stil Y) DOWN) - dy-bottom) - (+ (interval-bound (ly:stencil-extent stil Y) UP) - dy-top))))) - (space-stil (cdr stils) (cons new-stil result)))))) - -(define-builtin-markup-list-command (justified-lines layout props args) + (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?) - ((baseline-skip) - wordwrap-internal-markup-list) + #:properties ((baseline-skip) + wordwrap-internal-markup-list) " @cindex justifying lines of text @@ -3085,10 +4699,10 @@ Use @code{\\override-lines #'(line-width . @var{X})} to set the line width; (interpret-markup-list layout props (make-wordwrap-internal-markup-list #t args)))) -(define-builtin-markup-list-command (wordwrap-lines layout props args) +(define-markup-list-command (wordwrap-lines layout props args) (markup-list?) - ((baseline-skip) - wordwrap-internal-markup-list) + #:properties ((baseline-skip) + 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." @@ -3096,16 +4710,198 @@ where @var{X} is the number of staff spaces." (interpret-markup-list layout props (make-wordwrap-internal-markup-list #f args)))) -(define-builtin-markup-list-command (column-lines layout props args) +(define-markup-list-command (column-lines layout props args) (markup-list?) - ((baseline-skip)) + #:properties ((baseline-skip)) "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 (chain-assoc-get 'baseline-skip props) - (interpret-markup-list layout props args))) + (space-lines baseline-skip + (interpret-markup-list layout props args))) -(define-builtin-markup-list-command (override-lines layout props new-prop 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 +@var{args} (including elements of markup list command calls) in order +to produce a new markup list. Since the return value from a markup +list command call is not a markup list but rather a list of stencils, +this requires passing those stencils off as the results of individual +markup calls. That way, the results should work out as long as no +markups rely on side effects." + (let ((key (make-symbol "key"))) + (catch + key + (lambda () + ;; if `compose' does not actually interpret its markup + ;; argument, we still need to return a list of stencils, + ;; created from the single returned stencil + (list + (interpret-markup layout props + (compose + (make-on-the-fly-markup + (lambda (layout props m) + ;; here all effects of `compose' on the + ;; properties should be visible, so we + ;; call interpret-markup-list at this + ;; point of time and harvest its + ;; stencils + (throw key + (interpret-markup-list + layout props args))) + (make-null-markup)))))) + (lambda (key stencils) + (map + (lambda (sten) + (interpret-markup layout props + (compose (make-stencil-markup sten)))) + stencils)))))